home *** CD-ROM | disk | FTP | other *** search
/ Kompuutteri K-CD 2002 #1 / K-CD_2002-01.iso / Delphi / INFO / Extras / Jpeg / jpeg.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-05-22  |  53.7 KB  |  1,583 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Runtime Library                  }
  5. {       JPEG Image Compression/Decompression Unit       }
  6. {                                                       }
  7. {       Copyright (c) 1997,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10. {$HPPEMIT '#pragma link "jpeg.obj"'}
  11.  
  12. unit jpeg;
  13.  
  14. interface
  15.  
  16. uses Windows, SysUtils, Classes, Graphics;
  17.  
  18. type
  19.   TJPEGData = class(TSharedImage)
  20.   private
  21.     FData: TCustomMemoryStream;
  22.     FHeight: Integer;
  23.     FWidth: Integer;
  24.     FGrayscale: Boolean;
  25.   protected
  26.     procedure FreeHandle; override;
  27.   public
  28.     destructor Destroy; override;
  29.   end;
  30.  
  31.   TJPEGQualityRange = 1..100;   // 100 = best quality, 25 = pretty awful
  32.   TJPEGPerformance = (jpBestQuality, jpBestSpeed);
  33.   TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
  34.   TJPEGPixelFormat = (jf24Bit, jf8Bit);
  35.  
  36.   TJPEGImage = class(TGraphic)
  37.   private
  38.     FImage: TJPEGData;
  39.     FBitmap: TBitmap;
  40.     FScaledWidth: Integer;
  41.     FScaledHeight: Integer;
  42.     FTempPal: HPalette;
  43.     FSmoothing: Boolean;
  44.     FGrayScale: Boolean;
  45.     FPixelFormat: TJPEGPixelFormat;
  46.     FQuality: TJPEGQualityRange;
  47.     FProgressiveDisplay: Boolean;
  48.     FProgressiveEncoding: Boolean;
  49.     FPerformance: TJPEGPerformance;
  50.     FScale: TJPEGScale;
  51.     FNeedRecalc: Boolean;
  52.     procedure CalcOutputDimensions;
  53.     function GetBitmap: TBitmap;
  54.     function GetGrayscale: Boolean;
  55.     procedure SetGrayscale(Value: Boolean);
  56.     procedure SetPerformance(Value: TJPEGPerformance);
  57.     procedure SetPixelFormat(Value: TJPEGPixelFormat);
  58.     procedure SetScale(Value: TJPEGScale);
  59.     procedure SetSmoothing(Value: Boolean);
  60.   protected
  61.     procedure AssignTo(Dest: TPersistent); override;
  62.     procedure Changed(Sender: TObject); override;
  63.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  64.     function Equals(Graphic: TGraphic): Boolean; override;
  65.     procedure FreeBitmap;
  66.     function GetEmpty: Boolean; override;
  67.     function GetHeight: Integer; override;
  68.     function GetPalette: HPALETTE; override;
  69.     function GetWidth: Integer; override;
  70.     procedure NewBitmap;
  71.     procedure NewImage;
  72.     procedure ReadData(Stream: TStream); override;
  73.     procedure ReadStream(Size: Longint; Stream: TStream);
  74.     procedure SetHeight(Value: Integer); override;
  75.     procedure SetPalette(Value: HPalette); override;
  76.     procedure SetWidth(Value: Integer); override;
  77.     procedure WriteData(Stream: TStream); override;
  78.     property Bitmap: TBitmap read GetBitmap;  // volatile
  79.   public
  80.     constructor Create; override;
  81.     destructor Destroy; override;
  82.     procedure Compress;
  83.     procedure DIBNeeded;
  84.     procedure JPEGNeeded;
  85.     procedure Assign(Source: TPersistent); override;
  86.     procedure LoadFromStream(Stream: TStream); override;
  87.     procedure SaveToStream(Stream: TStream); override;
  88.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  89.       APalette: HPALETTE); override;
  90.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  91.       var APalette: HPALETTE); override;
  92.  
  93.     // Options affecting / reflecting compression and decompression behavior
  94.     property Grayscale: Boolean read GetGrayscale write SetGrayscale;
  95.     property ProgressiveEncoding: Boolean read FProgressiveEncoding write FProgressiveEncoding;
  96.  
  97.     // Compression options
  98.     property CompressionQuality: TJPEGQualityRange read FQuality write FQuality;
  99.  
  100.     // Decompression options
  101.     property PixelFormat: TJPEGPixelFormat read FPixelFormat write SetPixelFormat;
  102.     property ProgressiveDisplay: Boolean read FProgressiveDisplay write FProgressiveDisplay;
  103.     property Performance: TJPEGPerformance read FPerformance write SetPerformance;
  104.     property Scale: TJPEGScale read FScale write SetScale;
  105.     property Smoothing: Boolean read FSmoothing write SetSmoothing;
  106.   end;
  107.  
  108.   TJPEGDefaults = record
  109.     CompressionQuality: TJPEGQualityRange;
  110.     Grayscale: Boolean;
  111.     Performance: TJPEGPerformance;
  112.     PixelFormat: TJPEGPixelFormat;
  113.     ProgressiveDisplay: Boolean;
  114.     ProgressiveEncoding: Boolean;
  115.     Scale: TJPEGScale;
  116.     Smoothing: Boolean;
  117.   end;
  118.  
  119. var   // Default settings for all new TJPEGImage instances
  120.   JPEGDefaults: TJPEGDefaults = (
  121.     CompressionQuality: 90;
  122.     Grayscale: False;
  123.     Performance: jpBestQuality;
  124.     PixelFormat: jf24Bit;         // initialized to match video mode
  125.     ProgressiveDisplay: False;
  126.     ProgressiveEncoding: False;
  127.     Scale: jsFullSize;
  128.     Smoothing: True;
  129.   );
  130.  
  131. implementation
  132.  
  133. uses JConsts;
  134.  
  135. {$Z4}  // Minimum enum size = dword
  136. {$A4}  // DWord align data
  137.  
  138. { The following types and external function declarations are used to
  139.   call into functions of the Independent JPEG Group's (IJG) implementation
  140.   of the JPEG image compression/decompression public standard.  The IJG
  141.   library's C source code is compiled into OBJ files and linked into
  142.   the Delphi application. Only types and functions needed by this unit
  143.   are declared; all IJG internal structures are stubbed out with
  144.   generic pointers to reduce internal source code congestion.
  145.  
  146.   IJG source code copyright (C) 1991-1996, Thomas G. Lane. }
  147.  
  148. const
  149.   JPEG_LIB_VERSION = 61;        { Version 6a }
  150.  
  151.   JPEG_RST0     = $D0;  { RST0 marker code }
  152.   JPEG_EOI      = $D9;  { EOI marker code }
  153.   JPEG_APP0     = $E0;  { APP0 marker code }
  154.   JPEG_COM      = $FE;  { COM marker code }
  155.  
  156.   DCTSIZE             = 8;      { The basic DCT block is 8x8 samples }
  157.   DCTSIZE2            = 64;     { DCTSIZE squared; # of elements in a block }
  158.   NUM_QUANT_TBLS      = 4;      { Quantization tables are numbered 0..3 }
  159.   NUM_HUFF_TBLS       = 4;      { Huffman tables are numbered 0..3 }
  160.   NUM_ARITH_TBLS      = 16;     { Arith-coding tables are numbered 0..15 }
  161.   MAX_COMPS_IN_SCAN   = 4;      { JPEG limit on # of components in one scan }
  162.   MAX_SAMP_FACTOR     = 4;      { JPEG limit on sampling factors }
  163.   C_MAX_BLOCKS_IN_MCU = 10;     { compressor's limit on blocks per MCU }
  164.   D_MAX_BLOCKS_IN_MCU = 10;     { decompressor's limit on blocks per MCU }
  165.   MAX_COMPONENTS = 10;          { maximum number of image components (color channels) }
  166.  
  167.   MAXJSAMPLE = 255;
  168.   CENTERJSAMPLE = 128;
  169.  
  170. type
  171.   JSAMPLE = byte;
  172.   GETJSAMPLE = integer;
  173.   JCOEF = integer;
  174.   JCOEF_PTR = ^JCOEF;
  175.   UINT8 = byte;
  176.   UINT16 = Word;
  177.   UINT = Cardinal;
  178.   INT16 = SmallInt;
  179.   INT32 = Integer;
  180.   INT32PTR = ^INT32;
  181.   JDIMENSION = Cardinal;
  182.  
  183.   JOCTET = Byte;
  184.   jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
  185.   JOCTET_FIELD = array[jTOctet] of JOCTET;
  186.   JOCTET_FIELD_PTR = ^JOCTET_FIELD;
  187.   JOCTETPTR = ^JOCTET;
  188.  
  189.   JSAMPLE_PTR = ^JSAMPLE;
  190.   JSAMPROW_PTR = ^JSAMPROW;
  191.  
  192.   jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1;
  193.   JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE;  {far}
  194.   JSAMPROW = ^JSAMPLE_ARRAY;  { ptr to one image row of pixel samples. }
  195.  
  196.   jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1;
  197.   JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW;
  198.   JSAMPARRAY = ^JSAMPROW_ARRAY;  { ptr to some rows (a 2-D sample array) }
  199.  
  200.   jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1;
  201.   JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY;
  202.   JSAMPIMAGE = ^JSAMP_ARRAY;  { a 3-D sample array: top index is color }
  203.  
  204. const
  205.   CSTATE_START        = 100;    { after create_compress }
  206.   CSTATE_SCANNING     = 101;    { start_compress done, write_scanlines OK }
  207.   CSTATE_RAW_OK       = 102;    { start_compress done, write_raw_data OK }
  208.   CSTATE_WRCOEFS      = 103;    { jpeg_write_coefficients done }
  209.   DSTATE_START        = 200;    { after create_decompress }
  210.   DSTATE_INHEADER     = 201;    { reading header markers, no SOS yet }
  211.   DSTATE_READY        = 202;    { found SOS, ready for start_decompress }
  212.   DSTATE_PRELOAD      = 203;    { reading multiscan file in start_decompress}
  213.   DSTATE_PRESCAN      = 204;    { performing dummy pass for 2-pass quant }
  214.   DSTATE_SCANNING     = 205;    { start_decompress done, read_scanlines OK }
  215.   DSTATE_RAW_OK       = 206;    { start_decompress done, read_raw_data OK }
  216.   DSTATE_BUFIMAGE     = 207;    { expecting jpeg_start_output }
  217.   DSTATE_BUFPOST      = 208;    { looking for SOS/EOI in jpeg_finish_output }
  218.   DSTATE_RDCOEFS      = 209;    { reading file in jpeg_read_coefficients }
  219.   DSTATE_STOPPING     = 210;    { looking for EOI in jpeg_finish_decompress }
  220.  
  221. { Known color spaces. }
  222.  
  223. type
  224.   J_COLOR_SPACE = (
  225.     JCS_UNKNOWN,            { error/unspecified }
  226.     JCS_GRAYSCALE,          { monochrome }
  227.     JCS_RGB,                { red/green/blue }
  228.     JCS_YCbCr,              { Y/Cb/Cr (also known as YUV) }
  229.     JCS_CMYK,               { C/M/Y/K }
  230.     JCS_YCCK                { Y/Cb/Cr/K }
  231.                   );
  232.  
  233. { DCT/IDCT algorithm options. }
  234.  
  235. type
  236.   J_DCT_METHOD = (
  237.     JDCT_ISLOW,        { slow but accurate integer algorithm }
  238.     JDCT_IFAST,        { faster, less accurate integer method }
  239.     JDCT_FLOAT        { floating-point: accurate, fast on fast HW (Pentium)}
  240.                  );
  241.  
  242. { Dithering options for decompression. }
  243.  
  244. type
  245.   J_DITHER_MODE = (
  246.     JDITHER_NONE,               { no dithering }
  247.     JDITHER_ORDERED,            { simple ordered dither }
  248.     JDITHER_FS                  { Floyd-Steinberg error diffusion dither }
  249.                   );
  250.  
  251. { Error handler }
  252.  
  253. const
  254.   JMSG_LENGTH_MAX  = 200;  { recommended size of format_message buffer }
  255.   JMSG_STR_PARM_MAX = 80;
  256.  
  257.   JPOOL_PERMANENT = 0;  // lasts until master record is destroyed
  258.   JPOOL_IMAGE        = 1;     // lasts until done with image/datastream
  259.  
  260. type
  261.   jpeg_error_mgr_ptr = ^jpeg_error_mgr;
  262.   jpeg_progress_mgr_ptr = ^jpeg_progress_mgr;
  263.  
  264.   j_common_ptr = ^jpeg_common_struct;
  265.   j_compress_ptr = ^jpeg_compress_struct;
  266.   j_decompress_ptr = ^jpeg_decompress_struct;
  267.  
  268. { Routine signature for application-supplied marker processing methods.
  269.   Need not pass marker code since it is stored in cinfo^.unread_marker. }
  270.  
  271.   jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : LongBool;
  272.  
  273. { Marker reading & parsing }
  274.   jpeg_marker_reader_ptr = ^jpeg_marker_reader;
  275.   jpeg_marker_reader = record
  276.     reset_marker_reader : procedure(cinfo : j_decompress_ptr);
  277.     { Read markers until SOS or EOI.
  278.       Returns same codes as are defined for jpeg_consume_input:
  279.       JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. }
  280.  
  281.     read_markers : function (cinfo : j_decompress_ptr) : Integer;
  282.     { Read a restart marker --- exported for use by entropy decoder only }
  283.     read_restart_marker : jpeg_marker_parser_method;
  284.     { Application-overridable marker processing methods }
  285.     process_COM : jpeg_marker_parser_method;
  286.     process_APPn : Array[0..16-1] of jpeg_marker_parser_method;
  287.  
  288.     { State of marker reader --- nominally internal, but applications
  289.       supplying COM or APPn handlers might like to know the state. }
  290.  
  291.     saw_SOI : LongBool;            { found SOI? }
  292.     saw_SOF : LongBool;            { found SOF? }
  293.     next_restart_num : Integer;    { next restart number expected (0-7) }
  294.     discarded_bytes : UINT;        { # of bytes skipped looking for a marker }
  295.   end;
  296.  
  297.   {int8array = Array[0..8-1] of int;}
  298.   int8array = Array[0..8-1] of Integer;
  299.  
  300.   jpeg_error_mgr = record
  301.     { Error exit handler: does not return to caller }
  302.     error_exit : procedure  (cinfo : j_common_ptr);
  303.     { Conditionally emit a trace or warning message }
  304.     emit_message : procedure (cinfo : j_common_ptr; msg_level : Integer);
  305.     { Routine that actually outputs a trace or error message }
  306.     output_message : procedure (cinfo : j_common_ptr);
  307.     { Format a message string for the most recent JPEG error or message }
  308.     format_message : procedure  (cinfo : j_common_ptr; buffer: PChar);
  309.     { Reset error state variables at start of a new image }
  310.     reset_error_mgr : procedure (cinfo : j_common_ptr);
  311.  
  312.     { The message ID code and any parameters are saved here.
  313.       A message can have one string parameter or up to 8 int parameters. }
  314.  
  315.     msg_code : Integer;
  316.  
  317.     msg_parm : record
  318.       case byte of
  319.       0:(i : int8array);
  320.       1:(s : string[JMSG_STR_PARM_MAX]);
  321.     end;
  322.     trace_level : Integer;     { max msg_level that will be displayed }
  323.     num_warnings : Integer;    { number of corrupt-data warnings }
  324.   end;
  325.  
  326.  
  327. { Data destination object for compression }
  328.   jpeg_destination_mgr_ptr = ^jpeg_destination_mgr;
  329.   jpeg_destination_mgr = record
  330.     next_output_byte : JOCTETptr;  { => next byte to write in buffer }
  331.     free_in_buffer : Longint;    { # of byte spaces remaining in buffer }
  332.  
  333.     init_destination : procedure (cinfo : j_compress_ptr);
  334.     empty_output_buffer : function (cinfo : j_compress_ptr) : LongBool;
  335.     term_destination : procedure (cinfo : j_compress_ptr);
  336.   end;
  337.  
  338.  
  339. { Data source object for decompression }
  340.  
  341.   jpeg_source_mgr_ptr = ^jpeg_source_mgr;
  342.   jpeg_source_mgr = record
  343.     next_input_byte : JOCTETptr;      { => next byte to read from buffer }
  344.     bytes_in_buffer : Longint;       { # of bytes remaining in buffer }
  345.  
  346.     init_source : procedure  (cinfo : j_decompress_ptr);
  347.     fill_input_buffer : function (cinfo : j_decompress_ptr) : LongBool;
  348.     skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : Longint);
  349.     resync_to_restart : function (cinfo : j_decompress_ptr;
  350.                                   desired : Integer) : LongBool;
  351.     term_source : procedure (cinfo : j_decompress_ptr);
  352.   end;
  353.  
  354. { JPEG library memory manger routines }
  355.   jpeg_memory_mgr_ptr = ^jpeg_memory_mgr;
  356.   jpeg_memory_mgr = record
  357.     { Method pointers }
  358.     alloc_small : function (cinfo : j_common_ptr;
  359.                             pool_id, sizeofobject: Integer): pointer;
  360.     alloc_large : function (cinfo : j_common_ptr;
  361.                             pool_id, sizeofobject: Integer): pointer;
  362.     alloc_sarray : function (cinfo : j_common_ptr; pool_id : Integer;
  363.                              samplesperrow : JDIMENSION;
  364.                              numrows : JDIMENSION) : JSAMPARRAY;
  365.     alloc_barray : pointer;
  366.     request_virt_sarray : pointer;
  367.     request_virt_barray : pointer;
  368.     realize_virt_arrays : pointer;
  369.     access_virt_sarray : pointer;
  370.     access_virt_barray : pointer;
  371.     free_pool : pointer;
  372.     self_destruct : pointer;
  373.     max_memory_to_use : Longint;
  374.   end;
  375.  
  376.     { Fields shared with jpeg_decompress_struct }
  377.   jpeg_common_struct = record
  378.     err : jpeg_error_mgr_ptr;        { Error handler module }
  379.     mem : jpeg_memory_mgr_ptr;          { Memory manager module }
  380.     progress : jpeg_progress_mgr_ptr;   { Progress monitor, or NIL if none }
  381.     is_decompressor : LongBool;      { so common code can tell which is which }
  382.     global_state : Integer;          { for checking call sequence validity }
  383.   end;
  384.  
  385. { Progress monitor object }
  386.  
  387.   jpeg_progress_mgr = record
  388.     progress_monitor : procedure(const cinfo : jpeg_common_struct);
  389.     pass_counter : Integer;     { work units completed in this pass }
  390.     pass_limit : Integer;       { total number of work units in this pass }
  391.     completed_passes : Integer;    { passes completed so far }
  392.     total_passes : Integer;     { total number of passes expected }
  393.     // extra Delphi info
  394.     instance: TJPEGImage;       // ptr to current TJPEGImage object
  395.     last_pass: Integer;
  396.     last_pct: Integer;
  397.     last_time: Integer;
  398.     last_scanline: Integer;
  399.   end;
  400.  
  401.  
  402. { Master record for a compression instance }
  403.  
  404.   jpeg_compress_struct = record
  405.     common: jpeg_common_struct;
  406.  
  407.     dest : jpeg_destination_mgr_ptr; { Destination for compressed data }
  408.  
  409.   { Description of source image --- these fields must be filled in by
  410.     outer application before starting compression.  in_color_space must
  411.     be correct before you can even call jpeg_set_defaults(). }
  412.  
  413.     image_width : JDIMENSION;         { input image width }
  414.     image_height : JDIMENSION;        { input image height }
  415.     input_components : Integer;       { # of color components in input image }
  416.     in_color_space : J_COLOR_SPACE;   { colorspace of input image }
  417.     input_gamma : double;             { image gamma of input image }
  418.  
  419.     // Compression parameters
  420.     data_precision : Integer;             { bits of precision in image data }
  421.     num_components : Integer;             { # of color components in JPEG image }
  422.     jpeg_color_space : J_COLOR_SPACE;     { colorspace of JPEG image }
  423.     comp_info : Pointer;
  424.     quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of Pointer;
  425.     dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
  426.     ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
  427.     arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
  428.     arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
  429.     arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }
  430.     num_scans : Integer;         { # of entries in scan_info array }
  431.     scan_info : Pointer;     { script for multi-scan file, or NIL }
  432.     raw_data_in : LongBool;        { TRUE=caller supplies downsampled data }
  433.     arith_code : LongBool;         { TRUE=arithmetic coding, FALSE=Huffman }
  434.     optimize_coding : LongBool;    { TRUE=optimize entropy encoding parms }
  435.     CCIR601_sampling : LongBool;   { TRUE=first samples are cosited }
  436.     smoothing_factor : Integer;       { 1..100, or 0 for no input smoothing }
  437.     dct_method : J_DCT_METHOD;    { DCT algorithm selector }
  438.     restart_interval : UINT;      { MCUs per restart, or 0 for no restart }
  439.     restart_in_rows : Integer;        { if > 0, MCU rows per restart interval }
  440.  
  441.     { Parameters controlling emission of special markers. }
  442.     write_JFIF_header : LongBool;  { should a JFIF marker be written? }
  443.     { These three values are not used by the JPEG code, merely copied }
  444.     { into the JFIF APP0 marker.  density_unit can be 0 for unknown, }
  445.     { 1 for dots/inch, or 2 for dots/cm.  Note that the pixel aspect }
  446.     { ratio is defined by X_density/Y_density even when density_unit=0. }
  447.     density_unit : UINT8;         { JFIF code for pixel size units }
  448.     X_density : UINT16;           { Horizontal pixel density }
  449.     Y_density : UINT16;           { Vertical pixel density }
  450.     write_Adobe_marker : LongBool; { should an Adobe marker be written? }
  451.  
  452.     { State variable: index of next scanline to be written to
  453.       jpeg_write_scanlines().  Application may use this to control its
  454.       processing loop, e.g., "while (next_scanline < image_height)". }
  455.  
  456.     next_scanline : JDIMENSION;   { 0 .. image_height-1  }
  457.  
  458.     { Remaining fields are known throughout compressor, but generally
  459.       should not be touched by a surrounding application. }
  460.     progressive_mode : LongBool;   { TRUE if scan script uses progressive mode }
  461.     max_h_samp_factor : Integer;      { largest h_samp_factor }
  462.     max_v_samp_factor : Integer;      { largest v_samp_factor }
  463.     total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr }
  464.     comps_in_scan : Integer;          { # of JPEG components in this scan }
  465.     cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer;
  466.     MCUs_per_row : JDIMENSION;    { # of MCUs across the image }
  467.     MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image }
  468.     blocks_in_MCU : Integer;          { # of DCT blocks per MCU }
  469.     MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of Integer;
  470.     Ss, Se, Ah, Al : Integer;         { progressive JPEG parameters for scan }
  471.  
  472.     { Links to compression subobjects (methods and private variables of modules) }
  473.     master : Pointer;
  474.     main : Pointer;
  475.     prep : Pointer;
  476.     coef : Pointer;
  477.     marker : Pointer;
  478.     cconvert : Pointer;
  479.     downsample : Pointer;
  480.     fdct : Pointer;
  481.     entropy : Pointer;
  482.   end;
  483.  
  484.  
  485. { Master record for a decompression instance }
  486.  
  487.   jpeg_decompress_struct = record
  488.     common: jpeg_common_struct;
  489.  
  490.     { Source of compressed data }
  491.     src : jpeg_source_mgr_ptr;
  492.  
  493.     { Basic description of image --- filled in by jpeg_read_header(). }
  494.     { Application may inspect these values to decide how to process image. }
  495.  
  496.     image_width : JDIMENSION;      { nominal image width (from SOF marker) }
  497.     image_height : JDIMENSION;     { nominal image height }
  498.     num_components : Integer;          { # of color components in JPEG image }
  499.     jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image }
  500.  
  501.     { Decompression processing parameters }
  502.     out_color_space : J_COLOR_SPACE; { colorspace for output }
  503.     scale_num, scale_denom : uint ;  { fraction by which to scale image }
  504.     output_gamma : double;           { image gamma wanted in output }
  505.     buffered_image : LongBool;        { TRUE=multiple output passes }
  506.     raw_data_out : LongBool;          { TRUE=downsampled data wanted }
  507.     dct_method : J_DCT_METHOD;       { IDCT algorithm selector }
  508.     do_fancy_upsampling : LongBool;   { TRUE=apply fancy upsampling }
  509.     do_block_smoothing : LongBool;    { TRUE=apply interblock smoothing }
  510.     quantize_colors : LongBool;       { TRUE=colormapped output wanted }
  511.     { the following are ignored if not quantize_colors: }
  512.     dither_mode : J_DITHER_MODE;     { type of color dithering to use }
  513.     two_pass_quantize : LongBool;     { TRUE=use two-pass color quantization }
  514.     desired_number_of_colors : Integer;  { max # colors to use in created colormap }
  515.     { these are significant only in buffered-image mode: }
  516.     enable_1pass_quant : LongBool;    { enable future use of 1-pass quantizer }
  517.     enable_external_quant : LongBool; { enable future use of external colormap }
  518.     enable_2pass_quant : LongBool;    { enable future use of 2-pass quantizer }
  519.  
  520.     { Description of actual output image that will be returned to application.
  521.       These fields are computed by jpeg_start_decompress().
  522.       You can also use jpeg_calc_output_dimensions() to determine these values
  523.       in advance of calling jpeg_start_decompress(). }
  524.  
  525.     output_width : JDIMENSION;       { scaled image width }
  526.     output_height: JDIMENSION;       { scaled image height }
  527.     out_color_components : Integer;  { # of color components in out_color_space }
  528.     output_components : Integer;     { # of color components returned }
  529.     { output_components is 1 (a colormap index) when quantizing colors;
  530.       otherwise it equals out_color_components. }
  531.  
  532.     rec_outbuf_height : Integer;     { min recommended height of scanline buffer }
  533.     { If the buffer passed to jpeg_read_scanlines() is less than this many
  534.       rows high, space and time will be wasted due to unnecessary data
  535.       copying. Usually rec_outbuf_height will be 1 or 2, at most 4. }
  536.  
  537.     { When quantizing colors, the output colormap is described by these
  538.       fields. The application can supply a colormap by setting colormap
  539.       non-NIL before calling jpeg_start_decompress; otherwise a colormap
  540.       is created during jpeg_start_decompress or jpeg_start_output. The map
  541.       has out_color_components rows and actual_number_of_colors columns. }
  542.  
  543.     actual_number_of_colors : Integer;      { number of entries in use }
  544.     colormap : JSAMPARRAY;              { The color map as a 2-D pixel array }
  545.  
  546.     { State variables: these variables indicate the progress of decompression.
  547.       The application may examine these but must not modify them. }
  548.  
  549.     { Row index of next scanline to be read from jpeg_read_scanlines().
  550.       Application may use this to control its processing loop, e.g.,
  551.       "while (output_scanline < output_height)". }
  552.  
  553.     output_scanline : JDIMENSION; { 0 .. output_height-1  }
  554.  
  555.     { Current input scan number and number of iMCU rows completed in scan.
  556.       These indicate the progress of the decompressor input side. }
  557.  
  558.     input_scan_number : Integer;      { Number of SOS markers seen so far }
  559.     input_iMCU_row : JDIMENSION;  { Number of iMCU rows completed }
  560.  
  561.     { The "output scan number" is the notional scan being displayed by the
  562.       output side.  The decompressor will not allow output scan/row number
  563.       to get ahead of input scan/row, but it can fall arbitrarily far behind.}
  564.  
  565.     output_scan_number : Integer;     { Nominal scan number being displayed }
  566.     output_iMCU_row : Integer;        { Number of iMCU rows read }
  567.  
  568.     coef_bits : Pointer;
  569.  
  570.     { Internal JPEG parameters --- the application usually need not look at
  571.       these fields.  Note that the decompressor output side may not use
  572.       any parameters that can change between scans. }
  573.  
  574.     { Quantization and Huffman tables are carried forward across input
  575.       datastreams when processing abbreviated JPEG datastreams. }
  576.  
  577.     quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of Pointer;
  578.     dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
  579.     ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
  580.  
  581.     { These parameters are never carried across datastreams, since they
  582.       are given in SOF/SOS markers or defined to be reset by SOI. }
  583.     data_precision : Integer;          { bits of precision in image data }
  584.     comp_info : Pointer;
  585.     progressive_mode : LongBool;    { TRUE if SOFn specifies progressive mode }
  586.     arith_code : LongBool;          { TRUE=arithmetic coding, FALSE=Huffman }
  587.     arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
  588.     arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
  589.     arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }
  590.  
  591.     restart_interval : UINT; { MCUs per restart interval, or 0 for no restart }
  592.  
  593.     { These fields record data obtained from optional markers recognized by
  594.       the JPEG library. }
  595.     saw_JFIF_marker : LongBool;  { TRUE iff a JFIF APP0 marker was found }
  596.     { Data copied from JFIF marker: }
  597.     density_unit : UINT8;       { JFIF code for pixel size units }
  598.     X_density : UINT16;         { Horizontal pixel density }
  599.     Y_density : UINT16;         { Vertical pixel density }
  600.     saw_Adobe_marker : LongBool; { TRUE iff an Adobe APP14 marker was found }
  601.     Adobe_transform : UINT8;    { Color transform code from Adobe marker }
  602.  
  603.     CCIR601_sampling : LongBool; { TRUE=first samples are cosited }
  604.  
  605.     { Remaining fields are known throughout decompressor, but generally
  606.       should not be touched by a surrounding application. }
  607.     max_h_samp_factor : Integer;    { largest h_samp_factor }
  608.     max_v_samp_factor : Integer;    { largest v_samp_factor }
  609.     min_DCT_scaled_size : Integer;  { smallest DCT_scaled_size of any component }
  610.     total_iMCU_rows : JDIMENSION; { # of iMCU rows in image }
  611.     sample_range_limit : Pointer;   { table for fast range-limiting }
  612.  
  613.     { These fields are valid during any one scan.
  614.       They describe the components and MCUs actually appearing in the scan.
  615.       Note that the decompressor output side must not use these fields. }
  616.     comps_in_scan : Integer;           { # of JPEG components in this scan }
  617.     cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer;
  618.     MCUs_per_row : JDIMENSION;     { # of MCUs across the image }
  619.     MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image }
  620.     blocks_in_MCU : JDIMENSION;    { # of DCT blocks per MCU }
  621.     MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of Integer;
  622.     Ss, Se, Ah, Al : Integer;          { progressive JPEG parameters for scan }
  623.  
  624.     { This field is shared between entropy decoder and marker parser.
  625.       It is either zero or the code of a JPEG marker that has been
  626.       read from the data source, but has not yet been processed. }
  627.     unread_marker : Integer;
  628.  
  629.     { Links to decompression subobjects
  630.       (methods, private variables of modules) }
  631.     master : Pointer;
  632.     main : Pointer;
  633.     coef : Pointer;
  634.     post : Pointer;
  635.     inputctl : Pointer;
  636.     marker : Pointer;
  637.     entropy : Pointer;
  638.     idct : Pointer;
  639.     upsample : Pointer;
  640.     cconvert : Pointer;
  641.     cquantize : Pointer;
  642.   end;
  643.  
  644.   TJPEGContext = record
  645.     err: jpeg_error_mgr;
  646.     progress: jpeg_progress_mgr;
  647.     FinalDCT: J_DCT_METHOD;
  648.     FinalTwoPassQuant: Boolean;
  649.     FinalDitherMode: J_DITHER_MODE;
  650.     case byte of
  651.       0: (common: jpeg_common_struct);
  652.       1: (d: jpeg_decompress_struct);
  653.       2: (c: jpeg_compress_struct);
  654.   end;
  655.  
  656. { Decompression startup: read start of JPEG datastream to see what's there
  657.    function jpeg_read_header (cinfo : j_decompress_ptr;
  658.                               require_image : LongBool) : Integer;
  659.   Return value is one of: }
  660. const
  661.   JPEG_SUSPENDED              = 0; { Suspended due to lack of input data }
  662.   JPEG_HEADER_OK              = 1; { Found valid image datastream }
  663.   JPEG_HEADER_TABLES_ONLY     = 2; { Found valid table-specs-only datastream }
  664. { If you pass require_image = TRUE (normal case), you need not check for
  665.   a TABLES_ONLY return code; an abbreviated file will cause an error exit.
  666.   JPEG_SUSPENDED is only possible if you use a data source module that can
  667.   give a suspension return (the stdio source module doesn't). }
  668.  
  669.  
  670. { function jpeg_consume_input (cinfo : j_decompress_ptr) : Integer;
  671.   Return value is one of: }
  672.  
  673.   JPEG_REACHED_SOS            = 1; { Reached start of new scan }
  674.   JPEG_REACHED_EOI            = 2; { Reached end of image }
  675.   JPEG_ROW_COMPLETED          = 3; { Completed one iMCU row }
  676.   JPEG_SCAN_COMPLETED         = 4; { Completed last iMCU row of a scan }
  677.  
  678.  
  679. // Stubs for external C RTL functions referenced by JPEG OBJ files.
  680.  
  681. function _malloc(size: Integer): Pointer; cdecl;
  682. begin
  683.   GetMem(Result, size);
  684. end;
  685.  
  686. procedure _free(P: Pointer); cdecl;
  687. begin
  688.   FreeMem(P);
  689. end;
  690.  
  691. procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl;
  692. begin
  693.   FillChar(P^, count, B);
  694. end;
  695.  
  696. procedure _memcpy(dest, source: Pointer; count: Integer);cdecl;
  697. begin
  698.   Move(source^, dest^, count);
  699. end;
  700.  
  701. function _fread(var buf; recsize, reccount: Integer; S: TStream): Integer; cdecl;
  702. begin
  703.   Result := S.Read(buf, recsize * reccount);
  704. end;
  705.  
  706. function _fwrite(const buf; recsize, reccount: Integer; S: TStream): Integer; cdecl;
  707. begin
  708.   Result := S.Write(buf, recsize * reccount);
  709. end;
  710.  
  711. function _fflush(S: TStream): Integer; cdecl;
  712. begin
  713.   Result := 0;
  714. end;
  715.  
  716. function __ftol: Integer;
  717. var
  718.   f: double;
  719. begin
  720.   asm
  721.     lea    eax, f             //  BC++ passes floats on the FPU stack
  722.     fstp  qword ptr [eax]     //  Delphi passes floats on the CPU stack
  723.   end;
  724.   Result := Integer(Trunc(f));
  725. end;
  726.  
  727. var
  728.   __turboFloat: LongBool = False;
  729.  
  730. {$L jdapimin.obj}
  731. {$L jmemmgr.obj}
  732. {$L jmemnobs.obj}
  733. {$L jdinput.obj}
  734. {$L jdatasrc.obj}
  735. {$L jdapistd.obj}
  736. {$L jdmaster.obj}
  737. {$L jdphuff.obj}
  738. {$L jdhuff.obj}
  739. {$L jdmerge.obj}
  740. {$L jdcolor.obj}
  741. {$L jquant1.obj}
  742. {$L jquant2.obj}
  743. {$L jdmainct.obj}
  744. {$L jdcoefct.obj}
  745. {$L jdpostct.obj}
  746. {$L jddctmgr.obj}
  747. {$L jdsample.obj}
  748. {$L jidctflt.obj}
  749. {$L jidctfst.obj}
  750. {$L jidctint.obj}
  751. {$L jidctred.obj}
  752. {$L jdmarker.obj}
  753. {$L jutils.obj}
  754. {$L jcomapi.obj}
  755.  
  756. procedure jpeg_CreateDecompress (var cinfo : jpeg_decompress_struct;
  757.   version : integer; structsize : integer); external;
  758. procedure jpeg_stdio_src(var cinfo: jpeg_decompress_struct;
  759.   input_file: TStream); external;
  760. procedure jpeg_read_header(var cinfo: jpeg_decompress_struct;
  761.   RequireImage: LongBool); external;
  762. procedure jpeg_calc_output_dimensions(var cinfo: jpeg_decompress_struct); external;
  763. function jpeg_start_decompress(var cinfo: jpeg_decompress_struct): Longbool; external;
  764. function jpeg_read_scanlines(var cinfo: jpeg_decompress_struct;
  765.     scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external;
  766. function jpeg_finish_decompress(var cinfo: jpeg_decompress_struct): Longbool; external;
  767. procedure jpeg_destroy_decompress (var cinfo : jpeg_decompress_struct); external;
  768. function jpeg_has_multiple_scans(var cinfo: jpeg_decompress_struct): Longbool; external;
  769. function jpeg_consume_input(var cinfo: jpeg_decompress_struct): Integer; external;
  770. function jpeg_start_output(var cinfo: jpeg_decompress_struct; scan_number: Integer): Longbool; external;
  771. function jpeg_finish_output(var cinfo: jpeg_decompress_struct): LongBool; external;
  772. procedure jpeg_destroy(var cinfo: jpeg_common_struct); external;
  773.  
  774. {$L jdatadst.obj}
  775. {$L jcparam.obj}
  776. {$L jcapistd.obj}
  777. {$L jcapimin.obj}
  778. {$L jcinit.obj}
  779. {$L jcmarker.obj}
  780. {$L jcmaster.obj}
  781. {$L jcmainct.obj}
  782. {$L jcprepct.obj}
  783. {$L jccoefct.obj}
  784. {$L jccolor.obj}
  785. {$L jcsample.obj}
  786. {$L jcdctmgr.obj}
  787. {$L jcphuff.obj}
  788. {$L jfdctint.obj}
  789. {$L jfdctfst.obj}
  790. {$L jfdctflt.obj}
  791. {$L jchuff.obj}
  792.  
  793. procedure jpeg_CreateCompress (var cinfo : jpeg_compress_struct;
  794.   version : integer; structsize : integer); external;
  795. procedure jpeg_stdio_dest(var cinfo: jpeg_compress_struct;
  796.   output_file: TStream); external;
  797. procedure jpeg_set_defaults(var cinfo: jpeg_compress_struct); external;
  798. procedure jpeg_set_quality(var cinfo: jpeg_compress_struct; Quality: Integer;
  799.   Baseline: Longbool); external;
  800. procedure jpeg_set_colorspace(var cinfo: jpeg_compress_struct;
  801.   colorspace: J_COLOR_SPACE); external;
  802. procedure jpeg_simple_progression(var cinfo: jpeg_compress_struct); external;
  803. procedure jpeg_start_compress(var cinfo: jpeg_compress_struct;
  804.   WriteAllTables: LongBool); external;
  805. function jpeg_write_scanlines(var cinfo: jpeg_compress_struct;
  806.   scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external;
  807. procedure jpeg_finish_compress(var cinfo: jpeg_compress_struct); external;
  808.  
  809.  
  810. type
  811.   EJPEG = class(EInvalidGraphic);
  812.  
  813. procedure InvalidOperation(const Msg: string); near;
  814. begin
  815.   raise EInvalidGraphicOperation.Create(Msg);
  816. end;
  817.  
  818. procedure JpegError(cinfo: j_common_ptr);
  819. begin
  820.   raise EJPEG.CreateFmt(sJPEGError,[cinfo^.err^.msg_code]);
  821. end;
  822.  
  823. procedure EmitMessage(cinfo: j_common_ptr; msg_level: Integer);
  824. begin
  825.   //!!
  826. end;
  827.  
  828. procedure OutputMessage(cinfo: j_common_ptr);
  829. begin
  830.   //!!
  831. end;
  832.  
  833. procedure FormatMessage(cinfo: j_common_ptr; buffer: PChar);
  834. begin
  835.   //!!
  836. end;
  837.  
  838. procedure ResetErrorMgr(cinfo: j_common_ptr);
  839. begin
  840.   cinfo^.err^.num_warnings := 0;
  841.   cinfo^.err^.msg_code := 0;
  842. end;
  843.  
  844.  
  845. const
  846.   jpeg_std_error: jpeg_error_mgr = (
  847.     error_exit: JpegError;
  848.     emit_message: EmitMessage;
  849.     output_message: OutputMessage;
  850.     format_message: FormatMessage;
  851.     reset_error_mgr: ResetErrorMgr);
  852.  
  853.  
  854. { TJPEGData }
  855.  
  856. destructor TJPEGData.Destroy;
  857. begin
  858.   FData.Free;
  859.   inherited Destroy;
  860. end;
  861.  
  862. procedure TJPEGData.FreeHandle;
  863. begin
  864. end;
  865.  
  866. { TJPEGImage }
  867.  
  868. constructor TJPEGImage.Create;
  869. begin
  870.   inherited Create;
  871.   NewImage;
  872.   FQuality := JPEGDefaults.CompressionQuality;
  873.   FGrayscale := JPEGDefaults.Grayscale;
  874.   FPerformance := JPEGDefaults.Performance;
  875.   FPixelFormat := JPEGDefaults.PixelFormat;
  876.   FProgressiveDisplay := JPEGDefaults.ProgressiveDisplay;
  877.   FProgressiveEncoding := JPEGDefaults.ProgressiveEncoding;
  878.   FScale := JPEGDefaults.Scale;
  879.   FSmoothing := JPEGDefaults.Smoothing;
  880. end;
  881.  
  882. destructor TJPEGImage.Destroy;
  883. begin
  884.   if FTempPal <> 0 then DeleteObject(FTempPal);
  885.   FBitmap.Free;
  886.   FImage.Release;
  887.   inherited Destroy;
  888. end;
  889.  
  890. procedure TJPEGImage.Assign(Source: TPersistent);
  891. begin
  892.   if Source is TJPEGImage then
  893.   begin
  894.     FImage.Release;
  895.     FImage := TJPEGImage(Source).FImage;
  896.     FImage.Reference;
  897.     if TJPEGImage(Source).FBitmap <> nil then
  898.     begin
  899.       NewBitmap;
  900.       FBitmap.Assign(TJPEGImage(Source).FBitmap);
  901.     end;
  902.   end
  903.   else if Source is TBitmap then
  904.   begin
  905.     NewImage;
  906.     NewBitmap;
  907.     FBitmap.Assign(Source);
  908.   end
  909.   else
  910.     inherited Assign(Source);
  911. end;
  912.  
  913. procedure TJPEGImage.AssignTo(Dest: TPersistent);
  914. begin
  915.   if Dest is TBitmap then
  916.     Dest.Assign(Bitmap)
  917.   else
  918.     inherited AssignTo(Dest);
  919. end;
  920.  
  921. procedure ProgressCallback(const cinfo: jpeg_common_struct);
  922. var
  923.   Ticks: Integer;
  924.   R: TRect;
  925.   temp: Integer;
  926. begin
  927.   if (cinfo.progress = nil) or (cinfo.progress^.instance = nil) then Exit;
  928.   with cinfo.progress^ do
  929.   begin
  930.     Ticks := GetTickCount;
  931.     if (Ticks - last_time) < 500 then Exit;
  932.     temp := last_time;
  933.     last_time := Ticks;
  934.     if temp = 0 then Exit;
  935.     if cinfo.is_decompressor then
  936.       with j_decompress_ptr(@cinfo)^ do
  937.       begin
  938.         R := Rect(0, last_scanline, output_width, output_scanline);
  939.         if R.Bottom < last_scanline then
  940.           R.Bottom := output_height;
  941.       end
  942.     else
  943.       R := Rect(0,0,0,0);
  944.     temp := Integer(Trunc(100.0*(completed_passes + (pass_counter/pass_limit))/total_passes));
  945.     if temp = last_pct then Exit;
  946.     last_pct := temp;
  947.     if cinfo.is_decompressor then
  948.       last_scanline := j_decompress_ptr(@cinfo)^.output_scanline;
  949.     instance.Progress(instance, psRunning, temp, (R.Bottom - R.Top) >= 4, R, '');
  950.   end;
  951. end;
  952.  
  953. procedure ReleaseContext(var jc: TJPEGContext);
  954. begin
  955.   if jc.common.err = nil then Exit;
  956.   jpeg_destroy(jc.common);
  957.   jc.common.err := nil;
  958. end;
  959.  
  960. procedure InitDecompressor(Obj: TJPEGImage; var jc: TJPEGContext);
  961. begin
  962.   FillChar(jc, sizeof(jc), 0);
  963.   jc.err := jpeg_std_error;
  964.   jc.common.err := @jc.err;
  965.  
  966.   jpeg_CreateDecompress(jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
  967.   with Obj do
  968.   try
  969.     jc.progress.progress_monitor := @ProgressCallback;
  970.     jc.progress.instance := Obj;
  971.     jc.common.progress := @jc.progress;
  972.  
  973.     Obj.FImage.FData.Position := 0;
  974.     jpeg_stdio_src(jc.d, FImage.FData);
  975.     jpeg_read_header(jc.d, TRUE);
  976.  
  977.     jc.d.scale_num := 1;
  978.     jc.d.scale_denom := 1 shl Byte(FScale);
  979.     jc.d.do_block_smoothing := FSmoothing;
  980.  
  981.     if FGrayscale then jc.d.out_color_space := JCS_GRAYSCALE;
  982.     if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then
  983.     begin
  984.       jc.d.quantize_colors := True;
  985.       jc.d.desired_number_of_colors := 236;
  986.     end;
  987.  
  988.     if FPerformance = jpBestSpeed then
  989.     begin
  990.       jc.d.dct_method := JDCT_IFAST;
  991.       jc.d.two_pass_quantize := False;
  992. //      jc.d.do_fancy_upsampling := False;    !! AV inside jpeglib
  993.       jc.d.dither_mode := JDITHER_ORDERED;
  994.     end
  995.     else
  996.       jc.d.dct_method := JDCT_FLOAT;
  997.  
  998.     jc.FinalDCT := jc.d.dct_method;
  999.     jc.FinalTwoPassQuant := jc.d.two_pass_quantize;
  1000.     jc.FinalDitherMode := jc.d.dither_mode;
  1001.     if FProgressiveDisplay and jpeg_has_multiple_scans(jc.d) then
  1002.     begin  // save requested settings, reset for fastest on all but last scan
  1003.       jc.d.enable_2pass_quant := jc.d.two_pass_quantize;
  1004.       jc.d.dct_method := JDCT_IFAST;
  1005.       jc.d.two_pass_quantize := False;
  1006.       jc.d.dither_mode := JDITHER_ORDERED;
  1007.       jc.d.buffered_image := True;
  1008.     end;
  1009.   except
  1010.     ReleaseContext(jc);
  1011.     raise;
  1012.   end;
  1013. end;
  1014.  
  1015. procedure TJPEGImage.CalcOutputDimensions;
  1016. var
  1017.   jc: TJPEGContext;
  1018. begin
  1019.   if not FNeedRecalc then Exit;
  1020.   InitDecompressor(Self, jc);
  1021.   try
  1022.     jc.common.progress := nil;
  1023.     jpeg_calc_output_dimensions(jc.d);
  1024.     // read output dimensions
  1025.     FScaledWidth := jc.d.output_width;
  1026.     FScaledHeight := jc.d.output_height;
  1027.     FProgressiveEncoding := jpeg_has_multiple_scans(jc.d);
  1028.   finally
  1029.     ReleaseContext(jc);
  1030.   end;
  1031. end;
  1032.  
  1033. procedure TJPEGImage.Changed(Sender: TObject);
  1034. begin
  1035.   inherited Changed(Sender);
  1036. end;
  1037.  
  1038. procedure TJPEGImage.Compress;
  1039. var
  1040.   LinesWritten, LinesPerCall: Integer;
  1041.   SrcScanLine: Pointer;
  1042.   PtrInc: Integer;
  1043.   jc: TJPEGContext;
  1044.   Src: TBitmap;
  1045. begin
  1046.   FillChar(jc, sizeof(jc), 0);
  1047.   jc.err := jpeg_std_error;
  1048.   jc.common.err := @jc.err;
  1049.  
  1050.   jpeg_CreateCompress(jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
  1051.   try
  1052.     try
  1053.       jc.progress.progress_monitor := @ProgressCallback;
  1054.       jc.progress.instance := Self;
  1055.       jc.common.progress := @jc.progress;
  1056.  
  1057.       if FImage.FData <> nil then NewImage;
  1058.       FImage.FData := TMemoryStream.Create;
  1059.       FImage.FData.Position := 0;
  1060.       jpeg_stdio_dest(jc.c, FImage.FData);
  1061.  
  1062.       if (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0) then Exit;
  1063.       jc.c.image_width := FBitmap.Width;
  1064.       FImage.FWidth := FBitmap.Width;
  1065.       jc.c.image_height := FBitmap.Height;
  1066.       FImage.FHeight := FBitmap.Height;
  1067.       jc.c.input_components := 3;           // JPEG requires 24bit RGB input
  1068.       jc.c.in_color_space := JCS_RGB;
  1069.  
  1070.       Src := TBitmap.Create;
  1071.       try
  1072.         Src.Assign(FBitmap);
  1073.         Src.PixelFormat := pf24bit;
  1074.  
  1075.         jpeg_set_defaults(jc.c);
  1076.         jc.c.dct_method := JDCT_FLOAT;
  1077.         jpeg_set_quality(jc.c, FQuality, True);
  1078.  
  1079.         if FGrayscale then
  1080.         begin
  1081.           FImage.FGrayscale := True;
  1082.           jpeg_set_colorspace(jc.c, JCS_GRAYSCALE);
  1083.         end;
  1084.  
  1085.         if ProgressiveEncoding then
  1086.           jpeg_simple_progression(jc.c);
  1087.  
  1088.         SrcScanline := Src.ScanLine[0];
  1089.         PtrInc := Integer(Src.ScanLine[1]) - Integer(SrcScanline);
  1090.  
  1091.           // if no dword padding required and source bitmap is top-down
  1092.         if (PtrInc > 0) and ((PtrInc and 3) = 0) then
  1093.           LinesPerCall := jc.c.image_height  // do whole bitmap in one call
  1094.         else
  1095.           LinesPerCall := 1;      // otherwise spoonfeed one row at a time
  1096.  
  1097.         Progress(Self, psStarting, 0, False, Rect(0,0,0,0), '');
  1098.         try
  1099.           jpeg_start_compress(jc.c, True);
  1100.  
  1101.           while (jc.c.next_scanline < jc.c.image_height) do
  1102.           begin
  1103.             LinesWritten := jpeg_write_scanlines(jc.c, @SrcScanline, LinesPerCall);
  1104.             Inc(Integer(SrcScanline), PtrInc * LinesWritten);
  1105.           end;
  1106.  
  1107.           jpeg_finish_compress(jc.c);
  1108.         finally
  1109.           if ExceptObject = nil then
  1110.             PtrInc := 100
  1111.           else
  1112.             PtrInc := 0;
  1113.           Progress(Self, psEnding, PtrInc, False, Rect(0,0,0,0), '');
  1114.         end;
  1115.       finally
  1116.         Src.Free;
  1117.       end;
  1118.     except
  1119.       on EAbort do    // OnProgress can raise EAbort to cancel image save
  1120.         NewImage;     // Throw away any partial jpg data
  1121.     end;
  1122.   finally
  1123.     ReleaseContext(jc);
  1124.   end;
  1125. end;
  1126.  
  1127. procedure TJPEGImage.DIBNeeded;
  1128. begin
  1129.   GetBitmap;
  1130. end;
  1131.  
  1132. procedure TJPEGImage.Draw(ACanvas: TCanvas; const Rect: TRect);
  1133. begin
  1134.   ACanvas.StretchDraw(Rect, Bitmap);
  1135. end;
  1136.  
  1137. function TJPEGImage.Equals(Graphic: TGraphic): Boolean;
  1138. begin
  1139.   Result := False;
  1140.   if not (Graphic is TJPEGImage) then Exit;
  1141.   // Only call the inherited if both ends have compressed data.
  1142.   // We don't want to set off a compression cycle to create the FData stream
  1143.   if (FImage.FData <> nil) and (TJPEGImage(Graphic).FImage.FData <> nil) then
  1144.     Result := inherited Equals(Graphic)
  1145.   else  // FImage is shared if Assign is used to copy between TJPEGImage instances
  1146.     Result := (FImage = TJPEGImage(Graphic).FImage);
  1147. end;
  1148.  
  1149. procedure TJPEGImage.FreeBitmap;
  1150. begin
  1151.   FBitmap.Free;
  1152.   FBitmap := nil;
  1153. end;
  1154.  
  1155. function BuildPalette(const cinfo: jpeg_decompress_struct): HPalette;
  1156. var
  1157.   Pal: TMaxLogPalette;
  1158.   I: Integer;
  1159.   C: Byte;
  1160. begin
  1161.   Pal.palVersion := $300;
  1162.   Pal.palNumEntries := cinfo.actual_number_of_colors;
  1163.   if cinfo.out_color_space = JCS_GRAYSCALE then
  1164.     for I := 0 to Pal.palNumEntries-1 do
  1165.     begin
  1166.       C := cinfo.colormap^[0]^[I];
  1167.       Pal.palPalEntry[I].peRed := C;
  1168.       Pal.palPalEntry[I].peGreen := C;
  1169.       Pal.palPalEntry[I].peBlue := C;
  1170.       Pal.palPalEntry[I].peFlags := 0;
  1171.     end
  1172.   else
  1173.     for I := 0 to Pal.palNumEntries-1 do
  1174.     begin
  1175.       Pal.palPalEntry[I].peRed := cinfo.colormap^[2]^[I];
  1176.       Pal.palPalEntry[I].peGreen := cinfo.colormap^[1]^[I];
  1177.       Pal.palPalEntry[I].peBlue := cinfo.colormap^[0]^[I];
  1178.       Pal.palPalEntry[I].peFlags := 0;
  1179.     end;
  1180.   Result := CreatePalette(PLogPalette(@Pal)^);
  1181. end;
  1182.  
  1183. procedure BuildColorMap(var cinfo: jpeg_decompress_struct; P: HPalette);
  1184. var
  1185.   Pal: TMaxLogPalette;
  1186.   Count, I: Integer;
  1187. begin
  1188.   Count := GetPaletteEntries(P, 0, 256, Pal.palPalEntry);
  1189.   if Count = 0 then Exit;       // jpeg_destroy will free colormap
  1190.   cinfo.colormap := cinfo.common.mem.alloc_sarray(@cinfo.common, JPOOL_IMAGE, Count, 3);
  1191.   cinfo.actual_number_of_colors := Count;
  1192.   for I := 0 to Count-1 do
  1193.   begin
  1194.     Byte(cinfo.colormap^[2]^[I]) := Pal.palPalEntry[I].peRed;
  1195.     Byte(cinfo.colormap^[1]^[I]) := Pal.palPalEntry[I].peGreen;
  1196.     Byte(cinfo.colormap^[0]^[I]) := Pal.palPalEntry[I].peBlue;
  1197.   end;
  1198. end;
  1199.  
  1200. function TJPEGImage.GetBitmap: TBitmap;
  1201. var
  1202.   LinesPerCall, LinesRead: Integer;
  1203.   DestScanLine: Pointer;
  1204.   PtrInc: Integer;
  1205.   jc: TJPEGContext;
  1206.   GeneratePalette: Boolean;
  1207. begin
  1208.   Result := FBitmap;
  1209.   if Result <> nil then Exit;
  1210.   if (FBitmap = nil) then FBitmap := TBitmap.Create;
  1211.   Result := FBitmap;
  1212.   GeneratePalette := True;
  1213.  
  1214.   InitDecompressor(Self, jc);
  1215.   try
  1216.     try
  1217.       // Set the bitmap pixel format
  1218.       FBitmap.Handle := 0;
  1219.       if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then
  1220.         FBitmap.PixelFormat := pf8bit
  1221.       else
  1222.         FBitmap.PixelFormat := pf24bit;
  1223.  
  1224.       Progress(Self, psStarting, 0, False, Rect(0,0,0,0), '');
  1225.       try
  1226.         if (FTempPal <> 0) then
  1227.         begin
  1228.           if (FPixelFormat = jf8Bit) then
  1229.           begin                        // Generate DIB using assigned palette
  1230.             BuildColorMap(jc.d, FTempPal);
  1231.             FBitmap.Palette := CopyPalette(FTempPal);  // Keep FTempPal around
  1232.             GeneratePalette := False;
  1233.           end
  1234.           else
  1235.           begin
  1236.             DeleteObject(FTempPal);
  1237.             FTempPal := 0;
  1238.           end;
  1239.         end;
  1240.  
  1241.         jpeg_start_decompress(jc.d);
  1242.  
  1243.         // Set bitmap width and height
  1244.         with FBitmap do
  1245.         begin
  1246.           Handle := 0;
  1247.           Width := jc.d.output_width;
  1248.           Height := jc.d.output_height;
  1249.           DestScanline := ScanLine[0];
  1250.           PtrInc := Integer(ScanLine[1]) - Integer(DestScanline);
  1251.           if (PtrInc > 0) and ((PtrInc and 3) = 0) then
  1252.              // if no dword padding is required and output bitmap is top-down
  1253.             LinesPerCall := jc.d.rec_outbuf_height // read multiple rows per call
  1254.           else
  1255.             LinesPerCall := 1;            // otherwise read one row at a time
  1256.         end;
  1257.  
  1258.         if jc.d.buffered_image then
  1259.         begin  // decode progressive scans at low quality, high speed
  1260.           while jpeg_consume_input(jc.d) <> JPEG_REACHED_EOI do
  1261.           begin
  1262.             jpeg_start_output(jc.d, jc.d.input_scan_number);
  1263.             // extract color palette
  1264.             if (jc.common.progress^.completed_passes = 0) and (jc.d.colormap <> nil)
  1265.               and (FBitmap.PixelFormat = pf8bit) and GeneratePalette then
  1266.             begin
  1267.               FBitmap.Palette := BuildPalette(jc.d);
  1268.               PaletteModified := True;
  1269.             end;
  1270.             DestScanLine := FBitmap.ScanLine[0];
  1271.             while (jc.d.output_scanline < jc.d.output_height) do
  1272.             begin
  1273.               LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall);
  1274.               Inc(Integer(DestScanline), PtrInc * LinesRead);
  1275.             end;
  1276.             jpeg_finish_output(jc.d);
  1277.           end;
  1278.           // reset options for final pass at requested quality
  1279.           jc.d.dct_method := jc.FinalDCT;
  1280.           jc.d.dither_mode := jc.FinalDitherMode;
  1281.           if jc.FinalTwoPassQuant then
  1282.           begin
  1283.             jc.d.two_pass_quantize := True;
  1284.             jc.d.colormap := nil;
  1285.           end;
  1286.           jpeg_start_output(jc.d, jc.d.input_scan_number);
  1287.           DestScanLine := FBitmap.ScanLine[0];
  1288.         end;
  1289.  
  1290.         // build final color palette
  1291.         if (not jc.d.buffered_image or jc.FinalTwoPassQuant) and
  1292.           (jc.d.colormap <> nil) and GeneratePalette then
  1293.         begin
  1294.           FBitmap.Palette := BuildPalette(jc.d);
  1295.           PaletteModified := True;
  1296.           DestScanLine := FBitmap.ScanLine[0];
  1297.         end;
  1298.         // final image pass for progressive, first and only pass for baseline
  1299.         while (jc.d.output_scanline < jc.d.output_height) do
  1300.         begin
  1301.           LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall);
  1302.           Inc(Integer(DestScanline), PtrInc * LinesRead);
  1303.         end;
  1304.  
  1305.         if jc.d.buffered_image then jpeg_finish_output(jc.d);
  1306.         jpeg_finish_decompress(jc.d);
  1307.       finally
  1308.         if ExceptObject = nil then
  1309.           PtrInc := 100
  1310.         else
  1311.           PtrInc := 0;
  1312.         Progress(Self, psEnding, PtrInc, PaletteModified, Rect(0,0,0,0), '');
  1313.         // Make sure new palette gets realized, in case OnProgress event didn't.
  1314.         if PaletteModified then
  1315.           Changed(Self);
  1316.       end;
  1317.     except
  1318.       on EAbort do ;   // OnProgress can raise EAbort to cancel image load
  1319.     end;
  1320.   finally
  1321.     ReleaseContext(jc);
  1322.   end;
  1323. end;
  1324.  
  1325. function TJPEGImage.GetEmpty: Boolean;
  1326. begin
  1327.   Result := (FImage.FData = nil) and ((FBitmap = nil) or FBitmap.Empty);
  1328. end;
  1329.  
  1330. function TJPEGImage.GetGrayscale: Boolean;
  1331. begin
  1332.   Result := FGrayscale or FImage.FGrayscale;
  1333. end;
  1334.  
  1335. function TJPEGImage.GetPalette: HPalette;
  1336. var
  1337.   DC: HDC;
  1338. begin
  1339.   Result := 0;
  1340.   if FBitmap <> nil then
  1341.     Result := FBitmap.Palette
  1342.   else if FTempPal <> 0 then
  1343.     Result := FTempPal
  1344.   else if FPixelFormat = jf24Bit then   // check for 8 bit screen
  1345.   begin
  1346.     DC := GetDC(0);
  1347.     if (GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <= 8 then
  1348.     begin
  1349.       FTempPal := CreateHalftonePalette(DC);
  1350.       Result := FTempPal;
  1351.     end;
  1352.     ReleaseDC(0, DC);
  1353.   end;
  1354. end;
  1355.  
  1356. function TJPEGImage.GetHeight: Integer;
  1357. begin
  1358.   if FBitmap <> nil then
  1359.     Result := FBitmap.Height
  1360.   else if FScale = jsFullSize then
  1361.     Result := FImage.FHeight
  1362.   else
  1363.   begin
  1364.     CalcOutputDimensions;
  1365.     Result := FScaledHeight;
  1366.   end;
  1367. end;
  1368.  
  1369. function TJPEGImage.GetWidth: Integer;
  1370. begin
  1371.   if FBitmap <> nil then
  1372.     Result := FBitmap.Width
  1373.   else if FScale = jsFullSize then
  1374.     Result := FImage.FWidth
  1375.   else
  1376.   begin
  1377.     CalcOutputDimensions;
  1378.     Result := FScaledWidth;
  1379.   end;
  1380. end;
  1381.  
  1382. procedure TJPEGImage.JPEGNeeded;
  1383. begin
  1384.   if FImage.FData = nil then
  1385.     Compress;
  1386. end;
  1387.  
  1388. procedure TJPEGImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  1389.   APalette: HPALETTE);
  1390. begin
  1391.   //!! check for jpeg clipboard data, mime type image/jpeg
  1392.   FBitmap.LoadFromClipboardFormat(AFormat, AData, APalette);
  1393. end;
  1394.  
  1395. procedure TJPEGImage.LoadFromStream(Stream: TStream);
  1396. begin
  1397.   ReadStream(Stream.Size - Stream.Position, Stream);
  1398. end;
  1399.  
  1400. procedure TJPEGImage.NewBitmap;
  1401. begin
  1402.   FBitmap.Free;
  1403.   FBitmap := TBitmap.Create;
  1404. end;
  1405.  
  1406. procedure TJPEGImage.NewImage;
  1407. begin
  1408.   if FImage <> nil then FImage.Release;
  1409.   FImage := TJPEGData.Create;
  1410.   FImage.Reference;
  1411. end;
  1412.  
  1413. procedure TJPEGImage.ReadData(Stream: TStream);
  1414. var
  1415.   Size: Longint;
  1416. begin
  1417.   Stream.Read(Size, SizeOf(Size));
  1418.   ReadStream(Size, Stream);
  1419. end;
  1420.  
  1421. procedure TJPEGImage.ReadStream(Size: Longint; Stream: TStream);
  1422. var
  1423.   jerr: jpeg_error_mgr;
  1424.   cinfo: jpeg_decompress_struct;
  1425. begin
  1426.   NewImage;
  1427.   FBitmap.Free;
  1428.   FBitmap := nil;
  1429.   with FImage do
  1430.   begin
  1431.     FData := TMemoryStream.Create;
  1432.     FData.Size := Size;
  1433.     Stream.ReadBuffer(FData.Memory^, Size);
  1434.     if Size > 0 then
  1435.     begin
  1436.       jerr := jpeg_std_error;  // use local var for thread isolation
  1437.       cinfo.common.err := @jerr;
  1438.       jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION, sizeof(cinfo));
  1439.       try
  1440.         FData.Position := 0;
  1441.         jpeg_stdio_src(cinfo, FData);
  1442.         jpeg_read_header(cinfo, TRUE);
  1443.         FWidth := cinfo.image_width;
  1444.         FHeight := cinfo.image_height;
  1445.         FGrayscale := cinfo.jpeg_color_space = JCS_GRAYSCALE;
  1446.         FProgressiveEncoding := jpeg_has_multiple_scans(cinfo);
  1447.       finally
  1448.         jpeg_destroy_decompress(cinfo);
  1449.       end;
  1450.     end;
  1451.   end;
  1452.   PaletteModified := True;
  1453.   Changed(Self);
  1454. end;
  1455.  
  1456. procedure TJPEGImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  1457.   var APalette: HPALETTE);
  1458. begin
  1459. //!!  check for jpeg clipboard format, mime type image/jpeg
  1460.   Bitmap.SaveToClipboardFormat(AFormat, AData, APalette);
  1461. end;
  1462.  
  1463. procedure TJPEGImage.SaveToStream(Stream: TStream);
  1464. begin
  1465.   JPEGNeeded;
  1466.   with FImage.FData do
  1467.     Stream.Write(Memory^, Size);
  1468. end;
  1469.  
  1470. procedure TJPEGImage.SetGrayscale(Value: Boolean);
  1471. begin
  1472.   if FGrayscale <> Value then
  1473.   begin
  1474.     FreeBitmap;
  1475.     FGrayscale := Value;
  1476.     PaletteModified := True;
  1477.     Changed(Self);
  1478.   end;
  1479. end;
  1480.  
  1481. procedure TJPEGImage.SetHeight(Value: Integer);
  1482. begin
  1483.   InvalidOperation(SChangeJPGSize);
  1484. end;
  1485.  
  1486. procedure TJPEGImage.SetPalette(Value: HPalette);
  1487. var
  1488.   SignalChange: Boolean;
  1489. begin
  1490.   if Value <> FTempPal then
  1491.   begin
  1492.     SignalChange := (FBitmap <> nil) and (Value <> FBitmap.Palette);
  1493.     if SignalChange then FreeBitmap;
  1494.     if FTempPal <> 0 then DeleteObject(FTempPal);
  1495.     FTempPal := Value;
  1496.     if SignalChange then
  1497.     begin
  1498.       PaletteModified := True;
  1499.       Changed(Self);
  1500.     end;
  1501.   end;
  1502. end;
  1503.  
  1504. procedure TJPEGImage.SetPerformance(Value: TJPEGPerformance);
  1505. begin
  1506.   if FPerformance <> Value then
  1507.   begin
  1508.     FreeBitmap;
  1509.     FPerformance := Value;
  1510.     PaletteModified := True;
  1511.     Changed(Self);
  1512.   end;
  1513. end;
  1514.  
  1515. procedure TJPEGImage.SetPixelFormat(Value: TJPEGPixelFormat);
  1516. begin
  1517.   if FPixelFormat <> Value then
  1518.   begin
  1519.     FreeBitmap;
  1520.     FPixelFormat := Value;
  1521.     PaletteModified := True;
  1522.     Changed(Self);
  1523.   end;
  1524. end;
  1525.  
  1526. procedure TJPEGImage.SetScale(Value: TJPEGScale);
  1527. begin
  1528.   if FScale <> Value then
  1529.   begin
  1530.     FreeBitmap;
  1531.     FScale := Value;
  1532.     FNeedRecalc := True;
  1533.     Changed(Self);
  1534.   end;
  1535. end;
  1536.  
  1537. procedure TJPEGImage.SetSmoothing(Value: Boolean);
  1538. begin
  1539.   if FSmoothing <> Value then
  1540.   begin
  1541.     FreeBitmap;
  1542.     FSmoothing := Value;
  1543.     Changed(Self);
  1544.   end;
  1545. end;
  1546.  
  1547. procedure TJPEGImage.SetWidth(Value: Integer);
  1548. begin
  1549.   InvalidOperation(SChangeJPGSize);
  1550. end;
  1551.  
  1552. procedure TJPEGImage.WriteData(Stream: TStream);
  1553. var
  1554.   Size: Longint;
  1555. begin
  1556.   Size := 0;
  1557.   if Assigned(FImage.FData) then Size := FImage.FData.Size;
  1558.   Stream.Write(Size, Sizeof(Size));
  1559.   if Size > 0 then Stream.Write(FImage.FData.Memory^, Size);
  1560. end;
  1561.  
  1562. procedure InitDefaults;
  1563. var
  1564.   DC: HDC;
  1565. begin
  1566.   DC := GetDC(0);
  1567.   if (GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <= 8 then
  1568.     JPEGDefaults.PixelFormat := jf8Bit
  1569.   else
  1570.     JPEGDefaults.PixelFormat := jf24Bit;
  1571.   ReleaseDC(0, DC);
  1572. end;
  1573.  
  1574. initialization
  1575.   InitDefaults;
  1576.   TPicture.RegisterFileFormat('jpeg', sJPEGImageFile, TJPEGImage);
  1577.   TPicture.RegisterFileFormat('jpg', sJPEGImageFile, TJPEGImage);
  1578. finalization
  1579.   TPicture.UnregisterGraphicClass(TJPEGImage);
  1580. end.
  1581.  
  1582.  
  1583.