unit JpegObj;
{* Jpeg object. Decompression requires about 54 K (61K when err used).
   Compressor part requires extra 30 Kbytes.
   |<br>
 You can define conditional symbol JPEGERR in project options. In such
 case exceptions will be used to handle errors, and this will increase
 executable size a bit. Though, a practice shows that there are no needs
 in exceptions to work correctly even with corrupted jpeg images. Moreover,
 refuse from exceptions allows to show partially corrupted images, though
 when exceptions are used, such images can not be decoded at all.
}

//{$DEFINE VER62} // if you plan to use .obj-files from Delphi7 distributive only!

interface

{$I KOLDEF.INC}

{$IFDEF JPEGERR}
  {$IFDEF NOJPEGERR}
  {$UNDEF NOJPEGERR}
  {$ENDIF}
{$ENDIF}

uses windows, KOL {$IFDEF JPEGERR}, err {$ENDIF};

type
  PJPEGData = ^TJPEGData;
  TJPEGData = object( TObj )
  private
    FData: PStream;
    FHeight: Integer;
    FWidth: Integer;
    FGrayscale: Boolean;
  protected
  public
    destructor Destroy; virtual;
    procedure Clear;
  end;

  TJPEGQualityRange = 1..100;   // 100 = best quality, 25 = pretty awful
  TJPEGPerformance = (jpBestQuality, jpBestSpeed);
  TJPEGScale = (jsFullSize, jsHalf, jsQuarter, jsEighth);
  TJPEGPixelFormat = (jf24Bit, jf8Bit);

  PJpeg = ^TJpeg;
  TJPEGProgress = procedure( Sender: PJpeg; const Rect: TRect; var Stop: Boolean )
                of object;

  TJpeg = object( TObj )
  {* JPeg image incapsulation. If only decoding is used, about 54K of code
     is attached to executable. If encoding is used too, about 30K of code
     is attached additionally. }
  private
    FImage: PJPEGData;
    FBitmap: PBitmap;
    FScaledWidth: Integer;
    FScaledHeight: Integer;
    FTempPal: HPalette;
    FSmoothing: Boolean;
    FGrayScale: Boolean;
    FPixelFormat: TJPEGPixelFormat;
    FQuality: TJPEGQualityRange;
    FProgressiveDisplay: Boolean;
    FProgressiveEncoding: Boolean;
    FPerformance: TJPEGPerformance;
    FScale: TJPEGScale;
    FNeedRecalc: Boolean;
    FOnChange: TOnEvent;
    FCorrupted: Boolean;
    FOnProgress: TJPEGProgress;
    FProgress: function( JPEGobj: PJpeg; const R: TRect ): Boolean;
    FCallback: Pointer;
    FStop: Boolean;
    fProgressTime: Integer;
    FCMYK: Boolean;
    FConvertCMYK2RGBProc: procedure( Bmp: PBitmap );
    FConvertCMYK2RGB: Boolean;
    procedure CalcOutputDimensions;
    function GetBitmap: PBitmap;
    function GetGrayscale: Boolean;
    procedure SetGrayscale(Value: Boolean);
    procedure SetPerformance(Value: TJPEGPerformance);
    procedure SetPixelFormat(Value: TJPEGPixelFormat);
    procedure SetScale(Value: TJPEGScale);
    procedure SetSmoothing(Value: Boolean);
    procedure SetOnProgress(const Value: TJPEGProgress);
    procedure SetBitmap(const Value: PBitmap);
    procedure SetConvertCMYK2RGB(const Value: Boolean);
  protected
    function GetEmpty: Boolean;
    {*}
    procedure FreeBitmap;
    {* Call it to free bitmap, containing decoded JPeg image. }
    function GetHeight: Integer;
    {*}
    function GetWidth: Integer;
    {*}
    function GetPalette: HPALETTE;
    {* }
    procedure Changed;


    // internal methods. Do not know why not placed into 'private' section.
    procedure CreateBitmap;
    procedure CreateImage;
    procedure ReadData(Stream: PStream);
    procedure ReadStream(Size: Integer; Stream: PStream);
    procedure SetHeight(Value: Integer);
    procedure SetPalette(Value: HPalette);
    procedure SetWidth(Value: Integer);
    procedure WriteData(Stream: PStream);
  public
    destructor Destroy; virtual;
    {*}
    procedure Clear; virtual;
    {*}
    procedure Compress;
    {* }
    procedure DIBNeeded;
    {* }
    procedure JPEGNeeded;
    {* }
    procedure Draw(DC : HDC; X, Y : Integer);
    {*}
    procedure StretchDraw( DC : HDC; Dest : TRect );
    {*}

    property Palette : HPalette read GetPalette write SetPalette;
    {* }
    procedure LoadFromStream(Stream: PStream);
    {* Loads JPeg image from a stream (from current position). }
    procedure SaveToStream(Stream: PStream);
    {* Saves JPeg image to a stream. }
    function LoadFromFile( const FName : String ) : Boolean;
    {* Function to load jpeg image from a file. }
    function SaveToFile( const FName : String ) : Boolean;
    {* Function to save jpeg image into a file. }

    // Options affecting / reflecting compression and decompression behavior
    property Grayscale: Boolean read GetGrayscale write SetGrayscale;
    {* }
    property ProgressiveEncoding: Boolean read FProgressiveEncoding write FProgressiveEncoding;
    {* }

    // Compression options
    property CompressionQuality: TJPEGQualityRange read FQuality write FQuality;
    {* Compression quality. }

    // Decompression options
    property PixelFormat: TJPEGPixelFormat read FPixelFormat write SetPixelFormat;
    {* }

    {* Format of decompressed bitmap. }
    property ProgressiveDisplay: Boolean read FProgressiveDisplay write FProgressiveDisplay;
    {* }
    property Performance: TJPEGPerformance read FPerformance write SetPerformance;
    {* }
    property Scale: TJPEGScale read FScale write SetScale;
    {* }
    property Smoothing: Boolean read FSmoothing write SetSmoothing;
    {* True, if smoothing is enabled due decompression. }

    property Bitmap: PBitmap read GetBitmap write SetBitmap;
    {* Returns decompressed jpeg image as a bitmap. To detect if an image
       is corrupted, check Corrupted property after requesting the Bitmap.
       |<br>
       Assign a TBitmap object to this property before calling method
       SaveToStream or SaveToFile to convert bitmap image to jpeg format. }
    property Empty: Boolean read GetEmpty;
    {* Returns True, if empty. }

    property OnChange: TOnEvent read FOnChange write FOnChange;
    {* Is called when the image is changed. }
    property Width: Integer read GetWidth;
    {* }
    property Height: Integer read GetHeight;
    {* }
    property Corrupted: Boolean read FCorrupted;
    {* True, when an image is corrupted. This can be detected only AFTER
       Bitmap is requested, not just after loading the image. }
    property OnProgress: TJPEGProgress read FOnProgress write SetOnProgress;
    {* This event is called while decompressing (or compressing) the image.
       If You want paint portion of decompressed image, use Bitmap method
       DIBDrawRect, which does not change its DIBBits location during decoding.
       Otherwise, the abnormal termination can be caused. }
    property ProgressTime: Integer read fProgressTime write fProgressTime;
    {* By default, 100 milliseconds. Change this period to change frequency
       of OnProgress event calls during the compression / decompression. }
    property ConvertCMYK2RGB: Boolean read FConvertCMYK2RGB write SetConvertCMYK2RGB;
    {* Set it to true to convert decoded CMYK image to RGB. }
  end;

  TJPEGDefaults = record
    CompressionQuality: TJPEGQualityRange;
    Grayscale: Boolean;
    Performance: TJPEGPerformance;
    PixelFormat: TJPEGPixelFormat;
    ProgressiveDisplay: Boolean;
    ProgressiveEncoding: Boolean;
    Scale: TJPEGScale;
    Smoothing: Boolean;
  end;

function NewJpeg: PJpeg;
{* Constructs new TJpeg object. }

var   // Default settings for all new TJPEGImage instances
  JPEGDefaults: TJPEGDefaults = (
    CompressionQuality: 90;
    Grayscale: False;
    Performance: jpBestQuality;
    PixelFormat: jf24Bit;         // initialized to match video mode
    ProgressiveDisplay: False;
    ProgressiveEncoding: False;
    Scale: jsFullSize;
    Smoothing: True;
  );

implementation

{ The following types and external function declarations are used to
  call into functions of the Independent JPEG Group's (IJG) implementation
  of the JPEG image compression/decompression public standard.  The IJG
  library's C source code is compiled into OBJ files and linked into
  the Delphi application. Only types and functions needed by this unit
  are declared; all IJG internal structures are stubbed out with
  generic pointers to reduce internal source code congestion.

  IJG source code copyright (C) 1991-1996, Thomas G. Lane. }

{$Z4}  // Minimum enum size = dword

