ielcms.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

     *
     *  icUInt16Number      inputTable[inputChan][icAny];   * The in-table
     *  icUInt16Number      clutTable[icAny];               * The clut
     *  icUInt16Number      outputTable[outputChan][icAny]; * The out-table
     *)
  end;

  _cmsTestAlign16 = packed record
    a: icS15Fixed16Number;
    b: icUInt16Number;
  end;

  // icLutAtoB
  icLutAtoB = packed record
    inputChan: icUInt8Number; // Number of input channels
    outputChan: icUInt8Number; // Number of output channels
    pad1: icUInt8Number;
    pad2: icUInt8Number;
    offsetB: icUInt32Number; // Offset to first "B" curve
    offsetMat: icUInt32Number; // Offset to matrix
    offsetM: icUInt32Number; // Offset to first "M" curve
    offsetC: icUInt32Number; // Offset to CLUT
    offsetA: icUInt32Number; // Offset to first "A" curve
    //icUInt8Number     data[icAny];     Data follows see spec for size */
  end;

  GAMMATABLE = packed record

    nEntries: integer;
    GammaTable: array[0..0] of WORD;

  end;

  LPGAMMATABLE = ^GAMMATABLE;

  GAMMATABLEArray = array[0..$EFFFFFF] of LPGAMMATABLE;
  LPGAMMATABLEArray = ^GAMMATABLEArray;

  TPWORDARRAY = array[0..$EFFFFFF] of pword;
  PPWORDARRAY = ^TPWORDARRAY;

  icCLutStruct = packed record
    gridPoints: array[0..15] of icUInt8Number; // Number of grid points in each dimension.
    prec: icUInt8Number; // Precision of data elements in bytes.
    pad1: icUInt8Number;
    pad2: icUInt8Number;
    pad3: icUInt8Number;
    //icUInt8Number     data[icAny];     Data follows see spec for size */
  end;

  // icLutBtoA
  icLutBtoA = packed record
    inputChan: icUInt8Number; // Number of input channels
    outputChan: icUInt8Number; // Number of output channels
    pad1: icUInt8Number;
    pad2: icUInt8Number;
    offsetB: icUInt32Number; // Offset to first "B" curve
    offsetMat: icUInt32Number; // Offset to matrix
    offsetM: icUInt32Number; // Offset to first "M" curve
    offsetC: icUInt32Number; // Offset to CLUT
    offsetA: icUInt32Number; // Offset to first "A" curve
    //icUInt8Number     data[icAny];     Data follows see spec for size */
  end;

  icNamedColor2 = packed record
    vendorFlag: icUInt32Number; // Bottom 16 bits for IC use */
    count: icUInt32Number; // Count of named colors */
    nDeviceCoords: icUInt32Number; // Num of device coordinates */
    prefix: array[0..31] of icInt8Number; // Prefix for each color name */
    suffix: array[0..31] of icInt8Number; // Suffix for each color name */
    data: array[0..0] of icInt8Number; // Named color data follows */
  end;
  PicNamedColor2 = ^icNamedColor2;

  GAMUTCHAIN = packed record

    hForward, hReverse: cmsHTRANSFORM;
  end;

  LPGAMUTCHAIN = ^GAMUTCHAIN;

  cmsCIExyY = packed record

    x: double;
    y_mi: double;
    Y_ma: double;

  end;

  LPcmsCIExyY = ^cmsCIExyY;

  cmsCIExyYTRIPLE = packed record

    Red: cmsCIExyY;
    Green: cmsCIExyY;
    Blue: cmsCIExyY;

  end;

  LPcmsCIExyYTRIPLE = ^cmsCIExyYTRIPLE;

  cmsCIEXYZTRIPLE = packed record

    Red: cmsCIEXYZ;
    Green: cmsCIEXYZ;
    Blue: cmsCIEXYZ;

  end;

  LPcmsCIEXYZTRIPLE = ^cmsCIEXYZTRIPLE;

  cmsPSEQDESC = packed record

    deviceMfg: icSignature;
    deviceModel: icSignature;
    attributes: array[0..1] of icUInt32Number;
    technology: icTechnologySignature;

    Manufacturer: array[0..511] of char;
    Model: array[0..511] of char;

  end;

  LPcmsPSEQDESC = ^cmsPSEQDESC;

  cmsSEQ = packed record

    n: integer;
    seq: array[0..0] of cmsPSEQDESC;

  end;
  LPcmsSEQ = ^cmsSEQ;

  // Profile sequence structure */
  icDescStruct = packed record
    deviceMfg: icSignature; // Dev Manufacturer */
    deviceModel: icSignature; // Dev Model */
    attributes: icUInt64Number; // Dev attributes */
    technology: icTechnologySignature; // Technology sig */
    data: array[0..0] of icInt8Number; // Desc text follows */
  end;

  _cmsSAMPLER = function(xIn: pwordarray; xOut: pwordarray; Cargo: pointer): integer;

