src/lib/vampimg/JpegLib/imjcparam.pas

   1 unit imjcparam;
   2
   3 { This file contains optional default-setting code for the JPEG compressor.
   4   Applications do not have to use this file, but those that don't use it
   5   must know a lot more about the innards of the JPEG code. }
   6
   7 { Original: jcparam.c ; Copyright (C) 1991-1998, Thomas G. Lane. }
   8
   9 interface
  10
  11 {$I imjconfig.inc}
  12
  13 uses
  14   imjmorecfg,
  15   imjinclude,
  16   imjdeferr,
  17   imjerror,
  18   imjcomapi,
  19   imjpeglib;
  20
  21 { Quantization table setup routines }
  22
  23 {GLOBAL}
  24 procedure jpeg_add_quant_table (cinfo : j_compress_ptr;
  25                                 which_tbl : int;
  26                     const basic_table : array of uInt;
  27                     scale_factor : int;
  28                                 force_baseline : boolean);
  29
  30 {GLOBAL}
  31 procedure jpeg_set_linear_quality (cinfo : j_compress_ptr;
  32                                    scale_factor : int;
  33                  force_baseline : boolean);
  34 { Set or change the 'quality' (quantization) setting, using default tables
  35   and a straight percentage-scaling quality scale.  In most cases it's better
  36   to use jpeg_set_quality (below); this entry point is provided for
  37   applications that insist on a linear percentage scaling. }
  38
  39 {GLOBAL}
  40 function jpeg_quality_scaling (quality : int) : int;
  41 { Convert a user-specified quality rating to a percentage scaling factor
  42   for an underlying quantization table, using our recommended scaling curve.
  43   The input 'quality' factor should be 0 (terrible) to 100 (very good). }
  44
  45 {GLOBAL}
  46 procedure jpeg_set_quality (cinfo : j_compress_ptr;
  47                             quality : int;
  48                             force_baseline : boolean);
  49 { Set or change the 'quality' (quantization) setting, using default tables.
  50   This is the standard quality-adjusting entry point for typical user
  51   interfaces; only those who want detailed control over quantization tables
  52   would use the preceding three routines directly. }
  53
  54 {GLOBAL}
  55 procedure jpeg_set_defaults (cinfo : j_compress_ptr);
  56
  57 { Create a recommended progressive-JPEG script.
  58   cinfo^.num_components and cinfo^.jpeg_color_space must be correct. }
  59
  60 { Set the JPEG colorspace, and choose colorspace-dependent default values. }
  61
  62 {GLOBAL}
  63 procedure jpeg_set_colorspace (cinfo : j_compress_ptr;
  64                                colorspace : J_COLOR_SPACE);
  65
  66 { Select an appropriate JPEG colorspace for in_color_space. }
  67
  68 {GLOBAL}
  69 procedure jpeg_default_colorspace (cinfo : j_compress_ptr);
  70
  71 {GLOBAL}
  72 procedure jpeg_simple_progression (cinfo : j_compress_ptr);
  73
  74
  75 implementation
  76
  77 { Quantization table setup routines }
  78
  79 {GLOBAL}
  80 procedure jpeg_add_quant_table (cinfo : j_compress_ptr;
  81                       which_tbl : int;
  82           const basic_table : array of uInt;
  83           scale_factor : int;
  84                       force_baseline : boolean);
  85 { Define a quantization table equal to the basic_table times
  86   a scale factor (given as a percentage).
  87   If force_baseline is TRUE, the computed quantization table entries
  88   are limited to 1..255 for JPEG baseline compatibility. }
  89 var
  90   qtblptr :^JQUANT_TBL_PTR;
  91   i : int;
  92   temp : long;
  93 begin
  94   { Safety check to ensure start_compress not called yet. }
  95   if (cinfo^.global_state <> CSTATE_START) then
  96     ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
  97
  98   if (which_tbl < 0) or (which_tbl >= NUM_QUANT_TBLS) then
  99     ERREXIT1(j_common_ptr(cinfo), JERR_DQT_INDEX, which_tbl);
 100
 101   qtblptr := @(cinfo^.quant_tbl_ptrs[which_tbl]);
 102
 103   if (qtblptr^ = NIL) then
 104     qtblptr^ := jpeg_alloc_quant_table(j_common_ptr(cinfo));
 105
 106   for i := 0 to pred(DCTSIZE2) do
 107   begin
 108     temp := (long(basic_table[i]) * scale_factor + long(50)) div long(100);
 109     { limit the values to the valid range }
 110     if (temp <= long(0)) then
 111       temp := long(1);
 112     if (temp > long(32767)) then
 113       temp := long(32767); { max quantizer needed for 12 bits }
 114     if (force_baseline) and (temp > long(255)) then
 115       temp := long(255);    { limit to baseline range if requested }
 116     (qtblptr^)^.quantval[i] := UINT16 (temp);
 117   end;
 118
 119   { Initialize sent_table FALSE so table will be written to JPEG file. }
 120   (qtblptr^)^.sent_table := FALSE;
 121 end;
 122
 123
 124 {GLOBAL}
 125 procedure jpeg_set_linear_quality (cinfo : j_compress_ptr;
 126                                    scale_factor : int;
 127                  force_baseline : boolean);
 128 { Set or change the 'quality' (quantization) setting, using default tables
 129   and a straight percentage-scaling quality scale.  In most cases it's better
 130   to use jpeg_set_quality (below); this entry point is provided for
 131   applications that insist on a linear percentage scaling. }
 132
 133 { These are the sample quantization tables given in JPEG spec section K.1.
 134   The spec says that the values given produce "good" quality, and
 135   when divided by 2, "very good" quality. }
 136
 137 const
 138   std_luminance_quant_tbl : array[0..DCTSIZE2-1] of uInt =
 139    (16,  11,  10,  16,  24,  40,  51,  61,
 140     12,  12,  14,  19,  26,  58,  60,  55,
 141     14,  13,  16,  24,  40,  57,  69,  56,
 142     14,  17,  22,  29,  51,  87,  80,  62,
 143     18,  22,  37,  56,  68, 109, 103,  77,
 144     24,  35,  55,  64,  81, 104, 113,  92,
 145     49,  64,  78,  87, 103, 121, 120, 101,
 146     72,  92,  95,  98, 112, 100, 103,  99);
 147
 148 const
 149   std_chrominance_quant_tbl : array[0..DCTSIZE2-1] of uInt =
 150    (17,  18,  24,  47,  99,  99,  99,  99,
 151     18,  21,  26,  66,  99,  99,  99,  99,
 152     24,  26,  56,  99,  99,  99,  99,  99,
 153     47,  66,  99,  99,  99,  99,  99,  99,
 154     99,  99,  99,  99,  99,  99,  99,  99,
 155     99,  99,  99,  99,  99,  99,  99,  99,
 156     99,  99,  99,  99,  99,  99,  99,  99,
 157     99,  99,  99,  99,  99,  99,  99,  99);
 158 begin
 159   { Set up two quantization tables using the specified scaling }
 160   jpeg_add_quant_table(cinfo, 0, std_luminance_quant_tbl,
 161            scale_factor, force_baseline);
 162   jpeg_add_quant_table(cinfo, 1, std_chrominance_quant_tbl,
 163            scale_factor, force_baseline);
 164 end;
 165
 166
 167 {GLOBAL}
 168 function jpeg_quality_scaling (quality : int) : int;
 169 { Convert a user-specified quality rating to a percentage scaling factor
 170   for an underlying quantization table, using our recommended scaling curve.
 171   The input 'quality' factor should be 0 (terrible) to 100 (very good). }
 172 begin
 173   { Safety limit on quality factor.  Convert 0 to 1 to avoid zero divide. }
 174   if (quality <= 0) then
 175     quality := 1;
 176   if (quality > 100) then
 177     quality := 100;
 178
 179   { The basic table is used as-is (scaling 100) for a quality of 50.
 180     Qualities 50..100 are converted to scaling percentage 200 - 2*Q;
 181     note that at Q=100 the scaling is 0, which will cause jpeg_add_quant_table
 182     to make all the table entries 1 (hence, minimum quantization loss).
 183     Qualities 1..50 are converted to scaling percentage 5000/Q. }
 184   if (quality < 50) then
 185     quality := 5000 div quality
 186   else
 187     quality := 200 - quality*2;
 188
 189   jpeg_quality_scaling := quality;
 190 end;
 191
 192
 193 {GLOBAL}
 194 procedure jpeg_set_quality (cinfo : j_compress_ptr;
 195                             quality : int;
 196                             force_baseline : boolean);
 197 { Set or change the 'quality' (quantization) setting, using default tables.
 198   This is the standard quality-adjusting entry point for typical user
 199   interfaces; only those who want detailed control over quantization tables
 200   would use the preceding three routines directly. }
 201 begin
 202   { Convert user 0-100 rating to percentage scaling }
 203   quality := jpeg_quality_scaling(quality);
 204
 205   { Set up standard quality tables }
 206   jpeg_set_linear_quality(cinfo, quality, force_baseline);
 207 end;
 208
 209
 210 { Huffman table setup routines }
 211
 212 {LOCAL}
 213 procedure add_huff_table (cinfo : j_compress_ptr;
 214                           var htblptr : JHUFF_TBL_PTR;
 215                           var bits : array of UINT8;
 216                           var val : array of UINT8);
 217 { Define a Huffman table }
 218 var
 219   nsymbols, len : int;
 220 begin
 221   if (htblptr = NIL) then
 222     htblptr := jpeg_alloc_huff_table(j_common_ptr(cinfo));
 223
 224   { Copy the number-of-symbols-of-each-code-length counts }
 225   MEMCOPY(@htblptr^.bits, @bits, SIZEOF(htblptr^.bits));
 226
 227
 228   { Validate the counts.  We do this here mainly so we can copy the right
 229     number of symbols from the val[] array, without risking marching off
 230     the end of memory.  jchuff.c will do a more thorough test later. }
 231
 232   nsymbols := 0;
 233   for len := 1 to 16 do
 234     Inc(nsymbols, bits[len]);
 235   if (nsymbols < 1) or (nsymbols > 256) then
 236     ERREXIT(j_common_ptr(cinfo), JERR_BAD_HUFF_TABLE);
 237
 238   MEMCOPY(@htblptr^.huffval, @val, nsymbols * SIZEOF(UINT8));
 239
 240   { Initialize sent_table FALSE so table will be written to JPEG file. }
 241   (htblptr)^.sent_table := FALSE;
 242 end;
 243
 244
 245 {$J+}
 246 {LOCAL}
 247 procedure std_huff_tables (cinfo : j_compress_ptr);
 248 { Set up the standard Huffman tables (cf. JPEG standard section K.3) }
 249 { IMPORTANT: these are only valid for 8-bit data precision! }
 250   const bits_dc_luminance : array[0..17-1] of UINT8 =
 251     ({ 0-base } 0, 0, 1, 5, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0);
 252   const val_dc_luminance : array[0..11] of UINT8 =
 253     (0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11);
 254
 255   const bits_dc_chrominance : array[0..17-1] of UINT8 =
 256     ( { 0-base } 0, 0, 3, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 );
 257   const val_dc_chrominance : array[0..11] of UINT8 =
 258     ( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 );
 259
 260   const bits_ac_luminance : array[0..17-1] of UINT8 =
 261     ( { 0-base } 0, 0, 2, 1, 3, 3, 2, 4, 3, 5, 5, 4, 4, 0, 0, 1, $7d );
 262   const val_ac_luminance : array[0..161] of UINT8 =
 263     ( $01, $02, $03, $00, $04, $11, $05, $12,
 264       $21, $31, $41, $06, $13, $51, $61, $07,
 265       $22, $71, $14, $32, $81, $91, $a1, $08,
 266       $23, $42, $b1, $c1, $15, $52, $d1, $f0,
 267       $24, $33, $62, $72, $82, $09, $0a, $16,
 268       $17, $18, $19, $1a, $25, $26, $27, $28,
 269       $29, $2a, $34, $35, $36, $37, $38, $39,
 270       $3a, $43, $44, $45, $46, $47, $48, $49,
 271       $4a, $53, $54, $55, $56, $57, $58, $59,
 272       $5a, $63, $64, $65, $66, $67, $68, $69,
 273       $6a, $73, $74, $75, $76, $77, $78, $79,
 274       $7a, $83, $84, $85, $86, $87, $88, $89,
 275       $8a, $92, $93, $94, $95, $96, $97, $98,
 276       $99, $9a, $a2, $a3, $a4, $a5, $a6, $a7,
 277       $a8, $a9, $aa, $b2, $b3, $b4, $b5, $b6,
 278       $b7, $b8, $b9, $ba, $c2, $c3, $c4, $c5,
 279       $c6, $c7, $c8, $c9, $ca, $d2, $d3, $d4,
 280       $d5, $d6, $d7, $d8, $d9, $da, $e1, $e2,
 281       $e3, $e4, $e5, $e6, $e7, $e8, $e9, $ea,
 282       $f1, $f2, $f3, $f4, $f5, $f6, $f7, $f8,
 283       $f9, $fa );
 284
 285   const bits_ac_chrominance : array[0..17-1] of UINT8 =
 286     ( { 0-base } 0, 0, 2, 1, 2, 4, 4, 3, 4, 7, 5, 4, 4, 0, 1, 2, $77 );
 287   const val_ac_chrominance : array[0..161] of UINT8 =
 288     ( $00, $01, $02, $03, $11, $04, $05, $21,
 289       $31, $06, $12, $41, $51, $07, $61, $71,
 290       $13, $22, $32, $81, $08, $14, $42, $91,
 291       $a1, $b1, $c1, $09, $23, $33, $52, $f0,
 292       $15, $62, $72, $d1, $0a, $16, $24, $34,
 293       $e1, $25, $f1, $17, $18, $19, $1a, $26,
 294       $27, $28, $29, $2a, $35, $36, $37, $38,
 295       $39, $3a, $43, $44, $45, $46, $47, $48,
 296       $49, $4a, $53, $54, $55, $56, $57, $58,
 297       $59, $5a, $63, $64, $65, $66, $67, $68,
 298       $69, $6a, $73, $74, $75, $76, $77, $78,
 299       $79, $7a, $82, $83, $84, $85, $86, $87,
 300       $88, $89, $8a, $92, $93, $94, $95, $96,
 301       $97, $98, $99, $9a, $a2, $a3, $a4, $a5,
 302       $a6, $a7, $a8, $a9, $aa, $b2, $b3, $b4,
 303       $b5, $b6, $b7, $b8, $b9, $ba, $c2, $c3,
 304       $c4, $c5, $c6, $c7, $c8, $c9, $ca, $d2,
 305       $d3, $d4, $d5, $d6, $d7, $d8, $d9, $da,
 306       $e2, $e3, $e4, $e5, $e6, $e7, $e8, $e9,
 307       $ea, $f2, $f3, $f4, $f5, $f6, $f7, $f8,
 308       $f9, $fa );
 309 begin
 310   add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[0],
 311   bits_dc_luminance, val_dc_luminance);
 312   add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[0],
 313   bits_ac_luminance, val_ac_luminance);
 314   add_huff_table(cinfo, cinfo^.dc_huff_tbl_ptrs[1],
 315   bits_dc_chrominance, val_dc_chrominance);
 316   add_huff_table(cinfo, cinfo^.ac_huff_tbl_ptrs[1],
 317   bits_ac_chrominance, val_ac_chrominance);
 318 end;
 319
 320
 321 { Default parameter setup for compression.
 322
 323   Applications that don't choose to use this routine must do their
 324   own setup of all these parameters.  Alternately, you can call this
 325   to establish defaults and then alter parameters selectively.  This
 326   is the recommended approach since, if we add any new parameters,
 327   your code will still work (they'll be set to reasonable defaults). }
 328
 329 {GLOBAL}
 330 procedure jpeg_set_defaults (cinfo : j_compress_ptr);
 331 var
 332   i : int;
 333 begin
 334   { Safety check to ensure start_compress not called yet. }
 335   if (cinfo^.global_state <> CSTATE_START) then
 336     ERREXIT1(J_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
 337
 338   { Allocate comp_info array large enough for maximum component count.
 339     Array is made permanent in case application wants to compress
 340     multiple images at same param settings. }
 341
 342   if (cinfo^.comp_info = NIL) then
 343     cinfo^.comp_info := jpeg_component_info_list_ptr(
 344       cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
 345              MAX_COMPONENTS * SIZEOF(jpeg_component_info)) );
 346
 347   { Initialize everything not dependent on the color space }
 348
 349   cinfo^.data_precision := BITS_IN_JSAMPLE;
 350   { Set up two quantization tables using default quality of 75 }
 351   jpeg_set_quality(cinfo, 75, TRUE);
 352   { Set up two Huffman tables }
 353   std_huff_tables(cinfo);
 354
 355   { Initialize default arithmetic coding conditioning }
 356   for i := 0 to pred(NUM_ARITH_TBLS) do
 357   begin
 358     cinfo^.arith_dc_L[i] := 0;
 359     cinfo^.arith_dc_U[i] := 1;
 360     cinfo^.arith_ac_K[i] := 5;
 361   end;
 362
 363   { Default is no multiple-scan output }
 364   cinfo^.scan_info := NIL;
 365   cinfo^.num_scans := 0;
 366
 367   { Expect normal source image, not raw downsampled data }
 368   cinfo^.raw_data_in := FALSE;
 369
 370   { Use Huffman coding, not arithmetic coding, by default }
 371   cinfo^.arith_code := FALSE;
 372
 373   { By default, don't do extra passes to optimize entropy coding }
 374   cinfo^.optimize_coding := FALSE;
 375   { The standard Huffman tables are only valid for 8-bit data precision.
 376     If the precision is higher, force optimization on so that usable
 377     tables will be computed.  This test can be removed if default tables
 378     are supplied that are valid for the desired precision. }
 379
 380   if (cinfo^.data_precision > 8) then
 381     cinfo^.optimize_coding := TRUE;
 382
 383   { By default, use the simpler non-cosited sampling alignment }
 384   cinfo^.CCIR601_sampling := FALSE;
 385
 386   { No input smoothing }
 387   cinfo^.smoothing_factor := 0;
 388
 389   { DCT algorithm preference }
 390   cinfo^.dct_method := JDCT_DEFAULT;
 391
 392   { No restart markers }
 393   cinfo^.restart_interval := 0;
 394   cinfo^.restart_in_rows := 0;
 395
 396   { Fill in default JFIF marker parameters.  Note that whether the marker
 397     will actually be written is determined by jpeg_set_colorspace.
 398
 399     By default, the library emits JFIF version code 1.01.
 400     An application that wants to emit JFIF 1.02 extension markers should set
 401     JFIF_minor_version to 2.  We could probably get away with just defaulting
 402     to 1.02, but there may still be some decoders in use that will complain
 403     about that; saying 1.01 should minimize compatibility problems. }
 404
 405   cinfo^.JFIF_major_version := 1; { Default JFIF version = 1.01 }
 406   cinfo^.JFIF_minor_version := 1;
 407   cinfo^.density_unit := 0; { Pixel size is unknown by default }
 408   cinfo^.X_density := 1;    { Pixel aspect ratio is square by default }
 409   cinfo^.Y_density := 1;
 410
 411   { Choose JPEG colorspace based on input space, set defaults accordingly }
 412
 413   jpeg_default_colorspace(cinfo);
 414 end;
 415
 416
 417 { Select an appropriate JPEG colorspace for in_color_space. }
 418
 419 {GLOBAL}
 420 procedure jpeg_default_colorspace (cinfo : j_compress_ptr);
 421 begin
 422   case (cinfo^.in_color_space) of
 423   JCS_GRAYSCALE:
 424     jpeg_set_colorspace(cinfo, JCS_GRAYSCALE);
 425   JCS_RGB:
 426     jpeg_set_colorspace(cinfo, JCS_YCbCr);
 427   JCS_YCbCr:
 428     jpeg_set_colorspace(cinfo, JCS_YCbCr);
 429   JCS_CMYK:
 430     jpeg_set_colorspace(cinfo, JCS_CMYK); { By default, no translation }
 431   JCS_YCCK:
 432     jpeg_set_colorspace(cinfo, JCS_YCCK);
 433   JCS_UNKNOWN:
 434     jpeg_set_colorspace(cinfo, JCS_UNKNOWN);
 435   else
 436     ERREXIT(j_common_ptr(cinfo), JERR_BAD_IN_COLORSPACE);
 437   end;
 438 end;
 439
 440
 441 { Set the JPEG colorspace, and choose colorspace-dependent default values. }
 442
 443 {GLOBAL}
 444 procedure jpeg_set_colorspace (cinfo : j_compress_ptr;
 445                                colorspace : J_COLOR_SPACE);
 446   { macro }
 447   procedure SET_COMP(index,id,hsamp,vsamp,quant,dctbl,actbl : int);
 448   begin
 449     with cinfo^.comp_info^[index] do
 450     begin
 451       component_id := (id);
 452       h_samp_factor := (hsamp);
 453       v_samp_factor := (vsamp);
 454       quant_tbl_no := (quant);
 455       dc_tbl_no := (dctbl);
 456       ac_tbl_no := (actbl);
 457     end;
 458   end;
 459
 460 var
 461   ci : int;
 462 begin
 463   { Safety check to ensure start_compress not called yet. }
 464   if (cinfo^.global_state <> CSTATE_START) then
 465     ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
 466
 467   { For all colorspaces, we use Q and Huff tables 0 for luminance components,
 468     tables 1 for chrominance components. }
 469
 470   cinfo^.jpeg_color_space := colorspace;
 471
 472   cinfo^.write_JFIF_header := FALSE; { No marker for non-JFIF colorspaces }
 473   cinfo^.write_Adobe_marker := FALSE; { write no Adobe marker by default }
 474
 475   case (colorspace) of
 476   JCS_GRAYSCALE:
 477     begin
 478       cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker }
 479       cinfo^.num_components := 1;
 480       { JFIF specifies component ID 1 }
 481       SET_COMP(0, 1, 1,1, 0, 0,0);
 482     end;
 483   JCS_RGB:
 484     begin
 485       cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag RGB }
 486       cinfo^.num_components := 3;
 487       SET_COMP(0, $52 { 'R' }, 1,1, 0, 0,0);
 488       SET_COMP(1, $47 { 'G' }, 1,1, 0, 0,0);
 489       SET_COMP(2, $42 { 'B' }, 1,1, 0, 0,0);
 490     end;
 491   JCS_YCbCr:
 492     begin
 493       cinfo^.write_JFIF_header := TRUE; { Write a JFIF marker }
 494       cinfo^.num_components := 3;
 495       { JFIF specifies component IDs 1,2,3 }
 496       { We default to 2x2 subsamples of chrominance }
 497       SET_COMP(0, 1, 2,2, 0, 0,0);
 498       SET_COMP(1, 2, 1,1, 1, 1,1);
 499       SET_COMP(2, 3, 1,1, 1, 1,1);
 500     end;
 501   JCS_CMYK:
 502     begin
 503       cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag CMYK }
 504       cinfo^.num_components := 4;
 505       SET_COMP(0, $43 { 'C' }, 1,1, 0, 0,0);
 506       SET_COMP(1, $4D { 'M' }, 1,1, 0, 0,0);
 507       SET_COMP(2, $59 { 'Y' }, 1,1, 0, 0,0);
 508       SET_COMP(3, $4B { 'K' }, 1,1, 0, 0,0);
 509     end;
 510   JCS_YCCK:
 511     begin
 512       cinfo^.write_Adobe_marker := TRUE; { write Adobe marker to flag YCCK }
 513       cinfo^.num_components := 4;
 514       SET_COMP(0, 1, 2,2, 0, 0,0);
 515       SET_COMP(1, 2, 1,1, 1, 1,1);
 516       SET_COMP(2, 3, 1,1, 1, 1,1);
 517       SET_COMP(3, 4, 2,2, 0, 0,0);
 518     end;
 519   JCS_UNKNOWN:
 520     begin
 521       cinfo^.num_components := cinfo^.input_components;
 522       if (cinfo^.num_components < 1)
 523       or (cinfo^.num_components > MAX_COMPONENTS) then
 524         ERREXIT2(j_common_ptr(cinfo), JERR_COMPONENT_COUNT,
 525                  cinfo^.num_components, MAX_COMPONENTS);
 526       for ci := 0 to pred(cinfo^.num_components) do
 527       begin
 528         SET_COMP(ci, ci, 1,1, 0, 0,0);
 529       end;
 530     end;
 531   else
 532     ERREXIT(j_common_ptr(cinfo), JERR_BAD_J_COLORSPACE);
 533   end;
 534 end;
 535
 536
 537 {$ifdef C_PROGRESSIVE_SUPPORTED}
 538
 539 {LOCAL}
 540 function fill_a_scan (scanptr : jpeg_scan_info_ptr;
 541                       ci : int; Ss : int;
 542                       Se : int; Ah : int;
 543                       Al : int) : jpeg_scan_info_ptr;
 544 { Support routine: generate one scan for specified component }
 545 begin
 546   scanptr^.comps_in_scan := 1;
 547   scanptr^.component_index[0] := ci;
 548   scanptr^.Ss := Ss;
 549   scanptr^.Se := Se;
 550   scanptr^.Ah := Ah;
 551   scanptr^.Al := Al;
 552   Inc(scanptr);
 553   fill_a_scan := scanptr;
 554 end;
 555
 556 {LOCAL}
 557 function fill_scans (scanptr : jpeg_scan_info_ptr;
 558                      ncomps : int;
 559                Ss : int; Se : int;
 560                      Ah : int; Al : int) : jpeg_scan_info_ptr;
 561 { Support routine: generate one scan for each component }
 562 var
 563   ci : int;
 564 begin
 565
 566   for ci := 0 to pred(ncomps) do
 567   begin
 568     scanptr^.comps_in_scan := 1;
 569     scanptr^.component_index[0] := ci;
 570     scanptr^.Ss := Ss;
 571     scanptr^.Se := Se;
 572     scanptr^.Ah := Ah;
 573     scanptr^.Al := Al;
 574     Inc(scanptr);
 575   end;
 576   fill_scans := scanptr;
 577 end;
 578
 579 {LOCAL}
 580 function fill_dc_scans (scanptr : jpeg_scan_info_ptr;
 581                         ncomps : int;
 582                         Ah : int; Al : int) : jpeg_scan_info_ptr;
 583 { Support routine: generate interleaved DC scan if possible, else N scans }
 584 var
 585   ci : int;
 586 begin
 587
 588   if (ncomps <= MAX_COMPS_IN_SCAN) then
 589   begin
 590     { Single interleaved DC scan }
 591     scanptr^.comps_in_scan := ncomps;
 592     for ci := 0 to pred(ncomps) do
 593       scanptr^.component_index[ci] := ci;
 594     scanptr^.Ss := 0;
 595     scanptr^.Se := 0;
 596     scanptr^.Ah := Ah;
 597     scanptr^.Al := Al;
 598     Inc(scanptr);
 599   end
 600   else
 601   begin
 602     { Noninterleaved DC scan for each component }
 603     scanptr := fill_scans(scanptr, ncomps, 0, 0, Ah, Al);
 604   end;
 605   fill_dc_scans := scanptr;
 606 end;
 607
 608
 609 { Create a recommended progressive-JPEG script.
 610   cinfo^.num_components and cinfo^.jpeg_color_space must be correct. }
 611
 612 {GLOBAL}
 613 procedure jpeg_simple_progression (cinfo : j_compress_ptr);
 614 var
 615   ncomps : int;
 616   nscans : int;
 617   scanptr : jpeg_scan_info_ptr;
 618 begin
 619   ncomps := cinfo^.num_components;
 620
 621   { Safety check to ensure start_compress not called yet. }
 622   if (cinfo^.global_state <> CSTATE_START) then
 623     ERREXIT1(j_common_ptr(cinfo), JERR_BAD_STATE, cinfo^.global_state);
 624
 625   { Figure space needed for script.  Calculation must match code below! }
 626   if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then
 627   begin
 628     { Custom script for YCbCr color images. }
 629     nscans := 10;
 630   end
 631   else
 632   begin
 633     { All-purpose script for other color spaces. }
 634     if (ncomps > MAX_COMPS_IN_SCAN) then
 635       nscans := 6 * ncomps  { 2 DC + 4 AC scans per component }
 636     else
 637       nscans := 2 + 4 * ncomps; { 2 DC scans; 4 AC scans per component }
 638   end;
 639
 640   { Allocate space for script.
 641     We need to put it in the permanent pool in case the application performs
 642     multiple compressions without changing the settings.  To avoid a memory
 643     leak if jpeg_simple_progression is called repeatedly for the same JPEG
 644     object, we try to re-use previously allocated space, and we allocate
 645     enough space to handle YCbCr even if initially asked for grayscale. }
 646
 647   if (cinfo^.script_space = NIL) or (cinfo^.script_space_size < nscans) then
 648   begin
 649     if nscans > 10 then
 650       cinfo^.script_space_size := nscans
 651     else
 652       cinfo^.script_space_size := 10;
 653
 654     cinfo^.script_space := jpeg_scan_info_ptr(
 655       cinfo^.mem^.alloc_small (j_common_ptr(cinfo), JPOOL_PERMANENT,
 656     cinfo^.script_space_size * SIZEOF(jpeg_scan_info)) );
 657   end;
 658   scanptr := cinfo^.script_space;
 659
 660   cinfo^.scan_info := scanptr;
 661   cinfo^.num_scans := nscans;
 662
 663   if (ncomps = 3) and (cinfo^.jpeg_color_space = JCS_YCbCr) then
 664   begin
 665     { Custom script for YCbCr color images. }
 666     { Initial DC scan }
 667     scanptr := fill_dc_scans(scanptr, ncomps, 0, 1);
 668     { Initial AC scan: get some luma data out in a hurry }
 669     scanptr := fill_a_scan(scanptr, 0, 1, 5, 0, 2);
 670     { Chroma data is too small to be worth expending many scans on }
 671     scanptr := fill_a_scan(scanptr, 2, 1, 63, 0, 1);
 672     scanptr := fill_a_scan(scanptr, 1, 1, 63, 0, 1);
 673     { Complete spectral selection for luma AC }
 674     scanptr := fill_a_scan(scanptr, 0, 6, 63, 0, 2);
 675     { Refine next bit of luma AC }
 676     scanptr := fill_a_scan(scanptr, 0, 1, 63, 2, 1);
 677     { Finish DC successive approximation }
 678     scanptr := fill_dc_scans(scanptr, ncomps, 1, 0);
 679     { Finish AC successive approximation }
 680     scanptr := fill_a_scan(scanptr, 2, 1, 63, 1, 0);
 681     scanptr := fill_a_scan(scanptr, 1, 1, 63, 1, 0);
 682     { Luma bottom bit comes last since it's usually largest scan }
 683     scanptr := fill_a_scan(scanptr, 0, 1, 63, 1, 0);
 684   end
 685   else
 686   begin
 687     { All-purpose script for other color spaces. }
 688     { Successive approximation first pass }
 689     scanptr := fill_dc_scans(scanptr, ncomps, 0, 1);
 690     scanptr := fill_scans(scanptr, ncomps, 1, 5, 0, 2);
 691     scanptr := fill_scans(scanptr, ncomps, 6, 63, 0, 2);
 692     { Successive approximation second pass }
 693     scanptr := fill_scans(scanptr, ncomps, 1, 63, 2, 1);
 694     { Successive approximation final pass }
 695     scanptr := fill_dc_scans(scanptr, ncomps, 1, 0);
 696     scanptr := fill_scans(scanptr, ncomps, 1, 63, 1, 0);
 697   end;
 698 end;
 699
 700 {$endif}
 701 end.