/pliant/graphic/filter/pcl.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # Generic PCL driver 
 4  # tested on HP Designjet large format printers 
 5   
 6  module "/pliant/language/compiler.pli" 
 7  module "/pliant/language/context.pli" 
 8  module "/pliant/language/stream.pli" 
 9  module "/pliant/math/functions.pli" 
 10  module "prototype.pli" 
 11  module "/pliant/graphic/color/gamut.pli" 
 12  module "/pliant/util/encoding/packbits.pli" 
 13  module "/pliant/graphic/misc/dither.pli" 
 14  module "/pliant/graphic/color/adjust.pli" 
 15  module "/pliant/graphic/misc/bytes.pli" 
 16   
 17   
 18 
 
 19   
 20   
 21  method s xl_uInt8 v 
 22    arg_rw Stream s ; arg uInt v 
 23    var uInt8 := 0C0h ; raw_write addressof:1 
 24    var uInt8 v8 := v ; raw_write addressof:v8 1 
 25   
 26  method s xl_uInt16 v 
 27    arg_rw Stream s ; arg uInt v 
 28    var uInt8 := 0C1h ; raw_write addressof:1 
 29    var uInt16_li v16 := v ; raw_write addressof:v16 2 
 30   
 31  method s xl_uInt32 v 
 32    arg_rw Stream s ; arg uInt v 
 33    var uInt8 := 0C2h ; raw_write addressof:1 
 34    var uInt32_li v32 := v ; raw_write addressof:v32 4 
 35   
 36  method s xl_uInt8 v1 v2 
 37    arg_rw Stream s ; arg uInt v1 v2 
 38    var uInt8 := 0D0h ; raw_write addressof:1 
 39    var uInt8 v8 := v1 ; raw_write addressof:v8 1 
 40    var uInt8 v8 := v2 ; raw_write addressof:v8 1 
 41   
 42  method s xl_uInt16 v1 v2 
 43    arg_rw Stream s ; arg uInt v1 v2 
 44    var uInt8 := 0D1h ; raw_write addressof:1 
 45    var uInt16_li v16 := v1 ; raw_write addressof:v16 2 
 46    var uInt16_li v16 := v2 ; raw_write addressof:v16 2 
 47   
 48  method s xl_uInt32 v1 v2 
 49    arg_rw Stream s ; arg uInt v1 v2 
 50    var uInt8 := 0D2h ; raw_write addressof:1 
 51    var uInt32_li v32 := v1 ; raw_write addressof:v32 4 
 52    var uInt32_li v32 := v2 ; raw_write addressof:v32 4 
 53   
 54  method s xl_uInt8 v 
 55    arg_rw Stream s ; arg Array:uInt v 
 56    var uInt8 := 0C8h ; raw_write addressof:1 
 57    xl_uInt16 (cast v:size uInt) 
 58    for (var Int i) v:size-1 
 59      var uInt8 := i ; raw_write addressof:1 
 60   
 61   
 62  method s xl_attr attr 
 63    arg_rw Stream s ; arg Int attr 
 64    var uInt8 := 0F8h ; raw_write addressof:1 
 65    var uInt8 := attr ; raw_write addressof:1 
 66   
 67  constant xl_aUnitsPerMeasure 137 
 68   
 69  constant xl_aMeasure 134 
 70  constant xl_eInch 0 
 71   
 72  constant xl_aErrorReport 143 
 73  constant xl_eNoReporting 0 
 74  constant xl_eBackChannel 1 
 75  constant xl_eErrorPage 2 
 76  constant xl_eBackChAndErrPage 3 
 77   
 78  constant xl_aDataOrg 130 
 79  constant xl_eBinaryLowByteFirst 1 
 80   
 81  constant xl_aSourceType 136 
 82  constant xl_eDefaultSource 0 
 83   
 84  constant xl_aOrientation 40 
 85  constant xl_ePortraitOrientation 0 
 86  constant xl_eLandscapeOrientation 1 
 87   
 88  constant xl_aMediaSize 37 
 89  constant xl_eA4Paper 2 
 90  constant xl_eA3Paper 5 
 91   
 92  constant xl_aColorSpace 3 
 93  constant xl_eGrey 1 
 94  constant xl_eRGB 2 
 95   
 96  constant xl_aPaletteDepth 2 
 97  constant xl_aPaletteData 6 
 98  constant xl_e1Bit 0 
 99  constant xl_e4Bit 1 
 100  constant xl_e8Bit 2 
 101   
 102  constant xl_aPoint 76 
 103  constant xl_aROP3 44 
 104   
 105  constant xl_aColorMapping 100 
 106  constant xl_eDirectPixel 0 
 107  constant xl_eIndexedPixel 1 
 108   
 109  constant xl_aTxMode 45 
 110  constant xl_eOpaque 0 
 111  constant xl_eTransparent 1 
 112   
 113  constant xl_aNullBrush 4 
 114  constant xl_aNullPen 5 
 115   
 116  constant xl_aColorDepth 98 
 117  constant xl_aSourceWidth 108 
 118  constant xl_aSourceHeight 107 
 119  constant xl_aDestinationSize 103 
 120  constant xl_aStartLine 109 
 121  constant xl_aBlocHeight 99 
 122   
 123  constant xl_aCompressMode 101 
 124  constant xl_eNoCompression 0 
 125  constant xl_eRLECompression 1 
 126  constant xl_eDeltaRowCompression 3 
 127   
 128  constant xl_aPadBytesMultiple 110 
 129   
 130  method s xl_op op 
 131    arg_rw Stream s ; arg Int op 
 132    var uInt8 := op ; raw_write addressof:1 
 133   
 134  constant xl_oBeginSession 41h 
 135  constant xl_oOpenDataSource 48h 
 136  constant xl_oBeginPage 43h 
 137  constant xl_oSetColorSpace 6Ah 
 138  constant xl_oSetCursor 6Bh 
 139  constant xl_oSetROP 7Bh 
 140  constant xl_oSetBrushSource 63h 
 141  constant xl_oSetPenSource 79h 
 142  constant xl_oSetPatternTxMode 78h 
 143  constant xl_oSetSourceTxMode 7Ch 
 144  constant xl_oBeginImage B0h 
 145  constant xl_oReadImage B1h 
 146  constant xl_oEndImage B2h 
 147  constant xl_oEndPage 44h 
 148  constant xl_oCloseDataSource 49h 
 149  constant xl_oEndSession 42h 
 150   
 151   
 152  method s xl_length length 
 153    arg_rw Stream s ; arg Int length 
 154    var uInt8 := 0FAh ; raw_write addressof:1 
 155    var uInt32_li l32 := length ; raw_write addressof:l32 4 
 156   
 157   
 158 
 
 159   
 160   
 161  type ImageWriteFilterPcl 
 162    field Pointer:Stream stream 
 163    field Int size_x line_size 
 164    field Link:ColorGamut gamut 
 165    field Int current_y 
 166    field CBool pjl hpgl pclxl 
 167    field Address negative <- null 
 168    field Address plan <- null 
 169    field Address bits <- null 
 170    field Array:DitherMatrix dither 
 171    field Address padding <- null 
 172    field CBool packbits <- false 
 173    field CBool seedrow <- false 
 174    field CBool always_compress <- false 
 175    field Address previous_line <- null 
 176    field Address compressed <- null 
 177   
 178  ImageWriteFilter maybe ImageWriteFilterPcl 
 179   
 180   
 181  function memory_search_difference adr1 adr2 size -> offset 
 182    arg Address adr1 adr2 ; arg Int size ; arg Int offset 
 183    var Address a1 := adr1 ; var Address a2 := adr2 
 184    var Int remain := size 
 185    while remain>=Int:size and (a1 map Int)=(a2 map Int) 
 186      a1 := a1 translate Int 1 ; a2 := a2 translate Int 1 ; remain -= Int size 
 187    while remain>and (a1 map Int8)=(a2 map Int8) 
 188      a1 := a1 translate Int8 1 ; a2 := a2 translate Int8 1 ; remain -= 1 
 189    offset := size-remain 
 190   
 191  function seedrow_encode src dest count previous -> csize 
 192    arg Address src dest ; arg Int count ; arg Address previous ; arg Int csize 
 193    var Address := src ; var Address stop := src translate Byte count 
 194    var Address := dest 
 195    var Int delta := (cast previous Int).-.(cast src Int) 
 196    while { var Int offset := memory_search_difference s (translate Byte delta) (cast stop Int).-.(cast Int) ; offset<>(cast stop Int).-.(cast Int) } 
 197      var Address := translate Byte offset 
 198      var Address s2 := translate Byte 1 
 199      while s2<>stop and (s2 map uInt8 delta)<>(s2 map uInt8) 
 200        s2 := s2 translate Byte 1 
 201      var Int replace := (cast s2 Int).-.(cast Int) 
 202      while replace>0 
 203        var Int := min replace 8 ; replace -= r 
 204        var Int := min offset 31 ; offset -= o 
 205        map uInt8 := (r-1)*2^o ; := translate uInt8 1 
 206        if o=31 
 207          := 255 
 208          while o=255 
 209            := min offset 255 ; offset -= o 
 210            map uInt8 := o ; := translate uInt8 1 
 211        memory_copy r ; := translate Byte r ; := translate Byte r 
 212    csize := (cast Int).-.(cast dest Int) 
 213   
 214     
 215  constant escape character:27 
 216   
 217  method f open s options h -> status 
 218    arg_rw ImageWriteFilterPcl f ; arg_rw Stream s ; arg Str options ; arg ImagePrototype h ; arg ExtendedStatus status 
 219    stream :> s 
 220    size_x := size_x 
 221    line_size := line_size 
 222    gamut :> gamut 
 223    pjl := not (options option "no_pjl") 
 224    hpgl := options option "hpgl" 
 225    pclxl := options option "pclxl" 
 226    if not (options option "pcl_no_compression") 
 227      if (options option "pcl_seedrow_compression") 
 228        seedrow := true 
 229      eif (options option "pcl_packbits_compression") 
 230        packbits := true 
 231      eif f:pclxl # seedraw is only part of PCL XL 2.1 
 232        packbits := true 
 233      else 
 234        seedrow := true 
 235    always_compress := options option "pcl_always_compress" 
 236    if f:packbits or f:seedrow 
 237      compressed := memory_allocate 2*f:line_size+addressof:f 
 238    if f:seedrow 
 239      previous_line := memory_zallocate f:line_size addressof:f 
 240    var Float dpi := h:size_x/(abs h:x1-h:x0)*25.4 
 241    if f:pjl 
 242      var Str pjl_eol := options option "pjl_eol" Str "[cr][lf]" 
 243      var Str cmd := escape+"%-12345X" 
 244      if not (options option "no_pjl_resolution") 
 245        cmd += "@PJL SET RESOLUTION = "+string:dpi+pjl_eol 
 246      cmd += options option "pjl_options" Str 
 247      cmd += "@PJL ENTER LANGUAGE = "+(shunt f:hpgl "HPGL2" f:pclxl "PCLXL" "PCL")+pjl_eol 
 248      writechars cmd 
 249    if f:pclxl 
 250      check h:gamut:pixel_size=or h:gamut:pixel_size=3 
 251      writechars ") HP-PCL XL;1;1;Pliant "+string:pliant_release_number+"[cr][lf]" 
 252      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) ; xl_attr xl_aUnitsPerMeasure 
 253      xl_uInt8 xl_eInch ; xl_attr xl_aMeasure 
 254      xl_uInt8 xl_eBackChAndErrPage ; xl_attr xl_aErrorReport 
 255      xl_op xl_oBeginSession 
 256      xl_uInt8 xl_eBinaryLowByteFirst ; xl_attr xl_aDataOrg 
 257      xl_uInt8 xl_eDefaultSource ; xl_attr xl_aSourceType 
 258      xl_op xl_oOpenDataSource 
 259      xl_uInt8 xl_ePortraitOrientation ; xl_attr xl_aOrientation 
 260      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) ; xl_attr xl_aMediaSize 
 261      xl_op xl_oBeginPage 
 262      xl_uInt8 (shunt h:gamut:dimension=1 xl_eGrey xl_eRGB) ; xl_attr xl_aColorSpace 
 263      xl_op xl_oSetColorSpace 
 264      xl_uInt16 0 0 ; xl_attr xl_aPoint 
 265      xl_op xl_oSetCursor 
 266      xl_uInt8 204 ; xl_attr xl_aROP3 
 267      xl_op xl_oSetROP 
 268      xl_uInt8 0 ; xl_attr xl_aNullBrush 
 269      xl_op xl_oSetBrushSource 
 270      xl_uInt8 0 ; xl_attr xl_aNullPen 
 271      xl_op xl_oSetPenSource 
 272      xl_uInt8 xl_eDirectPixel ; xl_attr xl_aColorMapping 
 273      xl_uInt8 xl_e8Bit ; xl_attr xl_aColorDepth 
 274      xl_uInt16 (cast h:size_x uInt) ; xl_attr xl_aSourceWidth 
 275      xl_uInt16 (cast h:size_y uInt) ; xl_attr xl_aSourceHeight 
 276      xl_uInt16 (cast h:size_x uInt) (cast h:size_y uInt) ; xl_attr xl_aDestinationSize 
 277      xl_op xl_oBeginImage 
 278      if f:line_size%4<>0 
 279        padding := memory_zallocate (f:line_size+.and. -4) addressof:f 
 280    else # pcl5 
 281      writechars escape+"E" # reset 
 282      if f:hpgl 
 283        writechars escape+"%1B" # enter HP GL/2 mode 
 284        writechars "BP3,1,5,1;" # do not store file on the device disk and do not rotate automatically 
 285        if (options option "hpgl_page") 
 286          var Int nx := cast 1016.0*h:size_x/dpi+0.5 Int 
 287          var Int ny := cast 1016.0*h:size_y/dpi+0.5 Int 
 288          writechars "PS"+string:ny+","+string:nx+";" # set page size 
 289        else 
 290          writechars "PS;" # no page clip 
 291        writechars escape+"%0A" # enter HP RTL mode 
 292      if not (options option "pcl_no_paper_size") 
 293        # A4 = 26 , A3 = 27 , A3+ = 16, custom = 101 
 294        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 
 295      if (options option "pcl_no_perforation_skip") 
 296        writechars escape+"&l0L" # Turn off perforation skip 
 297      writechars escape+"&a1N" # No negative motion - allow plotting while receiving 
 298      if (options option "pcl_dither") 
 299        if h:gamut:dimension=1 
 300          writechars escape+"*r1U" 
 301          if h:gamut:model=color_gamut_additive 
 302            negative := memory_allocate f:line_size addressof:f 
 303        eif h:gamut:model=color_gamut_additive 
 304          check h:gamut:pixel_size=3 
 305          writechars escape+"*r"+(string h:gamut:dimension)+"U" 
 306        else 
 307          check h:gamut:pixel_size=or h:gamut:pixel_size=4 
 308          writechars escape+"*r"+(string -(h:gamut:dimension))+"U" 
 309        plan := memory_allocate f:size_x addressof:f 
 310        bits := memory_allocate (f:size_x+7)\addressof:f 
 311        f:dither size := h:gamut dimension 
 312        for (var Int i) 0  h:gamut:dimension-1 
 313          var Pointer:DitherMatrix dither :> f:dither i 
 314          dither := dither_matrix "" 
 315          for (var Int y) dither:size_y-1 
 316            for (var Int x) dither:size_x-1 
 317              var Float := (dither y)/(dither:size_x*dither:size_y) 
 318              := dot_unadjust "header [dq]pcl_"+(h:gamut query "component_name "+string:i)+"_[dq] header2 [dq]pcl_[dq] "+options 
 319              dither := max (cast d*255 Int) 1 
 320        if f:gamut:dimension>and f:seedrow 
 321          packbits := true 
 322          seedrow := false 
 323      else 
 324        if h:gamut:dimension=1 
 325          writechars escape+"*v6W"+character:0+character:1+character:8+character:0+character:0+character:0 
 326          for (var Int i) 0 255 
 327            for (var Int c) 0 2  
 328              writechars escape+"*v"+string:(shunt h:gamut:model=color_gamut_additive 255-i)+(character "A":number+c) 
 329            writechars escape+"*v"+string:i+"I" 
 330          writechars escape+"&b1M" 
 331        else # RGB 
 332          check h:gamut:model=color_gamut_additive and h:gamut:dimension=3 
 333          var Int color_model := shunt (options option "sRGB") 2 0 # 0 = device RGB, 1 = device CMY, 2 = sRGB 
 334          writechars escape+"*v6W"+character:color_model+character:3+character:0+character:8+character:8+character:# select 3 bytes per pixel trivial encoding 
 335      writechars escape+"*t"+string:(cast dpi Int)+"R" # set resolution 
 336      writechars escape+"*r"+(string h:size_x)+"S" # number of pixels per line 
 337      writechars escape+"*r"+(string h:size_y)+"T" # number of rows 
 338      writechars escape+"*r1A" # start raster graphics at current position, no scaling requested 
 339      if f:always_compress 
 340        writechars escape+"*b"+(shunt f:seedrow "3" f:packbits "2" "0")+"M" # select compression 
 341    current_y := 0 
 342    status := success 
 343   
 344   
 345  method f writeline adr -> status 
 346    arg_rw ImageWriteFilterPcl f ; arg Address adr ; arg Status status 
 347    var Pointer:Stream :> stream 
 348    var Address line := adr ; var Int size := line_size 
 349    if f:negative<>null 
 350      bytes_copy_255minus line f:negative f:line_size 
 351      line := negative 
 352    for (var Int i) 0 (shunt f:plan<>null f:gamut:dimension-1 0) 
 353      var Address memo_line := line ; var Int memo_size := size 
 354      if f:plan<>null 
 355        bytes_copy (line translate Byte (i+(shunt f:gamut:dimension=4 3 0))%4) f:gamut:pixel_size f:plan f:size_x 
 356        line := plan ; size := size_x 
 357      if f:bits<>null 
 358        memory_clear f:bits (size+7)\8 
 359        var Address src := line 
 360        var Address stop := line translate uInt8 size 
 361        var Address dest := bits ; var Int shift := 7 
 362        var Address dither := addressof (f:dither:f:current_y%f:dither:i:size_y) ; var Int dx := 0 ; var Int dm := f:dither:i:size_x 
 363        while src<>stop 
 364          if (src map uInt8)>=(dither map Int dx) 
 365            dest map uInt8 += 2^shift 
 366          src := src translate uInt8 
 367          dx += 1 
 368          if dx=dm 
 369            dx := 0 
 370          if shift>0 
 371            shift -= 1 
 372          else 
 373            dest := dest translate uInt8 1 ; shift := 7 
 374        line := bits ; size := (size+7)\8 
 375      if f:padding<>null 
 376        memory_copy line f:padding size 
 377        line := padding 
 378        size := size+.and. -4 
 379      var Int cmode := 0 
 380      if f:seedrow 
 381        var Int csize := seedrow_encode line f:compressed size f:previous_line 
 382        memory_copy line f:previous_line size 
 383        if csize<size or f:always_compress 
 384          line := compressed ; size := csize 
 385          cmode := 3 
 386      eif f:packbits 
 387        var Int csize := packbits_encode line f:compressed size 
 388        if csize<size or f:always_compress 
 389          line := compressed ; size := csize 
 390          cmode := 2 
 391      if f:pclxl 
 392        xl_uInt16 (cast f:current_y uInt) ; xl_attr xl_aStartLine 
 393        xl_uInt16 1 ; xl_attr xl_aBlocHeight 
 394        xl_uInt8 (shunt cmode=3 xl_eDeltaRowCompression cmode=2 xl_eRLECompression xl_eNoCompression) ; xl_attr xl_aCompressMode 
 395        # s xl_uInt8 1 ; s xl_attr xl_aPadBytesMultiple 
 396        xl_op xl_oReadImage 
 397        xl_length size 
 398        raw_write line size 
 399      else 
 400        writechars escape+"*b"+string:cmode+"m"+string:size+"W" 
 401        raw_write line size 
 402      line := memo_line ; size := memo_size 
 403    current_y += 1 
 404    status := success 
 405   
 406   
 407  method f close -> status 
 408    arg_rw ImageWriteFilterPcl f ; arg ExtendedStatus status 
 409    memory_free f:negative 
 410    memory_free f:plan 
 411    memory_free f:bits 
 412    memory_free f:padding 
 413    memory_free f:compressed 
 414    memory_free f:previous_line 
 415    var Pointer:Stream :> stream 
 416    if f:pclxl 
 417      xl_op xl_oEndImage 
 418      xl_op xl_oEndPage 
 419      xl_op xl_oCloseDataSource 
 420      xl_op xl_oEndSession 
 421    else # pcl5 
 422      writechars escape+"*rC" # end raster graphics 
 423      if f:hpgl 
 424        writechars escape+"%1B" # back to HP GL/2 
 425        writechars "PG;" # end of job: eject page or advance roll 
 426      writechars escape+"E" # reset 
 427    if f:pjl 
 428      writechars escape+"%-12345X" 
 429    status := success 
 430   
 431   
 432  image_record_filters ".pcl" Void false ImageWriteFilterPcl false