const
  JPEG_LIB_VERSION = {$IFDEF VER62} 62 {$ELSE} 61 {$ENDIF};        { Version 6a }

  JPEG_RST0     = $D0;  { RST0 marker code }
  JPEG_EOI      = $D9;  { EOI marker code }
  JPEG_APP0     = $E0;  { APP0 marker code }
  JPEG_COM      = $FE;  { COM marker code }

  DCTSIZE             = 8;      { The basic DCT block is 8x8 samples }
  DCTSIZE2            = 64;     { DCTSIZE squared; # of elements in a block }
  NUM_QUANT_TBLS      = 4;      { Quantization tables are numbered 0..3 }
  NUM_HUFF_TBLS       = 4;      { Huffman tables are numbered 0..3 }
  NUM_ARITH_TBLS      = 16;     { Arith-coding tables are numbered 0..15 }
  MAX_COMPS_IN_SCAN   = 4;      { JPEG limit on # of components in one scan }
  MAX_SAMP_FACTOR     = 4;      { JPEG limit on sampling factors }
  C_MAX_BLOCKS_IN_MCU = 10;     { compressor's limit on blocks per MCU }
  D_MAX_BLOCKS_IN_MCU = 10;     { decompressor's limit on blocks per MCU }
  MAX_COMPONENTS = 10;          { maximum number of image components (color channels) }

  MAXJSAMPLE = 255;
  CENTERJSAMPLE = 128;

type
  JSAMPLE = byte;
  GETJSAMPLE = integer;
  JCOEF = integer;
  JCOEF_PTR = ^JCOEF;
  UINT8 = byte;
  UINT16 = Word;
  UINT = Cardinal;
  INT16 = SmallInt;
  INT32 = Integer;
  INT32PTR = ^INT32;
  JDIMENSION = Cardinal;

  JOCTET = Byte;
  jTOctet = 0..(MaxInt div SizeOf(JOCTET))-1;
  JOCTET_FIELD = array[jTOctet] of JOCTET;
  JOCTET_FIELD_PTR = ^JOCTET_FIELD;
  JOCTETPTR = ^JOCTET;

  JSAMPLE_PTR = ^JSAMPLE;
  JSAMPROW_PTR = ^JSAMPROW;

  jTSample = 0..(MaxInt div SIZEOF(JSAMPLE))-1;
  JSAMPLE_ARRAY = Array[jTSample] of JSAMPLE;  {far}
  JSAMPROW = ^JSAMPLE_ARRAY;  { ptr to one image row of pixel samples. }

  jTRow = 0..(MaxInt div SIZEOF(JSAMPROW))-1;
  JSAMPROW_ARRAY = Array[jTRow] of JSAMPROW;
  JSAMPARRAY = ^JSAMPROW_ARRAY;  { ptr to some rows (a 2-D sample array) }

  jTArray = 0..(MaxInt div SIZEOF(JSAMPARRAY))-1;
  JSAMP_ARRAY = Array[jTArray] of JSAMPARRAY;
  JSAMPIMAGE = ^JSAMP_ARRAY;  { a 3-D sample array: top index is color }

const
  CSTATE_START        = 100;    { after create_compress }
  CSTATE_SCANNING     = 101;    { start_compress done, write_scanlines OK }
  CSTATE_RAW_OK       = 102;    { start_compress done, write_raw_data OK }
  CSTATE_WRCOEFS      = 103;    { jpeg_write_coefficients done }
  DSTATE_START        = 200;    { after create_decompress }
  DSTATE_INHEADER     = 201;    { reading header markers, no SOS yet }
  DSTATE_READY        = 202;    { found SOS, ready for start_decompress }
  DSTATE_PRELOAD      = 203;    { reading multiscan file in start_decompress}
  DSTATE_PRESCAN      = 204;    { performing dummy pass for 2-pass quant }
  DSTATE_SCANNING     = 205;    { start_decompress done, read_scanlines OK }
  DSTATE_RAW_OK       = 206;    { start_decompress done, read_raw_data OK }
  DSTATE_BUFIMAGE     = 207;    { expecting jpeg_start_output }
  DSTATE_BUFPOST      = 208;    { looking for SOS/EOI in jpeg_finish_output }
  DSTATE_RDCOEFS      = 209;    { reading file in jpeg_read_coefficients }
  DSTATE_STOPPING     = 210;    { looking for EOI in jpeg_finish_decompress }

{ Known color spaces. }

type
  J_COLOR_SPACE = (
	JCS_UNKNOWN,            { error/unspecified }
	JCS_GRAYSCALE,          { monochrome }
	JCS_RGB,                { red/green/blue }
	JCS_YCbCr,              { Y/Cb/Cr (also known as YUV) }
	JCS_CMYK,               { C/M/Y/K }
	JCS_YCCK                { Y/Cb/Cr/K }
                  );

{ DCT/IDCT algorithm options. }

type
  J_DCT_METHOD = (
	JDCT_ISLOW,		{ slow but accurate integer algorithm }
	JDCT_IFAST,		{ faster, less accurate integer method }
	JDCT_FLOAT		{ floating-point: accurate, fast on fast HW (Pentium)}
                 );

{ Dithering options for decompression. }

type
  J_DITHER_MODE = (
    JDITHER_NONE,               { no dithering }
    JDITHER_ORDERED,            { simple ordered dither }
    JDITHER_FS                  { Floyd-Steinberg error diffusion dither }
                  );

{ Error handler }

const
  JMSG_LENGTH_MAX  = 200;  { recommended size of format_message buffer }
  JMSG_STR_PARM_MAX = 80;

  JPOOL_PERMANENT = 0;  // lasts until master record is destroyed
  JPOOL_IMAGE	    = 1;	 // lasts until done with image/datastream

type
  jpeg_error_mgr_ptr = ^jpeg_error_mgr;
  jpeg_progress_mgr_ptr = ^jpeg_progress_mgr;

  j_common_ptr = ^jpeg_common_struct;
  j_compress_ptr = ^jpeg_compress_struct;
  j_decompress_ptr = ^jpeg_decompress_struct;

{ Routine signature for application-supplied marker processing methods.
  Need not pass marker code since it is stored in cinfo^.unread_marker. }

  jpeg_marker_parser_method = function(cinfo : j_decompress_ptr) : LongBool;

  jpeg_saved_marker_ptr = ^jpeg_marker_struct;

  jpeg_marker_struct = record
    next: jpeg_saved_marker_ptr;	{ next in list, or NULL }
    marker: Byte;			{ marker code: JPEG_COM, or JPEG_APP0+n }
    original_length: LongWord;	{ # bytes of data in the file }
    data_length: LongWord;	{ # bytes of data saved at data[] }
    data: JOCTETPTR;		{ the data contained in the marker }
    { the marker length word is not counted in data_length or original_length }
  end;

{ Marker reading & parsing }
  jpeg_marker_reader_ptr = ^jpeg_marker_reader;
  jpeg_marker_reader = record
    reset_marker_reader : procedure(cinfo : j_decompress_ptr);
    { Read markers until SOS or EOI.
      Returns same codes as are defined for jpeg_consume_input:
      JPEG_SUSPENDED, JPEG_REACHED_SOS, or JPEG_REACHED_EOI. }

    read_markers : function (cinfo : j_decompress_ptr) : Integer;
    { Read a restart marker --- exported for use by entropy decoder only }
    read_restart_marker : jpeg_marker_parser_method;
    { Application-overridable marker processing methods }
    process_COM : jpeg_marker_parser_method;
    process_APPn : Array[0..16-1] of jpeg_marker_parser_method;

    { State of marker reader --- nominally internal, but applications
      supplying COM or APPn handlers might like to know the state. }

    saw_SOI : LongBool;            { found SOI? }
    saw_SOF : LongBool;            { found SOF? }
    next_restart_num : Integer;    { next restart number expected (0-7) }
    discarded_bytes : UINT;        { # of bytes skipped looking for a marker }
  end;

  {int8array = Array[0..8-1] of int;}
  int8array = Array[0..8-1] of Integer;

  jpeg_error_mgr = record
    { Error exit handler: does not return to caller }
    error_exit : procedure  (cinfo : j_common_ptr);
    { Conditionally emit a trace or warning message }
    emit_message : procedure (cinfo : j_common_ptr; msg_level : Integer);
    { Routine that actually outputs a trace or error message }
    output_message : procedure (cinfo : j_common_ptr);
    { Format a message string for the most recent JPEG error or message }
    format_message : procedure  (cinfo : j_common_ptr; buffer: PChar);
    { Reset error state variables at start of a new image }
    reset_error_mgr : procedure (cinfo : j_common_ptr);

    { The message ID code and any parameters are saved here.
      A message can have one string parameter or up to 8 int parameters. }

    msg_code : Integer;

    msg_parm : record
      case byte of
      0:(i : int8array);
      {$IFDEF VER62}
      1:(s : array[0..JMSG_STR_PARM_MAX - 1] of char);
      {$ELSE}
      1:(s : string[JMSG_STR_PARM_MAX]);
      {$ENDIF}
    end;
    trace_level : Integer;     { max msg_level that will be displayed }
    num_warnings : Integer;    { number of corrupt-data warnings }
    {$IFDEF VER62}
    jpeg_message_table: ^PChar; { Library errors }
    last_jpeg_message: Integer; { Table contains strings 0..last_jpeg_message }
    { Second table can be added by application (see cjpeg/djpeg for example).
      It contains strings numbered first_addon_message..last_addon_message.
    }
    addon_message_table: ^PChar; { Non-library errors }
    first_addon_message: Integer; { code for first string in addon table }
    last_addon_message: Integer;  { code for last string in addon table }
    {$ENDIF}
  end;


{ Data destination object for compression }
  jpeg_destination_mgr_ptr = ^jpeg_destination_mgr;
  jpeg_destination_mgr = record
    next_output_byte : JOCTETptr;  { => next byte to write in buffer }
    free_in_buffer : Longint;    { # of byte spaces remaining in buffer }

    init_destination : procedure (cinfo : j_compress_ptr);
    empty_output_buffer : function (cinfo : j_compress_ptr) : LongBool;
    term_destination : procedure (cinfo : j_compress_ptr);
  end;


{ Data source object for decompression }

  jpeg_source_mgr_ptr = ^jpeg_source_mgr;
  jpeg_source_mgr = record
    next_input_byte : JOCTETptr;      { => next byte to read from buffer }
    bytes_in_buffer : Longint;       { # of bytes remaining in buffer }

    init_source : procedure  (cinfo : j_decompress_ptr);
    fill_input_buffer : function (cinfo : j_decompress_ptr) : LongBool;
    skip_input_data : procedure (cinfo : j_decompress_ptr; num_bytes : Longint);
    resync_to_restart : function (cinfo : j_decompress_ptr;
                                  desired : Integer) : LongBool;
    term_source : procedure (cinfo : j_decompress_ptr);
  end;

{ JPEG library memory manger routines }
  jpeg_memory_mgr_ptr = ^jpeg_memory_mgr;
  jpeg_memory_mgr = record
    { Method pointers }
    alloc_small : function (cinfo : j_common_ptr;
                            pool_id, sizeofobject: Integer): pointer;
    alloc_large : function (cinfo : j_common_ptr;
                            pool_id, sizeofobject: Integer): pointer;
    alloc_sarray : function (cinfo : j_common_ptr; pool_id : Integer;
                             samplesperrow : JDIMENSION;
                             numrows : JDIMENSION) : JSAMPARRAY;
    alloc_barray : pointer;
    request_virt_sarray : pointer;
    request_virt_barray : pointer;
    realize_virt_arrays : pointer;
    access_virt_sarray : pointer;
    access_virt_barray : pointer;
    free_pool : pointer;
    self_destruct : pointer;
    max_memory_to_use : Longint;
  end;

    { Fields shared with jpeg_decompress_struct }
  jpeg_common_struct = packed record
    err : jpeg_error_mgr_ptr;        { Error handler module }
    mem : jpeg_memory_mgr_ptr;          { Memory manager module }
    progress : jpeg_progress_mgr_ptr;   { Progress monitor, or NIL if none }
    {$IFDEF VER62}
    client_data: Pointer;            { Available for use by application }
    {$ENDIF}
    is_decompressor : LongBool;      { so common code can tell which is which }
    global_state : Integer;          { for checking call sequence validity }
  end;

{ Progress monitor object }

  jpeg_progress_mgr = record
    progress_monitor : procedure(const cinfo : jpeg_common_struct);
    pass_counter : Integer;     { work units completed in this pass }
    pass_limit : Integer;       { total number of work units in this pass }
    completed_passes : Integer;	{ passes completed so far }
    total_passes : Integer;     { total number of passes expected }
    // extra Delphi info
    instance: PJpeg;       // ptr to current PJpeg object
    last_pass: Integer;
    last_pct: Integer;
    last_time: Integer;
    last_scanline: Integer;
  end;


{ Master record for a compression instance }

  jpeg_compress_struct = {$IFNDEF VER62} packed {$ENDIF} record
    common: jpeg_common_struct;

    dest : jpeg_destination_mgr_ptr; { Destination for compressed data }

  { Description of source image --- these fields must be filled in by
    outer application before starting compression.  in_color_space must
    be correct before you can even call jpeg_set_defaults(). }

    image_width : JDIMENSION;         { input image width }
    image_height : JDIMENSION;        { input image height }
    input_components : Integer;       { # of color components in input image }
    in_color_space : J_COLOR_SPACE;   { colorspace of input image }
    input_gamma : double;             { image gamma of input image }

    // Compression parameters
    data_precision : Integer;             { bits of precision in image data }
    num_components : Integer;             { # of color components in JPEG image }
    jpeg_color_space : J_COLOR_SPACE;     { colorspace of JPEG image }
    comp_info : Pointer;
    quant_tbl_ptrs: Array[0..NUM_QUANT_TBLS-1] of Pointer;
    dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
    ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
    arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
    arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
    arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }
    num_scans : Integer;		 { # of entries in scan_info array }
    scan_info : Pointer;     { script for multi-scan file, or NIL }
    raw_data_in : LongBool;        { TRUE=caller supplies downsampled data }
    arith_code : LongBool;         { TRUE=arithmetic coding, FALSE=Huffman }
    optimize_coding : LongBool;    { TRUE=optimize entropy encoding parms }
    CCIR601_sampling : LongBool;   { TRUE=first samples are cosited }
    smoothing_factor : Integer;       { 1..100, or 0 for no input smoothing }
    dct_method : J_DCT_METHOD;    { DCT algorithm selector }
    restart_interval : UINT;      { MCUs per restart, or 0 for no restart }
    restart_in_rows : Integer;        { if > 0, MCU rows per restart interval }

    { Parameters controlling emission of special markers. }
    write_JFIF_header : LongBool;  { should a JFIF marker be written? }
    {$IFDEF VER62}
    JFIF_major_version: UINT8;      { What to write for a JFIF version number }
    JFIF_minor_version: UINT8;
    {$ENDIF}
    { These three values are not used by the JPEG code, merely copied }
    { into the JFIF APP0 marker.  density_unit can be 0 for unknown, }
    { 1 for dots/inch, or 2 for dots/cm.  Note that the pixel aspect }
    { ratio is defined by X_density/Y_density even when density_unit=0. }
    density_unit : UINT8;         { JFIF code for pixel size units }
    X_density : UINT16;           { Horizontal pixel density }
    Y_density : UINT16;           { Vertical pixel density }
    write_Adobe_marker : LongBool; { should an Adobe marker be written? }

    { State variable: index of next scanline to be written to
      jpeg_write_scanlines().  Application may use this to control its
      processing loop, e.g., "while (next_scanline < image_height)". }

    next_scanline : JDIMENSION;   { 0 .. image_height-1  }

    { Remaining fields are known throughout compressor, but generally
      should not be touched by a surrounding application. }
    progressive_mode : LongBool;   { TRUE if scan script uses progressive mode }
    max_h_samp_factor : Integer;      { largest h_samp_factor }
    max_v_samp_factor : Integer;      { largest v_samp_factor }
    total_iMCU_rows : JDIMENSION; { # of iMCU rows to be input to coef ctlr }
    comps_in_scan : Integer;          { # of JPEG components in this scan }
    cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer;
    MCUs_per_row : JDIMENSION;    { # of MCUs across the image }
    MCU_rows_in_scan : JDIMENSION;{ # of MCU rows in the image }
    blocks_in_MCU : Integer;          { # of DCT blocks per MCU }
    MCU_membership : Array[0..C_MAX_BLOCKS_IN_MCU-1] of Integer;
    Ss, Se, Ah, Al : Integer;         { progressive JPEG parameters for scan }

    { Links to compression subobjects (methods and private variables of modules) }
    master : Pointer;
    main : Pointer;
    prep : Pointer;
    coef : Pointer;
    marker : Pointer;
    cconvert : Pointer;
    downsample : Pointer;
    fdct : Pointer;
    entropy : Pointer;
    {$IFDEF VER62}
    script_space: Pointer;  { workspace for jpeg_simple_progression }
    script_space_size: Integer;
    {$ENDIF}
  end;


{ Master record for a decompression instance }

  jpeg_decompress_struct = {$IFNDEF VER62} packed {$ENDIF} record
    common: jpeg_common_struct;

    { Source of compressed data }
    src : jpeg_source_mgr_ptr;

    { Basic description of image --- filled in by jpeg_read_header(). }
    { Application may inspect these values to decide how to process image. }

    image_width : JDIMENSION;      { nominal image width (from SOF marker) }
    image_height : JDIMENSION;     { nominal image height }
    num_components : Integer;          { # of color components in JPEG image }
    jpeg_color_space : J_COLOR_SPACE; { colorspace of JPEG image }

    { Decompression processing parameters }
    out_color_space : J_COLOR_SPACE; { colorspace for output }
    scale_num, scale_denom : uint ;  { fraction by which to scale image }
    output_gamma : double;           { image gamma wanted in output }
    buffered_image : LongBool;        { TRUE=multiple output passes }
    raw_data_out : LongBool;          { TRUE=downsampled data wanted }
    dct_method : J_DCT_METHOD;       { IDCT algorithm selector }
    do_fancy_upsampling : LongBool;   { TRUE=apply fancy upsampling }
    do_block_smoothing : LongBool;    { TRUE=apply interblock smoothing }
    quantize_colors : LongBool;       { TRUE=colormapped output wanted }
    { the following are ignored if not quantize_colors: }
    dither_mode : J_DITHER_MODE;     { type of color dithering to use }
    two_pass_quantize : LongBool;     { TRUE=use two-pass color quantization }
    desired_number_of_colors : Integer;  { max # colors to use in created colormap }
    { these are significant only in buffered-image mode: }
    enable_1pass_quant : LongBool;    { enable future use of 1-pass quantizer }
    enable_external_quant : LongBool; { enable future use of external colormap }
    enable_2pass_quant : LongBool;    { enable future use of 2-pass quantizer }

    { Description of actual output image that will be returned to application.
      These fields are computed by jpeg_start_decompress().
      You can also use jpeg_calc_output_dimensions() to determine these values
      in advance of calling jpeg_start_decompress(). }

    output_width : JDIMENSION;       { scaled image width }
    output_height: JDIMENSION;       { scaled image height }
    out_color_components : Integer;  { # of color components in out_color_space }
    output_components : Integer;     { # of color components returned }
    { output_components is 1 (a colormap index) when quantizing colors;
      otherwise it equals out_color_components. }

    rec_outbuf_height : Integer;     { min recommended height of scanline buffer }
    { If the buffer passed to jpeg_read_scanlines() is less than this many
      rows high, space and time will be wasted due to unnecessary data
      copying. Usually rec_outbuf_height will be 1 or 2, at most 4. }

    { When quantizing colors, the output colormap is described by these
      fields. The application can supply a colormap by setting colormap
      non-NIL before calling jpeg_start_decompress; otherwise a colormap
      is created during jpeg_start_decompress or jpeg_start_output. The map
      has out_color_components rows and actual_number_of_colors columns. }

    actual_number_of_colors : Integer;      { number of entries in use }
    colormap : JSAMPARRAY;              { The color map as a 2-D pixel array }

    { State variables: these variables indicate the progress of decompression.
      The application may examine these but must not modify them. }

    { Row index of next scanline to be read from jpeg_read_scanlines().
      Application may use this to control its processing loop, e.g.,
      "while (output_scanline < output_height)". }

    output_scanline : JDIMENSION; { 0 .. output_height-1  }

    { Current input scan number and number of iMCU rows completed in scan.
      These indicate the progress of the decompressor input side. }

    input_scan_number : Integer;      { Number of SOS markers seen so far }
    input_iMCU_row : JDIMENSION;  { Number of iMCU rows completed }

    { The "output scan number" is the notional scan being displayed by the
      output side.  The decompressor will not allow output scan/row number
      to get ahead of input scan/row, but it can fall arbitrarily far behind.}

    output_scan_number : Integer;     { Nominal scan number being displayed }
    output_iMCU_row : Integer;        { Number of iMCU rows read }

    coef_bits : Pointer;

    { Internal JPEG parameters --- the application usually need not look at
      these fields.  Note that the decompressor output side may not use
      any parameters that can change between scans. }

    { Quantization and Huffman tables are carried forward across input
      datastreams when processing abbreviated JPEG datastreams. }

    quant_tbl_ptrs : Array[0..NUM_QUANT_TBLS-1] of Pointer;
    dc_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;
    ac_huff_tbl_ptrs : Array[0..NUM_HUFF_TBLS-1] of Pointer;

    { These parameters are never carried across datastreams, since they
      are given in SOF/SOS markers or defined to be reset by SOI. }
    data_precision : Integer;          { bits of precision in image data }
    comp_info : Pointer;
    progressive_mode : LongBool;    { TRUE if SOFn specifies progressive mode }
    arith_code : LongBool;          { TRUE=arithmetic coding, FALSE=Huffman }
    arith_dc_L : Array[0..NUM_ARITH_TBLS-1] of UINT8; { L values for DC arith-coding tables }
    arith_dc_U : Array[0..NUM_ARITH_TBLS-1] of UINT8; { U values for DC arith-coding tables }
    arith_ac_K : Array[0..NUM_ARITH_TBLS-1] of UINT8; { Kx values for AC arith-coding tables }

    restart_interval : UINT; { MCUs per restart interval, or 0 for no restart }

    { These fields record data obtained from optional markers recognized by
      the JPEG library. }
    saw_JFIF_marker : LongBool;  { TRUE iff a JFIF APP0 marker was found }
    { Data copied from JFIF marker: }
    {$IFDEF VER62}
    JFIF_major_version: UINT8;    { JFIF version number }
    JFIF_minor_version: UINT8;
    {$ENDIF}
    density_unit : UINT8;       { JFIF code for pixel size units }
    X_density : UINT16;         { Horizontal pixel density }
    Y_density : UINT16;         { Vertical pixel density }
    saw_Adobe_marker : LongBool; { TRUE iff an Adobe APP14 marker was found }
    Adobe_transform : UINT8;    { Color transform code from Adobe marker }

    CCIR601_sampling : LongBool; { TRUE=first samples are cosited }

    {$IFDEF VER62}
    { Aside from the specific data retained from APPn markers known to the
      library, the uninterpreted contents of any or all APPn and COM markers
      can be saved in a list for examination by the application. }
    marker_list: jpeg_saved_marker_ptr; { Head of list of saved markers }
    {$ENDIF}

    { Remaining fields are known throughout decompressor, but generally
      should not be touched by a surrounding application. }
    max_h_samp_factor : Integer;    { largest h_samp_factor }
    max_v_samp_factor : Integer;    { largest v_samp_factor }
    min_DCT_scaled_size : Integer;  { smallest DCT_scaled_size of any component }
    total_iMCU_rows : JDIMENSION; { # of iMCU rows in image }
    sample_range_limit : Pointer;   { table for fast range-limiting }

    { These fields are valid during any one scan.
      They describe the components and MCUs actually appearing in the scan.
      Note that the decompressor output side must not use these fields. }
    comps_in_scan : Integer;           { # of JPEG components in this scan }
    cur_comp_info : Array[0..MAX_COMPS_IN_SCAN-1] of Pointer;
    MCUs_per_row : JDIMENSION;     { # of MCUs across the image }
    MCU_rows_in_scan : JDIMENSION; { # of MCU rows in the image }
    blocks_in_MCU : JDIMENSION;    { # of DCT blocks per MCU }
    MCU_membership : Array[0..D_MAX_BLOCKS_IN_MCU-1] of Integer;
    Ss, Se, Ah, Al : Integer;          { progressive JPEG parameters for scan }

    { This field is shared between entropy decoder and marker parser.
      It is either zero or the code of a JPEG marker that has been
      read from the data source, but has not yet been processed. }
    unread_marker : Integer;

    { Links to decompression subobjects
      (methods, private variables of modules) }
    master : Pointer;
    main : Pointer;
    coef : Pointer;
    post : Pointer;
    inputctl : Pointer;
    marker : Pointer;
    entropy : Pointer;
    idct : Pointer;
    upsample : Pointer;
    cconvert : Pointer;
    cquantize : Pointer;
  end;

  TJPEGContext = record
    err: jpeg_error_mgr;
    progress: jpeg_progress_mgr;
    FinalDCT: J_DCT_METHOD;
    FinalTwoPassQuant: Boolean;
    FinalDitherMode: J_DITHER_MODE;
    case byte of
      0: (common: jpeg_common_struct);
      1: (d: jpeg_decompress_struct);
      2: (c: jpeg_compress_struct);
  end;

{ Decompression startup: read start of JPEG datastream to see what's there
   function jpeg_read_header (cinfo : j_decompress_ptr;
                              require_image : LongBool) : Integer;
  Return value is one of: }
const
  JPEG_SUSPENDED              = 0; { Suspended due to lack of input data }
  JPEG_HEADER_OK              = 1; { Found valid image datastream }
  JPEG_HEADER_TABLES_ONLY     = 2; { Found valid table-specs-only datastream }
{ If you pass require_image = TRUE (normal case), you need not check for
  a TABLES_ONLY return code; an abbreviated file will cause an error exit.
  JPEG_SUSPENDED is only possible if you use a data source module that can
  give a suspension return (the stdio source module doesn't). }


{ function jpeg_consume_input (cinfo : j_decompress_ptr) : Integer;
  Return value is one of: }

  JPEG_REACHED_SOS            = 1; { Reached start of new scan }
  JPEG_REACHED_EOI            = 2; { Reached end of image }
  JPEG_ROW_COMPLETED          = 3; { Completed one iMCU row }
  JPEG_SCAN_COMPLETED         = 4; { Completed last iMCU row of a scan }


// Stubs for external C RTL functions referenced by JPEG OBJ files.

function _malloc(size: Integer): Pointer; cdecl;
begin
  GetMem(Result, size);
end;

procedure _free(P: Pointer); cdecl;
begin
  FreeMem(P);
end;

procedure _memset(P: Pointer; B: Byte; count: Integer); cdecl;
begin
  FillChar(P^, count, B);
end;

procedure _memcpy(dest, source: Pointer; count: Integer); cdecl;
begin
  Move(source^, dest^, count);
end;

function _fread(var buf; recsize, reccount: Integer; S: PStream): Integer; cdecl;
begin
  Result := S.Read(buf, recsize * reccount);
end;

function _fwrite(var buf; recsize, reccount: Integer; S: PStream): Integer; cdecl;
begin
  Result := S.Write(buf, recsize * reccount);
end;

function _fflush(S: PStream): Integer; cdecl;
begin
  Result := 0;
end;

function __ftol: Integer;
var
  f: double;
begin
  asm
    lea    eax, f             //  BC++ passes floats on the FPU stack
    fstp  qword ptr [eax]     //  Delphi passes floats on the CPU stack
  end;
  Result := Integer(Trunc(f));
end;

var
  __turboFloat: LongBool = False;

{$L JPegObj\jdapimin.obj}
{$L JPegObj\jmemmgr.obj}
{$L JPegObj\jmemnobs.obj}
{$L JPegObj\jdinput.obj}
{$L JPegObj\jdatasrc.obj}
{$L JPegObj\jdapistd.obj}
{$L JPegObj\jdmaster.obj}
{$L JPegObj\jdphuff.obj}
{$L JPegObj\jdhuff.obj}
{$L JPegObj\jdmerge.obj}
{$L JPegObj\jdcolor.obj}
{$L JPegObj\jquant1.obj}
{$L JPegObj\jquant2.obj}
{$L JPegObj\jdmainct.obj}
{$L JPegObj\jdcoefct.obj}
{$L JPegObj\jdpostct.obj}
{$L JPegObj\jddctmgr.obj}
{$L JPegObj\jdsample.obj}
{$L JPegObj\jidctflt.obj}
{$L JPegObj\jidctfst.obj}
{$L JPegObj\jidctint.obj}
{$L JPegObj\jidctred.obj}
{$L JPegObj\jdmarker.obj}
{$L JPegObj\jutils.obj}
{$L JPegObj\jcomapi.obj}

procedure jpeg_CreateDecompress (var cinfo : jpeg_decompress_struct;
  version : integer; structsize : integer); external;
procedure jpeg_stdio_src(var cinfo: jpeg_decompress_struct;
  input_file: PStream); external;
procedure jpeg_read_header(var cinfo: jpeg_decompress_struct;
  RequireImage: LongBool); external;
procedure jpeg_calc_output_dimensions(var cinfo: jpeg_decompress_struct); external;
function jpeg_start_decompress(var cinfo: jpeg_decompress_struct): Longbool; external;
function jpeg_read_scanlines(var cinfo: jpeg_decompress_struct;
	scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external;
function jpeg_finish_decompress(var cinfo: jpeg_decompress_struct): Longbool; external;
procedure jpeg_destroy_decompress (var cinfo : jpeg_decompress_struct); external;
function jpeg_has_multiple_scans(var cinfo: jpeg_decompress_struct): Longbool; external;
function jpeg_consume_input(var cinfo: jpeg_decompress_struct): Integer; external;
function jpeg_start_output(var cinfo: jpeg_decompress_struct; scan_number: Integer): Longbool; external;
function jpeg_finish_output(var cinfo: jpeg_decompress_struct): LongBool; external;
procedure jpeg_destroy(var cinfo: jpeg_common_struct); external;

{$L JPegObj\jdatadst.obj}
{$L JPegObj\jcparam.obj}
{$L JPegObj\jcapistd.obj}
{$L JPegObj\jcapimin.obj}
{$L JPegObj\jcinit.obj}
{$L JPegObj\jcmarker.obj}
{$L JPegObj\jcmaster.obj}
{$L JPegObj\jcmainct.obj}
{$L JPegObj\jcprepct.obj}
{$L JPegObj\jccoefct.obj}
{$L JPegObj\jccolor.obj}
{$L JPegObj\jcsample.obj}
{$L JPegObj\jcdctmgr.obj}
{$L JPegObj\jcphuff.obj}
{$L JPegObj\jfdctint.obj}
{$L JPegObj\jfdctfst.obj}
{$L JPegObj\jfdctflt.obj}
{$L JPegObj\jchuff.obj}

procedure jpeg_CreateCompress (var cinfo : jpeg_compress_struct;
  version : integer; structsize : integer); external;
procedure jpeg_stdio_dest(var cinfo: jpeg_compress_struct;
  output_file: PStream); external;
procedure jpeg_set_defaults(var cinfo: jpeg_compress_struct); external;
procedure jpeg_set_quality(var cinfo: jpeg_compress_struct; Quality: Integer;
  Baseline: Longbool); external;
procedure jpeg_set_colorspace(var cinfo: jpeg_compress_struct;
  colorspace: J_COLOR_SPACE); external;
procedure jpeg_simple_progression(var cinfo: jpeg_compress_struct); external;
procedure jpeg_start_compress(var cinfo: jpeg_compress_struct;
  WriteAllTables: LongBool); external;
function jpeg_write_scanlines(var cinfo: jpeg_compress_struct;
  scanlines: JSAMPARRAY; max_lines: JDIMENSION): JDIMENSION; external;
procedure jpeg_finish_compress(var cinfo: jpeg_compress_struct); external;

var Jpeg_Error: Boolean = FALSE;

procedure InvalidOperation(const Msg: string); near;
begin
  //raise EInvalidGraphicOperation.Create(Msg);
  //MessageBox( 0, PChar(Msg), 'JPeg message: Invalid Operation', MB_OK );
  {$IFDEF JPEGERR}
  raise Exception.Create( e_Convert, 'Jpeg: InvalidOp' );
  {$ELSE}
  Jpeg_Error := TRUE;
  {$ENDIF}
end;

procedure JpegError(cinfo: j_common_ptr);
begin
  //TODO: raise EJPEG.CreateFmt(sJPEGError,[cinfo^.err^.msg_code]);

  {MessageBox( 0, PChar( 'JPeg error ' + #13 +
              'err: ' + Int2Str( Integer( cinfo.err ) ) + #13 +
              'mem: ' + Int2Str( Integer( cinfo.mem ) ) + #13 +
              'progress: ' + Int2Str( Integer( cinfo.progress ) ) + #13 +
              'is_decompressor: ' + Int2Str( Integer( cinfo.is_decompressor ) ) + #13 +
              'global_state: ' + Int2Str( cinfo.global_state ) ),
              'JPeg error', MB_OK );}

  {$IFDEF JPEGERR}
  raise Exception.CreateFmt( e_Convert,
        'Jpeg error: %d, mem: %d, progress: %d, isDecompressor: %d, globalState: %d',
        [ cinfo.err, cinfo.mem, cinfo.progress, cinfo.is_decompressor, cinfo.global_state ] );
  {$ELSE}
  Jpeg_Error := TRUE;
  {$ENDIF}
end;

procedure EmitMessage(cinfo: j_common_ptr; msg_level: Integer);
begin
  //!!
end;

procedure OutputMessage(cinfo: j_common_ptr);
begin
  //!!
end;

procedure FormatMessage(cinfo: j_common_ptr; buffer: PChar);
begin
  //!!
end;

procedure ResetErrorMgr(cinfo: j_common_ptr);
begin
  cinfo^.err^.num_warnings := 0;
  cinfo^.err^.msg_code := 0;
end;


const
  jpeg_std_error: jpeg_error_mgr = (
    error_exit: JpegError;
    emit_message: EmitMessage;
    output_message: OutputMessage;
    format_message: FormatMessage;
    reset_error_mgr: ResetErrorMgr);

{ TJPEGData }

procedure TJPEGData.Clear;
begin
  if FData <> nil then
     FData.Size := 0;
  FWidth := 0;
  FHeight := 0;
end;

destructor TJPEGData.Destroy;
begin
  FData.Free;
  inherited;
end;

procedure DummyProgressCallback( const cinfo: jpeg_common_struct );
begin
  // * nothing *
end;

procedure ProgressCallback(const cinfo: jpeg_common_struct);
var
  Ticks: Integer;
  R: TRect;
  temp: Integer;
begin
  if (cinfo.progress = nil) or (cinfo.progress^.instance = nil) then Exit;
  with cinfo.progress^ do
  begin
    Ticks := GetTickCount;
    if (Ticks - last_time) < cinfo.progress^.instance.fProgressTime then Exit;
    temp := last_time;
    last_time := Ticks;
    if temp = 0 then Exit;
    if cinfo.is_decompressor then
      with j_decompress_ptr(@cinfo)^ do
      begin
        R := MakeRect(0, last_scanline, output_width, output_scanline);
        if R.Bottom < last_scanline then
          R.Bottom := output_height;
      end
    else
      R := MakeRect(0,0,0,0);
    temp := Integer(Trunc(100.0*(completed_passes + (pass_counter/pass_limit))/total_passes));
    if temp = last_pct then Exit;
    last_pct := temp;
    if cinfo.is_decompressor then
      last_scanline := j_decompress_ptr(@cinfo)^.output_scanline;
    //instance.Progress(instance, psRunning, temp, (R.Bottom - R.Top) >= 4, R, '');
    if instance.FProgress( instance, R ) then
      instance.FStop := TRUE;
  end;
end;

procedure ReleaseContext(var jc: TJPEGContext);
begin
  if jc.common.err = nil then Exit;
  jpeg_destroy(jc.common);
  jc.common.err := nil;
end;

procedure InitDecompressor(Obj: PJpeg; var jc: TJPEGContext);
begin
  FillChar(jc, sizeof(jc), 0);
  jc.err := jpeg_std_error;
  jc.common.err := @jc.err;

  jpeg_CreateDecompress(jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
  with Obj^ do
  try
    jc.progress.progress_monitor := FCallback;
    jc.progress.instance := Obj;
    jc.common.progress := @jc.progress;

    Obj.FImage.FData.Position := 0;
    jpeg_stdio_src(jc.d, FImage.FData);
    jpeg_read_header(jc.d, TRUE);

    jc.d.scale_num := 1;
    jc.d.scale_denom := 1 shl Byte(FScale);
    jc.d.do_block_smoothing := FSmoothing;

    if FGrayscale then jc.d.out_color_space := JCS_GRAYSCALE;
    if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then
    begin
      jc.d.quantize_colors := True;
      jc.d.desired_number_of_colors := 236;
    end;

    if FPerformance = jpBestSpeed then
    begin
      jc.d.dct_method := JDCT_IFAST;
      jc.d.two_pass_quantize := False;
//      jc.d.do_fancy_upsampling := False;    !! AV inside jpeglib
      jc.d.dither_mode := JDITHER_ORDERED;
    end;

    jc.FinalDCT := jc.d.dct_method;
    jc.FinalTwoPassQuant := jc.d.two_pass_quantize;
    jc.FinalDitherMode := jc.d.dither_mode;
    if FProgressiveDisplay and jpeg_has_multiple_scans(jc.d) then
    begin  // save requested settings, reset for fastest on all but last scan
      jc.d.enable_2pass_quant := jc.d.two_pass_quantize;
      jc.d.dct_method := JDCT_IFAST;
      jc.d.two_pass_quantize := False;
      jc.d.dither_mode := JDITHER_ORDERED;
      jc.d.buffered_image := True;
    end;
  except
    ReleaseContext(jc);
    raise;
  end;
end;

{ TJpeg }

function DummyProgress( JPEGobj: PJpeg; const R: TRect ): Boolean;
begin
  Result := FALSE; // not stop
end;

function NormalProgress( JPEGobj: PJpeg; const R: TRect ): Boolean;
begin
  Result := FALSE; // not stop
  if Assigned( JPEGobj.FOnProgress ) then
    JPEGobj.FOnProgress( JPEGobj, R, Result );
end;

function NewJpeg: PJpeg;
begin
  new( Result, Create );
  with Result^ do
  begin
    CreateImage;
    FQuality := JPEGDefaults.CompressionQuality;
    FGrayscale := JPEGDefaults.Grayscale;
    FPerformance := JPEGDefaults.Performance;
    FPixelFormat := JPEGDefaults.PixelFormat;
    FProgressiveDisplay := JPEGDefaults.ProgressiveDisplay;
    FProgressiveEncoding := JPEGDefaults.ProgressiveEncoding;
    FScale := JPEGDefaults.Scale;
    FSmoothing := JPEGDefaults.Smoothing;
    FProgress := DummyProgress;
    FCallback := @ DummyProgressCallback;
    fProgressTime := 100;
  end;
end;

procedure TJpeg.CalcOutputDimensions;
var
  jc: TJPEGContext;
begin
  if not FNeedRecalc then Exit;
  InitDecompressor(@Self, jc);
  try
    jc.common.progress := nil;
    jpeg_calc_output_dimensions(jc.d);
    // read output dimensions
    FScaledWidth := jc.d.output_width;
    FScaledHeight := jc.d.output_height;
    FProgressiveEncoding := jpeg_has_multiple_scans(jc.d);
  finally
    ReleaseContext(jc);
  end;
end;

procedure TJpeg.Clear;
begin
  FreeBitmap;
  FImage.Clear;
end;

procedure TJpeg.Compress;
var
  LinesWritten, LinesPerCall: Integer;
  SrcScanLine: Pointer;
  PtrInc: Integer;
  jc: TJPEGContext;
  Src: PBitmap;
begin
  FillChar(jc, sizeof(jc), 0);
  jc.err := jpeg_std_error;
  jc.common.err := @jc.err;

  jpeg_CreateCompress(jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
  try
    try
      jc.progress.progress_monitor := FCallback;
      jc.progress.instance := @Self;
      jc.common.progress := @jc.progress;

      if FImage.FData <> nil then CreateImage;
      FImage.FData := NewMemoryStream;
      FImage.FData.Position := 0;
      jpeg_stdio_dest(jc.c, FImage.FData);

      if (FBitmap = nil) or (FBitmap.Width = 0) or (FBitmap.Height = 0) then Exit;
      jc.c.image_width := FBitmap.Width;
      FImage.FWidth := FBitmap.Width;
      jc.c.image_height := FBitmap.Height;
      FImage.FHeight := FBitmap.Height;
      jc.c.input_components := 3;           // JPEG requires 24bit RGB input
      jc.c.in_color_space := JCS_RGB;

      Src := NewBitmap( 0, 0 );
      try
        Src.Assign(FBitmap);
        Src.PixelFormat := pf24bit;

        jpeg_set_defaults(jc.c);
        jpeg_set_quality(jc.c, FQuality, True);

        if FGrayscale then
        begin
          FImage.FGrayscale := True;
          jpeg_set_colorspace(jc.c, JCS_GRAYSCALE);
        end;

        if ProgressiveEncoding then
          jpeg_simple_progression(jc.c);

        SrcScanline := Src.ScanLine[0];
        PtrInc := 0;
        //if jc.d.output_height > 1 then
        if FImage.FHeight > 1 then
          PtrInc := Integer(Src.ScanLine[1]) - Integer(SrcScanline);

          // if no dword padding required and source bitmap is top-down
        if (PtrInc > 0) and ((PtrInc and 3) = 0) then
          LinesPerCall := jc.c.image_height  // do whole bitmap in one call
        else
          LinesPerCall := 1;      // otherwise spoonfeed one row at a time

        //--Progress(Self, psStarting, 0, False, Rect(0,0,0,0), '');
        FProgress( @Self, MakeRect( 0, 0, 0, 0 ) );
        try
          jpeg_start_compress(jc.c, True);

          while (jc.c.next_scanline < jc.c.image_height) do
          begin
            LinesWritten := jpeg_write_scanlines(jc.c, @SrcScanline, LinesPerCall);
            Inc(Integer(SrcScanline), PtrInc * LinesWritten);
          end;

          jpeg_finish_compress(jc.c);
        finally
          {--
          if ExceptObject = nil then
            PtrInc := 100
          else
            PtrInc := 0;
          --}
          //--Progress(Self, psEnding, PtrInc, False, Rect(0,0,0,0), '');
          //FProgress( @Self, MakeRect( 0, 0, 0, 0 ) );
        end;
      finally
        Src.Free;
      end;
    {$IFDEF JPEGERR}
    except
      //on EAbort do    // OnProgress can raise EAbort to cancel image save
        CreateImage;     // Throw away any partial jpg data
    {$ELSE}
    finally {+}
    {$ENDIF}
    end;
  finally
    ReleaseContext(jc);
  end;
end;

destructor TJpeg.Destroy;
begin
  if FTempPal <> 0 then DeleteObject(FTempPal);
  FBitmap.Free;
  FImage.Free;
  inherited;
end;

procedure TJpeg.DIBNeeded;
begin
  GetBitmap;
end;

procedure TJpeg.Draw(DC: HDC; X, Y: Integer);
begin
  if Assigned(Bitmap) then
    Bitmap.Draw( DC, X, Y );
end;

procedure TJpeg.FreeBitmap;
begin
  FBitmap.Free;
  FBitmap := nil;
end;

function BuildPalette(const cinfo: jpeg_decompress_struct): HPalette;
var
  Pal: TMaxLogPalette;
  I: Integer;
  C: Byte;
begin
  Pal.palVersion := $300;
  Pal.palNumEntries := cinfo.actual_number_of_colors;
  if cinfo.out_color_space = JCS_GRAYSCALE then
    for I := 0 to Pal.palNumEntries-1 do
    begin
      C := cinfo.colormap^[0]^[I];
      Pal.palPalEntry[I].peRed := C;
      Pal.palPalEntry[I].peGreen := C;
      Pal.palPalEntry[I].peBlue := C;
      Pal.palPalEntry[I].peFlags := 0;
    end
  else
    for I := 0 to Pal.palNumEntries-1 do
    begin
      Pal.palPalEntry[I].peRed := cinfo.colormap^[0]^[I];
      Pal.palPalEntry[I].peGreen := cinfo.colormap^[1]^[I];
      Pal.palPalEntry[I].peBlue := cinfo.colormap^[2]^[I];
      // 23 Jun 2005: R <-> B fixed (reporter: Sapersky)
      Pal.palPalEntry[I].peFlags := 0;
    end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

procedure BuildColorMap(var cinfo: jpeg_decompress_struct; P: HPalette);
var
  Pal: TMaxLogPalette;
  Count, I: Integer;
begin
  Count := GetPaletteEntries(P, 0, 256, Pal.palPalEntry);
  if Count = 0 then Exit;       // jpeg_destroy will free colormap
  cinfo.colormap := cinfo.common.mem.alloc_sarray(@cinfo.common, JPOOL_IMAGE, Count, 3);
  cinfo.actual_number_of_colors := Count;
  for I := 0 to Count-1 do
  begin
    Byte(cinfo.colormap^[2]^[I]) := Pal.palPalEntry[I].peRed;
    Byte(cinfo.colormap^[1]^[I]) := Pal.palPalEntry[I].peGreen;
    Byte(cinfo.colormap^[0]^[I]) := Pal.palPalEntry[I].peBlue;
  end;
end;

procedure SetBitmapDIBPalette( Bmp: PBitmap; Pal: HPalette );
var Entries: array[ 0..255 ] of Integer;
    I: Integer;
begin
  GetPaletteEntries( Pal, 0, 256, Entries[ 0 ] );
  for I := 0 to 255 do
    Bmp.DIBPalEntries[ I ] := Entries[ I ];
end;

function TJpeg.GetBitmap: PBitmap;
var
  LinesPerCall, LinesRead: Integer;
  DestScanLine: Pointer;
  PtrInc: Integer;
  jc: TJPEGContext;
  GeneratePalette: Boolean;
  PaletteModified : Boolean;

  TmpPal: HPalette;
  OK: Boolean;
begin
  Result := FBitmap;
  if Result <> nil then Exit;

  if (Width = 0) or (Height = 0) then
    Exit;
  GeneratePalette := True;

  {$IFNDEF JPEGERR}
  Jpeg_Error := FALSE;
  {$ENDIF}
  FStop := FALSE;
  InitDecompressor(@Self, jc);
  {$IFNDEF JPEGERR}
  FCorrupted := Jpeg_Error;
  {$ENDIF}

  //++++++
  FBitmap.Free;
  if (PixelFormat = jf8Bit) or (jc.d.out_color_space = JCS_GRAYSCALE) then
    FBitmap := NewDIBBitmap( Width, Height, pf8bit )
  else
  begin
    if jc.d.out_color_space in [JCS_CMYK,JCS_YCCK] then
      FBitmap := NewDIBBitmap( Width, Height, pf32bit )
      //jc.d.out_color_space := JCS_RGB;
    else
      FBitmap := NewDIBBitmap( Width, Height, pf24bit );
  end;
  Result := FBitmap;
  //++++++


  try
    try
      // Set the bitmap pixel format

      //--Progress(Self, psStarting, 0, False, Rect(0,0,0,0), '');
      FProgress( @Self, MakeRect( 0, 0, 0, 0 ) );
      PaletteModified := False;
      OK := FALSE;
      try
        if (FTempPal <> 0) then
        begin
          if (FPixelFormat = jf8Bit) then
          begin                        // Generate DIB using assigned palette
            BuildColorMap(jc.d, FTempPal);
            //--------------------------------------
            //FBitmap.Palette := CopyPalette(FTempPal);  // Keep FTempPal around
            //---------------------------------------
            SetBitmapDIBPalette( FBitmap, FTempPal );

            GeneratePalette := False;
          end
          else
          begin
            DeleteObject(FTempPal);
            FTempPal := 0;
          end;
        end;

        jpeg_start_decompress(jc.d);
        //{$IFNDEF JPEGERR}
        //if Jpeg_Error then Exit;
        //{$ENDIF}

        // Set bitmap width and height
        with FBitmap^ do
        begin
          //Handle := 0;
          Width := jc.d.output_width;
          Height := jc.d.output_height;
          DestScanline := ScanLine[0];
          PtrInc := 0;
          if jc.d.output_height > 1 then
            PtrInc := Integer(ScanLine[1]) - Integer(DestScanline);
          if (PtrInc > 0) and ((PtrInc and 3) = 0) then
             // if no dword padding is required and output bitmap is top-down
            LinesPerCall := jc.d.rec_outbuf_height // read multiple rows per call
          else
            LinesPerCall := 1;            // otherwise read one row at a time
        end;

        if jc.d.buffered_image then
        begin  // decode progressive scans at low quality, high speed
          while jpeg_consume_input(jc.d) <> JPEG_REACHED_EOI do
          begin
            jpeg_start_output(jc.d, jc.d.input_scan_number);
            {$IFNDEF JPEGERR}
            if Jpeg_Error then Exit;
            {$ENDIF}
            if FStop then Exit;
            // extract color palette
            if (jc.common.progress^.completed_passes = 0) and (jc.d.colormap <> nil)
              and (FBitmap.PixelFormat = pf8bit) and GeneratePalette then
            begin
              //
              //FBitmap.Palette := BuildPalette(jc.d);
              ///////////////////////////////////////////
              TmpPal := BuildPalette(jc.d);            //
              SetBitmapDIBPalette( FBitmap, TmpPal );  //
              DeleteObject( TmpPal );                  //
              ///////////////////////////////////////////
              PaletteModified := True;
            end;
            DestScanLine := FBitmap.ScanLine[0];
            while (jc.d.output_scanline < jc.d.output_height) do
            begin
              LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall);
              Inc(Integer(DestScanline), PtrInc * LinesRead);
            end;
            jpeg_finish_output(jc.d);
          end;
          // reset options for final pass at requested quality
          jc.d.dct_method := jc.FinalDCT;
          jc.d.dither_mode := jc.FinalDitherMode;
          if jc.FinalTwoPassQuant then
          begin
            jc.d.two_pass_quantize := True;
            jc.d.colormap := nil;
          end;
          jpeg_start_output(jc.d, jc.d.input_scan_number);
          DestScanLine := FBitmap.ScanLine[0];
        end;

        // build final color palette
        if (not jc.d.buffered_image or jc.FinalTwoPassQuant) and
          (jc.d.colormap <> nil) and GeneratePalette then
        begin
          //
          //FBitmap.Palette := BuildPalette(jc.d);
          ///////////////////////////////////////////
          TmpPal := BuildPalette(jc.d);            //
          SetBitmapDIBPalette( FBitmap, TmpPal );  //
          DeleteObject( TmpPal );                  //
          ///////////////////////////////////////////
          PaletteModified := True;
          DestScanLine := FBitmap.ScanLine[0];
        end;
        // final image pass for progressive, first and only pass for baseline
        while (jc.d.output_scanline < jc.d.output_height) do
        begin
          LinesRead := jpeg_read_scanlines(jc.d, @DestScanline, LinesPerCall);
          Inc(Integer(DestScanline), PtrInc * LinesRead);
        end;

        if jc.d.buffered_image then jpeg_finish_output(jc.d);
        jpeg_finish_decompress(jc.d);
        OK := TRUE;
      finally
        {--
        if ExceptObject = nil then
          PtrInc := 100
        else
          PtrInc := 0;
        --}
        //--Progress(Self, psEnding, PtrInc, PaletteModified, Rect(0,0,0,0), '');
        FProgress( @Self, MakeRect( 0, 0, Width, Height ) );
        // Make sure new palette gets realized, in case OnProgress event didn't.
        if PaletteModified then
          Changed;
        Jpeg_Error := Jpeg_Error or not OK;
        if jc.d.out_color_space in [JCS_CMYK,JCS_YCCK] then
        begin
          FCMYK := TRUE;
          if Assigned( FConvertCMYK2RGBProc ) then
          begin
            FConvertCMYK2RGBProc( FBitmap );
            FCMYK := FALSE;
          end;
        end;
      end;
    except
      //--on EAbort do ;   // OnProgress can raise EAbort to cancel image load
      {$IFDEF JPEGERR}
      FCorrupted := TRUE;
      {$ENDIF}
    end;
  finally
    ReleaseContext(jc);
    {$IFNDEF JPEGERR}
    FCorrupted := Jpeg_Error;
    {$ENDIF}
  end;
end;

function TJpeg.GetEmpty: Boolean;
begin
  Result := (Width = 0) or (Height = 0);
  {Result := (FImage.FData = nil) and
            ((FBitmap = nil) or FBitmap.Empty);}
end;

function TJpeg.GetGrayscale: Boolean;
begin
  Result := FGrayscale or FImage.FGrayscale;
end;

function TJpeg.GetHeight: Integer;
begin
  if FBitmap <> nil then
    Result := FBitmap.Height
  else
  if FScale = jsFullSize then
    Result := FImage.FHeight
  else
  begin
    CalcOutputDimensions;
    Result := FScaledHeight;
  end;
end;

function TJpeg.GetPalette: HPALETTE;
var DC: HDC;
begin
  Result := 0;
  {if FBitmap <> nil then
    Result := FBitmap.Palette
  else} if FTempPal <> 0 then
    Result := FTempPal
  else if FPixelFormat = jf24Bit then   // check for 8 bit screen
  begin
    DC := GetDC(0);
    if (GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES)) <= 8 then
    begin
      FTempPal := CreateHalftonePalette(DC);
      Result := FTempPal;
    end;
    ReleaseDC(0, DC);
  end;
end;

function TJpeg.GetWidth: Integer;
begin
  if FBitmap <> nil then
    Result := FBitmap.Width
  else if FScale = jsFullSize then
    Result := FImage.FWidth
  else
  begin
    CalcOutputDimensions;
    Result := FScaledWidth;
  end;
end;

procedure TJpeg.JPEGNeeded;
begin
  if FImage.FData = nil then
    Compress;
end;

procedure TJpeg.LoadFromStream(Stream: PStream);
begin
  FCorrupted := FALSE;
  ReadStream(Stream.Size - Stream.Position, Stream);
end;

procedure TJpeg.CreateBitmap;
begin
  FBitmap.Free;
  FBitmap := NewBitmap(0, 0);
end;

procedure TJpeg.CreateImage;
begin
  FImage.Free;
  new( FImage, Create );
end;

procedure TJpeg.ReadData(Stream: PStream);
var Size: Integer;
begin
  Stream.Read(Size, SizeOf(Size));
  ReadStream(Size, Stream);
end;

procedure TJpeg.ReadStream(Size: Integer; Stream: PStream);
var
  jerr: jpeg_error_mgr;
  cinfo: jpeg_decompress_struct;
begin
  CreateImage;
  FreeBitmap;
  try
    with FImage^ do
    begin
      FData := NewMemoryStream;
      FData.Size := Size;
      Stream.Read(FData.Memory^, Size);
      if Size > 0 {SizeOf(cinfo)} then
      begin
        jerr := jpeg_std_error;  // use local var for thread isolation
        cinfo.common.err := @jerr;
        jpeg_CreateDecompress(cinfo, JPEG_LIB_VERSION, sizeof(cinfo));
        try
          FData.Position := 0;
          jpeg_stdio_src(cinfo, FData);
          jpeg_read_header(cinfo, TRUE);
          FWidth := cinfo.image_width;
          FHeight := cinfo.image_height;
          FGrayscale := cinfo.jpeg_color_space = JCS_GRAYSCALE;
          FProgressiveEncoding := jpeg_has_multiple_scans(cinfo);
        finally
          jpeg_destroy_decompress(cinfo);
        end;
      end;
    end;
    //PaletteModified := True;
  except
    CreateImage;
    //FreeBitmap;
  end;
  Changed;
end;

procedure TJpeg.SaveToStream(Stream: PStream);
begin
  JPEGNeeded;
  with FImage.FData^ do
    Stream.Write(Memory^, Size);
end;

procedure TJpeg.SetGrayscale(Value: Boolean);
begin
  if FGrayscale <> Value then
  begin
    FreeBitmap;
    FGrayscale := Value;
    //--PaletteModified := True;
    Changed;
  end;
end;

procedure TJpeg.SetHeight(Value: Integer);
begin
  InvalidOperation( 'Could not set height for JPEG image' );
end;

procedure TJpeg.SetPalette(Value: HPalette);
var SignalChange: Boolean;
begin
  if Value <> FTempPal then
  begin
    SignalChange := (FBitmap <> nil); //and (Value <> FBitmap.Palette);
    if SignalChange then FreeBitmap;
    if FTempPal <> 0 then DeleteObject(FTempPal);
    FTempPal := Value;
    if SignalChange then
    begin
      //PaletteModified := True;
      Changed;
    end;
  end;
end;

procedure TJpeg.SetPerformance(Value: TJPEGPerformance);
begin
  if FPerformance <> Value then
  begin
    FreeBitmap;
    FPerformance := Value;
    //--PaletteModified := True;
    Changed;
  end;
end;

procedure TJpeg.SetPixelFormat(Value: TJPEGPixelFormat);
begin
  if FPixelFormat <> Value then
  begin
    {
    FreeBitmap;
    FPixelFormat := Value;
    //--PaletteModified := True;
    Changed;
    }
    DIBNeeded;
    FImage.FData.Free;
    FImage.FData:= nil;
    FPixelFormat := Value;
    JPEGNeeded;
    FreeBitmap;
    Changed;
  end;
end;

procedure TJpeg.SetScale(Value: TJPEGScale);
begin
  if FScale <> Value then
  begin
    FreeBitmap;
    FScale := Value;
    FNeedRecalc := True;
    Changed;
  end;
end;

procedure TJpeg.SetSmoothing(Value: Boolean);
begin
  if FSmoothing <> Value then
  begin
    FreeBitmap;
    FSmoothing := Value;
    Changed;
  end;
end;

procedure TJpeg.SetWidth(Value: Integer);
begin
  InvalidOperation( 'Could not set width for JPEG image' );
end;

procedure TJpeg.StretchDraw(DC: HDC; Dest: TRect);
begin
  Bitmap.StretchDraw( DC, Dest );
end;

procedure TJpeg.WriteData(Stream: PStream);
var
  Size: Integer;
begin
  Size := 0;
  if Assigned(FImage.FData) then Size := FImage.FData.Size;
  Stream.Write(Size, Sizeof(Size));
  if Size > 0 then Stream.Write(FImage.FData.Memory^, Size);
end;

function TJpeg.LoadFromFile( const FName : String ) : Boolean;
var Strm : PStream;
begin
  Clear;
  Strm := NewReadFileStream( FName );
  if Strm.Size > 0 then
     LoadFromStream( Strm );
  Strm.Free;
  Result := not Empty;
end;

function TJpeg.SaveToFile( const FName : String ) : Boolean;
var Strm : PStream;
begin
  Result := False;
  if Empty then Exit;
  Strm := NewWriteFileStream( FName );
  SaveToStream( Strm );
  Result := Strm.Position > 0;
  Strm.Free;
end;

procedure TJpeg.Changed;
begin
  if Assigned( OnChange ) then
    OnChange( @Self );
end;

{function TJpeg.Empty: Boolean;
begin
  Result := (Width = 0) or (Height = 0);
end;}

procedure TJpeg.SetOnProgress(const Value: TJPEGProgress);
begin
  FOnProgress := Value;
  FProgress := NormalProgress;
  FCallback := @ ProgressCallback;
end;

procedure TJpeg.SetBitmap(const Value: PBitmap);
begin
  CreateImage;
  CreateBitmap;
  {FBitmap :=} FBitmap.Assign( Value );
  Changed;
end;

procedure DoConvertCMYK2RGB( Bmp: PBitmap );
var I, J: Integer;
    C, M, Y, K, R, G, B: Integer;
    P: PDWORD;
begin
  if Bmp.PixelFormat <> pf32bit then Exit;
  for I := 0 to Bmp.Height-1 do
  begin
    P := Bmp.ScanLine[ I ];
    for J := 0 to Bmp.Width - 1 do
    begin
      C := P^ and $FF;
      M := (P^ shr 8) and $FF;
      Y := (P^ shr 16) and $FF;
      K := P^ shr 24;
      R := Y * K div 255;
      G := M * K div 255;
      B := C * K div 255;
      P^ := R or (G shl 8) or (B shl 16);
      Inc( P );
    end;
  end;
end;

procedure TJpeg.SetConvertCMYK2RGB(const Value: Boolean);
begin
  FConvertCMYK2RGB := Value;
  if TRUE then
  begin
    FConvertCMYK2RGBProc := DoConvertCMYK2RGB;
    if (FBitmap <> nil) and FCMYK and
       (FBitmap.Width > 0) and (FBitmap.Height > 0) then
      DoConvertCMYK2RGB( FBitmap );
  end
    else
  begin
    FConvertCMYK2RGBProc := nil;
  end;
end;

end.