const

  Device2PCS: array[0..3] of icTagSignature = (icSigAToB0Tag, // Perceptual
    icSigAToB1Tag, // Relative colorimetric
    icSigAToB2Tag, // Saturation
    icSigAToB1Tag); // Absolute colorimetric
  // (Relative/WhitePoint)

  PCS2Device: array[0..3] of icTagSignature = (icSigBToA0Tag, // Perceptual
    icSigBToA1Tag, // Relative colorimetric
    icSigBToA2Tag, // Saturation
    icSigBToA1Tag); // Absolute colorimetric
  // (Relative/WhitePoint)
  Preview: array[0..3] of icTagSignature = (icSigPreview0Tag,
    icSigPreview1Tag,
    icSigPreview2Tag,
    icSigPreview1Tag);

  ///////////////////////////////////////////////////////////////////////////////////////////////////

function DOUBLE_TO_FIXED(x: double): Fixed32; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
  result := round(x * 65536 );
end;

function FIXED_TO_DOUBLE(x: Fixed32): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
  result := x / 65536;
end;

function FixedMul(a: Fixed32; b: Fixed32): Fixed32; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
  //result:=DOUBLE_TO_FIXED(FIXED_TO_DOUBLE(a) * FIXED_TO_DOUBLE(b));
  result := round(((a / 65536) * (b / 65536)) * 65536 );
end;

procedure DSWAP(var a, b: double); {$ifdef IESUPPORTINLINE} inline; {$endif}
var
  tmp: double;
begin
  tmp := a;
  a := b;
  b := tmp;
end;

function IEFileRead(buffer: pointer; size: integer; count: integer; stream: TStream): integer;
begin
  result := stream.Read(pbyte(buffer)^, size * count) div size;
end;

function IEFileSeek(stream: TStream; offset: int64): longbool;
begin
  result := false; // fdv
  stream.Position := offset;
end;

function IEFileClose(stream: TStream): longbool;
begin
  // nothing to do because we work with streams
end;

function IEFileTell(stream: TStream): int64;
begin
  result := stream.position;
end;

function IEFileWrite(stream: TStream; size: integer; Ptr: pointer): longbool;
begin
  result := true; // fdv
  stream.Write(pbyte(Ptr)^, size);
end;

procedure AdjustEndianess16(iepByte: pbytearray); 
var
  tmp: byte;
begin
  tmp := iepByte[0];
  iepByte[0] := iepByte[1];
  iepByte[1] := tmp;
end;

procedure AdjustEndianess32(iepByte: pbyte); 
var
  temp1: byte;
  temp2: byte;
  tp: pbyte;
begin
  temp1 := iepByte^;
  inc(iepByte);
  temp2 := iepByte^;
  inc(iepByte);
  tp := iepByte;
  dec(tp);
  tp^ := iepByte^;
  iepByte^ := temp2;
  inc(iepByte);
  tp := iepByte;
  dec(tp, 3);
  tp^ := iepByte^;
  iepByte^ := temp1;
end;

(*
procedure AdjustEndianess32(iepByte: pbyte);
begin
  pinteger(iepByte)^:=IESwapDWord(pinteger(iepByte)^);
end;
*)


// Initiate a vector (double version)

procedure VEC3init(r: LPVEC3; x, y, z: double); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
  r^.n[VX] := x;
  r^.n[VY] := y;
  r^.n[VZ] := z;
end;

// Identity

procedure MAT3identity(a: LPMAT3); 
begin
  VEC3init(@a^.v[0], 1.0, 0.0, 0.0);
  VEC3init(@a^.v[1], 0.0, 1.0, 0.0);
  VEC3init(@a^.v[2], 0.0, 0.0, 1.0);
end;

// Swap two double vectors

procedure VEC3swap(a: LPVEC3; b: LPVEC3); 
begin
  DSWAP(a^.n[VX], b^.n[VX]);
  DSWAP(a^.n[VY], b^.n[VY]);
  DSWAP(a^.n[VZ], b^.n[VZ]);
end;

// Divide a vector by a constant

procedure VEC3divK(r: LPVEC3; v: LPVEC3; d: double); 
var
  d_inv: double;
begin
  d_inv := 1 / d;
  r^.n[VX] := v^.n[VX] * d_inv;
  r^.n[VY] := v^.n[VY] * d_inv;
  r^.n[VZ] := v^.n[VZ] * d_inv;
end;

// Multiply by a constant

procedure VEC3perK(r: LPVEC3; v: LPVEC3; d: double); 
begin
  r^.n[VX] := v^.n[VX] * d;
  r^.n[VY] := v^.n[VY] * d;
  r^.n[VZ] := v^.n[VZ] * d;
end;

// Minus

procedure VEC3minus(r: LPVEC3; a: LPVEC3; b: LPVEC3);
begin
  r^.n[VX] := a^.n[VX] - b^.n[VX];
  r^.n[VY] := a^.n[VY] - b^.n[VY];
  r^.n[VZ] := a^.n[VZ] - b^.n[VZ];
end;

// Inverse of a matrix b = a^(-1)
// Gauss-Jordan elimination with partial pivoting

function MAT3inverse(a: LPMAT3; b: LPMAT3): integer;
var
  i, j, max: integer;
  temp: VEC3;
begin

  MAT3identity(b);

  for j := 0 to 2 do
  begin
    max := j;
    for i := j + 1 to 2 do
      if (abs(a^.v[i].n[j]) > abs(a^.v[max].n[j])) then
        max := i;

    VEC3swap(@a^.v[max], @a^.v[j]);
    VEC3swap(@b^.v[max], @b^.v[j]);

    if (a^.v[j].n[j] = 0) then
    begin
      result := -1;
      exit;
    end;

    VEC3divK(@b^.v[j], @b^.v[j], a^.v[j].n[j]);
    VEC3divK(@a^.v[j], @a^.v[j], a^.v[j].n[j]);

    for i := 0 to 2 do
      if (i <> j) then
      begin

        VEC3perK(@temp, @b^.v[j], a^.v[i].n[j]);
        VEC3minus(@b^.v[i], @b^.v[i], @temp);

        VEC3perK(@temp, @a^.v[j], a^.v[i].n[j]);
        VEC3minus(@a^.v[i], @a^.v[i], @temp);
      end;
  end;
  result := 1;
end;

function Convert15Fixed16(fix32: icS15Fixed16Number): double;
var
  floater, sign, mid, hack: double;
  Whole, FracPart: integer;
begin
  AdjustEndianess32(@fix32);

  if fix32 < 0 then
    sign := -1
  else
    sign := 1;

  fix32 := abs(fix32);

  Whole := LOWORD(fix32 shr 16);
  FracPart := LOWORD(fix32 and $0000FFFF);

  hack := 65536.0;
  mid := FracPart / hack;
  floater := Whole + mid;

  result := sign * floater;
end;

// Allocate ICC struct. I/O routines are passed through

function ICCAllocStruct(Read: TReadFunction; Seek: TSeekFunction; Tell: TTellFunction; Close: TCloseFunction): LPLCMSICCPROFILE;
var
  Icc: LPLCMSICCPROFILE;
begin
  getmem(Icc, sizeof(LCMSICCPROFILE));
  if (Icc = nil) then
  begin
    result := nil;
    exit;
  end;
  ZeroMemory(Icc, sizeof(LCMSICCPROFILE));

  Icc^.Read := Read;
  Icc^.Seek := Seek;
  Icc^.Tell := Tell;
  Icc^.Close := Close;
  Icc^.Write := nil;

  Icc^.Illuminant.X := D50X;
  Icc^.Illuminant.Y := D50Y;
  Icc^.Illuminant.Z := D50Z;

  Icc^.TagCount := 0;

  result := Icc;
end;

function _cmsCreateProfilePlaceholder: cmsHPROFILE;
begin
  result := cmsHPROFILE(ICCAllocStruct(nil, nil, nil, nil));
end;

const
  D50XYZ: cmsCIEXYZ = (X: D50X; Y: D50Y; Z: D50Z);

function cmsD50_XYZ: LPcmsCIEXYZ; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
  result := @D50XYZ;
end;

procedure NormalizeXYZ(Dest: LPcmsCIEXYZ);
begin
  while (Dest^.X > 2) and
    (Dest^.Y > 2) and
    (Dest^.Z > 2) do
  begin

    Dest^.X := Dest^.X / 10;
    Dest^.Y := Dest^.Y / 10;
    Dest^.Z := Dest^.Z / 10;
  end;
end;

function CreateICCProfileHandler(ICCfile: TStream; Read: TReadFunction; Seek: TSeekFunction; Tell: TTellFunction; Close: TCloseFunction): LPLCMSICCPROFILE;
var
  Icc: LPLCMSICCPROFILE;
  Tag: icTag;
  Header: icHeader;