BSOne.SFC/EM.Lib/ImageEn_SRC/Source/ielcms.pas

11998 lines
282 KiB
Plaintext

(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
//
// Little cms
// Copyright (C) 1998-2004 Marti Maria
//
// Permission is hereby granted, free of charge, to any person obtaining
// a copy of this software and associated documentation files (the "Software"),
// to deal in the Software without restriction, including without limitation
// the rights to use, copy, modify, merge, publish, distribute, sublicense,
// and/or sell copies of the Software, and to permit persons to whom the Software
// is furnished to do so, subject to the following conditions:
//
// The above copyright notice and this permission notice shall be included in
// all copies or substantial portions of the Software.
//
// THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
// EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO
// THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
// NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
// LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
// OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
// WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
// Version 1.13
(*
File version 1001
*)
unit ielcms;
{$I ie.inc}
interface
{$IFDEF IEINCLUDECMS}
uses
Windows, Classes, SysUtils, imageenproc, hyiedefs;
type
LCMSHANDLE = pointer;
cmsHPROFILE = LCMSHANDLE;
cmsHTRANSFORM = LCMSHANDLE;
PcmsHTRANSFORM = ^cmsHTRANSFORM;
const
// Pixel types
PT_ANY = 0;
PT_GRAY = 3;
PT_RGB = 4;
PT_CMY = 5;
PT_CMYK = 6;
PT_YCbCr = 7;
PT_YUV = 8; // Lu'v'
PT_XYZ = 9;
PT_Lab = 10;
PT_YUVK = 11; // Lu'v'K
PT_HSV = 12;
PT_HLS = 13;
PT_Yxy = 14;
PT_HiFi = 15;
PT_HiFi7 = 16;
PT_HiFi8 = 17;
TYPE_GRAY_8 = ((PT_GRAY shl 16) or (1 shl 3) or (1));
TYPE_GRAY_8_REV = ((PT_GRAY shl 16) or (1 shl 3) or (1) or (1 shl 13));
TYPE_GRAY_16 = ((PT_GRAY shl 16) or (1 shl 3) or (2));
TYPE_GRAY_16_REV = ((PT_GRAY shl 16) or (1 shl 3) or (2) or (1 shl 13));
TYPE_GRAY_16_SE = ((PT_GRAY shl 16) or (1 shl 3) or (2) or (1 shl 11));
TYPE_GRAYA_8 = ((PT_GRAY shl 16) or (1 shl 7) or (1 shl 3) or (1));
TYPE_GRAYA_16 = ((PT_GRAY shl 16) or (1 shl 7) or (1 shl 3) or (2));
TYPE_GRAYA_16_SE = ((PT_GRAY shl 16) or (1 shl 7) or (1 shl 3) or (2) or (1 shl 11));
TYPE_GRAYA_8_PLANAR = ((PT_GRAY shl 16) or (1 shl 7) or (1 shl 3) or (1) or (1 shl 12));
TYPE_GRAYA_16_PLANAR = ((PT_GRAY shl 16) or (1 shl 7) or (1 shl 3) or (2) or (1 shl 12));
TYPE_RGB_8 = ((PT_RGB shl 16) or (3 shl 3) or (1));
TYPE_RGB_8_PLANAR = ((PT_RGB shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_BGR_8 = ((PT_RGB shl 16) or (3 shl 3) or (1) or (1 shl 10));
TYPE_BGR_8_PLANAR = ((PT_RGB shl 16) or (3 shl 3) or (1) or (1 shl 10) or (1 shl 12));
TYPE_RGB_16 = ((PT_RGB shl 16) or (3 shl 3) or (2));
TYPE_RGB_16_PLANAR = ((PT_RGB shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_RGB_16_SE = ((PT_RGB shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_BGR_16 = ((PT_RGB shl 16) or (3 shl 3) or (2) or (1 shl 10));
TYPE_BGR_16_PLANAR = ((PT_RGB shl 16) or (3 shl 3) or (2) or (1 shl 10) or (1 shl 12));
TYPE_BGR_16_SE = ((PT_RGB shl 16) or (3 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_RGBA_8 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (1));
TYPE_RGBA_8_PLANAR = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (1) or (1 shl 12));
TYPE_RGBA_16 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2));
TYPE_RGBA_16_PLANAR = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 12));
TYPE_RGBA_16_SE = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 11));
TYPE_ARGB_8 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (1) or (1 shl 14));
TYPE_ARGB_16 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 14));
TYPE_ABGR_8 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (1) or (1 shl 10));
TYPE_ABGR_16 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 10));
TYPE_ABGR_16_PLANAR = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 10) or (1 shl 12));
TYPE_ABGR_16_SE = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_BGRA_8 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (1) or (1 shl 10) or (1 shl 14));
TYPE_BGRA_16 = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 10) or (1 shl 14));
TYPE_BGRA_16_SE = ((PT_RGB shl 16) or (1 shl 7) or (3 shl 3) or (2) or (1 shl 11) or (1 shl 14));
TYPE_CMY_8 = ((PT_CMY shl 16) or (3 shl 3) or (1));
TYPE_CMY_8_PLANAR = ((PT_CMY shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_CMY_16 = ((PT_CMY shl 16) or (3 shl 3) or (2));
TYPE_CMY_16_PLANAR = ((PT_CMY shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_CMY_16_SE = ((PT_CMY shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_CMYK_8 = ((PT_CMYK shl 16) or (4 shl 3) or (1));
TYPE_CMYK_8_REV = ((PT_CMYK shl 16) or (4 shl 3) or (1) or (1 shl 13));
TYPE_YUVK_8 = TYPE_CMYK_8_REV;
TYPE_CMYK_8_PLANAR = ((PT_CMYK shl 16) or (4 shl 3) or (1) or (1 shl 12));
TYPE_CMYK_16 = ((PT_CMYK shl 16) or (4 shl 3) or (2));
TYPE_CMYK_16_REV = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 13));
TYPE_YUVK_16 = TYPE_CMYK_16_REV;
TYPE_CMYK_16_PLANAR = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 12));
TYPE_CMYK_16_SE = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 11));
TYPE_KYMC_8 = ((PT_CMYK shl 16) or (4 shl 3) or (1) or (1 shl 10));
TYPE_KYMC_16 = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 10));
TYPE_KYMC_16_SE = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_KCMY_8 = ((PT_CMYK shl 16) or (4 shl 3) or (1) or (1 shl 14));
TYPE_KCMY_8_REV = ((PT_CMYK shl 16) or (4 shl 3) or (1) or (1 shl 13) or (1 shl 14));
TYPE_KCMY_16 = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 14));
TYPE_KCMY_16_REV = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 13) or (1 shl 14));
TYPE_KCMY_16_SE = ((PT_CMYK shl 16) or (4 shl 3) or (2) or (1 shl 11) or (1 shl 14));
TYPE_CMYK5_8 = ((5 shl 3) or (1));
TYPE_CMYK5_16 = ((5 shl 3) or (2));
TYPE_CMYK5_16_SE = ((5 shl 3) or (2) or (1 shl 11));
TYPE_KYMC5_8 = ((5 shl 3) or (1) or (1 shl 10));
TYPE_KYMC5_16 = ((5 shl 3) or (2) or (1 shl 10));
TYPE_KYMC5_16_SE = ((5 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYKcm_8 = ((6 shl 3) or (1));
TYPE_CMYKcm_8_PLANAR = ((6 shl 3) or (1) or (1 shl 12));
TYPE_CMYKcm_16 = ((6 shl 3) or (2));
TYPE_CMYKcm_16_PLANAR = ((6 shl 3) or (2) or (1 shl 12));
TYPE_CMYKcm_16_SE = ((6 shl 3) or (2) or (1 shl 11));
TYPE_CMYK7_8 = ((7 shl 3) or (1));
TYPE_CMYK7_16 = ((7 shl 3) or (2));
TYPE_CMYK7_16_SE = ((7 shl 3) or (2) or (1 shl 11));
TYPE_KYMC7_8 = ((7 shl 3) or (1) or (1 shl 10));
TYPE_KYMC7_16 = ((7 shl 3) or (2) or (1 shl 10));
TYPE_KYMC7_16_SE = ((7 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYK8_8 = ((8 shl 3) or (1));
TYPE_CMYK8_16 = ((8 shl 3) or (2));
TYPE_CMYK8_16_SE = ((8 shl 3) or (2) or (1 shl 11));
TYPE_KYMC8_8 = ((8 shl 3) or (1) or (1 shl 10));
TYPE_KYMC8_16 = ((8 shl 3) or (2) or (1 shl 10));
TYPE_KYMC8_16_SE = ((8 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYK9_8 = ((9 shl 3) or (1));
TYPE_CMYK9_16 = ((9 shl 3) or (2));
TYPE_CMYK9_16_SE = ((9 shl 3) or (2) or (1 shl 11));
TYPE_KYMC9_8 = ((9 shl 3) or (1) or (1 shl 10));
TYPE_KYMC9_16 = ((9 shl 3) or (2) or (1 shl 10));
TYPE_KYMC9_16_SE = ((9 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYK10_8 = ((10 shl 3) or (1));
TYPE_CMYK10_16 = ((10 shl 3) or (2));
TYPE_CMYK10_16_SE = ((10 shl 3) or (2) or (1 shl 11));
TYPE_KYMC10_8 = ((10 shl 3) or (1) or (1 shl 10));
TYPE_KYMC10_16 = ((10 shl 3) or (2) or (1 shl 10));
TYPE_KYMC10_16_SE = ((10 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYK11_8 = ((11 shl 3) or (1));
TYPE_CMYK11_16 = ((11 shl 3) or (2));
TYPE_CMYK11_16_SE = ((11 shl 3) or (2) or (1 shl 11));
TYPE_KYMC11_8 = ((11 shl 3) or (1) or (1 shl 10));
TYPE_KYMC11_16 = ((11 shl 3) or (2) or (1 shl 10));
TYPE_KYMC11_16_SE = ((11 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_CMYK12_8 = ((12 shl 3) or (1));
TYPE_CMYK12_16 = ((12 shl 3) or (2));
TYPE_CMYK12_16_SE = ((12 shl 3) or (2) or (1 shl 11));
TYPE_KYMC12_8 = ((12 shl 3) or (1) or (1 shl 10));
TYPE_KYMC12_16 = ((12 shl 3) or (2) or (1 shl 10));
TYPE_KYMC12_16_SE = ((12 shl 3) or (2) or (1 shl 10) or (1 shl 11));
TYPE_XYZ_16 = ((PT_XYZ shl 16) or (3 shl 3) or (2));
TYPE_Lab_8 = ((PT_Lab shl 16) or (3 shl 3) or (1));
TYPE_ALab_8 = ((PT_Lab shl 16) or (3 shl 3) or (1) or (1 shl 7) or (1 shl 10));
TYPE_Lab_16 = ((PT_Lab shl 16) or (3 shl 3) or (2));
TYPE_Yxy_16 = ((PT_Yxy shl 16) or (3 shl 3) or (2));
TYPE_YCbCr_8 = ((PT_YCbCr shl 16) or (3 shl 3) or (1));
TYPE_YCbCr_8_PLANAR = ((PT_YCbCr shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_YCbCr_16 = ((PT_YCbCr shl 16) or (3 shl 3) or (2));
TYPE_YCbCr_16_PLANAR = ((PT_YCbCr shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_YCbCr_16_SE = ((PT_YCbCr shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_YUV_8 = ((PT_YUV shl 16) or (3 shl 3) or (1));
TYPE_YUV_8_PLANAR = ((PT_YUV shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_YUV_16 = ((PT_YUV shl 16) or (3 shl 3) or (2));
TYPE_YUV_16_PLANAR = ((PT_YUV shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_YUV_16_SE = ((PT_YUV shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_HLS_8 = ((PT_HLS shl 16) or (3 shl 3) or (1));
TYPE_HLS_8_PLANAR = ((PT_HLS shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_HLS_16 = ((PT_HLS shl 16) or (3 shl 3) or (2));
TYPE_HLS_16_PLANAR = ((PT_HLS shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_HLS_16_SE = ((PT_HLS shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_HSV_8 = ((PT_HSV shl 16) or (3 shl 3) or (1));
TYPE_HSV_8_PLANAR = ((PT_HSV shl 16) or (3 shl 3) or (1) or (1 shl 12));
TYPE_HSV_16 = ((PT_HSV shl 16) or (3 shl 3) or (2));
TYPE_HSV_16_PLANAR = ((PT_HSV shl 16) or (3 shl 3) or (2) or (1 shl 12));
TYPE_HSV_16_SE = ((PT_HSV shl 16) or (3 shl 3) or (2) or (1 shl 11));
TYPE_NAMED_COLOR_INDEX = ((1 shl 3) or (2));
TYPE_XYZ_DBL = ((PT_XYZ shl 16) or (3 shl 3) or (0));
TYPE_Lab_DBL = ((PT_Lab shl 16) or (3 shl 3) or (0));
TYPE_GRAY_DBL = ((PT_GRAY shl 16) or (1 shl 3) or (0));
TYPE_RGB_DBL = ((PT_RGB shl 16) or (3 shl 3) or (0));
TYPE_CMYK_DBL = ((PT_CMYK shl 16) or (4 shl 3) or (0));
// Intents
INTENT_PERCEPTUAL = 0;
INTENT_RELATIVE_COLORIMETRIC = 1;
INTENT_SATURATION = 2;
INTENT_ABSOLUTE_COLORIMETRIC = 3;
cmsFLAGS_NOTPRECALC = $0100;
cmsFLAGS_NULLTRANSFORM = $0200; // Don't transform anyway
cmsFLAGS_HIGHRESPRECALC = $0400; // Use more memory to give better accurancy
cmsFLAGS_LOWRESPRECALC = $0800; // Use less memory to minimize resouces
function IEcmsOpenProfileFromFile(stream: TStream; save: boolean; save8bit: boolean): cmsHPROFILE;
function IEcmsCreateTransform(Input: cmsHPROFILE; InputFormat: DWORD; Output: cmsHPROFILE; OutputFormat: DWORD; Intent: integer; dwFlags: DWORD): cmsHTRANSFORM;
function IEcmsCloseProfile(hProfile: cmsHPROFILE): longbool;
procedure IEcmsDeleteTransform(hTransform: cmsHTRANSFORM);
procedure IEcmsDoTransform(Transform: cmsHTRANSFORM; InputBuffer: pointer; OutputBuffer: pointer; Size: dword);
function IEcmsCreate_sRGBProfile: cmsHPROFILE;
function IEcmsCreateLabProfile(WhitePoint_x, WhitePoint_y, WhitePoint_Y_: double): cmsHPROFILE;
function IEcmsCreateLabProfileD50: cmsHPROFILE;
function IEcmsCreateXYZProfile: cmsHPROFILE;
function IEcmsWhitePointFromTemp(TempK: integer; var WhitePoint_x, WhitePoint_y, WhitePoint_Y_: double): boolean;
implementation
uses
math, hyieutils;
{$WARNINGS OFF}
var
UsedSpace: integer;
const
MAX_TABLE_TAG = 50;
D50X = (0.9642);
D50Y = (1.0);
D50Z = (0.8249);
icMagicNumber = $61637370; // 'acsp' */
icVersionNumber = $02100000; // 2.1.0, BCD */
icSigChromaticAdaptationTag = $63686164; // 'chad'
VX = 0;
VY = 1;
VZ = 2;
MAXCHANNELS = 16;
LUT_V4_OUTPUT_EMULATE_V2 = $10000; // Is a V4 output LUT, emulating V2
LUT_V4_INPUT_EMULATE_V2 = $20000; // Is a V4 input LUT, emulating V2
LUT_V2_OUTPUT_EMULATE_V4 = $40000; // Is a V2 output LUT, emulating V4
LUT_V2_INPUT_EMULATE_V4 = $80000; // Is a V2 input LUT, emulating V4
// LUT handling
LUT_HASMATRIX = $0001;
LUT_HASTL1 = $0002;
LUT_HASTL2 = $0008;
LUT_HAS3DGRID = $0010;
LUT_HASMATRIX3 = $0020; // Matrix + offset for LutAToB
LUT_HASMATRIX4 = $0040; // Matrix + offset for LutBToA
LUT_HASTL3 = $0100; // '3' curves for LutAToB
LUT_HASTL4 = $0200; // '4' curves for LutBToA
AlarmR: WORD = $8FFF;
AlarmG: WORD = $8FFF;
AlarmB: WORD = $8FFF;
icSigLuvKData = $4C75764B; // 'LuvK'
icSigHexachromeData = $4D434836; // MCH6
icSigHeptachromeData = $4D434837; // MCH7
icSigOctachromeData = $4D434838; // MCH8
icSiglutAtoBType = $6D414220; // mAB
icSiglutBtoAType = $6D424120; // mBA
icSigParametricCurveType = $70617261; // parametric (ICC 4.0)
cmsFLAGS_NOTCACHE = $0040; // Inhibit 1-pixel cache
XYZRel = 0;
LabRel = 1;
cmsFLAGS_GAMUTCHECK = $1000; // Out of Gamut alarm
cmsFLAGS_SOFTPROOFING = $4000; // Do softproofing
icSigChromaticityTag = $6368726D; // As per Addendum 2 to Spec. ICC.1:1998-09
lcmsSignature = $6C636D73;
icSigChromaticityType = $6368726D;
SAMPLER_HASTL1 = LUT_HASTL1;
SAMPLER_HASTL2 = LUT_HASTL2;
SAMPLER_INSPECT = $01000000;
ERR_THERESHOLD = 5;
cmsFLAGS_MATRIXINPUT = $0001;
cmsFLAGS_MATRIXOUTPUT = $0002;
MATSHAPER_INPUT = $0004;
MATSHAPER_OUTPUT = $0008;
MATSHAPER_HASINPSHAPER = $0010;
MATSHAPER_ALLSMELTED = (MATSHAPER_INPUT or MATSHAPER_OUTPUT);
MATSHAPER_HASMATRIX = $0001;
MATSHAPER_HASSHAPER = $0002;
icReflective = $00000000; // Bit pos 0 */
icTransparency = $00000001; // Bit pos 0 */
icGlossy = $00000000; // Bit pos 1 */
icMatte = $00000002; // Bit pos 1 */
LCMS_BPFLAGS_D50_ADAPTED = $0001;
PERCEPTUAL_BLACK_X = (0.00336);
PERCEPTUAL_BLACK_Y = (0.0034731);
PERCEPTUAL_BLACK_Z = (0.00287);
LCMS_USED_AS_INPUT = 0;
LCMS_USED_AS_OUTPUT = 1;
LCMS_USED_AS_PROOF = 2;
cmsFLAGS_WHITEBLACKCOMPENSATION = $2000;
cmsFLAGS_BLACKPOINTCOMPENSATION = cmsFLAGS_WHITEBLACKCOMPENSATION;
cmsFLAGS_NOPRELINEARIZATION = $0010;
type
icUInt32Number = dword;
icInt32Number = integer;
icSignature = integer;
icUInt16Number = word;
icInt8Number = shortint;
icUInt8Number = byte;
icUInt64Number = array[0..1] of dword;
icS15Fixed16Number = icInt32Number;
Fixed32 = icInt32Number;
type
icProfileClassSignature = integer;
const
icSigInputClass = $73636E72; (* 'scnr' *)
icSigDisplayClass = $6D6E7472; (* 'mntr' *)
icSigOutputClass = $70727472; (* 'prtr' *)
icSigLinkClass = $6C696E6B; (* 'link' *)
icSigAbstractClass = $61627374; (* 'abst' *)
icSigColorSpaceClass = $73706163; (* 'spac' *)
icSigNamedColorClass = $6E6D636C; (* 'nmcl' *)
icMaxEnumClass = $FFFFFFFF;
type
icColorSpaceSignature = integer;
const
icSigXYZData = $58595A20; (* 'XYZ ' *)
icSigLabData = $4C616220; (* 'Lab ' *)
icSigLuvData = $4C757620; (* 'Luv ' *)
icSigYCbCrData = $59436272; (* 'YCbr' *)
icSigYxyData = $59787920; (* 'Yxy ' *)
icSigRgbData = $52474220; (* 'RGB ' *)
icSigGrayData = $47524159; (* 'GRAY' *)
icSigHsvData = $48535620; (* 'HSV ' *)
icSigHlsData = $484C5320; (* 'HLS ' *)
icSigCmykData = $434D594B; (* 'CMYK' *)
icSigCmyData = $434D5920; (* 'CMY ' *)
icSig2colorData = $32434C52; (* '2CLR' *)
icSig3colorData = $33434C52; (* '3CLR' *)
icSig4colorData = $34434C52; (* '4CLR' *)
icSig5colorData = $35434C52; (* '5CLR' *)
icSig6colorData = $36434C52; (* '6CLR' *)
icSig7colorData = $37434C52; (* '7CLR' *)
icSig8colorData = $38434C52; (* '8CLR' *)
icSig9colorData = $39434C52; (* '9CLR' *)
icSig10colorData = $41434C52; (* 'ACLR' *)
icSig11colorData = $42434C52; (* 'BCLR' *)
icSig12colorData = $43434C52; (* 'CCLR' *)
icSig13colorData = $44434C52; (* 'DCLR' *)
icSig14colorData = $45434C52; (* 'ECLR' *)
icSig15colorData = $46434C52; (* 'FCLR' *)
icMaxEnumData = $FFFFFFFF;
type
icTagSignature = integer;
const
icSigAToB0Tag = $41324230; (* 'A2B0' *)
icSigAToB1Tag = $41324231; (* 'A2B1' *)
icSigAToB2Tag = $41324232; (* 'A2B2' *)
icSigBlueColorantTag = $6258595A; (* 'bXYZ' *)
icSigBlueTRCTag = $62545243; (* 'bTRC' *)
icSigBToA0Tag = $42324130; (* 'B2A0' *)
icSigBToA1Tag = $42324131; (* 'B2A1' *)
icSigBToA2Tag = $42324132; (* 'B2A2' *)
icSigCalibrationDateTimeTag = $63616C74; (* 'calt' *)
icSigCharTargetTag = $74617267; (* 'targ' *)
icSigCopyrightTag = $63707274; (* 'cprt' *)
icSigCrdInfoTag = $63726469; (* 'crdi' *)
icSigDeviceMfgDescTag = $646D6E64; (* 'dmnd' *)
icSigDeviceModelDescTag = $646D6464; (* 'dmdd' *)
icSigGamutTag = $67616D74; (* 'gamt ' *)
icSigGrayTRCTag = $6B545243; (* 'kTRC' *)
icSigGreenColorantTag = $6758595A; (* 'gXYZ' *)
icSigGreenTRCTag = $67545243; (* 'gTRC' *)
icSigLuminanceTag = $6C756D69; (* 'lumi' *)
icSigMeasurementTag = $6D656173; (* 'meas' *)
icSigMediaBlackPointTag = $626B7074; (* 'bkpt' *)
icSigMediaWhitePointTag = $77747074; (* 'wtpt' *)
icSigNamedColorTag = $6E636F6C; (* 'ncol'
* OBSOLETE, use ncl2 *)
icSigNamedColor2Tag = $6E636C32; (* 'ncl2' *)
icSigPreview0Tag = $70726530; (* 'pre0' *)
icSigPreview1Tag = $70726531; (* 'pre1' *)
icSigPreview2Tag = $70726532; (* 'pre2' *)
icSigProfileDescriptionTag = $64657363; (* 'desc' *)
icSigProfileSequenceDescTag = $70736571; (* 'pseq' *)
icSigPs2CRD0Tag = $70736430; (* 'psd0' *)
icSigPs2CRD1Tag = $70736431; (* 'psd1' *)
icSigPs2CRD2Tag = $70736432; (* 'psd2' *)
icSigPs2CRD3Tag = $70736433; (* 'psd3' *)
icSigPs2CSATag = $70733273; (* 'ps2s' *)
icSigPs2RenderingIntentTag = $70733269; (* 'ps2i' *)
icSigRedColorantTag = $7258595A; (* 'rXYZ' *)
icSigRedTRCTag = $72545243; (* 'rTRC' *)
icSigScreeningDescTag = $73637264; (* 'scrd' *)
icSigScreeningTag = $7363726E; (* 'scrn' *)
icSigTechnologyTag = $74656368; (* 'tech' *)
icSigUcrBgTag = $62666420; (* 'bfd ' *)
icSigViewingCondDescTag = $76756564; (* 'vued' *)
icSigViewingConditionsTag = $76696577; (* 'view' *)
icMaxEnumTag = $FFFFFFFF;
type
PicTagSignature = ^icTagSignature;
icRenderingIntent = integer;
const
icPerceptual = 0;
icRelativeColorimetric = 1;
icSaturation = 2;
icAbsoluteColorimetric = 3;
icMaxEnumIntent = $FFFFFFFF;
type
icPlatformSignature = integer;
const
icSigMacintosh = $4150504C; // 'APPL' */
icSigMicrosoft = $4D534654; // 'MSFT' */
icSigSolaris = $53554E57; // 'SUNW' */
icSigSGI = $53474920; // 'SGI ' */
icSigTaligent = $54474E54; // 'TGNT' */
icMaxEnumPlatform = $FFFFFFFF;
type
icTagTypeSignature = integer;
const
icSigCurveType = $63757276; // 'curv' */
icSigDataType = $64617461; // 'data' */
icSigDateTimeType = $6474696D; // 'dtim' */
icSigLut16Type = $6D667432; // 'mft2' */
icSigLut8Type = $6D667431; // 'mft1' */
icSigMeasurementType = $6D656173; // 'meas' */
icSigNamedColorType = $6E636F6C; // 'ncol'
//* OBSOLETE; use ncl2 */
icSigProfileSequenceDescType = $70736571; // 'pseq' */
icSigS15Fixed16ArrayType = $73663332; // 'sf32' */
icSigScreeningType = $7363726E; // 'scrn' */
icSigSignatureType = $73696720; // 'sig ' */
icSigTextType = $74657874; // 'text' */
icSigTextDescriptionType = $64657363; // 'desc' */
icSigU16Fixed16ArrayType = $75663332; // 'uf32' */
icSigUcrBgType = $62666420; // 'bfd ' */
icSigUInt16ArrayType = $75693136; // 'ui16' */
icSigUInt32ArrayType = $75693332; // 'ui32' */
icSigUInt64ArrayType = $75693634; // 'ui64' */
icSigUInt8ArrayType = $75693038; // 'ui08' */
icSigViewingConditionsType = $76696577; // 'view' */
icSigXYZType = $58595A20; // 'XYZ ' */
icSigXYZArrayType = $58595A20; // 'XYZ ' */
icSigNamedColor2Type = $6E636C32; // 'ncl2' */
icSigCrdInfoType = $63726469; // 'crdi' */
icMaxEnumType = $FFFFFFFF;
// technology signature descriptions */
type
icTechnologySignature = integer;
const
icSigDigitalCamera = $6463616D; // 'dcam' */
icSigFilmScanner = $6673636E; // 'fscn' */
icSigReflectiveScanner = $7273636E; // 'rscn' */
icSigInkJetPrinter = $696A6574; // 'ijet' */
icSigThermalWaxPrinter = $74776178; // 'twax' */
icSigElectrophotographicPrinter = $6570686F; // 'epho' */
icSigElectrostaticPrinter = $65737461; // 'esta' */
icSigDyeSublimationPrinter = $64737562; // 'dsub' */
icSigPhotographicPaperPrinter = $7270686F; // 'rpho' */
icSigFilmWriter = $6670726E; // 'fprn' */
icSigVideoMonitor = $7669646D; // 'vidm' */
icSigVideoCamera = $76696463; // 'vidc' */
icSigProjectionTelevision = $706A7476; // 'pjtv' */
icSigCRTDisplay = $43525420; // 'CRT ' */
icSigPMDisplay = $504D4420; // 'PMD ' */
icSigAMDisplay = $414D4420; // 'AMD ' */
icSigPhotoCD = $4B504344; // 'KPCD' */
icSigPhotoImageSetter = $696D6773; // 'imgs' */
icSigGravure = $67726176; // 'grav' */
icSigOffsetLithography = $6F666673; // 'offs' */
icSigSilkscreen = $73696C6B; // 'silk' */
icSigFlexography = $666C6578; // 'flex' */
icMaxEnumTechnology = $FFFFFFFF;
type
cmsCIEXYZ = packed record
X: double;
Y: double;
Z: double;
end;
LPcmsCIEXYZ = ^cmsCIEXYZ;
VEC3 = packed record
n: array[0..2] of double;
end;
LPVEC3 = ^VEC3;
MAT3 = packed record
v: array[0..2] of VEC3;
end;
LPMAT3 = ^MAT3;
icTag = packed record
sig: icTagSignature;
offset: icUInt32Number;
size: icUInt32Number;
end;
icDateTimeNumber = packed record
year: icUInt16Number;
month: icUInt16Number;
day: icUInt16Number;
hours: icUInt16Number;
minutes: icUInt16Number;
seconds: icUInt16Number;
end;
PicDateTimeNumber = ^icDateTimeNumber;
icXYZNumber = packed record
X: icS15Fixed16Number;
Y: icS15Fixed16Number;
Z: icS15Fixed16Number;
end;
icHeader = packed record
size: icUInt32Number;
cmmId: icSignature;
version: icUInt32Number;
deviceClass: icProfileClassSignature;
colorSpace: icColorSpaceSignature;
pcs: icColorSpaceSignature;
date: icDateTimeNumber;
magic: icSignature;
xplatform: icPlatformSignature;
flags: icUInt32Number;
manufacturer: icSignature;
model: icUInt32Number;
attributes: icUInt64Number;
renderingIntent: icUInt32Number;
illuminant: icXYZNumber;
creator: icSignature;
reserved: array[0..43] of icInt8Number;
end;
TReadFunction = function(buffer: pointer; size: integer; count: integer; stream: TStream): integer;
TSeekFunction = function(stream: TStream; offset: int64): longbool;
TCloseFunction = function(stream: TStream): longbool;
TTellFunction = function(stream: TStream): int64;
TWriteFunction = function(stream: TStream; size: integer; Ptr: pointer): longbool;
LCMSICCPROFILE = packed record
stream: TStream;
DeviceClass: icProfileClassSignature;
ColorSpace: icColorSpaceSignature;
PCS: icColorSpaceSignature;
RenderingIntent: icRenderingIntent;
flags: icUInt32Number;
Illuminant: cmsCIEXYZ;
Version: icUInt32Number;
ChromaticAdaptation: MAT3;
MediaWhitePoint: cmsCIEXYZ;
MediaBlackPoint: cmsCIEXYZ;
ProfileID: array[0..15] of BYTE;
TagCount: icInt32Number;
TagNames: array[0..MAX_TABLE_TAG - 1] of icTagSignature;
TagSizes: array[0..MAX_TABLE_TAG - 1] of integer;
TagOffsets: array[0..MAX_TABLE_TAG - 1] of integer;
TagPtrs: array[0..MAX_TABLE_TAG - 1] of pointer;
PhysicalFile: TStream;
IsWrite: longbool;
SaveAs8Bits: longbool;
Read: TReadFunction;
Seek: TSeekFunction;
Close: TCloseFunction;
Tell: TTellFunction;
Write: TWriteFunction;
end;
LPLCMSICCPROFILE = ^LCMSICCPROFILE;
icTagBase = packed record
sig: icTagTypeSignature; // Signature */
reserved: array[0..3] of icInt8Number; // Reserved, set to 0 */
end;
WVEC3 = packed record
n: array[0..2] of Fixed32;
end;
LPWVEC3 = ^WVEC3;
WMAT3 = packed record
v: array[0..2] of WVEC3;
end;
LPWMAT3 = ^WMAT3;
_LPcmsTRANSFORM = ^_cmsTRANSFORM;
_cmsCOLORCALLBACKFN = procedure(Transform: _LPcmsTRANSFORM;
InputBuffer: pointer;
OutputBuffer: pointer; Size: dword);
_cmsFIXFN = function(info: _LPcmsTRANSFORM; ToUnroll: pwordarray; Buffer: pbyte): pbyte;
_cmsTRANSFN = procedure(Transform: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray);
_cmsADJFN = procedure(xIn: pwordarray; xOut: pwordarray; m: LPWMAT3; b: LPWVEC3);
LPLUT = ^LUT;
LPL16PARAMS = ^L16PARAMS;
_cms3DLERP = procedure(Input: pwordarray; Output: pwordarray; LutTable: pwordarray; p: LPL16PARAMS);
//_lcms_l8opt_struc
L8PARAMS = packed record
X0, Y0, Z0: array[0..255] of dword;
rx, ry, rz: array[0..255] of word;
end;
LPL8PARAMS = ^L8PARAMS;
// _lcms_l16params_struc
L16PARAMS = packed record
nSamples: integer;
nInputs: integer;
nOutputs: integer;
Domain: WORD;
opta1, opta2: integer;
opta3, opta4: integer;
opta5, opta6: integer;
opta7, opta8: integer;
Interp3D: _cms3DLERP;
p8: LPL8PARAMS;
end;
//struct _lcms_LUT_struc
LUT = packed record
wFlags: DWORD;
Matrix: WMAT3;
InputChan: dword;
OutputChan: dword;
InputEntries: dword;
OutputEntries: dword;
cLutPoints: dword;
L1: array[0..MAXCHANNELS - 1] of PWORD;
L2: array[0..MAXCHANNELS - 1] of PWORD;
T: PWORD;
Tsize: integer;
In16params: L16PARAMS;
Out16params: L16PARAMS;
CLut16params: L16PARAMS;
Intent: integer;
Mat3: WMAT3;
Ofs3: WVEC3;
L3: array[0..MAXCHANNELS - 1] of PWORD;
L3params: L16PARAMS;
L3Entries: dword;
Mat4: WMAT3;
Ofs4: WVEC3;
L4: array[0..MAXCHANNELS - 1] of PWORD;
L4params: L16PARAMS;
L4Entries: dword;
end;
MATSHAPER = packed record
dwFlags: DWORD;
Matrix: WMAT3;
p16: L16PARAMS;
L: array[0..2] of PWORD;
p2_16: L16PARAMS;
L2: array[0..2] of PWORD;
end;
LPMATSHAPER = ^MATSHAPER;
cmsNAMEDCOLOR = packed record
Name: array[0..MAX_PATH - 1] of AnsiChar;
PCS: array[0..2] of WORD;
DeviceColorant: array[0..MAXCHANNELS - 1] of WORD;
end;
LPcmsNAMEDCOLOR = ^cmsNAMEDCOLOR;
cmsNAMEDCOLORLIST = packed record
nColors: integer;
Allocated: integer;
ColorantCount: integer;
Prefix: array[0..32] of AnsiChar;
Suffix: array[0..32] of AnsiChar;
List: array[0..0] of cmsNAMEDCOLOR;
end;
LPcmsNAMEDCOLORLIST = ^cmsNAMEDCOLORLIST;
// Transformation
_cmsTRANSFORM = packed record
InputFormat, OutputFormat: DWORD;
StrideIn, StrideOut: DWORD;
Intent, ProofIntent: integer;
DoGamutCheck: integer;
InputProfile: cmsHPROFILE;
OutputProfile: cmsHPROFILE;
PreviewProfile: cmsHPROFILE;
EntryColorSpace: icColorSpaceSignature;
ExitColorSpace: icColorSpaceSignature;
m1, m2: WMAT3;
of1, of2: WVEC3;
xform: _cmsCOLORCALLBACKFN;
FromInput: _cmsFIXFN;
FromDevice: _cmsTRANSFN;
Stage1: _cmsADJFN;
Stage2: _cmsADJFN;
ToDevice: _cmsTRANSFN;
ToOutput: _cmsFIXFN;
Device2PCS: LPLUT;
PCS2Device: LPLUT;
Gamut: LPLUT;
Preview: LPLUT;
DeviceLink: LPLUT;
InMatShaper: LPMATSHAPER;
OutMatShaper: LPMATSHAPER;
SmeltMatShaper: LPMATSHAPER;
Phase1, Phase2, Phase3: integer;
NamedColorList: LPcmsNAMEDCOLORLIST;
lInputV4Lab, lOutputV4Lab: longbool;
CacheIn: array[0..MAXCHANNELS - 1] of word;
CacheOut: array[0..MAXCHANNELS - 1] of word;
end;
_cmstransform_struct = _cmsTRANSFORM;
P_cmstransform_struct = ^_cmstransform_struct;
cmsCIELab = packed record
L: double;
a: double;
b: double;
end;
LPcmsCIELab = ^cmsCIELab;
// lut8, input & output tables are always 256 bytes in length */
icLut8 = packed record
inputChan: icUInt8Number; // Num of input channels */
outputChan: icUInt8Number; // Num of output channels */
clutPoints: icUInt8Number; // Num of grid points */
pad: icInt8Number;
e00: icS15Fixed16Number; // e00 in the 3 * 3 */
e01: icS15Fixed16Number; // e01 in the 3 * 3 */
e02: icS15Fixed16Number; // e02 in the 3 * 3 */
e10: icS15Fixed16Number; // e10 in the 3 * 3 */
e11: icS15Fixed16Number; // e11 in the 3 * 3 */
e12: icS15Fixed16Number; // e12 in the 3 * 3 */
e20: icS15Fixed16Number; // e20 in the 3 * 3 */
e21: icS15Fixed16Number; // e21 in the 3 * 3 */
e22: icS15Fixed16Number; // e22 in the 3 * 3 */
data: array[0..0] of icUInt8Number; // Data follows see spec */
(*
* Data that follows is of this form
*
* icUInt8Number inputTable[inputChan][256]; * The in-table
* icUInt8Number clutTable[icAny]; * The clut
* icUInt8Number outputTable[outputChan][256]; * The out-table
*)
end;
_cmsTestAlign8 = packed record
a: icS15Fixed16Number;
b: icUInt8Number;
end;
// lut16 */
icLut16 = packed record
inputChan: icUInt8Number; // Number of input channels */
outputChan: icUInt8Number; // Number of output channels */
clutPoints: icUInt8Number; // Number of grid points */
pad: icInt8Number; // Padding for byte alignment */
e00: icS15Fixed16Number; // e00 in the 3 * 3 */
e01: icS15Fixed16Number; // e01 in the 3 * 3 */
e02: icS15Fixed16Number; // e02 in the 3 * 3 */
e10: icS15Fixed16Number; // e10 in the 3 * 3 */
e11: icS15Fixed16Number; // e11 in the 3 * 3 */
e12: icS15Fixed16Number; // e12 in the 3 * 3 */
e20: icS15Fixed16Number; // e20 in the 3 * 3 */
e21: icS15Fixed16Number; // e21 in the 3 * 3 */
e22: icS15Fixed16Number; // e22 in the 3 * 3 */
inputEnt: icUInt16Number; // Num of in-table entries */
outputEnt: icUInt16Number; // Num of out-table entries */
data: array[0..0] of icUInt16Number; // Data follows see spec */
(*
* Data that follows is of this form
*
* 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 AnsiChar;
Model: array[0..511] of AnsiChar;
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;
TagCount, i: icInt32Number;
begin
result := nil;
Icc := ICCAllocStruct(Read, Seek, Tell, Close);
if (Icc = nil) then
begin
result := nil;
exit;
end;
Icc^.stream := ICCfile;
Icc^.Read(@Header, sizeof(icHeader), 1, ICCfile);
AdjustEndianess32(@Header.size);
AdjustEndianess32(@Header.cmmId);
AdjustEndianess32(@Header.version);
AdjustEndianess32(@Header.deviceClass);
AdjustEndianess32(@Header.colorSpace);
AdjustEndianess32(@Header.pcs);
AdjustEndianess32(@Header.magic);
AdjustEndianess32(@Header.flags);
AdjustEndianess32(@Header.renderingIntent);
try
if (Header.magic <> icMagicNumber) then
exit;
if (Icc^.Read(@TagCount, sizeof(icInt32Number), 1, ICCfile) <> 1) then
exit;
AdjustEndianess32(@TagCount);
Icc^.DeviceClass := Header.deviceClass;
Icc^.ColorSpace := Header.colorSpace;
Icc^.PCS := Header.pcs;
Icc^.RenderingIntent := icRenderingIntent(Header.renderingIntent);
Icc^.flags := Header.flags;
Icc^.Illuminant.X := Convert15Fixed16(Header.illuminant.X);
Icc^.Illuminant.Y := Convert15Fixed16(Header.illuminant.Y);
Icc^.Illuminant.Z := Convert15Fixed16(Header.illuminant.Z);
Icc^.Version := Header.version;
Icc^.Illuminant := cmsD50_XYZ^;
CopyMemory(@Icc^.ProfileID[0], @Header.reserved[0], 16);
NormalizeXYZ(@Icc^.Illuminant);
Icc^.TagCount := TagCount;
for i := 0 to TagCount - 1 do
begin
Icc^.Read(@Tag, sizeof(icTag), 1, ICCfile);
AdjustEndianess32(@Tag.offset);
AdjustEndianess32(@Tag.size);
AdjustEndianess32(@Tag.sig);
Icc^.TagNames[i] := Tag.sig;
Icc^.TagOffsets[i] := Tag.offset;
Icc^.TagSizes[i] := Tag.size;
end;
result := Icc;
finally
if result = nil then
begin
Icc^.Close(ICCfile);
freemem(Icc);
end;
end;
end;
// Does search for a specific tag in tag dictionary
// Returns position or -1 if tag not found
function SearchTag(Profile: LPLCMSICCPROFILE; sig: icTagSignature): icInt32Number;
var
i: icInt32Number;
begin
if (integer(sig) = 0) then
begin
result := -1;
exit;
end;
for i := 0 to Profile^.TagCount - 1 do
begin
if (sig = Profile^.TagNames[i]) then
begin
result := i;
exit;
end;
end;
result := -1;
end;
function ReadICCXYZ(hProfile: cmsHPROFILE; sig: icTagSignature; Value: LPcmsCIEXYZ; lIsFatal: longbool): integer;
var
Icc: LPLCMSICCPROFILE;
Base: icTagBase;
offset: integer;
n: integer;
XYZ: icXYZNumber;
begin
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
result := -1;
exit;
end;
if (Icc^.stream = nil) then
begin
CopyMemory(Value, Icc^.TagPtrs[n], Icc^.TagSizes[n]);
result := Icc^.TagSizes[n];
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := -1;
exit;
end;
Icc^.Read(@Base, 1, sizeof(icTagBase), Icc^.stream);
AdjustEndianess32(@Base.sig);
case Base.sig of
icTagTypeSignature($7C3B10C),
icSigXYZType:
begin
Icc^.Read(@XYZ, sizeof(icXYZNumber), 1, Icc^.stream);
Value^.X := Convert15Fixed16(XYZ.X);
Value^.Y := Convert15Fixed16(XYZ.Y);
Value^.Z := Convert15Fixed16(XYZ.Z);
end;
else
if (lIsFatal) then
begin
result := -1;
exit;
end;
end;
result := 1;
end;
// Read a icSigS15Fixed16ArrayType (currently only a 3x3 matrix)
function ReadICCXYZArray(hProfile: cmsHPROFILE; sig: icTagSignature; v: LPMAT3): integer;
var
Icc: LPLCMSICCPROFILE;
Base: icTagBase;
offset, sz: integer;
i, n: integer;
XYZ: array[0..2] of icXYZNumber;
XYZdbl: array[0..2] of cmsCIEXYZ;
begin
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
result := -1;
exit;
end;
if (Icc^.stream = nil) then
begin
CopyMemory(v, Icc^.TagPtrs[n], Icc^.TagSizes[n]);
result := Icc^.TagSizes[n];
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := -1;
exit;
end;
Icc^.Read(@Base, 1, sizeof(icTagBase), Icc^.stream);
AdjustEndianess32(@Base.sig);
case (Base.sig) of
icSigS15Fixed16ArrayType:
begin
sz := Icc^.TagSizes[n] div sizeof(icXYZNumber);
if (sz <> 3) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Bad array size of %d entries.", sz);
result := -1;
exit;
end;
Icc^.Read(@XYZ[0], sizeof(icXYZNumber), 3, Icc^.stream);
for i := 0 to 2 do
begin
XYZdbl[i].X := Convert15Fixed16(XYZ[i].X);
XYZdbl[i].Y := Convert15Fixed16(XYZ[i].Y);
XYZdbl[i].Z := Convert15Fixed16(XYZ[i].Z);
end;
CopyMemory(v, @XYZdbl[0], 3 * sizeof(cmsCIEXYZ));
end;
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Bad tag signature %lx found.", Base.sig);
result := -1;
exit;
end;
end;
result := sizeof(MAT3);
end;
// linear transform
procedure MAT3eval(r: LPVEC3; a: LPMAT3; v: LPVEC3);
begin
r^.n[VX] := a^.v[0].n[VX] * v^.n[VX] + a^.v[0].n[VY] * v^.n[VY] + a^.v[0].n[VZ] * v^.n[VZ];
r^.n[VY] := a^.v[1].n[VX] * v^.n[VX] + a^.v[1].n[VY] * v^.n[VY] + a^.v[1].n[VZ] * v^.n[VZ];
r^.n[VZ] := a^.v[2].n[VX] * v^.n[VX] + a^.v[2].n[VY] * v^.n[VY] + a^.v[2].n[VZ] * v^.n[VZ];
end;
// Evaluates a XYZ tristimulous across chromatic adaptation matrix
procedure EvalCHRM(Dest: LPcmsCIEXYZ; Chrm: LPMAT3; Src: LPcmsCIEXYZ);
var
d, s: VEC3;
begin
s.n[VX] := Src^.X;
s.n[VY] := Src^.Y;
s.n[VZ] := Src^.Z;
MAT3eval(@d, Chrm, @s);
Dest^.X := d.n[VX];
Dest^.Y := d.n[VY];
Dest^.Z := d.n[VZ];
end;
function ROWCOL(a, b: LPMAT3; i, j: integer): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := a^.v[i].n[0] * b^.v[0].n[j] + a^.v[i].n[1] * b^.v[1].n[j] + a^.v[i].n[2] * b^.v[2].n[j]
end;
// Multiply two matrices
procedure MAT3per(r: LPMAT3; a: LPMAT3; b: LPMAT3);
begin
VEC3init(@r^.v[0], ROWCOL(a, b, 0, 0), ROWCOL(a, b, 0, 1), ROWCOL(a, b, 0, 2));
VEC3init(@r^.v[1], ROWCOL(a, b, 1, 0), ROWCOL(a, b, 1, 1), ROWCOL(a, b, 1, 2));
VEC3init(@r^.v[2], ROWCOL(a, b, 2, 0), ROWCOL(a, b, 2, 1), ROWCOL(a, b, 2, 2));
(*
with a^.v[0] do
VEC3init(@r^.v[0], n[0] * b^.v[0].n[0] + n[1] * b^.v[1].n[0] + n[2] * b^.v[2].n[0],
n[0] * b^.v[0].n[1] + n[1] * b^.v[1].n[1] + n[2] * b^.v[2].n[1],
n[0] * b^.v[0].n[2] + n[1] * b^.v[1].n[2] + n[2] * b^.v[2].n[2]);
with a^.v[1] do
VEC3init(@r^.v[1], n[0] * b^.v[0].n[0] + n[1] * b^.v[1].n[0] + n[2] * b^.v[2].n[0],
n[0] * b^.v[0].n[1] + n[1] * b^.v[1].n[1] + n[2] * b^.v[2].n[1],
n[0] * b^.v[0].n[2] + n[1] * b^.v[1].n[2] + n[2] * b^.v[2].n[2]);
with a^.v[2] do
VEC3init(@r^.v[2], n[0] * b^.v[0].n[0] + n[1] * b^.v[1].n[0] + n[2] * b^.v[2].n[0],
n[0] * b^.v[0].n[1] + n[1] * b^.v[1].n[1] + n[2] * b^.v[2].n[1],
n[0] * b^.v[0].n[2] + n[1] * b^.v[1].n[2] + n[2] * b^.v[2].n[2]);
*)
end;
// Compute chromatic adaptation matrix using Chad as cone matrix
procedure ComputeChromaticAdaptation(Conversion: LPMAT3; SourceWhitePoint: LPcmsCIEXYZ; DestWhitePoint: LPcmsCIEXYZ; Chad: LPMAT3);
var
Chad_Inv: MAT3;
ConeSourceXYZ, ConeSourceRGB: VEC3;
ConeDestXYZ, ConeDestRGB: VEC3;
Cone, Tmp: MAT3;
begin
Tmp := Chad^;
MAT3inverse(@Tmp, @Chad_Inv);
VEC3init(@ConeSourceXYZ, SourceWhitePoint^.X,
SourceWhitePoint^.Y,
SourceWhitePoint^.Z);
VEC3init(@ConeDestXYZ, DestWhitePoint^.X,
DestWhitePoint^.Y,
DestWhitePoint^.Z);
MAT3eval(@ConeSourceRGB, Chad, @ConeSourceXYZ);
MAT3eval(@ConeDestRGB, Chad, @ConeDestXYZ);
VEC3init(@Cone.v[0], ConeDestRGB.n[0] / ConeSourceRGB.n[0], 0.0, 0.0);
VEC3init(@Cone.v[1], 0.0, ConeDestRGB.n[1] / ConeSourceRGB.n[1], 0.0);
VEC3init(@Cone.v[2], 0.0, 0.0, ConeDestRGB.n[2] / ConeSourceRGB.n[2]);
MAT3per(@Tmp, @Cone, Chad);
MAT3per(Conversion, @Chad_Inv, @Tmp);
end;
// Returns the final chrmatic adaptation from illuminant FromIll to Illuminant ToIll
// The cone matrix can be specified in ConeMatrix. If NULL, Bradford is assumed
function cmsAdaptationMatrix(r: LPMAT3; ConeMatrix: LPMAT3; FromIll: LPcmsCIEXYZ; ToIll: LPcmsCIEXYZ): longbool;
const
LamRigg: MAT3 = (
v: ((n: (0.8951, 0.2664, -0.1614)),
(n: (-0.7502, 1.7135, 0.0367)),
(n: (0.0389, -0.0685, 1.0296)))
);
begin
if (ConeMatrix = nil) then
ConeMatrix := @LamRigg;
ComputeChromaticAdaptation(r, FromIll, ToIll, ConeMatrix);
result := true;
end;
procedure ReadCriticalTags(Icc: LPLCMSICCPROFILE);
const
Brfd: MAT3 = (
v: ((n: (0.8951, 0.2664, -0.1614)),
(n: (-0.7502, 1.7135, 0.0367)),
(n: (0.0389, -0.0685, 1.0296)))
);
var
hProfile: cmsHPROFILE;
ChrmCanonical: MAT3;
begin
hProfile := cmsHPROFILE(Icc);
if (Icc^.Version >= $4000000) then
begin
if (ReadICCXYZ(hProfile, icSigMediaWhitePointTag, @Icc^.MediaWhitePoint, FALSE) < 0) then
begin
Icc^.MediaWhitePoint := cmsD50_XYZ()^;
end;
if (ReadICCXYZ(hProfile, icSigMediaBlackPointTag, @Icc^.MediaBlackPoint, FALSE) < 0) then
begin
Icc^.MediaBlackPoint.X := 0;
Icc^.MediaBlackPoint.Y := 0;
Icc^.MediaBlackPoint.X := 0;
end;
NormalizeXYZ(@Icc^.MediaWhitePoint);
NormalizeXYZ(@Icc^.MediaBlackPoint);
if (ReadICCXYZArray(hProfile, icTagSignature(icSigChromaticAdaptationTag), @ChrmCanonical) > 0) then
begin
MAT3inverse(@ChrmCanonical, @Icc^.ChromaticAdaptation);
end
else
begin
MAT3identity(@Icc^.ChromaticAdaptation);
end;
EvalCHRM(@Icc^.MediaWhitePoint, @Icc^.ChromaticAdaptation, @Icc^.MediaWhitePoint);
EvalCHRM(@Icc^.MediaBlackPoint, @Icc^.ChromaticAdaptation, @Icc^.MediaBlackPoint);
end
else
begin
if (ReadICCXYZ(hProfile, icSigMediaWhitePointTag, @Icc^.MediaWhitePoint, FALSE) < 0) then
begin
Icc^.MediaWhitePoint := cmsD50_XYZ()^;
end;
if (ReadICCXYZ(hProfile, icSigMediaBlackPointTag, @Icc^.MediaBlackPoint, FALSE) < 0) then
begin
Icc^.MediaBlackPoint.X := 0;
Icc^.MediaBlackPoint.Y := 0;
Icc^.MediaBlackPoint.X := 0;
end;
NormalizeXYZ(@Icc^.MediaWhitePoint);
NormalizeXYZ(@Icc^.MediaBlackPoint);
cmsAdaptationMatrix(@Icc^.ChromaticAdaptation, @Brfd, @Icc^.Illuminant, @Icc^.MediaWhitePoint);
end;
end;
// Create profile from disk file
function IEcmsOpenProfileFromFile(stream: TStream; save: boolean; save8bit: boolean): cmsHPROFILE;
var
NewIcc: LPLCMSICCPROFILE;
hEmpty: cmsHPROFILE;
begin
if save then
begin
hEmpty := _cmsCreateProfilePlaceholder();
NewIcc := LPLCMSICCPROFILE(hEmpty);
NewIcc^.IsWrite := TRUE;
NewIcc^.PhysicalFile := stream;
if save8bit then
NewIcc^.SaveAs8Bits := TRUE;
result := hEmpty;
exit;
end;
NewIcc := CreateICCProfileHandler(stream, IEFileRead, IEFileSeek, IEFileTell, IEFileClose);
if (NewIcc = nil) then
begin
result := nil;
exit;
end;
ReadCriticalTags(NewIcc);
NewIcc^.PhysicalFile := stream;
NewIcc^.IsWrite := FALSE;
result := cmsHPROFILE(NewIcc);
end;
// Auxiliary: allocate transform struct and set to defaults
function AllocEmptyTransform: _LPcmsTRANSFORM;
var
p: _LPcmsTRANSFORM;
begin
getmem(p, sizeof(_cmsTRANSFORM));
if (p = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "cmsCreateTransform: malloc() failed");
result := nil;
exit;
end;
ZeroMemory(p, sizeof(_cmsTRANSFORM));
p^.xform := nil;
p^.Intent := INTENT_PERCEPTUAL;
p^.ProofIntent := INTENT_ABSOLUTE_COLORIMETRIC;
p^.DoGamutCheck := 0;
p^.InputProfile := nil;
p^.OutputProfile := nil;
p^.PreviewProfile := nil;
p^.Preview := nil;
p^.Gamut := nil;
p^.DeviceLink := nil;
p^.InMatShaper := nil;
p^.OutMatShaper := nil;
p^.SmeltMatShaper := nil;
p^.NamedColorList := nil;
p^.EntryColorSpace := icColorSpaceSignature(0);
p^.ExitColorSpace := icColorSpaceSignature(0);
result := p;
end;
function _cmsEndPointsBySpace(Space: icColorSpaceSignature; var White: pword; var Black: pword; nOutputs: pinteger): longbool;
const
RGBblack: array[0..3] of word = (0, 0, 0, 0);
RGBwhite: array[0..3] of word = ($FFFF, $FFFF, $FFFF, 0);
CMYKblack: array[0..3] of word = ($FFFF, $FFFF, $FFFF, $FFFF);
CMYKwhite: array[0..3] of word = (0, 0, 0, 0);
LABblack: array[0..3] of word = (0, $8000, $8000, 0);
LABwhite: array[0..3] of word = ($FF00, $8000, $8000, 0);
CMYblack: array[0..3] of word = ($FFFF, $FFFF, $FFFF, 0);
CMYwhite: array[0..3] of word = (0, 0, 0, 0);
begin
case (Space) of
icSigRgbData:
begin
White := @RGBwhite;
Black := @RGBblack;
nOutputs^ := 3;
result := true;
exit;
end;
icSigLabData:
begin
White := @LABwhite;
Black := @LABblack;
nOutputs^ := 3;
result := true;
exit;
end;
icSigCmykData:
begin
White := @CMYKwhite;
Black := @CMYKblack;
nOutputs^ := 4;
result := true;
exit;
end;
icSigCmyData:
begin
White := @CMYwhite;
Black := @CMYblack;
nOutputs^ := 3;
result := true;
exit;
end;
end;
result := false;
end;
function _cmsWhiteBySpace(Space: icColorSpaceSignature): PWORD;
const
Default: array[0..MAXCHANNELS - 1] of word = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
var
White, Black: pword;
Dummy: integer;
begin
White := nil;
Black := nil;
if (_cmsEndPointsBySpace(Space, White, Black, @Dummy)) then
result := White
else
result := @Default;
end;
function cmsGetColorSpace(hProfile: cmsHPROFILE): icColorSpaceSignature;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := Icc^.ColorSpace;
end;
procedure COPY_3CHANS(xto, xfrom: pwordarray); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
xto[0] := xfrom[0];
xto[1] := xfrom[1];
xto[2] := xfrom[2];
end;
function FROM_V2_TO_V4(x: word): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((((x) shl 8) + (x)) + $80) shr 8);
end;
function FROM_V4_TO_V2(x: word): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := ((((x) shl 8) + $80) div 257);
end;
function ToFixedDomain(a: integer): Fixed32; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := a + ((a + $7FFF) div $FFFF);
end;
function FromFixedDomain(a: Fixed32): integer; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := a - ((a + $7FFF) shr 16);
end;
(*
function FixedMul(a: Fixed32; b: Fixed32): Fixed32;
begin
result := round(((a / 65536) * (b / 65536)) * 65536 );
end;
*)
procedure MAT3evalW(r: LPWVEC3; a: LPWMAT3; v: LPWVEC3);
var
o1, o2, o3: double;
begin
with v^ do
begin
o1 := n[0] / 65536;
o2 := n[1] / 65536;
o3 := n[2] / 65536;
end;
with a^.v[0] do
r^.n[VX] := round(((n[0] / 65536) * o1) * 65536 ) +
round(((n[1] / 65536) * o2) * 65536 ) +
round(((n[2] / 65536) * o3) * 65536 );
with a^.v[1] do
r^.n[VY] := round(((n[0] / 65536) * o1) * 65536 ) +
round(((n[1] / 65536) * o2) * 65536 ) +
round(((n[2] / 65536) * o3) * 65536 );
with a^.v[2] do
r^.n[VZ] := round(((n[0] / 65536) * o1) * 65536 ) +
round(((n[1] / 65536) * o2) * 65536 ) +
round(((n[2] / 65536) * o3) * 65536 );
(*
r^.n[VX] := FixedMul(a^.v[0].n[0], v^.n[0]) +
FixedMul(a^.v[0].n[1], v^.n[1]) +
FixedMul(a^.v[0].n[2], v^.n[2]);
r^.n[VY] := FixedMul(a^.v[1].n[0], v^.n[0]) +
FixedMul(a^.v[1].n[1], v^.n[1]) +
FixedMul(a^.v[1].n[2], v^.n[2]);
r^.n[VZ] := FixedMul(a^.v[2].n[0], v^.n[0]) +
FixedMul(a^.v[2].n[1], v^.n[1]) +
FixedMul(a^.v[2].n[2], v^.n[2]);
*)
end;
function Clamp_RGB(xin: integer): word;
begin
if (xin < 0) then
begin
result := 0;
exit;
end;
if (xin > $FFFF) then
result := $FFFF
else
result := xin;
end;
function cmsLinearInterpLUT16(Value: WORD; LutTable: pwordarray; p: LPL16PARAMS): word;
var
y1, y0: double;
y: double;
val2, rest: double;
cell0, cell1: integer;
begin
if (Value = $FFFF) then
begin
result := LutTable[p^.Domain];
exit;
end;
val2 := p^.Domain * (Value / 65535.0);
cell0 := Floor(val2);
cell1 := Ceil(val2);
rest := val2 - cell0;
y0 := LutTable[cell0];
y1 := LutTable[cell1];
y := y0 + (y1 - y0) * rest;
result := floor(y + 0.5);
end;
procedure cmsEvalLUT(Lut: LPLUT; xIn: pwordarray; xOut: pwordarray);
var
i: dword;
StageABC, StageLMN: array[0..MAXCHANNELS - 1] of WORD;
InVect, OutVect: WVEC3;
begin
(*
for i := 0 to Lut ^. InputChan-1 do
StageABC[i] := xIn[i];
if (Lut ^.wFlags and LUT_V4_OUTPUT_EMULATE_V2)<>0 then
begin
StageABC[0] := FROM_V2_TO_V4(StageABC[0]);
StageABC[1] := FROM_V2_TO_V4(StageABC[1]);
StageABC[2] := FROM_V2_TO_V4(StageABC[2]);
end;
if (Lut ^.wFlags and LUT_V2_OUTPUT_EMULATE_V4)<>0 then
begin
StageABC[0] := FROM_V4_TO_V2(StageABC[0]);
StageABC[1] := FROM_V4_TO_V2(StageABC[1]);
StageABC[2] := FROM_V4_TO_V2(StageABC[2]);
end;
if (Lut ^. wFlags and LUT_HASMATRIX)<>0 then
begin
InVect.n[VX] := ToFixedDomain(StageABC[0]);
InVect.n[VY] := ToFixedDomain(StageABC[1]);
InVect.n[VZ] := ToFixedDomain(StageABC[2]);
MAT3evalW(@OutVect, @Lut ^. Matrix, @InVect);
StageABC[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageABC[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageABC[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (Lut ^. wFlags and LUT_HASTL1)<>0 then
begin
for i := 0 to Lut ^. InputChan-1 do
StageABC[i] := cmsLinearInterpLUT16(StageABC[i],
PWordArray(Lut ^. L1[i]),
@Lut ^. In16params);
end;
if (Lut ^.wFlags and LUT_HASMATRIX3)<>0 then
begin
InVect.n[VX] := ToFixedDomain(StageABC[0]);
InVect.n[VY] := ToFixedDomain(StageABC[1]);
InVect.n[VZ] := ToFixedDomain(StageABC[2]);
MAT3evalW(@OutVect, @Lut ^. Mat3, @InVect);
OutVect.n[VX] := OutVect.n[VX] + Lut ^.Ofs3.n[VX];
OutVect.n[VY] := OutVect.n[VY] + Lut ^.Ofs3.n[VY];
OutVect.n[VZ] := OutVect.n[VZ] + Lut ^.Ofs3.n[VZ];
StageABC[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageABC[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageABC[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (Lut ^.wFlags and LUT_HASTL3)<>0 then
begin
for i := 0 to Lut ^. InputChan-1 do
StageABC[i] := cmsLinearInterpLUT16(StageABC[i],
pwordarray(Lut ^. L3[i]),
@Lut ^. L3params);
end;
if (Lut ^. wFlags and LUT_HAS3DGRID)<>0 then
begin
Lut ^.CLut16params.Interp3D(@StageABC, @StageLMN, pwordarray(Lut ^. T), @Lut ^. CLut16params);
end
else
begin
for i := 0 to Lut ^. InputChan-1 do
StageLMN[i] := StageABC[i];
end;
if (Lut ^.wFlags and LUT_HASTL4)<>0 then
begin
for i := 0 to Lut ^. OutputChan-1 do
StageLMN[i] := cmsLinearInterpLUT16(StageLMN[i],
pwordarray(Lut ^. L4[i]),
@Lut ^. L4params);
end;
if (Lut ^.wFlags and LUT_HASMATRIX4)<>0 then
begin
InVect.n[VX] := ToFixedDomain(StageLMN[0]);
InVect.n[VY] := ToFixedDomain(StageLMN[1]);
InVect.n[VZ] := ToFixedDomain(StageLMN[2]);
MAT3evalW(@OutVect, @Lut ^. Mat4, @InVect);
OutVect.n[VX] := OutVect.n[VX]+ Lut ^.Ofs4.n[VX];
OutVect.n[VY] := OutVect.n[VY]+ Lut ^.Ofs4.n[VY];
OutVect.n[VZ] := OutVect.n[VZ]+ Lut ^.Ofs4.n[VZ];
StageLMN[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageLMN[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageLMN[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (Lut ^. wFlags and LUT_HASTL2)<>0 then
begin
for i := 0 to Lut ^. OutputChan-1 do
xOut[i] := cmsLinearInterpLUT16(StageLMN[i],
pwordarray(Lut ^. L2[i]),
@Lut ^. Out16params);
end
else
begin
for i := 0 to Lut ^. OutputChan-1 do
xOut[i] := StageLMN[i];
end;
if (Lut ^.wFlags and LUT_V4_INPUT_EMULATE_V2)<>0 then
begin
xOut[0] := FROM_V4_TO_V2(xOut[0]);
xOut[1] := FROM_V4_TO_V2(xOut[1]);
xOut[2] := FROM_V4_TO_V2(xOut[2]);
end;
if (Lut ^.wFlags and LUT_V2_INPUT_EMULATE_V4)<>0 then
begin
xOut[0] := FROM_V2_TO_V4(xOut[0]);
xOut[1] := FROM_V2_TO_V4(xOut[1]);
xOut[2] := FROM_V2_TO_V4(xOut[2]);
end;
*)
with Lut^ do
begin
for i := 0 to InputChan - 1 do
StageABC[i] := xIn[i];
if (wFlags and LUT_V4_OUTPUT_EMULATE_V2) <> 0 then
begin
StageABC[0] := FROM_V2_TO_V4(StageABC[0]);
StageABC[1] := FROM_V2_TO_V4(StageABC[1]);
StageABC[2] := FROM_V2_TO_V4(StageABC[2]);
end;
if (wFlags and LUT_V2_OUTPUT_EMULATE_V4) <> 0 then
begin
StageABC[0] := FROM_V4_TO_V2(StageABC[0]);
StageABC[1] := FROM_V4_TO_V2(StageABC[1]);
StageABC[2] := FROM_V4_TO_V2(StageABC[2]);
end;
if (wFlags and LUT_HASMATRIX) <> 0 then
begin
InVect.n[VX] := ToFixedDomain(StageABC[0]);
InVect.n[VY] := ToFixedDomain(StageABC[1]);
InVect.n[VZ] := ToFixedDomain(StageABC[2]);
MAT3evalW(@OutVect, @Matrix, @InVect);
StageABC[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageABC[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageABC[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (wFlags and LUT_HASTL1) <> 0 then
begin
for i := 0 to InputChan - 1 do
StageABC[i] := cmsLinearInterpLUT16(StageABC[i],
PWordArray(L1[i]),
@In16params);
end;
if (wFlags and LUT_HASMATRIX3) <> 0 then
begin
InVect.n[VX] := ToFixedDomain(StageABC[0]);
InVect.n[VY] := ToFixedDomain(StageABC[1]);
InVect.n[VZ] := ToFixedDomain(StageABC[2]);
MAT3evalW(@OutVect, @Mat3, @InVect);
OutVect.n[VX] := OutVect.n[VX] + Ofs3.n[VX];
OutVect.n[VY] := OutVect.n[VY] + Ofs3.n[VY];
OutVect.n[VZ] := OutVect.n[VZ] + Ofs3.n[VZ];
StageABC[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageABC[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageABC[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (wFlags and LUT_HASTL3) <> 0 then
begin
for i := 0 to InputChan - 1 do
StageABC[i] := cmsLinearInterpLUT16(StageABC[i],
pwordarray(L3[i]),
@L3params);
end;
if (wFlags and LUT_HAS3DGRID) <> 0 then
begin
CLut16params.Interp3D(@StageABC, @StageLMN, pwordarray(T), @CLut16params);
end
else
begin
for i := 0 to InputChan - 1 do
StageLMN[i] := StageABC[i];
end;
if (wFlags and LUT_HASTL4) <> 0 then
begin
for i := 0 to OutputChan - 1 do
StageLMN[i] := cmsLinearInterpLUT16(StageLMN[i],
pwordarray(L4[i]),
@L4params);
end;
if (wFlags and LUT_HASMATRIX4) <> 0 then
begin
InVect.n[VX] := ToFixedDomain(StageLMN[0]);
InVect.n[VY] := ToFixedDomain(StageLMN[1]);
InVect.n[VZ] := ToFixedDomain(StageLMN[2]);
MAT3evalW(@OutVect, @Mat4, @InVect);
OutVect.n[VX] := OutVect.n[VX] + Ofs4.n[VX];
OutVect.n[VY] := OutVect.n[VY] + Ofs4.n[VY];
OutVect.n[VZ] := OutVect.n[VZ] + Ofs4.n[VZ];
StageLMN[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
StageLMN[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
StageLMN[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
if (wFlags and LUT_HASTL2) <> 0 then
begin
for i := 0 to OutputChan - 1 do
xOut[i] := cmsLinearInterpLUT16(StageLMN[i],
pwordarray(L2[i]),
@Out16params);
end
else
begin
for i := 0 to OutputChan - 1 do
xOut[i] := StageLMN[i];
end;
if (wFlags and LUT_V4_INPUT_EMULATE_V2) <> 0 then
begin
xOut[0] := FROM_V4_TO_V2(xOut[0]);
xOut[1] := FROM_V4_TO_V2(xOut[1]);
xOut[2] := FROM_V4_TO_V2(xOut[2]);
end;
if (wFlags and LUT_V2_INPUT_EMULATE_V4) <> 0 then
begin
xOut[0] := FROM_V2_TO_V4(xOut[0]);
xOut[1] := FROM_V2_TO_V4(xOut[1]);
xOut[2] := FROM_V2_TO_V4(xOut[2]);
end;
end;
end;
// This is the "normal" proofing transform
procedure NormalXFORM(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: dword);
var
accum: PBYTE;
output: PBYTE;
wIn, wOut: array[0..MAXCHANNELS - 1] of WORD;
wStageABC, wPCS: array[0..2] of WORD;
wStageLMN: array[0..MAXCHANNELS - 1] of WORD;
wGamut: array[0..0] of WORD;
i, n: dword;
wPreview: array[0..2] of WORD;
begin
accum := xin;
output := xout;
n := Size;
for i := 0 to n - 1 do
begin
accum := p^.FromInput(p, @wIn, accum);
p^.FromDevice(p, @wIn, @wStageABC);
if (@p^.Stage1 <> nil) then
begin
p^.Stage1(@wStageABC, @wPCS, @p^.m1, @p^.of1);
if (wPCS[0] = $FFFF) and (wPCS[1] = $FFFF) and (wPCS[2] = $FFFF) then
begin
output := p^.ToOutput(_LPcmsTRANSFORM(p),
pwordarray(_cmsWhiteBySpace(cmsGetColorSpace(p^.OutputProfile))),
output);
continue;
end;
end
else
COPY_3CHANS(@wPCS, @wStageABC);
if (p^.Gamut <> nil) then
begin
cmsEvalLUT(p^.Gamut, @wPCS, @wGamut);
if (wGamut[0] >= 1) then
begin
wOut[0] := AlarmR;
wOut[1] := AlarmG;
wOut[2] := AlarmB;
wOut[3] := 0;
output := p^.ToOutput(_LPcmsTRANSFORM(p), @wOut, output);
continue;
end;
end;
if (p^.Preview <> nil) then
begin
cmsEvalLUT(p^.Preview, @wPCS, @wPreview);
COPY_3CHANS(@wPCS, @wPreview);
end;
if (@p^.Stage2 <> nil) then
begin
p^.Stage2(@wPCS, @wStageLMN, @p^.m2, @p^.of2);
if (wPCS[0] = $FFFF) and (wPCS[1] = $FFFF) and (wPCS[2] = $FFFF) then
begin
output := p^.ToOutput(_LPcmsTRANSFORM(p),
pwordarray(_cmsWhiteBySpace(cmsGetColorSpace(p^.OutputProfile))),
output);
continue;
end;
end
else
COPY_3CHANS(@wStageLMN, @wPCS);
p^.ToDevice(p, @wStageLMN, @wOut);
output := p^.ToOutput(_LPcmsTRANSFORM(p), @wOut, output);
end;
end;
function cmsGetDeviceClass(hProfile: cmsHPROFILE): icProfileClassSignature;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := Icc^.DeviceClass;
end;
(*
function CHANNELS_SH(c: dword): dword;
begin
result := ((c) shl 3);
end;
*)
(*
function BYTES_SH(b: dword): dword;
begin
result := (b);
end;
*)
(*
function TYPE_NAMED_COLOR_INDEX: dword;
begin
result := (CHANNELS_SH(1) or BYTES_SH(2));
end;
*)
(*
function T_BYTES(b: dword): dword;
begin
result := ((b) and 7);
end;
*)
function T_COLORSPACE(s: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((s) shr 16) and 31);
end;
function L2Fix4(L: double): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := round(L * 655.35 );
end;
function ab2Fix4(ab: double): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := round((ab + 128.0) * 257.0 );
end;
procedure cmsFloat2LabEncoded4(wLab: pwordarray; fLab: LPcmsCIELab);
var
Lab: cmsCIELab;
begin
Lab.L := fLab^.L;
Lab.a := fLab^.a;
Lab.b := fLab^.b;
if (Lab.L < 0) then
Lab.L := 0;
if (Lab.L > 100) then
Lab.L := 100;
if (Lab.a < -128) then
Lab.a := -128;
if (Lab.a > 127) then
Lab.a := 127;
if (Lab.b < -128) then
Lab.b := -128;
if (Lab.b > 127) then
Lab.b := 127;
wLab[0] := L2Fix4(Lab.L);
wLab[1] := ab2Fix4(Lab.a);
wLab[2] := ab2Fix4(Lab.b);
end;
function L2Fix3(L: double): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := round(L * 652.800 );
end;
function ab2Fix3(ab: double): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := round((ab + 128.0) * 256.0 );
end;
procedure cmsFloat2LabEncoded(wLab: pwordarray; fLab: LPcmsCIELab);
var
Lab: cmsCIELab;
begin
Lab.L := fLab^.L;
Lab.a := fLab^.a;
Lab.b := fLab^.b;
if (Lab.L < 0) then
Lab.L := 0;
if (Lab.L > 100) then
Lab.L := 100;
if (Lab.a < -128) then
Lab.a := -128;
if (Lab.a > 127.9961) then
Lab.a := 127.9961;
if (Lab.b < -128) then
Lab.b := -128;
if (Lab.b > 127.9961) then
Lab.b := 127.9961;
wLab[0] := L2Fix3(Lab.L);
wLab[1] := ab2Fix3(Lab.a);
wLab[2] := ab2Fix3(Lab.b);
end;
// floating point
function UnrollLabDouble(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
if (info^.lInputV4Lab) then
cmsFloat2LabEncoded4(wIn, LPcmsCIELab(accum))
else
cmsFloat2LabEncoded(wIn, LPcmsCIELab(accum));
inc(accum, sizeof(cmsCIELab));
result := accum;
end;
// In XYZ All 3 components are encoded using 1.15 fixed point
function XYZ2Fix(d: double): WORD; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := floor(d * 32768.0 + 0.5);
end;
procedure cmsFloat2XYZEncoded(MXYZ: pwordarray; fXYZ: LPcmsCIEXYZ);
var
xyz: cmsCIEXYZ;
begin
xyz.X := fXYZ^.X;
xyz.Y := fXYZ^.Y;
xyz.Z := fXYZ^.Z;
if (xyz.Y <= 0) then
begin
xyz.X := 0;
xyz.Y := 0;
xyz.Z := 0;
end;
if (xyz.X > 1.99996) then
xyz.X := 1.99996;
if (xyz.X < 0) then
xyz.X := 0;
if (xyz.Y > 1.99996) then
xyz.Y := 1.99996;
if (xyz.Y < 0) then
xyz.Y := 0;
if (xyz.Z > 1.99996) then
xyz.Z := 1.99996;
if (xyz.Z < 0) then
xyz.Z := 0;
MXYZ[0] := XYZ2Fix(xyz.X);
MXYZ[1] := XYZ2Fix(xyz.Y);
MXYZ[2] := XYZ2Fix(xyz.Z);
end;
function UnrollXYZDouble(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
cmsFloat2XYZEncoded(wIn, LPcmsCIEXYZ(accum));
inc(accum, sizeof(cmsCIEXYZ));
result := accum;
end;
function T_CHANNELS(c: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((c) shr 3) and 15);
end;
function T_EXTRA(e: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((e) shr 7) and 7);
end;
type
tdoublearray = array[0..$EFFFFFF] of double;
pdoublearray = ^tdoublearray;
// Remaining cases are between 0..1.0
function UnrollDouble(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
Inks: pdoublearray;
nChan: integer;
i: integer;
v: double;
begin
Inks := pdoublearray(accum);
nChan := T_CHANNELS(info^.InputFormat);
for i := 0 to nChan - 1 do
begin
v := floor(Inks[i] * 65535.0 + 0.5);
if (v > 65535.0) then
v := 65535.0;
if (v < 0) then
v := 0;
wIn[i] := trunc(v);
end;
inc(accum, (nChan + T_EXTRA(info^.InputFormat)) * sizeof(double));
result := accum;
end;
// Inks does come in percentage
function UnrollInkDouble(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
Inks: pdoublearray;
nChan, i: integer;
v: double;
begin
Inks := pdoublearray(accum);
nChan := T_CHANNELS(info^.InputFormat);
for i := 0 to nChan - 1 do
begin
v := floor(Inks[i] * 655.35 + 0.5);
if (v > 65535.0) then
v := 65535.0;
if (v < 0) then
v := 0;
wIn[i] := trunc(v);
end;
inc(accum, (nChan + T_EXTRA(info^.InputFormat)) * sizeof(double));
result := accum;
end;
function T_PLANAR(p: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((p) shr 12) and 1);
end;
function RGB_8_TO_16(rgb: word): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := ((((rgb)) shl 8) or (rgb));
end;
function UnrollPlanarBytes(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
nChan: integer;
i: integer;
Init: pbyte;
begin
nChan := T_CHANNELS(info^.InputFormat);
Init := accum;
for i := 0 to nChan - 1 do
begin
wIn[i] := RGB_8_TO_16(accum^);
inc(accum, info^.StrideIn);
end;
inc(Init);
result := Init;
end;
function T_ENDIAN16(e: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((e) shr 11) and 1);
end;
function CHANGE_ENDIAN(w: word): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((w) shl 8) or ((w) shr 8));
end;
function UnrollPlanarWordsBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
nChan: integer;
i: integer;
Init: pbyte;
begin
nChan := T_CHANNELS(info^.InputFormat);
Init := accum;
for i := 0 to nChan - 1 do
begin
wIn[i] := CHANGE_ENDIAN(pword(accum)^);
inc(accum, (info^.StrideIn * 2));
end;
inc(Init, 2);
result := Init;
end;
function UnrollPlanarWords(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
nChan: integer;
i: integer;
Init: pbyte;
begin
nChan := T_CHANNELS(info^.InputFormat);
Init := accum;
for i := 0 to nChan - 1 do
begin
wIn[i] := pword(accum)^;
inc(accum, (info^.StrideIn * 2));
end;
inc(Init, 2);
result := Init;
end;
function T_FLAVOR(s: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((s) shr 13) and 1);
end;
function REVERSE_FLAVOR_16(x: word): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (($FFFF - (x)));
end;
function Unroll1ByteReversed(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := REVERSE_FLAVOR_16(RGB_8_TO_16(accum^));
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum);
result := accum;
end;
// Monochrome duplicates L into RGB for null-transforms
function Unroll1Byte(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := RGB_8_TO_16(accum^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum);
result := accum;
end;
function T_SWAPFIRST(s: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((s) shr 14) and 1);
end;
function Unroll2ByteSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := RGB_8_TO_16(accum^);
inc(accum);
wIn[2] := RGB_8_TO_16(accum^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum);
result := accum;
end;
// Monochrome + alpha. Alpha is lost
function Unroll2Byte(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := RGB_8_TO_16(accum^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum);
wIn[3] := RGB_8_TO_16(accum^);
inc(accum);
result := accum;
end;
function T_DOSWAP(e: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((e) shr 10) and 1);
end;
// BRG
function Unroll3BytesSwap(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := RGB_8_TO_16(accum^);
inc(accum);
wIn[1] := RGB_8_TO_16(accum^);
inc(accum);
wIn[0] := RGB_8_TO_16(accum^);
inc(accum);
result := accum;
end;
function Unroll1ByteSkip2(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := RGB_8_TO_16(accum^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum);
inc(accum, 2);
result := accum;
end;
function Unroll3Bytes(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := RGB_8_TO_16(accum^);
inc(accum);
wIn[1] := RGB_8_TO_16(accum^);
inc(accum);
wIn[2] := RGB_8_TO_16(accum^);
inc(accum);
result := accum;
end;
function Unroll4BytesSwapSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := RGB_8_TO_16(accum^);
inc(accum); // K
wIn[1] := RGB_8_TO_16(accum^);
inc(accum); // Y
wIn[0] := RGB_8_TO_16(accum^);
inc(accum); // M
wIn[3] := RGB_8_TO_16(accum^);
inc(accum); // C
result := accum;
end;
function Unroll4BytesSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := RGB_8_TO_16(accum^);
inc(accum); // K
wIn[0] := RGB_8_TO_16(accum^);
inc(accum); // C
wIn[1] := RGB_8_TO_16(accum^);
inc(accum); // M
wIn[2] := RGB_8_TO_16(accum^);
inc(accum); // Y
result := accum;
end;
// KYMC
function Unroll4BytesSwap(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := RGB_8_TO_16(accum^);
inc(accum); // K
wIn[2] := RGB_8_TO_16(accum^);
inc(accum); // Y
wIn[1] := RGB_8_TO_16(accum^);
inc(accum); // M
wIn[0] := RGB_8_TO_16(accum^);
inc(accum); // C
result := accum;
end;
function REVERSE_FLAVOR_8(x: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (($FF - (x)));
end;
function Unroll4BytesReverse(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
i: word;
begin
(*
result := accum;
wIn[0] := RGB_8_TO_16(($FF - result^));
inc(result); // C
wIn[1] := RGB_8_TO_16(($FF - result^));
inc(result); // M
wIn[2] := RGB_8_TO_16(($FF - result^));
inc(result); // Y
wIn[3] := RGB_8_TO_16(($FF - result^));
inc(result); // K
*)
result := accum;
i := $FF-result^;
wIn[0] := ((i shl 8) or i);
inc(result);
i := $FF-result^;
wIn[1] := ((i shl 8) or i);
inc(result);
i := $FF-result^;
wIn[2] := ((i shl 8) or i);
inc(result);
i := $FF-result^;
wIn[3] := ((i shl 8) or i);
inc(result);
end;
function Unroll4Bytes(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := RGB_8_TO_16(accum^);
inc(accum); // C
wIn[1] := RGB_8_TO_16(accum^);
inc(accum); // M
wIn[2] := RGB_8_TO_16(accum^);
inc(accum); // Y
wIn[3] := RGB_8_TO_16(accum^);
inc(accum); // K
result := accum;
end;
//result := ((( (rgb)) shl 8)or (rgb));
function UnrollAnyBytes(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
nChan: integer;
i: integer;
begin
nChan := (info^.InputFormat shr 3) and 15; //nChan := T_CHANNELS(info ^. InputFormat);
for i := 0 to nChan - 1 do
begin
wIn[i] := (accum^ shl 8) or accum^; // wIn[i] := RGB_8_TO_16(accum^)
inc(accum);
end;
result := accum;
end;
function Unroll1WordBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
result := accum;
end;
function Unroll1WordReversed(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := REVERSE_FLAVOR_16(PWORD(accum)^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
result := accum;
end;
function Unroll1Word(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := PWORD(accum)^;
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
result := accum;
end;
function Unroll2WordBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
wIn[3] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
result := accum;
end;
function Unroll2WordSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := PWORD(accum)^;
inc(accum, 2);
wIn[2] := PWORD(accum)^;
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
result := accum;
end;
function Unroll2Word(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := PWORD(accum)^;
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 2);
wIn[3] := PWORD(accum)^;
inc(accum, 2);
result := accum;
end;
function Unroll3WordsSwapBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
wIn[1] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
wIn[0] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
result := accum;
end;
function Unroll3WordsSwap(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := PWORD(accum)^;
inc(accum, 2);
wIn[1] := PWORD(accum)^;
inc(accum, 2);
wIn[0] := PWORD(accum)^;
inc(accum, 2);
result := accum;
end;
function Unroll3WordsBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
wIn[1] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2);
result := accum;
end;
function Unroll3Words(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := PWORD(accum)^;
inc(accum, 2); // C R
wIn[1] := PWORD(accum)^;
inc(accum, 2); // M G
wIn[2] := PWORD(accum)^;
inc(accum, 2); // Y B
result := accum;
end;
// KYMC
function Unroll4WordsSwapBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //K
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //Y
wIn[1] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //M
wIn[0] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //C
result := accum;
end;
function Unroll4WordsSwapSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := PWORD(accum)^;
inc(accum, 2); // K
wIn[1] := PWORD(accum)^;
inc(accum, 2); // Y
wIn[0] := PWORD(accum)^;
inc(accum, 2); // M
wIn[3] := PWORD(accum)^;
inc(accum, 2); // C
result := accum;
end;
// KYMC
function Unroll4WordsSwap(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := PWORD(accum)^;
inc(accum, 2); // K
wIn[2] := PWORD(accum)^;
inc(accum, 2); // Y
wIn[1] := PWORD(accum)^;
inc(accum, 2); // M
wIn[0] := PWORD(accum)^;
inc(accum, 2); // C
result := accum;
end;
function Unroll1WordSkip3(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[2] := accum^;
wIn[1] := wIn[2];
wIn[0] := wIn[1];
inc(accum, 8);
result := accum;
end;
function Unroll4WordsBigEndianReverse(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := REVERSE_FLAVOR_16(CHANGE_ENDIAN(PWORD(accum)^));
inc(accum, 2); //C
wIn[1] := REVERSE_FLAVOR_16(CHANGE_ENDIAN(PWORD(accum)^));
inc(accum, 2); //M
wIn[2] := REVERSE_FLAVOR_16(CHANGE_ENDIAN(PWORD(accum)^));
inc(accum, 2); //Y
wIn[3] := REVERSE_FLAVOR_16(CHANGE_ENDIAN(PWORD(accum)^));
inc(accum, 2); //K
result := accum;
end;
function Unroll4WordsBigEndian(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //C
wIn[1] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //M
wIn[2] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //Y
wIn[3] := CHANGE_ENDIAN(PWORD(accum)^);
inc(accum, 2); //K
result := accum;
end;
function Unroll4WordsSwapFirst(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[3] := PWORD(accum)^;
inc(accum, 2); // K
wIn[0] := PWORD(accum)^;
inc(accum, 2); // C
wIn[1] := PWORD(accum)^;
inc(accum, 2); // M
wIn[2] := PWORD(accum)^;
inc(accum, 2); // Y
result := accum;
end;
function Unroll4WordsReverse(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
wIn[0] := REVERSE_FLAVOR_16(PWORD(accum)^);
inc(accum, 2); // C
wIn[1] := REVERSE_FLAVOR_16(PWORD(accum)^);
inc(accum, 2); // M
wIn[2] := REVERSE_FLAVOR_16(PWORD(accum)^);
inc(accum, 2); // Y
wIn[3] := REVERSE_FLAVOR_16(PWORD(accum)^);
inc(accum, 2); // K
result := accum;
end;
function Unroll4Words(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
begin
result := accum;
wIn[0] := PWORD(result)^;
inc(result, 2); // C
wIn[1] := PWORD(result)^;
inc(result, 2); // M
wIn[2] := PWORD(result)^;
inc(result, 2); // Y
wIn[3] := PWORD(result)^;
inc(result, 2); // K
end;
function UnrollAnyWords(info: _LPcmsTRANSFORM; wIn: pwordarray; accum: pbyte): pbyte;
var
nChan: integer;
i: integer;
begin
nChan := T_CHANNELS(info^.InputFormat);
for i := 0 to nChan - 1 do
begin
wIn[i] := PWORD(accum)^;
inc(accum, 2);
end;
result := accum;
end;
// choose routine from Input identifier
function _cmsIdentifyInputFormat(xform: _LPcmsTRANSFORM; dwInput: DWORD): _cmsFIXFN;
var
FromInput: _cmsFIXFN;
begin
FromInput := nil;
if (xform <> nil) then
begin
if (xform^.InputProfile <> nil) then
begin
if (cmsGetDeviceClass(xform^.InputProfile) = icSigNamedColorClass) then
begin
if (dwInput <> TYPE_NAMED_COLOR_INDEX) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Named color needs TYPE_NAMED_COLOR_INDEX");
result := nil;
exit;
end;
end;
end;
end;
if ((dwInput and 7) = 0) then
begin
case (T_COLORSPACE(dwInput)) of
PT_Lab:
FromInput := UnrollLabDouble;
PT_XYZ:
FromInput := UnrollXYZDouble;
PT_GRAY,
PT_RGB,
PT_YCbCr,
PT_YUV,
PT_YUVK,
PT_HSV,
PT_HLS,
PT_Yxy:
FromInput := UnrollDouble;
else
FromInput := UnrollInkDouble;
end
end
else
if (T_PLANAR(dwInput) <> 0) then
begin
case ((dwInput and 7)) of
1:
FromInput := UnrollPlanarBytes;
2:
if (T_ENDIAN16(dwInput) <> 0) then
FromInput := UnrollPlanarWordsBigEndian
else
FromInput := UnrollPlanarWords;
end
end
else
begin
case ((dwInput and 7)) of
1:
case (T_CHANNELS(dwInput) + T_EXTRA(dwInput)) of
1: if (T_FLAVOR(dwInput) <> 0) then
FromInput := Unroll1ByteReversed
else
FromInput := Unroll1Byte;
2: if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll2ByteSwapFirst
else
FromInput := Unroll2Byte;
3: if (T_DOSWAP(dwInput) <> 0) then
FromInput := Unroll3BytesSwap
else
begin
if (T_EXTRA(dwInput) = 2) then
FromInput := Unroll1ByteSkip2
else
FromInput := Unroll3Bytes;
end;
4: if (T_DOSWAP(dwInput) <> 0) then
begin
if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll4BytesSwapSwapFirst
else
FromInput := Unroll4BytesSwap;
end
else
begin
if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll4BytesSwapFirst
else
begin
if ((((dwInput) shr 13) and 1) <> 0) then
FromInput := Unroll4BytesReverse
else
FromInput := Unroll4Bytes;
end;
end;
5,
6,
7,
8:
if (T_DOSWAP(dwInput) = 0) and (T_SWAPFIRST(dwInput) = 0) then
FromInput := UnrollAnyBytes;
end;
2:
case (T_CHANNELS(dwInput) + T_EXTRA(dwInput)) of
1: if (T_ENDIAN16(dwInput) <> 0) then
FromInput := Unroll1WordBigEndian
else
if (T_FLAVOR(dwInput) <> 0) then
FromInput := Unroll1WordReversed
else
FromInput := Unroll1Word;
2: if (T_ENDIAN16(dwInput) <> 0) then
FromInput := Unroll2WordBigEndian
else
begin
if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll2WordSwapFirst
else
FromInput := Unroll2Word;
end;
3: if (T_DOSWAP(dwInput) <> 0) then
begin
if (T_ENDIAN16(dwInput) <> 0) then
FromInput := Unroll3WordsSwapBigEndian
else
FromInput := Unroll3WordsSwap;
end
else
begin
if (T_ENDIAN16(dwInput) <> 0) then
FromInput := Unroll3WordsBigEndian
else
FromInput := Unroll3Words;
end;
4: if (T_DOSWAP(dwInput) <> 0) then
begin
if (T_ENDIAN16(dwInput) <> 0) then
FromInput := Unroll4WordsSwapBigEndian
else
begin
if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll4WordsSwapSwapFirst
else
FromInput := Unroll4WordsSwap;
end;
end
else
begin
if (T_EXTRA(dwInput) = 3) then
FromInput := Unroll1WordSkip3
else
if (T_ENDIAN16(dwInput) <> 0) then
begin
if (T_FLAVOR(dwInput) <> 0) then
FromInput := Unroll4WordsBigEndianReverse
else
FromInput := Unroll4WordsBigEndian;
end
else
begin
if (T_SWAPFIRST(dwInput) <> 0) then
FromInput := Unroll4WordsSwapFirst
else
begin
if ((((dwInput) shr 13) and 1) <> 0) then
FromInput := Unroll4WordsReverse
else
FromInput := Unroll4Words;
end;
end;
end;
5,
6,
7,
8:
if (T_DOSWAP(dwInput) = 0) and (T_SWAPFIRST(dwInput) = 0) then
FromInput := UnrollAnyWords;
end;
end;
end;
//if (FromInput=nil) then;
//cmsSignalError(LCMS_ERRC_ABORTED, "Unknown input format");
result := FromInput;
end;
function L2float4(v: WORD): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
var
fix32: Fixed32;
begin
fix32 := v;
result := fix32 / 655.35;
end;
function ab2float4(v: WORD): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
var
fix32: Fixed32;
begin
fix32 := v;
result := (fix32 / 257.0) - 128.0;
end;
function L2float3(v: WORD): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
var
fix32: Fixed32;
begin
fix32 := v;
result := fix32 / 652.800;
end;
procedure cmsLabEncoded2Float4(Lab: LPcmsCIELab; wLab: pwordarray);
begin
Lab^.L := L2float4(wLab[0]);
Lab^.a := ab2float4(wLab[1]);
Lab^.b := ab2float4(wLab[2]);
end;
function ab2float3(v: WORD): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
var
fix32: Fixed32;
begin
fix32 := v;
result := (fix32 / 256.0) - 128.0;
end;
procedure cmsLabEncoded2Float(Lab: LPcmsCIELab; wLab: pwordarray);
begin
Lab^.L := L2float3(wLab[0]);
Lab^.a := ab2float3(wLab[1]);
Lab^.b := ab2float3(wLab[2]);
end;
// Unencoded Float values -- don't try optimize speed
function PackLabDouble(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
if (Info^.lOutputV4Lab) then
cmsLabEncoded2Float4(LPcmsCIELab(output), wOut)
else
cmsLabEncoded2Float(LPcmsCIELab(output), wOut);
inc(output, sizeof(cmsCIELab));
result := output;
end;
function XYZ2float(v: WORD): double;
var
fix32: Fixed32;
begin
fix32 := v shl 1;
result := FIXED_TO_DOUBLE(fix32);
end;
procedure cmsXYZEncoded2Float(fXYZ: LPcmsCIEXYZ; XYZ: pwordarray);
begin
fXYZ^.X := XYZ2float(XYZ[0]);
fXYZ^.Y := XYZ2float(XYZ[1]);
fXYZ^.Z := XYZ2float(XYZ[2]);
end;
function PackXYZDouble(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
cmsXYZEncoded2Float(LPcmsCIEXYZ(output), wOut);
inc(output, sizeof(cmsCIEXYZ));
result := output;
end;
function PackDouble(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
Inks: pdoublearray;
i, nChan: integer;
begin
Inks := pdoublearray(output);
nChan := T_CHANNELS(Info^.OutputFormat);
for i := 0 to nChan - 1 do
begin
Inks[i] := wOut[i] / 65535;
end;
inc(output, (nChan + T_EXTRA(Info^.OutputFormat)) * sizeof(double));
result := output;
end;
function PackInkDouble(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
Inks: pdoublearray;
i, nChan: integer;
begin
Inks := pdoublearray(output);
nChan := T_CHANNELS(Info^.OutputFormat);
for i := 0 to nChan - 1 do
begin
Inks[i] := wOut[i] / 655.35;
end;
inc(output, (nChan + T_EXTRA(Info^.OutputFormat)) * sizeof(double));
result := output;
end;
function RGB_16_TO_8(rgb: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := ((((rgb) * 65281 + 8388608) shr 24) and $FF);
end;
function PackPlanarBytes(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan: integer;
i: integer;
Init: pbyte;
begin
nChan := T_CHANNELS(info^.OutputFormat);
Init := output;
for i := 0 to nChan - 1 do
begin
output^ := RGB_16_TO_8(wOut[i]);
inc(output, info^.StrideOut);
end;
inc(Init);
result := Init;
end;
function PackPlanarWords(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan: integer;
i: integer;
Init: pbyte;
begin
nChan := T_CHANNELS(info^.OutputFormat);
Init := output;
for i := 0 to nChan - 1 do
begin
pword(output)^ := wOut[i];
inc(output, (info^.StrideOut * sizeof(WORD)));
end;
inc(Init, 2);
result := Init;
end;
function Pack1Byte(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
result := output;
end;
function Pack1ByteAndSkip1SwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
result := output;
end;
function Pack1ByteAndSkip1(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
inc(output);
result := output;
end;
function Pack3BytesSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
result := output;
result^ := ((((wOut[2]) * 65281 + 8388608) shr 24) and $FF);
inc(result);
result^ := ((((wOut[1]) * 65281 + 8388608) shr 24) and $FF);
inc(result);
result^ := ((((wOut[0]) * 65281 + 8388608) shr 24) and $FF);
inc(result);
end;
function Pack3Bytes(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
result := output;
end;
function Pack3BytesAndSkip1SwapSwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
inc(output);
result := output;
end;
function Pack3BytesAndSkip1SwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
result := output;
end;
function Pack3BytesAndSkip1Swap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
result := output;
end;
function Pack3BytesAndSkip1(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
inc(output);
result := output;
end;
function Pack4BytesSwapSwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
result := output;
end;
function Pack4BytesSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
result := output;
end;
function Pack4BytesSwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
result := output;
end;
function Pack4BytesReverse(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := REVERSE_FLAVOR_8(RGB_16_TO_8(wOut[0]));
inc(output);
output^ := REVERSE_FLAVOR_8(RGB_16_TO_8(wOut[1]));
inc(output);
output^ := REVERSE_FLAVOR_8(RGB_16_TO_8(wOut[2]));
inc(output);
output^ := REVERSE_FLAVOR_8(RGB_16_TO_8(wOut[3]));
inc(output);
result := output;
end;
function Pack4Bytes(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
result := output;
end;
function Pack6BytesSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[4]);
inc(output);
output^ := RGB_16_TO_8(wOut[5]);
inc(output);
result := output;
end;
function Pack6Bytes(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
output^ := RGB_16_TO_8(wOut[0]);
inc(output);
output^ := RGB_16_TO_8(wOut[1]);
inc(output);
output^ := RGB_16_TO_8(wOut[2]);
inc(output);
output^ := RGB_16_TO_8(wOut[3]);
inc(output);
output^ := RGB_16_TO_8(wOut[4]);
inc(output);
output^ := RGB_16_TO_8(wOut[5]);
inc(output);
result := output;
end;
function PackNBytesSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
i, nChan: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
i := nChan - 1;
while (i >= 0) do
begin
output^ := RGB_16_TO_8(wOut[i]);
inc(output);
dec(i);
end;
result := output;
end;
function PackNBytes(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan, i: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
for i := 0 to nChan - 1 do
begin
output^ := RGB_16_TO_8(wOut[i]);
inc(output);
end;
result := output;
end;
function Pack1WordBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
result := output;
end;
function Pack1Word(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 2);
result := output;
end;
function Pack1WordAndSkip1BigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 4);
result := output;
end;
function Pack1WordAndSkip1SwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
result := output;
end;
function Pack1WordAndSkip1(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 4);
result := output;
end;
function Pack3WordsSwapBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
result := output;
end;
function Pack3WordsSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
result := output;
end;
function Pack3WordsBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
result := output;
end;
function Pack3Words(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
result := output;
end;
function Pack3WordsAndSkip1SwapBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
result := output;
end;
function Pack3WordsAndSkip1SwapSwapFirst(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
inc(output, 2);
result := output;
end;
function Pack3WordsAndSkip1Swap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
result := output;
end;
function Pack3WordsAndSkip1BigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
inc(output, 2);
result := output;
end;
function Pack3WordsAndSkip1(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
inc(output, 2);
result := output;
end;
function Pack4WordsSwapBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[3]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
result := output;
end;
function Pack4WordsSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[3];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
result := output;
end;
function Pack4WordsBigEndianReverse(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(REVERSE_FLAVOR_16(wOut[0]));
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(REVERSE_FLAVOR_16(wOut[1]));
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(REVERSE_FLAVOR_16(wOut[2]));
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(REVERSE_FLAVOR_16(wOut[3]));
inc(output, 2);
result := output;
end;
function Pack4WordsBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[3]);
inc(output, 2);
result := output;
end;
function Pack4WordsReverse(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := REVERSE_FLAVOR_16(wOut[0]);
inc(output, 2);
pword(output)^ := REVERSE_FLAVOR_16(wOut[1]);
inc(output, 2);
pword(output)^ := REVERSE_FLAVOR_16(wOut[2]);
inc(output, 2);
pword(output)^ := REVERSE_FLAVOR_16(wOut[3]);
inc(output, 2);
result := output;
end;
function Pack4Words(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[3];
inc(output, 2);
result := output;
end;
function Pack6WordsSwapBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[3]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[4]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[5]);
inc(output, 2);
result := output;
end;
function Pack6WordsSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[3];
inc(output, 2);
pword(output)^ := wOut[0];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[4];
inc(output, 2);
pword(output)^ := wOut[5];
inc(output, 2);
result := output;
end;
function Pack6WordsBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := CHANGE_ENDIAN(wOut[0]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[1]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[2]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[3]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[4]);
inc(output, 2);
pword(output)^ := CHANGE_ENDIAN(wOut[5]);
inc(output, 2);
result := output;
end;
function Pack6Words(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
begin
pword(output)^ := wOut[0];
inc(output, 2);
pword(output)^ := wOut[1];
inc(output, 2);
pword(output)^ := wOut[2];
inc(output, 2);
pword(output)^ := wOut[3];
inc(output, 2);
pword(output)^ := wOut[4];
inc(output, 2);
pword(output)^ := wOut[5];
inc(output, 2);
result := output;
end;
function PackNWordsSwapBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan, i: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
i := nChan - 1;
while (i >= 0) do
begin
pword(output)^ := CHANGE_ENDIAN(wOut[i]);
inc(output, sizeof(WORD));
dec(i);
end;
result := output;
end;
function PackNWordsSwap(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan, i: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
i := nChan - 1;
while (i >= 0) do
begin
pword(output)^ := wOut[i];
inc(output, sizeof(WORD));
dec(i);
end;
result := output;
end;
function PackNWordsBigEndian(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan, i: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
for i := 0 to nChan - 1 do
begin
pword(output)^ := CHANGE_ENDIAN(wOut[i]);
inc(output, sizeof(WORD));
end;
result := output;
end;
function PackNWords(Info: _LPcmsTRANSFORM; wOut: pwordarray; output: pbyte): pbyte;
var
nChan, i: integer;
begin
nChan := T_CHANNELS(info^.OutputFormat);
for i := 0 to nChan - 1 do
begin
pword(output)^ := wOut[i];
inc(output, sizeof(WORD));
end;
result := output;
end;
// choose routine from Input identifier
function _cmsIdentifyOutputFormat(xform: _LPcmsTRANSFORM; dwOutput: DWORD): _cmsFIXFN;
var
ToOutput: _cmsFIXFN;
begin
ToOutput := nil;
if ((dwOutput and 7) = 0) then
begin
case (T_COLORSPACE(dwOutput)) of
PT_Lab:
ToOutput := PackLabDouble;
PT_XYZ:
ToOutput := PackXYZDouble;
PT_GRAY,
PT_RGB,
PT_YCbCr,
PT_YUV,
PT_YUVK,
PT_HSV,
PT_HLS,
PT_Yxy:
ToOutput := PackDouble;
else
ToOutput := PackInkDouble;
end;
end
else
if (T_PLANAR(dwOutput) <> 0) then
begin
case ((dwOutput and 7)) of
1: ToOutput := PackPlanarBytes;
2: if (T_ENDIAN16(dwOutput) = 0) then
ToOutput := PackPlanarWords;
end;
end
else
begin
case ((dwOutput and 7)) of
1:
case (T_CHANNELS(dwOutput)) of
1:
begin
ToOutput := Pack1Byte;
if (T_EXTRA(dwOutput) = 1) then
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack1ByteAndSkip1SwapFirst
else
ToOutput := Pack1ByteAndSkip1;
end;
end;
3:
case (T_EXTRA(dwOutput)) of
0: if (T_DOSWAP(dwOutput) <> 0) then
ToOutput := Pack3BytesSwap
else
ToOutput := Pack3Bytes;
1: if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack3BytesAndSkip1SwapSwapFirst
else
ToOutput := Pack3BytesAndSkip1Swap;
end
else
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack3BytesAndSkip1SwapFirst
else
ToOutput := Pack3BytesAndSkip1;
end;
end;
4: if (T_EXTRA(dwOutput) = 0) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack4BytesSwapSwapFirst
else
ToOutput := Pack4BytesSwap;
end
else
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack4BytesSwapFirst
else
begin
if (T_FLAVOR(dwOutput) <> 0) then
ToOutput := Pack4BytesReverse
else
ToOutput := Pack4Bytes;
end;
end;
end;
6: if (T_EXTRA(dwOutput) = 0) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
ToOutput := Pack6BytesSwap
else
ToOutput := Pack6Bytes;
end;
5,
7,
8,
9,
10,
11,
12,
13,
14,
15:
if ((T_EXTRA(dwOutput) = 0) and (T_SWAPFIRST(dwOutput) = 0)) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
ToOutput := PackNBytesSwap
else
ToOutput := PackNBytes;
end;
end;
2:
case (T_CHANNELS(dwOutput)) of
1:
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack1WordBigEndian
else
ToOutput := Pack1Word;
if (T_EXTRA(dwOutput) = 1) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack1WordAndSkip1BigEndian
else
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack1WordAndSkip1SwapFirst
else
ToOutput := Pack1WordAndSkip1;
end;
end;
end;
3:
case (T_EXTRA(dwOutput)) of
0:
if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack3WordsSwapBigEndian
else
ToOutput := Pack3WordsSwap;
end
else
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack3WordsBigEndian
else
ToOutput := Pack3Words;
end;
1: if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack3WordsAndSkip1SwapBigEndian
else
begin
if (T_SWAPFIRST(dwOutput) <> 0) then
ToOutput := Pack3WordsAndSkip1SwapSwapFirst
else
ToOutput := Pack3WordsAndSkip1Swap;
end;
end
else
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack3WordsAndSkip1BigEndian
else
ToOutput := Pack3WordsAndSkip1;
end;
end;
4:
if (T_EXTRA(dwOutput) = 0) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack4WordsSwapBigEndian
else
ToOutput := Pack4WordsSwap;
end
else
begin
if (T_ENDIAN16(dwOutput) <> 0) then
begin
if (T_FLAVOR(dwOutput) <> 0) then
ToOutput := Pack4WordsBigEndianReverse
else
ToOutput := Pack4WordsBigEndian;
end
else
begin
if (T_FLAVOR(dwOutput) <> 0) then
ToOutput := Pack4WordsReverse
else
ToOutput := Pack4Words;
end;
end;
end;
6:
if (T_EXTRA(dwOutput) = 0) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack6WordsSwapBigEndian
else
ToOutput := Pack6WordsSwap;
end
else
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := Pack6WordsBigEndian
else
ToOutput := Pack6Words;
end;
end;
5,
7,
8,
9,
10,
11,
12,
13,
14,
15: if ((T_EXTRA(dwOutput) = 0) and (T_SWAPFIRST(dwOutput) = 0)) then
begin
if (T_DOSWAP(dwOutput) <> 0) then
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := PackNWordsSwapBigEndian
else
ToOutput := PackNWordsSwap;
end
else
begin
if (T_ENDIAN16(dwOutput) <> 0) then
ToOutput := PackNWordsBigEndian
else
ToOutput := PackNWords;
end;
end;
end;
end;
end;
//if (not ToOutput)
//cmsSignalError(LCMS_ERRC_ABORTED, "Unknown output format");
result := ToOutput;
end;
// Null transformation, only hold channels
procedure NullXFORM(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: dword);
var
accum: pbyte;
output: pbyte;
wIn: array[0..MAXCHANNELS - 1] of WORD;
i, n: dword;
begin
accum := xin;
output := xout;
n := Size;
for i := 0 to n - 1 do
begin
accum := p^.FromInput(p, @wIn, accum);
output := p^.ToOutput(p, @wIn, output);
end;
end;
procedure cmsFreeLUT(Lut: LPLUT);
var
i: integer; // 3.0.1
begin
if (Lut = nil) then
exit;
if (Lut^.T <> nil) then
freemem(Lut^.T);
for i := 0 to Lut^.OutputChan - 1 do
begin
if (Lut^.L2[i] <> nil) then
freemem(Lut^.L2[i]);
end;
for i := 0 to Lut^.InputChan - 1 do
begin
if (Lut^.L1[i] <> nil) then
freemem(Lut^.L1[i]);
end;
if (Lut^.wFlags and LUT_HASTL3) <> 0 then
begin
for i := 0 to Lut^.InputChan - 1 do
begin
if (Lut^.L3[i] <> nil) then
freemem(Lut^.L3[i]);
end;
end;
if (Lut^.wFlags and LUT_HASTL4) <> 0 then
begin
for i := 0 to Lut^.OutputChan - 1 do
begin
if (Lut^.L4[i] <> nil) then
freemem(Lut^.L4[i]);
end;
end;
if (Lut^.CLut16params.p8 <> nil) then
freemem(Lut^.CLut16params.p8);
freemem(Lut);
end;
procedure cmsFreeMatShaper(MatShaper: LPMATSHAPER);
var
i: integer;
begin
if (MatShaper = nil) then
exit;
for i := 0 to 2 do
begin
if (MatShaper^.L[i] <> nil) then
freemem(MatShaper^.L[i]);
if (MatShaper^.L2[i] <> nil) then
freemem(MatShaper^.L2[i]);
end;
freemem(MatShaper);
end;
procedure cmsFreeNamedColorList(v: LPcmsNAMEDCOLORLIST);
begin
if (v = nil) then
begin
//cmsSignalError(LCMS_ERRC_RECOVERABLE, "Couldn't free a NULL named color list");
exit;
end;
freemem(v);
end;
procedure IEcmsDeleteTransform(hTransform: cmsHTRANSFORM);
var
p: _LPcmsTRANSFORM;
begin
p := _LPcmsTRANSFORM(hTransform);
if (p^.Device2PCS <> nil) then
cmsFreeLUT(p^.Device2PCS);
if (p^.PCS2Device <> nil) then
cmsFreeLUT(p^.PCS2Device);
if (p^.Gamut <> nil) then
cmsFreeLUT(p^.Gamut);
if (p^.Preview <> nil) then
cmsFreeLUT(p^.Preview);
if (p^.DeviceLink <> nil) then
cmsFreeLUT(p^.DeviceLink);
if (p^.InMatShaper <> nil) then
cmsFreeMatShaper(p^.InMatShaper);
if (p^.OutMatShaper <> nil) then
cmsFreeMatShaper(p^.OutMatShaper);
if (p^.SmeltMatShaper <> nil) then
cmsFreeMatShaper(p^.SmeltMatShaper);
if (p^.NamedColorList <> nil) then
cmsFreeNamedColorList(p^.NamedColorList);
freemem(p);
end;
// Translate from our colorspace to ICC representation
function _cmsICCcolorSpace(OurNotation: integer): icColorSpaceSignature;
begin
case (OurNotation) of
1,
PT_GRAY: result := icSigGrayData;
2,
PT_RGB: result := icSigRgbData;
PT_CMY: result := icSigCmyData;
PT_CMYK: result := icSigCmykData;
PT_YCbCr: result := icSigYCbCrData;
PT_YUV: result := icSigLuvData;
PT_XYZ: result := icSigXYZData;
PT_Lab: result := icSigLabData;
PT_YUVK: result := icColorSpaceSignature(icSigLuvKData);
PT_HSV: result := icSigHsvData;
PT_HLS: result := icSigHlsData;
PT_Yxy: result := icSigYxyData;
PT_HiFi: result := icColorSpaceSignature(icSigHexachromeData);
PT_HiFi7: result := icColorSpaceSignature(icSigHeptachromeData);
PT_HiFi8: result := icColorSpaceSignature(icSigOctachromeData);
else
result := icMaxEnumData;
end;
end;
function cmsGetPCS(hProfile: cmsHPROFILE): icColorSpaceSignature;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := Icc^.PCS;
end;
// Check colorspace
function IsProperColorSpace(hProfile: cmsHPROFILE; dwFormat: DWORD; lUsePCS: longbool): longbool;
var
Space: integer;
begin
Space := T_COLORSPACE(dwFormat);
if (Space = PT_ANY) then
begin
result := true;
exit;
end;
if (lUsePCS) then
result := (_cmsICCcolorSpace(Space) = cmsGetPCS(hProfile))
else
result := (_cmsICCcolorSpace(Space) = cmsGetColorSpace(hProfile));
end;
function cmsAllocLUT: LPLUT;
var
NewLUT: LPLUT;
begin
getmem(NewLUT, sizeof(LUT));
if (NewLUT <> nil) then
ZeroMemory(NewLUT, sizeof(LUT));
result := NewLUT;
end;
function DupBlockTab(Org: pointer; size: integer): pointer;
var
mem: pointer;
begin
getmem(mem, size);
CopyMemory(mem, Org, size);
result := mem;
end;
function cmsDupLUT(Orig: LPLUT): LPLUT;
var
NewLUT: LPLUT;
i: integer;
begin
NewLUT := cmsAllocLUT;
CopyMemory(NewLUT, Orig, sizeof(LUT));
for i := 0 to Orig^.InputChan - 1 do
NewLUT^.L1[i] := PWORD(DupBlockTab(Orig^.L1[i], sizeof(WORD) * Orig^.In16params.nSamples));
for i := 0 to Orig^.OutputChan - 1 do
NewLUT^.L2[i] := PWORD(DupBlockTab(Orig^.L2[i], sizeof(WORD) * Orig^.Out16params.nSamples));
NewLUT^.T := PWORD(DupBlockTab(Orig^.T, Orig^.Tsize));
result := NewLUT;
end;
function SIZEOF_UINT8_ALIGNED: integer; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (sizeof(_cmsTestAlign8) - sizeof(icS15Fixed16Number));
end;
// Convert to fixed point encoding is 1.0 = 0xFFFF
procedure VEC3toFix(r: LPWVEC3; v: LPVEC3);
begin
r^.n[VX] := round(v^.n[VX] * 65536 );
r^.n[VY] := round(v^.n[VY] * 65536 );
r^.n[VZ] := round(v^.n[VZ] * 65536 );
end;
procedure MAT3toFix(r: LPWMAT3; v: LPMAT3);
begin
VEC3toFix(@r^.v[0], @v^.v[0]);
VEC3toFix(@r^.v[1], @v^.v[1]);
VEC3toFix(@r^.v[2], @v^.v[2]);
end;
// Check id two vectors are the same, allowing tolerance
function RangeCheck(l, h, v: double): longbool; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (v >= l) and (v <= h);
end;
(*
function FIXED_TO_DOUBLE(x: Fixed32): double;
begin
result := x / 65536;
end;
*)
function VEC3equal(a: LPWVEC3; b: LPWVEC3; Tolerance: double): longbool;
var
i: integer;
c: double;
begin
for i := 0 to 2 do
begin
c := a^.n[i] / 65536;
if (not RangeCheck(c - Tolerance, c + Tolerance, (b^.n[i]/65536) )) then
begin
result := FALSE;
exit;
end;
end;
result := TRUE;
end;
// Check if matrix is Identity. Allow a tolerance as %
function MAT3isIdentity(a: LPWMAT3; Tolerance: double): longbool;
var
i: integer;
Idd: MAT3;
Idf: WMAT3;
begin
MAT3identity(@Idd);
MAT3toFix(@Idf, @Idd);
for i := 0 to 2 do
if (not VEC3equal(@a^.v[i], @Idf.v[i], Tolerance)) then
begin
result := false;
exit;
end;
result := true;
end;
function TO16_TAB(x: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((x) shl 8) or (x));
end;
function _cmsQuantizeVal(i: double; MaxSamples: integer): WORD; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := floor(((i * 65535) / (MaxSamples - 1)) + 0.5);
end;
// Is a table linear?
function cmsIsLinear(Table: pwordarray; nEntries: integer): integer;
var
i, diff: integer;
begin
for i := 0 to nEntries - 1 do
begin
//diff := abs(Table[i] - _cmsQuantizeVal(i, nEntries));
diff := abs(Table[i] - (floor(((i * 65535) / (nEntries - 1)) + 0.5)));
if (diff > 3) then
begin
result := 0;
exit;
end;
end;
result := 1;
end;
function uipow(a, b: integer): dword;
var
rv: dword;
begin
rv := 1;
while b > 0 do
begin
rv := rv * a;
dec(b);
end;
result := rv;
end;
procedure cmsCalcL16Params(nSamples: integer; p: LPL16PARAMS);
begin
p^.nSamples := nSamples;
p^.Domain := (nSamples - 1);
p^.nOutputs := 1;
p^.nInputs := p^.nOutputs;
end;
function FIXED_TO_INT(x: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := ((x) shr 16);
end;
function FIXED_REST_TO_INT(x: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := ((x) and $FFFF);
end;
(*
function FixedLERP(a, l, h: Fixed32): Fixed32;
begin
result := round(((((h - l) * a) / 65536) + l) );
end;
*)
function FixedLERP(a, l, h: Fixed32): Fixed32;
var
dif: double;
begin
dif := h - l;
dif := dif * a;
dif := dif / 65536;
dif := dif + l;
result := round(dif);
end;
// Eval gray LUT having only one input channel
procedure Eval1Input(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, k1, rk, xK0, xK1: Fixed32;
OutChan: integer;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := FIXED_TO_INT(fk);
rk := FIXED_REST_TO_INT(fk);
if StageABC[0] <> $FFFF then
k1 := k0 + 1
else
k1 := k0;
xK0 := p16^.opta1 * k0;
xK1 := p16^.opta1 * k1;
for OutChan := 0 to p16^.nOutputs - 1 do
StageLMN[OutChan] := FixedLERP(rk, LutTable[xK0 + OutChan], LutTable[xK1 + OutChan]);
end;
// Tetrahedral interpolation, using Sakamoto algorithm.
procedure cmsTetrahedralInterp16(Input: pwordarray; Output: pwordarray; LutTable: pwordarray; p: LPL16PARAMS);
var
px, py, pz: double;
x0, y0, z0, x1, y1, z1: integer;
fx, fy, fz: double;
c1, c2, c3: double;
t1, t2: double;
i1: integer;
clutPoints, OutChan, TotalOut: integer;
(*
function DENS(X, Y, Z: integer): double;
begin
result := (LutTable[TotalOut*((Z)+clutPoints*((Y)+clutPoints*(X)))+OutChan])
end;
*)
begin
clutPoints := p^.Domain + 1;
TotalOut := p^.nOutputs;
px := (Input[0] * p^.Domain) / 65535;
py := (Input[1] * p^.Domain) / 65535;
pz := (Input[2] * p^.Domain) / 65535;
x0 := floor(px);
fx := (px - x0);
y0 := floor(py);
fy := (py - y0);
z0 := floor(pz);
fz := (pz - z0);
if Input[0] <> $FFFF then
x1 := x0 + 1
else
x1 := x0;
if Input[1] <> $FFFF then
y1 := y0 + 1
else
y1 := y0;
if Input[2] <> $FFFF then
z1 := z0 + 1
else
z1 := z0;
for OutChan := 0 to TotalOut - 1 do
begin
if (fx >= fy) and (fy >= fz) then
begin
//
i1 := clutPoints * (x1);
t1 := (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + i1)) + OutChan]);
t2 := (LutTable[TotalOut * ((z0) + clutPoints * ((y1) + i1)) + OutChan]);
c1 := t1 - (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
c2 := t2 - t1;
c3 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + i1)) + OutChan]) - t2;
(*
c1 := DENS(x1, y0, z0) - DENS(x0, y0, z0);
c2 := DENS(x1, y1, z0) - DENS(x1, y0, z0);
c3 := DENS(x1, y1, z1) - DENS(x1, y1, z0);
*)
end
else
if (fx >= fz) and (fz >= fy) then
begin
i1 := clutPoints * (x1);
t1 := (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + i1)) + OutChan]);
t2 := (LutTable[TotalOut * ((z1) + clutPoints * ((y0) + i1)) + OutChan]);
c1 := t1 - (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
c2 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + i1)) + OutChan]) - t2;
c3 := t2 - t1;
(*
c1 := DENS(x1, y0, z0) - DENS(x0, y0, z0);
c2 := DENS(x1, y1, z1) - DENS(x1, y0, z1);
c3 := DENS(x1, y0, z1) - DENS(x1, y0, z0);
*)
end
else
if (fz >= fx) and (fx >= fy) then
begin
t1 := (LutTable[TotalOut * ((Z1) + clutPoints * ((Y0) + clutPoints * (X1))) + OutChan]);
t2 := (LutTable[TotalOut * ((Z1) + clutPoints * ((Y0) + clutPoints * (X0))) + OutChan]);
c1 := t1 - t2;
c2 := (LutTable[TotalOut * ((Z1) + clutPoints * ((Y1) + clutPoints * (X1))) + OutChan]) - t1;
c3 := t2 - (LutTable[TotalOut * ((Z0) + clutPoints * ((Y0) + clutPoints * (X0))) + OutChan]);
(*
c1 := DENS(x1, y0, z1) - DENS(x0, y0, z1);
c2 := DENS(x1, y1, z1) - DENS(x1, y0, z1);
c3 := DENS(x0, y0, z1) - DENS(x0, y0, z0);
*)
end
else
if (fy >= fx) and (fx >= fz) then
begin
t1 := (LutTable[TotalOut * ((z0) + clutPoints * ((y1) + clutPoints * (x1))) + OutChan]);
t2 := (LutTable[TotalOut * ((z0) + clutPoints * ((y1) + clutPoints * (x0))) + OutChan]);
c1 := t1 - t2;
c2 := t2 - (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
c3 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + clutPoints * (x1))) + OutChan]) - t1;
(*
c1 := DENS(x1, y1, z0) - DENS(x0, y1, z0);
c2 := DENS(x0, y1, z0) - DENS(x0, y0, z0);
c3 := DENS(x1, y1, z1) - DENS(x1, y1, z0);
*)
end
else
if (fy >= fz) and (fz >= fx) then
begin
t1 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + clutPoints * (x0))) + OutChan]);
t2 := (LutTable[TotalOut * ((z0) + clutPoints * ((y1) + clutPoints * (x0))) + OutChan]);
c1 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + clutPoints * (x1))) + OutChan]) - t1;
c2 := t2 - (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
c3 := t1 - t2;
(*
c1 := DENS(x1, y1, z1) - DENS(x0, y1, z1);
c2 := DENS(x0, y1, z0) - DENS(x0, y0, z0);
c3 := DENS(x0, y1, z1) - DENS(x0, y1, z0);
*)
end
else
if (fz >= fy) and (fy >= fx) then
begin
t1 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + clutPoints * (x0))) + OutChan]);
t2 := (LutTable[TotalOut * ((z1) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
c1 := (LutTable[TotalOut * ((z1) + clutPoints * ((y1) + clutPoints * (x1))) + OutChan]) - t1;
c2 := t1 - t2;
c3 := t2 - (LutTable[TotalOut * ((z0) + clutPoints * ((y0) + clutPoints * (x0))) + OutChan]);
(*
c1 := DENS(x1, y1, z1) - DENS(x0, y1, z1);
c2 := DENS(x0, y1, z1) - DENS(x0, y0, z1);
c3 := DENS(x0, y0, z1) - DENS(x0, y0, z0);
*)
end
else
begin
c3 := 0;
c2 := 0;
c1 := 0;
end;
Output[OutChan] := floor((LutTable[TotalOut * ((Z0) + clutPoints * ((Y0) + clutPoints * (X0))) + OutChan]) + c1 * fx + c2 * fy + c3 * fz + 0.5);
end;
end;
// Trilinear interpolation (16 bits) - float version
(*
procedure cmsTrilinearInterp16(Input: pwordarray; Output: pwordarray; LutTable: pwordarray; p: LPL16PARAMS);
var
px, py, pz: double;
x0, y0, z0,
x1, y1, z1: integer;
clutPoints, TotalOut, OutChan: integer;
fx, fy, fz,
d000, d001, d010, d011,
d100, d101, d110, d111,
dx00, dx01, dx10, dx11,
dxy0, dxy1, dxyz: double;
function LERP(a, l, h: double): double;
begin
result := ((l)+(((h)-(l))*(a)));
end;
function DENS(X, Y, Z: integer): double;
begin
result := (LutTable[TotalOut*((Z)+clutPoints*((Y)+clutPoints*(X)))+OutChan]);
end;
begin
clutPoints := p ^. Domain + 1;
TotalOut := p ^. nOutputs;
px := ( Input[0] * (p^.Domain)) / 65535.0;
py := ( Input[1] * (p^.Domain)) / 65535.0;
pz := ( Input[2] * (p^.Domain)) / 65535.0;
x0 := floor(px); fx := px - x0;
y0 := floor(py); fy := py - y0;
z0 := floor(pz); fz := pz - z0;
if Input[0] <> $FFFF then
x1 := x0 + 1
else
x1 := x0 ;
if Input[1] <> $FFFF then
y1 := y0 + 1
else
y1 := y0;
if Input[2] <> $FFFF then
z1 := z0 + 1
else
z1 := z0;
for OutChan := 0 to TotalOut-1 do begin
d000 := DENS(x0, y0, z0);
d001 := DENS(x0, y0, z1);
d010 := DENS(x0, y1, z0);
d011 := DENS(x0, y1, z1);
d100 := DENS(x1, y0, z0);
d101 := DENS(x1, y0, z1);
d110 := DENS(x1, y1, z0);
d111 := DENS(x1, y1, z1);
dx00 := LERP(fx, d000, d100);
dx01 := LERP(fx, d001, d101);
dx10 := LERP(fx, d010, d110);
dx11 := LERP(fx, d011, d111);
dxy0 := LERP(fy, dx00, dx10);
dxy1 := LERP(fy, dx01, dx11);
dxyz := LERP(fz, dxy0, dxy1);
Output[OutChan] := floor(dxyz + 0.5);
end;
end;
*)
procedure cmsTrilinearInterp16(Input: pwordarray; Output: pwordarray;
LutTable: pwordarray; p: LPL16PARAMS);
var
OutChan, TotalOut: integer;
fx, fy, fz: Fixed32;
rx, ry, rz: WORD;
x0mi, y0mi, z0mi, x1mi, y1mi, z1mi: integer;
X0ma, X1ma, Y0ma, Y1ma, Z0ma, Z1ma: integer;
d000, d001, d010, d011,
d100, d101, d110, d111,
dx00, dx01, dx10, dx11,
dxy0, dxy1, dxyz: integer;
function DENS(i, j, k: integer): integer;
begin
result := (LutTable[(i) + (j) + (k) + OutChan]);
end;
function LERP(a, l, h: integer): word;
begin
result := l + ((((h - l) * a) + $8000) shr 16);
end;
begin
TotalOut := p^.nOutputs;
fx := ToFixedDomain(Input[0] * p^.Domain);
x0mi := FIXED_TO_INT(fx);
rx := FIXED_REST_TO_INT(fx);
fy := ToFixedDomain(Input[1] * p^.Domain);
y0mi := FIXED_TO_INT(fy);
ry := FIXED_REST_TO_INT(fy);
fz := ToFixedDomain(Input[2] * p^.Domain);
z0mi := FIXED_TO_INT(fz);
rz := FIXED_REST_TO_INT(fz);
if Input[0] <> $FFFF then
x1mi := x0mi + (1)
else
x1mi := x0mi + (0);
if Input[1] <> $FFFF then
y1mi := y0mi + (1)
else
y1mi := y0mi + (0);
if Input[2] <> $FFFF then
z1mi := z0mi + (1)
else
z1mi := z0mi + (0);
Z0ma := p^.opta1 * z0mi;
Z1ma := p^.opta1 * z1mi;
Y0ma := p^.opta2 * y0mi;
Y1ma := p^.opta2 * y1mi;
X0ma := p^.opta3 * x0mi;
X1ma := p^.opta3 * x1mi;
for OutChan := 0 to TotalOut - 1 do
begin
d000 := DENS(X0ma, Y0ma, Z0ma);
d001 := DENS(X0ma, Y0ma, Z1ma);
d010 := DENS(X0ma, Y1ma, Z0ma);
d011 := DENS(X0ma, Y1ma, Z1ma);
d100 := DENS(X1ma, Y0ma, Z0ma);
d101 := DENS(X1ma, Y0ma, Z1ma);
d110 := DENS(X1ma, Y1ma, Z0ma);
d111 := DENS(X1ma, Y1ma, Z1ma);
dx00 := LERP(rx, d000, d100);
dx01 := LERP(rx, d001, d101);
dx10 := LERP(rx, d010, d110);
dx11 := LERP(rx, d011, d111);
dxy0 := LERP(ry, dx00, dx10);
dxy1 := LERP(ry, dx01, dx11);
dxyz := LERP(rz, dxy0, dxy1);
Output[OutChan] := dxyz;
end;
end;
procedure Eval4Inputs(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, rk: Fixed32;
xK0, xK1: integer;
T, T1: PWORD;
i: integer;
Tmp1, Tmp2: array[0..MAXCHANNELS - 1] of WORD;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := ((fk) shr 16);
rk := ((fk) and $FFFF);
xK0 := p16^.opta4 * k0;
if StageABC[0] <> $FFFF then
xK1 := p16^.opta4 * (k0 + 1)
else
xK1 := p16^.opta4 * (k0);
p16^.nInputs := 3;
T := pword(LutTable);
inc(T, xK0);
T1 := PWORD(StageABC);
inc(T1);
cmsTetrahedralInterp16(pwordarray(T1), @Tmp1, pwordarray(T), p16);
T := pword(LutTable);
inc(T, xK1);
T1 := PWORD(StageABC);
inc(T1);
cmsTetrahedralInterp16(pwordarray(T1), @Tmp2, pwordarray(T), p16);
p16^.nInputs := 4;
for i := 0 to p16^.nOutputs - 1 do
//StageLMN[i] := FixedLERP(rk, Tmp1[i], Tmp2[i]);
StageLMN[i] := round(((((Tmp2[i] - Tmp1[i]) * rk) / 65536) + Tmp1[i]) );
end;
procedure Eval5Inputs(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, rk: Fixed32;
xK0, xK1: integer;
T, T1: PWORD;
i: integer;
Tmp1, Tmp2: array[0..MAXCHANNELS - 1] of WORD;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := FIXED_TO_INT(fk);
rk := FIXED_REST_TO_INT(fk);
xK0 := p16^.opta5 * k0;
if StageABC[0] <> $FFFF then
xK1 := p16^.opta5 * (k0 + (1))
else
xK1 := p16^.opta5 * (k0);
p16^.nInputs := 4;
T := pword(LutTable);
inc(T, xK0);
T1 := pword(StageABC);
inc(T1);
Eval4Inputs(pwordarray(T1), @Tmp1, pwordarray(T), p16);
T := pword(LutTable);
inc(T, xK1);
T1 := pword(StageABC);
inc(T1);
Eval4Inputs(pwordarray(T1), @Tmp2, pwordarray(T), p16);
p16^.nInputs := 5;
for i := 0 to p16^.nOutputs - 1 do
StageLMN[i] := FixedLERP(rk, Tmp1[i], Tmp2[i]);
end;
procedure Eval6Inputs(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, rk: Fixed32;
xK0, xK1: integer;
T, T1: PWORD;
i: integer;
Tmp1, Tmp2: array[0..MAXCHANNELS - 1] of WORD;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := FIXED_TO_INT(fk);
rk := FIXED_REST_TO_INT(fk);
xK0 := p16^.opta6 * k0;
if StageABC[0] <> $FFFF then
xK1 := p16^.opta6 * (k0 + (1))
else
xK1 := p16^.opta6 * (k0);
p16^.nInputs := 5;
T := pword(LutTable);
inc(T, xK0);
T1 := pword(StageABC);
inc(T1);
Eval5Inputs(pwordarray(T1), @Tmp1, pwordarray(T), p16);
T := pword(LutTable);
inc(T, xK1);
T1 := pword(StageABC);
inc(T1);
Eval5Inputs(pwordarray(T1), @Tmp2, pwordarray(T), p16);
p16^.nInputs := 6;
for i := 0 to p16^.nOutputs - 1 do
StageLMN[i] := FixedLERP(rk, Tmp1[i], Tmp2[i]);
end;
procedure Eval7Inputs(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, rk: Fixed32;
xK0, xK1: integer;
T, T1: PWORD;
i: integer;
Tmp1, Tmp2: array[0..MAXCHANNELS - 1] of WORD;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := FIXED_TO_INT(fk);
rk := FIXED_REST_TO_INT(fk);
xK0 := p16^.opta7 * k0;
if StageABC[0] <> $FFFF then
xK1 := p16^.opta7 * (k0 + (1))
else
xK1 := p16^.opta7 * (k0);
p16^.nInputs := 6;
T := pword(LutTable);
inc(T, xK0);
T1 := pword(StageABC);
inc(T1);
Eval6Inputs(pwordarray(T1), @Tmp1, pwordarray(T), p16);
T := pword(LutTable);
inc(T, xK1);
T1 := pword(StageABC);
inc(T1);
Eval6Inputs(pwordarray(T1), @Tmp2, pwordarray(T), p16);
p16^.nInputs := 7;
for i := 0 to p16^.nOutputs - 1 do
StageLMN[i] := FixedLERP(rk, Tmp1[i], Tmp2[i]);
end;
procedure Eval8Inputs(StageABC: pwordarray; StageLMN: pwordarray; LutTable: pwordarray; p16: LPL16PARAMS);
var
fk: Fixed32;
k0, rk: Fixed32;
xK0, xK1: integer;
T, T1: PWORD;
i: integer;
Tmp1, Tmp2: array[0..MAXCHANNELS - 1] of WORD;
begin
fk := ToFixedDomain(StageABC[0] * p16^.Domain);
k0 := FIXED_TO_INT(fk);
rk := FIXED_REST_TO_INT(fk);
xK0 := p16^.opta8 * k0;
if StageABC[0] <> $FFFF then
xK1 := p16^.opta8 * (k0 + (1))
else
xK1 := p16^.opta8 * (k0);
p16^.nInputs := 7;
T := pword(LutTable);
inc(T, xK0);
T1 := pword(StageABC);
inc(T1);
Eval7Inputs(pwordarray(T1), @Tmp1, pwordarray(T), p16);
T := pword(LutTable);
inc(T, xK1);
T1 := pword(StageABC);
inc(T1);
Eval7Inputs(pwordarray(T1), @Tmp2, pwordarray(T), p16);
p16^.nInputs := 8;
for i := 0 to p16^.nOutputs - 1 do
StageLMN[i] := FixedLERP(rk, Tmp1[i], Tmp2[i]);
end;
// Fills optimization parameters
procedure cmsCalcCLUT16ParamsEx(nSamples: integer; InputChan: integer; OutputChan: integer; lUseTetrahedral: longbool; p: LPL16PARAMS);
var
clutPoints: integer;
begin
cmsCalcL16Params(nSamples, p);
p^.nInputs := InputChan;
p^.nOutputs := OutputChan;
clutPoints := p^.Domain + 1;
p^.opta1 := p^.nOutputs; // Z
p^.opta2 := p^.opta1 * clutPoints; // Y
p^.opta3 := p^.opta2 * clutPoints; // X
p^.opta4 := p^.opta3 * clutPoints; // Used only in 4 inputs LUT
p^.opta5 := p^.opta4 * clutPoints;
p^.opta6 := p^.opta5 * clutPoints; // Used only on 6 inputs LUT
p^.opta7 := p^.opta6 * clutPoints; // Used only on 7 inputs LUT
p^.opta8 := p^.opta7 * clutPoints; // Used only on 8 inputs LUT
case (InputChan) of
1: // Gray LUT
p^.Interp3D := Eval1Input;
3: // RGB et al
if (lUseTetrahedral) then
p^.Interp3D := cmsTetrahedralInterp16
else
p^.Interp3D := cmsTrilinearInterp16;
4: // CMYK LUT
p^.Interp3D := Eval4Inputs;
5: // 5 Inks
p^.Interp3D := Eval5Inputs;
6: // Hexachrome
p^.Interp3D := Eval6Inputs;
7: // 7 inks
p^.Interp3D := Eval7Inputs;
8: // 8 inks
p^.Interp3D := Eval8Inputs;
else
;
//cmsSignalError(LCMS_ERRC_ABORTED, "Unsupported restoration (%d channels)", InputChan);
end;
end;
procedure cmsCalcCLUT16Params(nSamples: integer; InputChan: integer; OutputChan: integer; p: LPL16PARAMS);
begin
cmsCalcCLUT16ParamsEx(nSamples, InputChan, OutputChan, FALSE, p);
end;
procedure VEC3fromFix(r: LPVEC3; v: LPWVEC3);
begin
r^.n[VX] := FIXED_TO_DOUBLE(v^.n[VX]);
r^.n[VY] := FIXED_TO_DOUBLE(v^.n[VY]);
r^.n[VZ] := FIXED_TO_DOUBLE(v^.n[VZ]);
end;
procedure MAT3fromFix(r: LPMAT3; v: LPWMAT3);
begin
VEC3fromFix(@r^.v[0], @v^.v[0]);
VEC3fromFix(@r^.v[1], @v^.v[1]);
VEC3fromFix(@r^.v[2], @v^.v[2]);
end;
procedure FixLUT8(Lut: LPLUT; sig: icTagSignature; nTabSize: integer);
var
Fixup, Original, Result: MAT3;
PtrW: PWORD;
i: integer;
begin
case (sig) of
icSigBToA0Tag,
icSigBToA1Tag,
icSigBToA2Tag,
icSigGamutTag,
icSigPreview0Tag,
icSigPreview1Tag,
icSigPreview2Tag:
begin
VEC3init(@Fixup.v[0], $FFFF / $FF00, 0, 0);
VEC3init(@Fixup.v[1], 0, $FFFF / $FF00, 0);
VEC3init(@Fixup.v[2], 0, 0, $FFFF / $FF00);
MAT3fromFix(@Original, @Lut^.Matrix);
MAT3per(@Result, @Original, @Fixup);
MAT3toFix(@Lut^.Matrix, @Result);
Lut^.wFlags := Lut^.wFlags or LUT_HASMATRIX;
end;
else
begin
PtrW := Lut^.T;
for i := 0 to nTabSize - 1 do
begin
PtrW^ := PtrW^ and $FF00;
inc(PtrW);
end;
end;
end;
end;
procedure ReadLUT8(Icc: LPLCMSICCPROFILE; NewLUT: LPLUT; sig: icTagSignature);
var
LUT8: icLut8;
Temp: pbytearray;
nTabSize: integer;
i, j: dword;
AllLinear: dword;
PtrW: pwordarray;
begin
Icc^.Read(@LUT8, sizeof(icLut8) - SIZEOF_UINT8_ALIGNED, 1, Icc^.stream);
NewLUT^.wFlags := LUT_HASTL1 or LUT_HASTL2 or LUT_HAS3DGRID;
NewLUT^.cLutPoints := LUT8.clutPoints;
NewLUT^.InputChan := LUT8.inputChan;
NewLUT^.OutputChan := LUT8.outputChan;
NewLUT^.InputEntries := 256;
NewLUT^.OutputEntries := 256;
AdjustEndianess32(PBYTE(@LUT8.e00));
AdjustEndianess32(PBYTE(@LUT8.e01));
AdjustEndianess32(PBYTE(@LUT8.e02));
AdjustEndianess32(PBYTE(@LUT8.e10));
AdjustEndianess32(PBYTE(@LUT8.e11));
AdjustEndianess32(PBYTE(@LUT8.e12));
AdjustEndianess32(PBYTE(@LUT8.e20));
AdjustEndianess32(PBYTE(@LUT8.e21));
AdjustEndianess32(PBYTE(@LUT8.e22));
NewLUT^.Matrix.v[0].n[0] := Fixed32(LUT8.e00);
NewLUT^.Matrix.v[0].n[1] := Fixed32(LUT8.e01);
NewLUT^.Matrix.v[0].n[2] := Fixed32(LUT8.e02);
NewLUT^.Matrix.v[1].n[0] := Fixed32(LUT8.e10);
NewLUT^.Matrix.v[1].n[1] := Fixed32(LUT8.e11);
NewLUT^.Matrix.v[1].n[2] := Fixed32(LUT8.e12);
NewLUT^.Matrix.v[2].n[0] := Fixed32(LUT8.e20);
NewLUT^.Matrix.v[2].n[1] := Fixed32(LUT8.e21);
NewLUT^.Matrix.v[2].n[2] := Fixed32(LUT8.e22);
if (not MAT3isIdentity(@NewLUT^.Matrix, 0.0001)) then
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASMATRIX;
end;
getmem(Temp, 256);
AllLinear := 0;
for i := 0 to NewLUT^.InputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * 256);
NewLUT^.L1[i] := pword(PtrW);
Icc^.Read(Temp, 1, 256, Icc^.stream);
for j := 0 to 255 do
PtrW[j] := TO16_TAB(Temp[j]);
AllLinear := AllLinear + cmsIsLinear(pwordarray(NewLUT^.L1[i]), NewLUT^.InputEntries);
end;
if (AllLinear = NewLUT^.InputChan) then
begin
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HASTL1);
end;
freemem(Temp);
nTabSize := (NewLUT^.OutputChan * uipow(NewLUT^.cLutPoints, NewLUT^.InputChan));
if (nTabSize > 0) then
begin
getmem(PtrW, sizeof(WORD) * nTabSize);
getmem(Temp, nTabSize);
Icc^.Read(Temp, 1, nTabSize, Icc^.stream);
NewLUT^.T := pword(PtrW);
NewLUT^.Tsize := (nTabSize * sizeof(WORD));
for i := 0 to nTabSize - 1 do
begin
pword(PtrW)^ := TO16_TAB(Temp[i]);
inc(pword(PtrW));
end;
freemem(Temp);
end
else
begin
NewLUT^.T := nil;
NewLUT^.Tsize := 0;
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HAS3DGRID);
end;
getmem(Temp, 256);
AllLinear := 0;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * 256);
NewLUT^.L2[i] := pword(PtrW);
Icc^.Read(Temp, 1, 256, Icc^.stream);
for j := 0 to 255 do
PtrW[j] := TO16_TAB(Temp[j]);
AllLinear := AllLinear + cmsIsLinear(pwordarray(NewLUT^.L2[i]), 256);
end;
if (AllLinear = NewLUT^.OutputChan) then
begin
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HASTL2);
end;
freemem(Temp);
cmsCalcL16Params(NewLUT^.InputEntries, @NewLUT^.In16params);
cmsCalcL16Params(NewLUT^.OutputEntries, @NewLUT^.Out16params);
cmsCalcCLUT16Params(NewLUT^.cLutPoints, NewLUT^.InputChan,
NewLUT^.OutputChan,
@NewLUT^.CLut16params);
if (Icc^.PCS = icSigLabData) then
FixLUT8(NewLUT, sig, nTabSize);
end;
function SIZEOF_UINT16_ALIGNED: integer;
begin
result := (sizeof(_cmsTestAlign16) - sizeof(icS15Fixed16Number));
end;
procedure xswab(from: pointer; xto: pointer; len: integer);
var
temp: dword;
n: integer;
fp, tp: pbyte;
procedure STEP;
begin
temp := fp^;
inc(fp);
tp^ := fp^;
inc(tp);
inc(fp);
tp^ := temp;
inc(tp);
end;
begin
n := (len shr 1) + 1;
fp := from;
tp := xto;
dec(n);
while ((n) and 07) <> 0 do
begin
STEP;
dec(n);
end;
n := n shr 3;
dec(n);
while (n >= 0) do
begin
STEP;
STEP;
STEP;
STEP;
STEP;
STEP;
STEP;
STEP;
dec(n);
end;
end;
// swap bytes in a array of words
procedure AdjustEndianessArray16(p: PWORD; num_words: integer); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
xswab(p, p, num_words * sizeof(WORD));
end;
procedure ReadLUT16(Icc: LPLCMSICCPROFILE; NewLUT: LPLUT);
var
LUT16: icLut16;
nTabSize: integer;
i: dword;
AllLinear: dword;
PtrW: pword;
begin
Icc^.Read(@LUT16, sizeof(icLut16) - SIZEOF_UINT16_ALIGNED, 1, Icc^.stream);
NewLUT^.wFlags := LUT_HASTL1 or LUT_HASTL2 or LUT_HAS3DGRID;
NewLUT^.cLutPoints := LUT16.clutPoints;
NewLUT^.InputChan := LUT16.inputChan;
NewLUT^.OutputChan := LUT16.outputChan;
AdjustEndianess16(PBYTEARRAY(@LUT16.inputEnt));
AdjustEndianess16(PBYTEARRAY(@LUT16.outputEnt));
NewLUT^.InputEntries := LUT16.inputEnt;
NewLUT^.OutputEntries := LUT16.outputEnt;
AdjustEndianess32(PBYTE(@LUT16.e00));
AdjustEndianess32(PBYTE(@LUT16.e01));
AdjustEndianess32(PBYTE(@LUT16.e02));
AdjustEndianess32(PBYTE(@LUT16.e10));
AdjustEndianess32(PBYTE(@LUT16.e11));
AdjustEndianess32(PBYTE(@LUT16.e12));
AdjustEndianess32(PBYTE(@LUT16.e20));
AdjustEndianess32(PBYTE(@LUT16.e21));
AdjustEndianess32(PBYTE(@LUT16.e22));
NewLUT^.Matrix.v[0].n[0] := Fixed32(LUT16.e00);
NewLUT^.Matrix.v[0].n[1] := Fixed32(LUT16.e01);
NewLUT^.Matrix.v[0].n[2] := Fixed32(LUT16.e02);
NewLUT^.Matrix.v[1].n[0] := Fixed32(LUT16.e10);
NewLUT^.Matrix.v[1].n[1] := Fixed32(LUT16.e11);
NewLUT^.Matrix.v[1].n[2] := Fixed32(LUT16.e12);
NewLUT^.Matrix.v[2].n[0] := Fixed32(LUT16.e20);
NewLUT^.Matrix.v[2].n[1] := Fixed32(LUT16.e21);
NewLUT^.Matrix.v[2].n[2] := Fixed32(LUT16.e22);
if (not MAT3isIdentity(@NewLUT^.Matrix, 0.0001)) then
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASMATRIX;
end;
AllLinear := 0;
for i := 0 to NewLUT^.InputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.InputEntries);
NewLUT^.L1[i] := PtrW;
Icc^.Read(PtrW, sizeof(WORD), NewLUT^.InputEntries, Icc^.stream);
AdjustEndianessArray16(PtrW, NewLUT^.InputEntries);
AllLinear := AllLinear + cmsIsLinear(pwordarray(NewLUT^.L1[i]), NewLUT^.InputEntries);
end;
if (AllLinear = NewLUT^.InputChan) then
begin
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HASTL1);
end;
nTabSize := (NewLUT^.OutputChan * uipow(NewLUT^.cLutPoints, NewLUT^.InputChan));
if (nTabSize > 0) then
begin
getmem(PtrW, sizeof(WORD) * nTabSize);
NewLUT^.T := PtrW;
NewLUT^.Tsize := (nTabSize * sizeof(WORD));
Icc^.Read(PtrW, sizeof(WORD), nTabSize, Icc^.stream);
AdjustEndianessArray16(NewLUT^.T, nTabSize);
end
else
begin
NewLUT^.T := nil;
NewLUT^.Tsize := 0;
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HAS3DGRID);
end;
AllLinear := 0;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.OutputEntries);
NewLUT^.L2[i] := PtrW;
Icc^.Read(PtrW, sizeof(WORD), NewLUT^.OutputEntries, Icc^.stream);
AdjustEndianessArray16(PtrW, NewLUT^.OutputEntries);
AllLinear := AllLinear + cmsIsLinear(pwordarray(NewLUT^.L2[i]), NewLUT^.OutputEntries);
end;
if (AllLinear = NewLUT^.OutputChan) then
begin
NewLUT^.wFlags := NewLUT^.wFlags and (not LUT_HASTL2);
end;
cmsCalcL16Params(NewLUT^.InputEntries, @NewLUT^.In16params);
cmsCalcL16Params(NewLUT^.OutputEntries, @NewLUT^.Out16params);
cmsCalcCLUT16Params(NewLUT^.cLutPoints, NewLUT^.InputChan,
NewLUT^.OutputChan,
@NewLUT^.CLut16params);
end;
function cmsAllocGamma(nEntries: integer): LPGAMMATABLE;
var
p: LPGAMMATABLE;
size: integer;
begin
size := sizeof(GAMMATABLE) + (sizeof(WORD) * (nEntries - 1));
getmem(p, size);
if (p = nil) then
begin
result := nil;
exit;
end;
p^.nEntries := nEntries;
ZeroMemory(@p^.GammaTable, nEntries * sizeof(WORD));
result := p;
end;
function FGamma(R: double; x: double): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := Power(R, x);
end;
// Build a gamma table based on gamma constant
function cmsBuildGamma(nEntries: integer; Gamma: double): LPGAMMATABLE;
var
p: LPGAMMATABLE;
Table: PWORDARRAY;
i: integer;
R, Val: double;
begin
if (nEntries > 65530) then
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Couldn't create gammatable of more than 65530 entries; 65530 assumed");
nEntries := 65530;
end;
p := cmsAllocGamma(nEntries);
if (p = nil) then
begin
result := nil;
exit;
end;
Table := @p^.GammaTable;
if (Gamma = 0.0) then
begin
ZeroMemory(Table, nEntries * sizeof(WORD));
result := p;
exit;
end;
if (Gamma = 1.0) then
begin
for i := 0 to nEntries - 1 do
begin
Table[i] := _cmsQuantizeVal(i, nEntries);
end;
result := p;
exit;
end;
for i := 0 to nEntries - 1 do
begin
R := i / (nEntries - 1);
Val := FGamma(R, Gamma);
Table[i] := floor(Val * 65535 + 0.5);
end;
result := p;
end;
// Fixed point conversion
function Convert8Fixed8(fixed8: WORD): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
var
msb, lsb: BYTE;
begin
lsb := (fixed8 and $FF);
msb := ((fixed8 shr 8) and $FF);
result := (msb + (lsb / 256));
end;
procedure cmsFreeGamma(Gamma: LPGAMMATABLE);
begin
if (Gamma <> nil) then
freemem(Gamma);
end;
function cmsBuildParametricGamma(nEntries: integer; xType: integer; Params: pdoublearray): LPGAMMATABLE;
var
Table: LPGAMMATABLE;
R, Val, dval, e: double;
i: integer;
begin
Table := cmsAllocGamma(nEntries);
if (Table = nil) then
begin
result := nil;
exit;
end;
for i := 0 to nEntries - 1 do
begin
R := i / (nEntries - 1);
case (xType) of
1:
Val := Power(R, Params[0]);
-1:
Val := Power(R, 1 / Params[0]);
2:
if (R >= -Params[2] / Params[1]) then
begin
e := Params[1] * R + Params[2];
if (e > 0) then
Val := Power(e, Params[0])
else
Val := 0;
end
else
Val := 0;
-2:
begin
Val := (Power(R, 1.0 / Params[0]) - Params[2]) / Params[1];
if (Val < 0) then
Val := 0;
end;
3:
if (R >= -Params[2] / Params[1]) then
begin
e := Params[1] * R + Params[2];
Val := Power(e, Params[0]) + Params[3];
end
else
Val := Params[3];
-3:
if (R >= Params[3]) then
begin
e := R - Params[3];
Val := (Power(e, 1 / Params[0]) - Params[2]) / Params[1];
if (Val < 0) then
Val := 0;
end
else
begin
Val := -Params[2] / Params[1];
end;
4:
if (R >= Params[4]) then
begin
e := Params[1] * R + Params[2];
if (e > 0) then
Val := Power(e, Params[0])
else
Val := 0;
end
else
Val := R * Params[3];
-4:
if (R >= Power(Params[1] * Params[4] + Params[2], Params[0])) then
begin
Val := (Power(R, 1.0 / Params[0]) - Params[2]) / Params[1];
end
else
begin
Val := R / Params[3];
end;
5:
if (R >= Params[4]) then
begin
e := Params[1] * R + Params[2];
Val := Power(e, Params[0]) + Params[5];
end
else
Val := R * Params[3] + Params[6];
-5:
if (R >= Power(Params[1] * Params[4], Params[0]) + Params[5]) then
begin
Val := Power(R - Params[5], 1 / Params[0]) - Params[2] / Params[1];
end
else
begin
Val := (R - Params[6]) / Params[3];
end;
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Unsupported parametric curve type=%d", abs(xType)-1);
cmsFreeGamma(Table);
result := nil;
exit;
end;
end;
dval := Val * 65535.0 + 0.5;
if (dval > 65535) then
dval := 65535;
if (dval < 0) then
dval := 0;
Table^.GammaTable[i] := floor(dval);
end;
result := Table;
end;
function ReadCurve(Icc: LPLCMSICCPROFILE): LPGAMMATABLE;
const
ParamsByType: array[0..4] of integer = (1, 3, 4, 5, 7);
var
Count: icUInt32Number;
NewGamma: LPGAMMATABLE;
Base: icTagBase;
n: integer;
SingleGammaFixed: WORD;
Params: array[0..9] of double;
Num: icS15Fixed16Number;
Reserved: icUInt32Number;
xType: icUInt16Number;
i: integer;
begin
Icc^.Read(@Base, 1, sizeof(icTagBase), Icc^.stream);
AdjustEndianess32(@Base.sig);
case (Base.sig) of
icTagTypeSignature($9478EE00),
icSigCurveType:
begin
Icc^.Read(@Count, sizeof(icUInt32Number), 1, Icc^.stream);
AdjustEndianess32(@Count);
case (Count) of
0:
begin
NewGamma := cmsAllocGamma(2);
if (NewGamma = nil) then
begin
result := nil;
exit;
end;
pwordarray(@NewGamma^.GammaTable)[0] := 0;
pwordarray(@NewGamma^.GammaTable)[1] := $FFFF;
result := NewGamma;
exit;
end;
1:
begin
Icc^.Read(@SingleGammaFixed, sizeof(WORD), 1, Icc^.stream);
AdjustEndianess16(@SingleGammaFixed);
result := cmsBuildGamma(4096, Convert8Fixed8(SingleGammaFixed));
exit;
end;
else
begin
NewGamma := cmsAllocGamma(Count);
if (NewGamma = nil) then
begin
result := nil;
exit;
end;
Icc^.Read(@NewGamma^.GammaTable, sizeof(WORD), Count, Icc^.stream);
AdjustEndianessArray16(@NewGamma^.GammaTable, Count);
result := NewGamma;
exit;
end;
end;
end;
icTagTypeSignature(icSigParametricCurveType):
begin
Icc^.Read(@xType, sizeof(icUInt16Number), 1, Icc^.stream);
Icc^.Read(@Reserved, sizeof(icUInt16Number), 1, Icc^.stream);
AdjustEndianess16(@xType);
if (xType > 5) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Unknown parametric curve type '%d' found.", xType);
result := nil;
exit;
end;
ZeroMemory(@Params, 10 * sizeof(double));
n := ParamsByType[xType];
for i := 0 to n - 1 do
begin
Num := 0;
Icc^.Read(@Num, sizeof(icS15Fixed16Number), 1, Icc^.stream);
Params[i] := Convert15Fixed16(Num);
end;
NewGamma := cmsBuildParametricGamma(4096, xType + 1, @Params);
result := NewGamma;
exit;
end;
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Bad tag signature '%lx' found.", Base.sig);
result := nil;
exit;
end;
end;
end;
function cmsAllocLinearTable(NewLUT: LPLUT; Tables: LPGAMMATABLEArray; nTable: integer): LPLUT;
var
i: dword;
PtrW: PWORD;
begin
case (nTable) of
1:
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASTL1;
cmsCalcL16Params(Tables[0]^.nEntries, @NewLUT^.In16params);
NewLUT^.InputEntries := Tables[0]^.nEntries;
for i := 0 to NewLUT^.InputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.InputEntries);
NewLUT^.L1[i] := PtrW;
CopyMemory(PtrW, @Tables[i]^.GammaTable, sizeof(WORD) * NewLUT^.InputEntries);
end;
end;
2:
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASTL2;
cmsCalcL16Params(Tables[0]^.nEntries, @NewLUT^.Out16params);
NewLUT^.OutputEntries := Tables[0]^.nEntries;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.OutputEntries);
NewLUT^.L2[i] := PtrW;
CopyMemory(PtrW, @Tables[i]^.GammaTable, sizeof(WORD) * NewLUT^.OutputEntries);
end;
end;
3:
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASTL3;
cmsCalcL16Params(Tables[0]^.nEntries, @NewLUT^.L3params);
NewLUT^.L3Entries := Tables[0]^.nEntries;
for i := 0 to NewLUT^.InputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.L3Entries);
NewLUT^.L3[i] := PtrW;
CopyMemory(PtrW, @Tables[i]^.GammaTable, sizeof(WORD) * NewLUT^.L3Entries);
end;
end;
4:
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HASTL4;
cmsCalcL16Params(Tables[0]^.nEntries, @NewLUT^.L4params);
NewLUT^.L4Entries := Tables[0]^.nEntries;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
getmem(PtrW, sizeof(WORD) * NewLUT^.L4Entries);
NewLUT^.L4[i] := PtrW;
CopyMemory(PtrW, @Tables[i]^.GammaTable, sizeof(WORD) * NewLUT^.L4Entries);
end;
end;
end;
result := NewLUT;
end;
// Read a set of curves from specific offset
function ReadSetOfCurves(Icc: LPLCMSICCPROFILE; Offset: integer; NewLUT: LPLUT; nLocation: integer): longbool;
var
Curves: array[0..MAXCHANNELS - 1] of LPGAMMATABLE;
i, nCurves: dword;
begin
if (Icc^.Seek(Icc^.stream, Offset)) then
begin
result := FALSE;
exit;
end;
if (nLocation = 1) or (nLocation = 3) then
nCurves := NewLUT^.InputChan
else
nCurves := NewLUT^.OutputChan;
try
// 3.0.1
for i := 0 to nCurves - 1 do
Curves[i] := nil;
for i := 0 to nCurves - 1 do
begin
Curves[i] := ReadCurve(LPLCMSICCPROFILE(Icc));
// 3.0.2
if Curves[i]=nil then
begin
result := FALSE;
exit;
end;
end;
cmsAllocLinearTable(NewLUT, @Curves, nLocation);
result := TRUE;
finally
for i := 0 to nCurves - 1 do
cmsFreeGamma(Curves[i]);
end;
end;
function cmsSetMatrixLUT4(Lut: LPLUT; M: LPMAT3; off: LPVEC3; dwFlags: DWORD): LPLUT;
const
Zero: VEC3 = (n: (0, 0, 0));
var
WMat: WMAT3;
Woff: WVEC3;
begin
MAT3toFix(@WMat, M);
if (off = nil) then
off := @Zero;
VEC3toFix(@Woff, off);
if MAT3isIdentity(@WMat, 0.0001) and (Woff.n[VX] = 0) and (Woff.n[VY] = 0) and (Woff.n[VZ] = 0) then
begin
result := Lut;
exit;
end;
case (dwFlags) of
LUT_HASMATRIX:
begin
Lut^.Matrix := WMat;
Lut^.wFlags := Lut^.wFlags or LUT_HASMATRIX;
end;
LUT_HASMATRIX3:
begin
Lut^.Mat3 := WMat;
Lut^.Ofs3 := Woff;
Lut^.wFlags := Lut^.wFlags or LUT_HASMATRIX3;
end;
LUT_HASMATRIX4:
begin
Lut^.Mat4 := WMat;
Lut^.Ofs4 := Woff;
Lut^.wFlags := Lut^.wFlags or LUT_HASMATRIX4;
end;
end;
result := Lut;
end;
function ReadMatrixOffset(Icc: LPLCMSICCPROFILE; Offset: integer; NewLUT: LPLUT; dwFlags: DWORD): longbool;
var
All: array[0..11] of icS15Fixed16Number;
i: integer;
m: MAT3;
o: VEC3;
begin
if (Icc^.Seek(Icc^.stream, Offset)) then
begin
result := FALSE;
exit;
end;
Icc^.Read(@All, sizeof(icS15Fixed16Number), 12, Icc^.stream);
for i := 0 to 11 do
AdjustEndianess32(@All[i]);
m.v[0].n[0] := FIXED_TO_DOUBLE(Fixed32(All[0]));
m.v[0].n[1] := FIXED_TO_DOUBLE(Fixed32(All[1]));
m.v[0].n[2] := FIXED_TO_DOUBLE(Fixed32(All[2]));
m.v[1].n[0] := FIXED_TO_DOUBLE(Fixed32(All[3]));
m.v[1].n[1] := FIXED_TO_DOUBLE(Fixed32(All[4]));
m.v[1].n[2] := FIXED_TO_DOUBLE(Fixed32(All[5]));
m.v[2].n[0] := FIXED_TO_DOUBLE(Fixed32(All[6]));
m.v[2].n[1] := FIXED_TO_DOUBLE(Fixed32(All[7]));
m.v[2].n[2] := FIXED_TO_DOUBLE(Fixed32(All[8]));
o.n[0] := FIXED_TO_DOUBLE(Fixed32(All[9]));
o.n[1] := FIXED_TO_DOUBLE(Fixed32(All[10]));
o.n[2] := FIXED_TO_DOUBLE(Fixed32(All[11]));
cmsSetMatrixLUT4(NewLUT, @m, @o, dwFlags);
result := TRUE;
end;
function cmsAlloc3DGrid(NewLUT: LPLUT; clutPoints: integer; inputChan: integer; outputChan: integer): LPLUT;
var
nTabSize: DWORD;
begin
NewLUT^.wFlags := NewLUT^.wFlags or LUT_HAS3DGRID;
NewLUT^.cLutPoints := clutPoints;
NewLUT^.InputChan := inputChan;
NewLUT^.OutputChan := outputChan;
nTabSize := (NewLUT^.OutputChan * UIpow(NewLUT^.cLutPoints, NewLUT^.InputChan) * sizeof(WORD));
getmem(NewLUT^.T, nTabSize);
ZeroMemory(NewLUT^.T, nTabSize);
NewLUT^.Tsize := nTabSize;
cmsCalcCLUT16Params(NewLUT^.cLutPoints, NewLUT^.InputChan,
NewLUT^.OutputChan,
@NewLUT^.CLut16params);
result := NewLUT;
end;
function ReadCLUT(Icc: LPLCMSICCPROFILE; Offset: integer; NewLUT: LPLUT): longbool;
var
CLUT: icCLutStruct;
v: byte;
i: dword;
begin
if (Icc^.Seek(Icc^.stream, Offset)) then
begin
result := FALSE;
exit;
end;
Icc^.Read(@CLUT, sizeof(icCLutStruct), 1, Icc^.stream);
cmsAlloc3DGrid(NewLUT, CLUT.gridPoints[0], NewLUT^.InputChan,
NewLUT^.OutputChan);
if (CLUT.prec = 1) then
begin
for i := 0 to NewLUT^.Tsize - 1 do
begin
Icc^.Read(@v, sizeof(BYTE), 1, Icc^.stream);
pwordarray(NewLUT^.T)^[i] := TO16_TAB(v);
end;
end
else
if (CLUT.prec = 2) then
begin
Icc^.Read(NewLUT^.T, sizeof(WORD), NewLUT^.Tsize div sizeof(WORD), Icc^.stream);
AdjustEndianessArray16(NewLUT^.T, NewLUT^.Tsize div sizeof(WORD));
end
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Unknow precission of '%d'", CLUT.prec);
result := FALSE;
exit;
end;
result := TRUE;
end;
function ReadLUT_A2B(Icc: LPLCMSICCPROFILE; NewLUT: LPLUT; BaseOffset: integer; sig: icTagSignature): longbool;
var
LUT16: icLutAtoB;
begin
result := true;
Icc^.Read(@LUT16, sizeof(icLutAtoB), 1, Icc^.stream);
NewLUT^.InputChan := LUT16.inputChan;
NewLUT^.OutputChan := LUT16.outputChan;
AdjustEndianess32(@LUT16.offsetB);
AdjustEndianess32(@LUT16.offsetMat);
AdjustEndianess32(@LUT16.offsetM);
AdjustEndianess32(@LUT16.offsetC);
AdjustEndianess32(@LUT16.offsetA);
if (LUT16.offsetB <> 0) then
result := result and ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetB, NewLUT, 2); // 3.0.2
if (LUT16.offsetMat <> 0) then
ReadMatrixOffset(Icc, BaseOffset + LUT16.offsetMat, NewLUT, LUT_HASMATRIX4);
if (LUT16.offsetM <> 0) then
result := result and ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetM, NewLUT, 4); // 3.0.2
if (LUT16.offsetC <> 0) then
ReadCLUT(Icc, BaseOffset + LUT16.offsetC, NewLUT);
if (LUT16.offsetA <> 0) then
result := result and ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetA, NewLUT, 1); // 3.0.2
if (Icc^.PCS = icSigLabData) then
begin
case (sig) of
icSigAToB0Tag,
icSigAToB1Tag,
icSigAToB2Tag,
icSigGamutTag,
icSigPreview0Tag,
icSigPreview1Tag,
icSigPreview2Tag:
NewLUT^.wFlags := NewLUT^.wFlags or LUT_V4_INPUT_EMULATE_V2;
end;
end;
end;
function ReadLUT_B2A(Icc: LPLCMSICCPROFILE; NewLUT: LPLUT; BaseOffset: integer; sig: icTagSignature): longbool;
var
LUT16: icLutBtoA;
begin
Icc^.Read(@LUT16, sizeof(icLutBtoA), 1, Icc^.stream);
NewLUT^.InputChan := LUT16.inputChan;
NewLUT^.OutputChan := LUT16.outputChan;
AdjustEndianess32(@LUT16.offsetB);
AdjustEndianess32(@LUT16.offsetMat);
AdjustEndianess32(@LUT16.offsetM);
AdjustEndianess32(@LUT16.offsetC);
AdjustEndianess32(@LUT16.offsetA);
if (LUT16.offsetB <> 0) then
ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetB, NewLUT, 1);
if (LUT16.offsetMat <> 0) then
ReadMatrixOffset(Icc, BaseOffset + LUT16.offsetMat, NewLUT, LUT_HASMATRIX3);
if (LUT16.offsetM <> 0) then
ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetM, NewLUT, 3);
if (LUT16.offsetC <> 0) then
ReadCLUT(Icc, BaseOffset + LUT16.offsetC, NewLUT);
if (LUT16.offsetA <> 0) then
ReadSetOfCurves(Icc, BaseOffset + LUT16.offsetA, NewLUT, 2);
if (Icc^.PCS = icSigLabData) then
begin
case (sig) of
icSigBToA0Tag,
icSigBToA1Tag,
icSigBToA2Tag,
icSigGamutTag,
icSigPreview0Tag,
icSigPreview1Tag,
icSigPreview2Tag:
NewLUT^.wFlags := NewLUT^.wFlags or LUT_V4_OUTPUT_EMULATE_V2;
end;
end;
result := TRUE;
end;
// CLUT main reader
function cmsReadICCLut(hProfile: cmsHPROFILE; sig: icTagSignature): LPLUT;
var
Icc: LPLCMSICCPROFILE;
Base: icTagBase;
n: integer;
offset: integer;
NewLUT: LPLUT;
begin
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Tag not found");
result := nil;
exit;
end;
if (Icc^.stream = nil) then
begin
result := cmsDupLUT(LPLUT(Icc^.TagPtrs[n]));
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := nil;
exit;
end;
Icc^.Read(@Base, sizeof(icTagBase), 1, Icc^.stream);
AdjustEndianess32(pbyte(@Base.sig));
NewLUT := cmsAllocLUT();
if (NewLUT = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "cmsAllocLUT() failed");
result := nil;
exit;
end;
case (Base.sig) of
icSigLut8Type: ReadLUT8(Icc, NewLUT, sig);
icSigLut16Type: ReadLUT16(Icc, NewLUT);
icTagTypeSignature(icSiglutAtoBType):
begin
// 3.0.2
if not ReadLUT_A2B(Icc, NewLUT, offset, sig) then
begin
cmsFreeLUT(NewLUT);
result := nil;
exit;
end;
end;
icTagTypeSignature(icSiglutBtoAType): ReadLUT_B2A(Icc, NewLUT, offset, sig);
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Bad tag signature %lx found.", Base.sig);
cmsFreeLUT(NewLUT);
result := nil;
exit;
end;
end;
result := NewLUT;
end;
procedure PrecalculatedXFORM(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: dword);
var
accum: pbyte;
output: pbyte;
wIn, wOut: array[0..MAXCHANNELS - 1] of WORD;
i, n: dword;
begin
accum := xin;
output := xout;
n := Size;
for i := 0 to n - 1 do
begin
accum := p^.FromInput(p, @wIn, accum);
cmsEvalLUT(p^.DeviceLink, @wIn, @wOut);
output := p^.ToOutput(p, @wOut, output);
end;
end;
procedure CachedXFORM(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: dword);
var
accum: pbyte;
output: pbyte;
wIn, wOut: array[0..MAXCHANNELS - 1] of WORD;
i, n: dword;
begin
accum := PBYTE(xin);
output := PBYTE(xout);
n := Size;
ZeroMemory(@wIn, sizeof(WORD) * MAXCHANNELS);
ZeroMemory(@wOut, sizeof(WORD) * MAXCHANNELS);
for i := 0 to n - 1 do
begin
with p^ do
begin
accum := FromInput(p, @wIn, accum);
// it seems that disabling cache it speed up!
(*
if (comparemem(@wIn, @p ^.CacheIn, sizeof(WORD) * MAXCHANNELS) ) then
begin
CopyMemory(@wOut, @p ^.CacheOut, sizeof(WORD) * MAXCHANNELS);
end
else
begin
*)
//CopyMemory(@p ^.CacheIn, @wIn, sizeof(WORD) * MAXCHANNELS);
cmsEvalLUT(DeviceLink, @wIn, @wOut);
//CopyMemory(@p ^.CacheOut, @wOut, sizeof(WORD) * MAXCHANNELS);
//end;
output := ToOutput(p, @wOut, output);
end;
end;
end;
procedure SetPrecalculatedTransform(p: _LPcmsTRANSFORM; dwFlags: DWORD);
begin
p^.xform := PrecalculatedXFORM;
if ((dwFlags and cmsFLAGS_NOTCACHE) = 0) then
begin
ZeroMemory(@p^.CacheIn, sizeof(WORD) * MAXCHANNELS);
cmsEvalLUT(p^.DeviceLink, @p^.CacheIn, @p^.CacheOut);
p^.xform := CachedXFORM;
end;
end;
// Transform is identified as device-link
function CreateDeviceLinkTransform(p: _LPcmsTRANSFORM; dwFlags: DWORD): cmsHPROFILE;
begin
if (not IsProperColorSpace(p^.InputProfile, p^.InputFormat, FALSE)) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Device link is operating on wrong colorspace on input");
result := nil;
exit;
end;
if (not IsProperColorSpace(p^.InputProfile, p^.OutputFormat, TRUE)) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Device link is operating on wrong colorspace on output");
result := nil;
exit;
end;
p^.DeviceLink := cmsReadICCLut(p^.InputProfile, icSigAToB0Tag);
if (p^.DeviceLink = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Noncompliant device-link profile");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
if (p^.PreviewProfile <> nil) then
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Proofing not supported on device link transforms");
end;
if (p^.OutputProfile <> nil) then
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Output profile should be NULL, since this is a device-link transform");
end;
p^.Phase1 := -1;
p^.Phase2 := -1;
p^.Phase3 := -1;
SetPrecalculatedTransform(p, dwFlags);
p^.ExitColorSpace := cmsGetPCS(p^.InputProfile);
// Precalculated device-link profile is ready
result := cmsHTRANSFORM(p);
end;
function cmsAllocNamedColorList(n: integer): LPcmsNAMEDCOLORLIST;
var
size: integer;
v: LPcmsNAMEDCOLORLIST;
begin
size := sizeof(cmsNAMEDCOLORLIST) + (n - 1) * sizeof(cmsNAMEDCOLOR);
getmem(v, size);
if (v = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Out of memory creating named color list");
result := nil;
exit;
end;
ZeroMemory(v, size);
v^.nColors := n;
v^.Allocated := n;
v^.Prefix[0] := #0;
v^.Suffix[0] := #0;
result := v;
end;
function CheckHeader(v: LPcmsNAMEDCOLORLIST; nc2: PicNamedColor2): longbool;
begin
if (v^.Prefix[0] = #0) and (v^.Suffix[0] = #0) and (v^.ColorantCount = 0) then
begin
result := TRUE;
exit;
end;
if (strcomp(PAnsiChar(@v^.Prefix), PAnsiChar(@nc2^.prefix)) <> 0) then
begin
result := FALSE;
exit;
end;
if (strcomp(PAnsiChar(@v^.Suffix), PAnsiChar(@nc2^.suffix)) <> 0) then
begin
result := FALSE;
exit;
end;
result := (v^.ColorantCount = nc2^.nDeviceCoords);
end;
function GrowNamedColorList(v: LPcmsNAMEDCOLORLIST; ByElements: integer): LPcmsNAMEDCOLORLIST;
var
TheNewList: LPcmsNAMEDCOLORLIST;
NewElements: integer;
begin
if (ByElements > v^.Allocated) then
begin
if (v^.Allocated = 0) then
NewElements := 64
else
NewElements := v^.Allocated;
while (ByElements > NewElements) do
NewElements := NewElements * 2;
getmem(TheNewList, sizeof(cmsNAMEDCOLORLIST) + (sizeof(cmsNAMEDCOLOR) * NewElements));
if (TheNewList = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Out of memory reallocating named color list");
result := nil;
exit;
end
else
begin
CopyMemory(TheNewList, v, sizeof(cmsNAMEDCOLORLIST) + (v^.nColors - 1) * sizeof(cmsNAMEDCOLOR));
TheNewList^.Allocated := NewElements;
freemem(v);
result := TheNewList;
exit;
end;
end;
result := v;
end;
function cmsAppendNamedColor(xform: cmsHTRANSFORM; Name: PAnsiChar; PCS: pwordarray; Colorant: pwordarray): longbool;
var
v: _LPcmsTRANSFORM;
List: LPcmsNAMEDCOLORLIST;
i: integer;
begin
v := _LPcmsTRANSFORM(xform);
if (v^.NamedColorList = nil) then
begin
result := FALSE;
exit;
end;
v^.NamedColorList := GrowNamedColorList(v^.NamedColorList, v^.NamedColorList^.nColors + 1);
List := v^.NamedColorList;
for i := 0 to MAXCHANNELS - 1 do
List^.List[List^.nColors].DeviceColorant[i] := Colorant[i];
for i := 0 to 2 do
List^.List[List^.nColors].PCS[i] := PCS[i];
strlcopy(List^.List[List^.nColors].Name, Name, MAX_PATH - 1);
inc(List^.nColors);
result := TRUE;
end;
function cmsReadICCnamedColorList(xform: cmsHTRANSFORM; hProfile: cmsHPROFILE; sig: icTagSignature): integer;
var
v: _LPcmsTRANSFORM;
Icc: LPLCMSICCPROFILE;
n: integer;
Base: icTagBase;
offset: integer;
size: integer;
nc2: icNamedColor2;
i, j: integer;
PCS: array[0..2] of WORD;
Colorant: array[0..MAXCHANNELS - 1] of WORD;
Root: array[0..32] of AnsiChar;
begin
v := _LPcmsTRANSFORM(xform);
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Named color tag not found");
result := 0;
exit;
end;
if (Icc^.stream = nil) then
begin
size := Icc^.TagSizes[n];
if (v^.NamedColorList <> nil) then
cmsFreeNamedColorList(v^.NamedColorList);
getmem(v^.NamedColorList, size);
CopyMemory(v^.NamedColorList, Icc^.TagPtrs[n], size);
result := v^.NamedColorList^.nColors;
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := 0;
exit;
end;
Icc^.Read(@Base, 1, sizeof(icTagBase), Icc^.stream);
AdjustEndianess32(@Base.sig);
case (Base.sig) of
icSigNamedColorType:
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Ancient named color profiles are not supported.");
result := 0;
exit;
end;
icSigNamedColor2Type:
begin
Icc^.Read(@nc2, sizeof(icNamedColor2) - SIZEOF_UINT8_ALIGNED, 1, Icc^.stream);
AdjustEndianess32(@nc2.vendorFlag);
AdjustEndianess32(@nc2.count);
AdjustEndianess32(@nc2.nDeviceCoords);
if (not CheckHeader(v^.NamedColorList, @nc2)) then
begin
//cmsSignalError(LCMS_ERRC_WARNING, "prefix/suffix/device for named color profiles mismatch.");
end;
strlcopy(v^.NamedColorList^.Prefix, @nc2.prefix, 32);
strlcopy(v^.NamedColorList^.Suffix, @nc2.suffix, 32);
v^.NamedColorList^.Suffix[32] := #0;
v^.NamedColorList^.Prefix[32] := v^.NamedColorList^.Suffix[32];
v^.NamedColorList^.ColorantCount := nc2.nDeviceCoords;
for i := 0 to nc2.count - 1 do
begin
ZeroMemory(@Colorant, sizeof(WORD) * MAXCHANNELS);
Icc^.Read(@Root, 1, 32, Icc^.stream);
Icc^.Read(@PCS, 3, sizeof(WORD), Icc^.stream);
for j := 0 to 2 do
AdjustEndianess16(@PCS[j]);
Icc^.Read(@Colorant, sizeof(WORD), nc2.nDeviceCoords, Icc^.stream);
for j := 0 to nc2.nDeviceCoords - 1 do
AdjustEndianess16(@Colorant[j]);
cmsAppendNamedColor(v, Root, @PCS, @Colorant);
end;
result := v^.NamedColorList^.nColors;
exit;
end;
else
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Bad tag signature '%lx' found.", Base.sig);
result := 0;
exit;
end;
end;
end;
procedure NC2deviceXform(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: integer);
var
accum: pbyte;
output: pbyte;
wIn, wOut: array[0..MAXCHANNELS - 1] of WORD;
i: dword;
begin
accum := xin;
output := xout;
for i := 0 to Size - 1 do
begin
accum := p^.FromInput(p, @wIn, accum);
CopyMemory(@wOut, @(p^.NamedColorList^.List[wIn[0]].DeviceColorant), sizeof(WORD) * MAXCHANNELS);
output := p^.ToOutput(p, @wOut, output);
end;
end;
function GetPhase(hProfile: cmsHPROFILE): integer;
begin
case (cmsGetPCS(hProfile)) of
icSigXYZData:
begin
result := XYZRel;
exit;
end;
icSigLabData:
begin
result := LabRel;
exit;
end;
else
; //cmsSignalError(LCMS_ERRC_ABORTED, "Invalid PCS");
end;
result := XYZRel;
end;
function cmsIsTag(hProfile: cmsHPROFILE; sig: icTagSignature): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := SearchTag(Icc, sig) >= 0;
end;
procedure cmsSetDeviceClass(hProfile: cmsHPROFILE; sig: icProfileClassSignature);
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Icc^.DeviceClass := sig;
end;
procedure cmsSetColorSpace(hProfile: cmsHPROFILE; sig: icColorSpaceSignature);
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Icc^.ColorSpace := sig;
end;
procedure cmsSetPCS(hProfile: cmsHPROFILE; pcs: icColorSpaceSignature);
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Icc^.PCS := pcs;
end;
function InitTag(Icc: LPLCMSICCPROFILE; sig: icTagSignature; size: integer; Init: pointer): pointer;
var
Ptr: pointer;
i: icInt32Number;
begin
i := SearchTag(Icc, sig);
if (i >= 0) then
begin
if (Icc^.TagPtrs[i] <> nil) then
freemem(Icc^.TagPtrs[i]);
end
else
begin
i := Icc^.TagCount;
inc(Icc^.TagCount);
end;
getmem(Ptr, size);
CopyMemory(Ptr, Init, size);
Icc^.TagNames[i] := sig;
Icc^.TagSizes[i] := size;
Icc^.TagPtrs[i] := Ptr;
result := Ptr;
end;
function _cmsAddTextTag(hProfile: cmsHPROFILE; sig: icTagSignature; Text: PAnsiChar): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, IEStrLen(Text) + 1, Text);
result := TRUE;
end;
procedure cmsSetRenderingIntent(hProfile: cmsHPROFILE; RenderingIntent: integer);
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Icc^.RenderingIntent := icRenderingIntent(RenderingIntent);
end;
function _cmsAddXYZTag(hProfile: cmsHPROFILE; sig: icTagSignature; XYZ: LPcmsCIEXYZ): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, sizeof(cmsCIEXYZ), XYZ);
result := TRUE;
end;
function SizeOfGammaTab(xIn: LPGAMMATABLE): integer;
begin
result := sizeof(GAMMATABLE) + (xIn^.nEntries - 1) * sizeof(WORD);
end;
function _cmsAddGammaTag(hProfile: cmsHPROFILE; sig: icTagSignature; TransferFunction: LPGAMMATABLE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, SizeOfGammaTab(TransferFunction), TransferFunction);
result := TRUE;
end;
function DupBlock(Icc: LPLCMSICCPROFILE; Block: pointer; size: integer): pointer;
begin
if (Block <> nil) and (size > 0) then
result := InitTag(Icc, icTagSignature(0), size, Block)
else
result := nil;
end;
function _cmsAddLUTTag(hProfile: cmsHPROFILE; sig: icTagSignature; xlut: pointer): longbool;
var
Icc: LPLCMSICCPROFILE;
Orig, Stored: LPLUT;
i: dword;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Orig := LPLUT(xlut);
Stored := LPLUT(InitTag(Icc, icTagSignature(sig), sizeof(LUT), xlut));
for i := 0 to Orig^.InputChan - 1 do
Stored^.L1[i] := DupBlock(Icc, Orig^.L1[i], sizeof(WORD) * Orig^.In16params.nSamples);
for i := 0 to Orig^.OutputChan - 1 do
Stored^.L2[i] := DupBlock(Icc, Orig^.L2[i], sizeof(WORD) * Orig^.Out16params.nSamples);
Stored^.T := DupBlock(Icc, Orig^.T, Orig^.Tsize);
result := TRUE;
end;
function _cmsAddChromaticityTag(hProfile: cmsHPROFILE; sig: icTagSignature; Chrm: LPcmsCIExyYTRIPLE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, sizeof(cmsCIExyYTRIPLE), Chrm);
result := TRUE;
end;
function _cmsAddSequenceDescriptionTag(hProfile: cmsHPROFILE; sig: icTagSignature; pseq: LPcmsSEQ): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, sizeof(integer) + pseq^.n * sizeof(cmsPSEQDESC), pseq);
result := TRUE;
end;
function _cmsAddNamedColorTag(hProfile: cmsHPROFILE; sig: icTagSignature; nc: LPcmsNAMEDCOLORLIST): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
InitTag(Icc, sig, sizeof(cmsNAMEDCOLORLIST) + (nc^.nColors - 1) * sizeof(cmsNAMEDCOLOR), nc);
result := FALSE;
end;
function cmsAddTag(hProfile: cmsHPROFILE; sig: icTagSignature; Tag: pointer): longbool;
var
rc: longbool;
begin
case (sig) of
icSigCharTargetTag,
icSigCopyrightTag,
icSigProfileDescriptionTag,
icSigDeviceMfgDescTag,
icSigDeviceModelDescTag:
rc := _cmsAddTextTag(hProfile, sig, PAnsiChar(Tag));
icSigRedColorantTag,
icSigGreenColorantTag,
icSigBlueColorantTag,
icSigMediaWhitePointTag,
icSigMediaBlackPointTag:
rc := _cmsAddXYZTag(hProfile, sig, LPcmsCIEXYZ(Tag));
icSigRedTRCTag,
icSigGreenTRCTag,
icSigBlueTRCTag,
icSigGrayTRCTag:
rc := _cmsAddGammaTag(hProfile, sig, LPGAMMATABLE(Tag));
icSigAToB0Tag,
icSigAToB1Tag,
icSigAToB2Tag,
icSigBToA0Tag,
icSigBToA1Tag,
icSigBToA2Tag,
icSigGamutTag,
icSigPreview0Tag,
icSigPreview1Tag,
icSigPreview2Tag:
rc := _cmsAddLUTTag(hProfile, sig, Tag);
icTagSignature(icSigChromaticityTag):
rc := _cmsAddChromaticityTag(hProfile, sig, LPcmsCIExyYTRIPLE(Tag));
icSigProfileSequenceDescTag:
rc := _cmsAddSequenceDescriptionTag(hProfile, sig, LPcmsSEQ(Tag));
icSigNamedColor2Tag:
rc := _cmsAddNamedColorTag(hProfile, sig, LPcmsNAMEDCOLORLIST(Tag));
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "cmsAddTag: Tag '%x' is unsupported", sig);
result := FALSE;
exit;
end;
end;
case (sig) of
icSigMediaWhitePointTag,
icSigMediaBlackPointTag,
icTagSignature(icSigChromaticAdaptationTag):
ReadCriticalTags(LPLCMSICCPROFILE(hProfile));
end;
result := rc;
end;
procedure cmsxyY2XYZ(Dest: LPcmsCIEXYZ; Source: LPcmsCIExyY); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
Dest^.X := (Source^.x / Source^.y_mi) * Source^.Y_ma;
Dest^.Y := Source^.Y_ma;
Dest^.Z := ((1 - Source^.x - Source^.y_mi) / Source^.y_mi) * Source^.Y_ma;
end;
function cmsBuildRGB2XYZtransferMatrix(r: LPMAT3; WhitePt: LPcmsCIExyY; Primrs: LPcmsCIExyYTRIPLE): longbool;
var
WhitePoint, Coef: VEC3;
xResult, Primaries: MAT3;
xn, yn: double;
xr, yr: double;
xg, yg: double;
xb, yb: double;
begin
xn := WhitePt^.x;
yn := WhitePt^.y_mi;
xr := Primrs^.Red.x;
yr := Primrs^.Red.y_mi;
xg := Primrs^.Green.x;
yg := Primrs^.Green.y_mi;
xb := Primrs^.Blue.x;
yb := Primrs^.Blue.y_mi;
VEC3init(@Primaries.v[0], xr, xg, xb);
VEC3init(@Primaries.v[1], yr, yg, yb);
VEC3init(@Primaries.v[2], (1 - xr - yr), (1 - xg - yg), (1 - xb - yb));
if (MAT3inverse(@Primaries, @xResult) = 0) then
begin
result := FALSE;
exit;
end;
VEC3init(@WhitePoint, xn / yn, 1.0, (1.0 - xn - yn) / yn);
MAT3eval(@Coef, @xResult, @WhitePoint);
VEC3init(@r^.v[0], Coef.n[VX] * xr, Coef.n[VY] * xg, Coef.n[VZ] * xb);
VEC3init(@r^.v[1], Coef.n[VX] * yr, Coef.n[VY] * yg, Coef.n[VZ] * yb);
VEC3init(@r^.v[2], Coef.n[VX] * (1.0 - xr - yr), Coef.n[VY] * (1.0 - xg - yg), Coef.n[VZ] * (1.0 - xb - yb));
result := TRUE;
end;
function TransportValue32(Value: icInt32Number): icInt32Number;
var
Temp: icInt32Number;
begin
Temp := Value;
AdjustEndianess32(@Temp);
result := Temp;
end;
function TransportValue16(Value: WORD): WORD;
var
Temp: WORD;
begin
Temp := Value;
AdjustEndianess16(@Temp);
result := Temp;
end;
procedure EncodeDateTime(DateTime: PicDateTimeNumber);
var
tm: TDateTime;
year, month, day: word;
hour, min, sec, msec: word;
begin
tm := date + time;
DecodeDate(tm, year, month, day);
DecodeTime(tm, hour, min, sec, msec);
DateTime^.year := TransportValue16(year);
DateTime^.month := TransportValue16(month);
DateTime^.day := TransportValue16(day);
DateTime^.hours := TransportValue16(hour);
DateTime^.minutes := TransportValue16(min);
DateTime^.seconds := TransportValue16(sec);
end;
function SaveHeader(OutStream: TStream; Icc: LPLCMSICCPROFILE): longbool;
var
Header: icHeader;
begin
Header.size := TransportValue32(icInt32Number(UsedSpace));
Header.cmmId := TransportValue32(lcmsSignature);
Header.version := TransportValue32(icInt32Number($02300000));
Header.deviceClass := icProfileClassSignature(TransportValue32(integer(Icc^.DeviceClass)));
Header.colorSpace := icColorSpaceSignature(TransportValue32(integer(Icc^.ColorSpace)));
Header.pcs := icColorSpaceSignature(TransportValue32(integer(Icc^.PCS)));
EncodeDateTime(@Header.date);
Header.magic := TransportValue32(icMagicNumber);
Header.xplatform := icPlatformSignature(TransportValue32(integer(icSigMicrosoft)));
Header.flags := TransportValue32(Icc^.flags);
Header.manufacturer := TransportValue32(lcmsSignature);
Header.model := TransportValue32(0);
Header.attributes[0] := TransportValue32(0);
Header.attributes[1] := TransportValue32(0);
Header.renderingIntent := TransportValue32(integer(Icc^.RenderingIntent));
Header.illuminant.X := TransportValue32(DOUBLE_TO_FIXED(Icc^.Illuminant.X));
Header.illuminant.Y := TransportValue32(DOUBLE_TO_FIXED(Icc^.Illuminant.Y));
Header.illuminant.Z := TransportValue32(DOUBLE_TO_FIXED(Icc^.Illuminant.Z));
Header.creator := TransportValue32(lcmsSignature);
ZeroMemory(@Header.reserved, sizeof(Header.reserved));
CopyMemory(@Header.reserved, @Icc^.ProfileID, 16);
UsedSpace := 0;
result := Icc^.Write(OutStream, sizeof(icHeader), @Header);
end;
function SaveTagDirectory(OutStream: TStream; Icc: LPLCMSICCPROFILE): longbool;
var
i: icInt32Number;
Tag: icTag;
Count: icInt32Number;
begin
Count := 0;
for i := 0 to Icc^.TagCount - 1 do
begin
if (Icc^.TagNames[i] <> icTagSignature(0)) then
inc(Count);
end;
Count := TransportValue32(Count);
if (not Icc^.Write(OutStream, sizeof(icInt32Number), @Count)) then
begin
result := FALSE;
exit;
end;
for i := 0 to Icc^.TagCount - 1 do
begin
if (Icc^.TagNames[i] = icTagSignature(0)) then
continue;
Tag.sig := icTagSignature(TransportValue32(integer(Icc^.TagNames[i])));
Tag.offset := TransportValue32(icInt32Number(Icc^.TagOffsets[i]));
Tag.size := TransportValue32(icInt32Number(Icc^.TagSizes[i]));
if (not Icc^.Write(OutStream, sizeof(icTag), @Tag)) then
begin
result := FALSE;
exit;
end;
end;
result := TRUE;
end;
function ALIGNLONG(x: dword): dword; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := (((x) + 3) and not (3)); // Aligns to DWORD boundary
end;
function SetupBase(OutStream: TStream; sig: icTagTypeSignature; Icc: LPLCMSICCPROFILE): longbool;
var
Base: icTagBase;
begin
Base.sig := icTagTypeSignature(TransportValue32(integer(sig)));
ZeroMemory(@Base.reserved, sizeof(Base.reserved));
result := Icc^.Write(OutStream, sizeof(icTagBase), @Base);
end;
function SaveDescription(OutStream: TStream; Text: PAnsiChar; Icc: LPLCMSICCPROFILE): longbool;
var
len, Count, TotalSize, AlignedSize: icUInt32Number;
Filler: array[0..255] of AnsiChar;
begin
len := icUInt32Number((IEStrLen(Text) + 1));
TotalSize := sizeof(icTagBase) + sizeof(icUInt32Number) + len +
sizeof(icUInt32Number) + sizeof(icUInt32Number) +
sizeof(icUInt16Number) + sizeof(icUInt8Number) + 67;
AlignedSize := TotalSize;
if (not SetupBase(OutStream, icSigTextDescriptionType, Icc)) then
begin
result := FALSE;
exit;
end;
AlignedSize := AlignedSize - sizeof(icTagBase);
Count := TransportValue32(len);
if (not Icc^.Write(OutStream, sizeof(icUInt32Number), @Count)) then
begin
result := FALSE;
exit;
end;
AlignedSize := AlignedSize - sizeof(icUInt32Number);
if (not Icc^.Write(OutStream, len, pointer(Text))) then
begin
result := FALSE;
exit;
end;
AlignedSize := AlignedSize - len;
ZeroMemory(@Filler, AlignedSize);
if (not Icc^.Write(OutStream, AlignedSize, @Filler)) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function SaveXYZNumber(OutStream: TStream; Value: LPcmsCIEXYZ; Icc: LPLCMSICCPROFILE): longbool;
var
XYZ: icXYZNumber;
begin
if (not SetupBase(OutStream, icSigXYZType, Icc)) then
begin
result := FALSE;
exit;
end;
XYZ.X := TransportValue32(DOUBLE_TO_FIXED(Value^.X));
XYZ.Y := TransportValue32(DOUBLE_TO_FIXED(Value^.Y));
XYZ.Z := TransportValue32(DOUBLE_TO_FIXED(Value^.Z));
result := Icc^.Write(OutStream, sizeof(icXYZNumber), @XYZ);
end;
function SaveGamma(OutStream: TStream; Gamma: LPGAMMATABLE; Icc: LPLCMSICCPROFILE): longbool;
var
Count: icInt32Number;
i: integer;
Val: WORD;
begin
if (not SetupBase(OutStream, icSigCurveType, Icc)) then
begin
result := FALSE;
exit;
end;
Count := TransportValue32(Gamma^.nEntries);
if (not Icc^.Write(OutStream, sizeof(icInt32Number), @Count)) then
begin
result := FALSE;
exit;
end;
for i := 0 to Gamma^.nEntries - 1 do
begin
Val := TransportValue16(Gamma^.GammaTable[i]);
if (not Icc^.Write(OutStream, sizeof(WORD), @Val)) then
begin
result := FALSE;
exit;
end;
end;
result := TRUE;
end;
function SaveText(OutStream: TStream; Text: PAnsiChar; Icc: LPLCMSICCPROFILE): longbool;
var
len: integer;
begin
len := IEStrLen(Text) + 1;
if (not SetupBase(OutStream, icSigTextType, Icc)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, len, pointer(Text))) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function SaveOneChromaticity(OutStream: TStream; x, y: double; Icc: LPLCMSICCPROFILE): longbool;
var
xf, yf: Fixed32;
begin
xf := TransportValue32(DOUBLE_TO_FIXED(x));
yf := TransportValue32(DOUBLE_TO_FIXED(y));
if (not Icc^.Write(OutStream, sizeof(Fixed32), @xf)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, sizeof(Fixed32), @yf)) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function SaveChromaticities(OutStream: TStream; chrm: LPcmsCIExyYTRIPLE; Icc: LPLCMSICCPROFILE): longbool;
var
nChans, Table: WORD;
begin
if (not SetupBase(OutStream, icTagTypeSignature(icSigChromaticityType), Icc)) then
begin
result := FALSE;
exit;
end;
nChans := TransportValue16(3);
if (not Icc^.Write(OutStream, sizeof(WORD), @nChans)) then
begin
result := FALSE;
exit;
end;
Table := TransportValue16(0);
if (not Icc^.Write(OutStream, sizeof(WORD), @Table)) then
begin
result := FALSE;
exit;
end;
if (not SaveOneChromaticity(OutStream, chrm^.Red.x, chrm^.Red.y_mi, Icc)) then
begin
result := FALSE;
exit;
end;
if (not SaveOneChromaticity(OutStream, chrm^.Green.x, chrm^.Green.y_mi, Icc)) then
begin
result := FALSE;
exit;
end;
if (not SaveOneChromaticity(OutStream, chrm^.Blue.x, chrm^.Blue.y_mi, Icc)) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function SaveLUT8(OutStream: TStream; NewLUT: LPLUT; Icc: LPLCMSICCPROFILE): longbool;
var
LUT8: icLut8;
i, j: integer;
nTabSize: integer;
val: BYTE;
begin
if (NewLUT^.wFlags and LUT_HASTL1) <> 0 then
begin
if (NewLUT^.InputEntries <> 256) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "LUT8 needs 256 entries on prelinearization");
result := FALSE;
exit;
end;
end;
if (NewLUT^.wFlags and LUT_HASTL2) <> 0 then
begin
if (NewLUT^.OutputEntries <> 256) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "LUT8 needs 256 entries on postlinearization");
result := FALSE;
exit;
end;
end;
if (not SetupBase(OutStream, icSigLut8Type, Icc)) then
begin
result := FALSE;
exit;
end;
LUT8.clutPoints := icUInt8Number(NewLUT^.cLutPoints);
LUT8.inputChan := icUInt8Number(NewLUT^.InputChan);
LUT8.outputChan := icUInt8Number(NewLUT^.OutputChan);
if (NewLUT^.wFlags and LUT_HASMATRIX) <> 0 then
begin
LUT8.e00 := TransportValue32(NewLUT^.Matrix.v[0].n[0]);
LUT8.e01 := TransportValue32(NewLUT^.Matrix.v[0].n[1]);
LUT8.e02 := TransportValue32(NewLUT^.Matrix.v[0].n[2]);
LUT8.e10 := TransportValue32(NewLUT^.Matrix.v[1].n[0]);
LUT8.e11 := TransportValue32(NewLUT^.Matrix.v[1].n[1]);
LUT8.e12 := TransportValue32(NewLUT^.Matrix.v[1].n[2]);
LUT8.e20 := TransportValue32(NewLUT^.Matrix.v[2].n[0]);
LUT8.e21 := TransportValue32(NewLUT^.Matrix.v[2].n[1]);
LUT8.e22 := TransportValue32(NewLUT^.Matrix.v[2].n[2]);
end
else
begin
LUT8.e00 := TransportValue32(DOUBLE_TO_FIXED(1));
LUT8.e01 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e02 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e10 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e11 := TransportValue32(DOUBLE_TO_FIXED(1));
LUT8.e12 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e20 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e21 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT8.e22 := TransportValue32(DOUBLE_TO_FIXED(1));
end;
Icc^.Write(OutStream, sizeof(icLut8) - SIZEOF_UINT8_ALIGNED, @LUT8);
for i := 0 to NewLUT^.InputChan - 1 do
begin
for j := 0 to 255 do
begin
if (NewLUT^.wFlags and LUT_HASTL1) <> 0 then
val := floor(pwordarray(NewLUT^.L1[i])[j] / 257.0 + 0.5)
else
val := j;
Icc^.Write(OutStream, 1, @val);
end;
end;
nTabSize := (NewLUT^.OutputChan * uipow(NewLUT^.cLutPoints,
NewLUT^.InputChan));
for j := 0 to nTabSize - 1 do
begin
val := floor(pwordarray(NewLUT^.T)[j] / 257.0 + 0.5);
Icc^.Write(OutStream, 1, @val);
end;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
for j := 0 to 255 do
begin
if (NewLUT^.wFlags and LUT_HASTL2) <> 0 then
val := floor(pwordarray(NewLUT^.L2[i])[j] / 257.0 + 0.5)
else
val := j;
Icc^.Write(OutStream, 1, @val);
end;
end;
result := TRUE;
end;
function SaveWordsTable(OutStream: TStream; nEntries: integer; Tab: PWORD; Icc: LPLCMSICCPROFILE): longbool;
var
nTabSize: integer;
PtrW: PWORD;
begin
nTabSize := sizeof(WORD) * nEntries;
getmem(PtrW, nTabSize);
if (PtrW = nil) then
begin
result := FALSE;
exit;
end;
CopyMemory(PtrW, Tab, nTabSize);
AdjustEndianessArray16(PtrW, nEntries);
Icc^.Write(OutStream, nTabSize, PtrW);
freemem(PtrW);
result := TRUE;
end;
function SaveLUT(OutStream: TStream; NewLUT: LPLUT; Icc: LPLCMSICCPROFILE): longbool;
const
NullTbl: array[0..1] of WORD = (0, $FFFF);
var
LUT16: icLut16;
i: dword;
nTabSize: integer;
begin
if (not SetupBase(OutStream, icSigLut16Type, Icc)) then
begin
result := FALSE;
exit;
end;
LUT16.clutPoints := icUInt8Number(NewLUT^.cLutPoints);
LUT16.inputChan := icUInt8Number(NewLUT^.InputChan);
LUT16.outputChan := icUInt8Number(NewLUT^.OutputChan);
if (NewLUT^.wFlags and LUT_HASTL1) <> 0 then
LUT16.inputEnt := TransportValue16((NewLUT^.InputEntries))
else
LUT16.inputEnt := TransportValue16((2));
if (NewLUT^.wFlags and LUT_HASTL2) <> 0 then
LUT16.outputEnt := TransportValue16((NewLUT^.OutputEntries))
else
LUT16.outputEnt := TransportValue16((2));
if (NewLUT^.wFlags and LUT_HASMATRIX) <> 0 then
begin
LUT16.e00 := TransportValue32(NewLUT^.Matrix.v[0].n[0]);
LUT16.e01 := TransportValue32(NewLUT^.Matrix.v[0].n[1]);
LUT16.e02 := TransportValue32(NewLUT^.Matrix.v[0].n[2]);
LUT16.e10 := TransportValue32(NewLUT^.Matrix.v[1].n[0]);
LUT16.e11 := TransportValue32(NewLUT^.Matrix.v[1].n[1]);
LUT16.e12 := TransportValue32(NewLUT^.Matrix.v[1].n[2]);
LUT16.e20 := TransportValue32(NewLUT^.Matrix.v[2].n[0]);
LUT16.e21 := TransportValue32(NewLUT^.Matrix.v[2].n[1]);
LUT16.e22 := TransportValue32(NewLUT^.Matrix.v[2].n[2]);
end
else
begin
LUT16.e00 := TransportValue32(DOUBLE_TO_FIXED(1));
LUT16.e01 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e02 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e10 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e11 := TransportValue32(DOUBLE_TO_FIXED(1));
LUT16.e12 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e20 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e21 := TransportValue32(DOUBLE_TO_FIXED(0));
LUT16.e22 := TransportValue32(DOUBLE_TO_FIXED(1));
end;
Icc^.Write(OutStream, sizeof(icLut16) - SIZEOF_UINT16_ALIGNED, @LUT16);
for i := 0 to NewLUT^.InputChan - 1 do
begin
if (NewLUT^.wFlags and LUT_HASTL1) <> 0 then
begin
if (not SaveWordsTable(OutStream, NewLUT^.InputEntries, NewLUT^.L1[i], Icc)) then
begin
result := FALSE;
exit;
end;
end
else
Icc^.Write(OutStream, sizeof(WORD) * 2, @NullTbl);
end;
nTabSize := (NewLUT^.OutputChan * uipow(NewLUT^.cLutPoints, NewLUT^.InputChan));
if (not SaveWordsTable(OutStream, nTabSize, NewLUT^.T, Icc)) then
begin
result := FALSE;
exit;
end;
for i := 0 to NewLUT^.OutputChan - 1 do
begin
if (NewLUT^.wFlags and LUT_HASTL2) <> 0 then
begin
if (not SaveWordsTable(OutStream, NewLUT^.OutputEntries, NewLUT^.L2[i], Icc)) then
begin
result := FALSE;
exit;
end;
end
else
Icc^.Write(OutStream, sizeof(WORD) * 2, @NullTbl);
end;
result := TRUE;
end;
function SaveSequenceDescriptionTag(OutStream: TStream; seq: LPcmsSEQ; Icc: LPLCMSICCPROFILE): longbool;
var
nSeqs: icUInt32Number;
DescStruct: icDescStruct;
i, n: integer;
pseq: LPcmsPSEQDESC;
sec: LPcmsPSEQDESC;
begin
n := seq^.n;
pseq := @seq^.seq;
if (not SetupBase(OutStream, icSigProfileSequenceDescType, Icc)) then
begin
result := FALSE;
exit;
end;
nSeqs := TransportValue32(n);
if (not Icc^.Write(OutStream, sizeof(icUInt32Number), @nSeqs)) then
begin
result := FALSE;
exit;
end;
for i := 0 to n - 1 do
begin
sec := pseq;
inc(sec, i);
DescStruct.deviceMfg := icSignature(icTagTypeSignature(TransportValue32(sec^.deviceMfg)));
DescStruct.deviceModel := icSignature(icTagTypeSignature(TransportValue32(sec^.deviceModel)));
DescStruct.technology := icTechnologySignature(TransportValue32(integer(sec^.technology)));
DescStruct.attributes[0] := TransportValue32(sec^.attributes[0]);
DescStruct.attributes[1] := TransportValue32(sec^.attributes[1]);
if (not Icc^.Write(OutStream, sizeof(icDescStruct) - SIZEOF_UINT8_ALIGNED, @DescStruct)) then
begin
result := FALSE;
exit;
end;
if (not SaveDescription(OutStream, sec^.Manufacturer, Icc)) then
begin
result := FALSE;
exit;
end;
if (not SaveDescription(OutStream, sec^.Model, Icc)) then
begin
result := FALSE;
exit;
end;
end;
result := TRUE;
end;
function SaveNamedColorList(OutStream: TStream; NamedColorList: LPcmsNAMEDCOLORLIST; Icc: LPLCMSICCPROFILE): longbool;
var
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
i: integer;
PCS: array[0..2] of icUInt16Number;
Colorant: array[0..MAXCHANNELS - 1] of icUInt16Number;
root: array[0..31] of icInt8Number;
Color: LPcmsNAMEDCOLOR;
j: integer;
begin
if (not SetupBase(OutStream, icSigNamedColor2Type, Icc)) then
begin
result := FALSE;
exit;
end;
vendorFlag := TransportValue32(0);
count := TransportValue32(NamedColorList^.nColors);
nDeviceCoords := TransportValue32(NamedColorList^.ColorantCount);
strlcopy(@prefix, NamedColorList^.Prefix, 32);
strlcopy(@suffix, NamedColorList^.Suffix, 32);
if (not Icc^.Write(OutStream, sizeof(icUInt32Number), @vendorFlag)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, sizeof(icUInt32Number), @count)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, sizeof(icUInt32Number), @nDeviceCoords)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, 32, @prefix)) then
begin
result := FALSE;
exit;
end;
if (not Icc^.Write(OutStream, 32, @suffix)) then
begin
result := FALSE;
exit;
end;
for i := 0 to NamedColorList^.nColors - 1 do
begin
Color := @NamedColorList^.List;
inc(Color, i);
strlcopy(@root, Color^.Name, 32);
if (not Icc^.Write(OutStream, 32, @root)) then
begin
result := FALSE;
exit;
end;
for j := 0 to 2 do
PCS[j] := TransportValue16(Color^.PCS[j]);
if (not Icc^.Write(OutStream, 3 * sizeof(icUInt16Number), @PCS)) then
begin
result := FALSE;
exit;
end;
for j := 0 to NamedColorList^.ColorantCount - 1 do
Colorant[j] := TransportValue16(Color^.DeviceColorant[j]);
if (not Icc^.Write(OutStream, NamedColorList^.ColorantCount * sizeof(icUInt16Number), @Colorant)) then
begin
result := FALSE;
exit;
end;
end;
result := TRUE;
end;
function SaveTags(OutStream: TStream; Icc: LPLCMSICCPROFILE): longbool;
var
Data: PBYTE;
i: icInt32Number;
xBegin: integer;
AlignedSpace, FillerSize: integer;
Filler: array[0..19] of BYTE;
begin
for i := 0 to Icc^.TagCount - 1 do
begin
if (Icc^.TagNames[i] = icTagSignature(0)) then
continue;
AlignedSpace := ALIGNLONG(UsedSpace);
FillerSize := AlignedSpace - UsedSpace;
if (FillerSize > 0) then
begin
ZeroMemory(@Filler, 16);
if (not Icc^.Write(OutStream, FillerSize, @Filler)) then
begin
result := FALSE;
exit;
end;
end;
xBegin := UsedSpace;
Icc^.TagOffsets[i] := xBegin;
Data := Icc^.TagPtrs[i];
if (Data = nil) then
continue;
case (Icc^.TagNames[i]) of
icSigProfileDescriptionTag,
icSigDeviceMfgDescTag,
icSigDeviceModelDescTag:
if (not SaveDescription(OutStream, PAnsiChar(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icSigRedColorantTag,
icSigGreenColorantTag,
icSigBlueColorantTag,
icSigMediaWhitePointTag,
icSigMediaBlackPointTag:
if (not SaveXYZNumber(OutStream, LPcmsCIEXYZ(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icSigRedTRCTag,
icSigGreenTRCTag,
icSigBlueTRCTag,
icSigGrayTRCTag:
if (not SaveGamma(OutStream, LPGAMMATABLE(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icSigCharTargetTag,
icSigCopyrightTag:
if (not SaveText(OutStream, PAnsiChar(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icTagSignature(icSigChromaticityTag):
if (not SaveChromaticities(OutStream, LPcmsCIExyYTRIPLE(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icSigAToB0Tag,
icSigAToB1Tag,
icSigAToB2Tag,
icSigBToA0Tag,
icSigBToA1Tag,
icSigBToA2Tag,
icSigGamutTag,
icSigPreview0Tag,
icSigPreview1Tag,
icSigPreview2Tag:
if (Icc^.SaveAs8Bits) then
begin
if (not SaveLUT8(OutStream, LPLUT(Data), Icc)) then
begin
result := FALSE;
exit;
end;
end
else
begin
if (not SaveLUT(OutStream, LPLUT(Data), Icc)) then
begin
result := FALSE;
exit;
end;
end;
icSigProfileSequenceDescTag:
if (not SaveSequenceDescriptionTag(OutStream, LPcmsSEQ(Data), Icc)) then
begin
result := FALSE;
exit;
end;
icTagSignature(icSigNamedColor2Type):
if (not SaveNamedColorList(OutStream, LPcmsNAMEDCOLORLIST(Data), Icc)) then
begin
result := FALSE;
exit;
end;
else
begin
result := FALSE;
exit;
end;
end;
Icc^.TagSizes[i] := (UsedSpace - xBegin);
end;
result := TRUE;
end;
function _cmsSaveProfile(hProfile: cmsHPROFILE; stream: TStream): longbool;
var
OutStream: TStream;
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Icc^.Write := @FileWrite;
if (not SaveHeader(nil, Icc)) then
begin
result := FALSE;
exit;
end;
if (not SaveTagDirectory(nil, Icc)) then
begin
result := FALSE;
exit;
end;
if (not SaveTags(nil, Icc)) then
begin
result := FALSE;
exit;
end;
OutStream := stream;
if (OutStream = nil) then
begin
result := FALSE;
exit;
end;
if (SaveHeader(OutStream, Icc)) and
(SaveTagDirectory(OutStream, Icc)) and
(SaveTags(OutStream, Icc)) then
begin
//OutStream.Free; // do not free, because we don't control the stream object
result := true;
end
else
begin
//OutStream.Free; // do not free, because we don't control the stream object
//unlink(FileName);
result := FALSE;
end;
end;
function IEcmsCloseProfile(hProfile: cmsHPROFILE): longbool;
var
icco: LPLCMSICCPROFILE;
xfile: tstream;
rc: longbool;
i: icInt32Number;
begin
icco := LPLCMSICCPROFILE(hProfile);
rc := TRUE;
if (icco = nil) then
begin
result := FALSE;
exit;
end;
if (icco^.IsWrite) then
begin
icco^.IsWrite := FALSE;
rc := _cmsSaveProfile(hProfile, icco^.PhysicalFile);
end;
xfile := icco^.stream;
if (xfile = nil) then
begin
for i := 0 to icco^.TagCount - 1 do
begin
if (icco^.TagPtrs[i] <> nil) then
freemem(icco^.TagPtrs[i]);
end;
end
else
begin
icco^.Close(xfile);
end;
freemem(icco);
result := rc;
end;
function cmsAdaptMatrixToD50(r: LPMAT3; SourceWhitePt: LPcmsCIExyY): longbool;
var
Dn: cmsCIEXYZ;
Bradford: MAT3;
Tmp: MAT3;
begin
cmsxyY2XYZ(@Dn, SourceWhitePt);
cmsAdaptationMatrix(@Bradford, nil, @Dn, cmsD50_XYZ);
Tmp := r^;
MAT3per(r, @Bradford, @Tmp);
result := TRUE;
end;
function cmsCreateRGBProfile(WhitePoint: LPcmsCIExyY; Primaries: LPcmsCIExyYTRIPLE; TransferFunction: LPGAMMATABLEArray): cmsHPROFILE;
var
hICC: cmsHPROFILE;
tmp: cmsCIEXYZ;
MColorants: MAT3;
Colorants: cmsCIEXYZTRIPLE;
MaxWhite: cmsCIExyY;
begin
hICC := _cmsCreateProfilePlaceholder;
if (hICC = nil) then
begin
result := nil;
exit;
end;
cmsSetDeviceClass(hICC, icSigDisplayClass);
cmsSetColorSpace(hICC, icSigRgbData);
cmsSetPCS(hICC, icSigXYZData);
cmsSetRenderingIntent(hICC, INTENT_PERCEPTUAL);
cmsAddTag(hICC, icSigDeviceMfgDescTag, PAnsiChar('(lcms internal)'));
cmsAddTag(hICC, icSigProfileDescriptionTag, PAnsiChar('lcms RGB virtual profile'));
cmsAddTag(hICC, icSigDeviceModelDescTag, PAnsiChar('rgb built-in'));
if (WhitePoint <> nil) then
begin
cmsxyY2XYZ(@tmp, WhitePoint);
cmsAddTag(hICC, icSigMediaWhitePointTag, @tmp);
end;
if (WhitePoint <> nil) and (Primaries <> nil) then
begin
MaxWhite.x := WhitePoint^.x;
MaxWhite.y_mi := WhitePoint^.y_mi;
MaxWhite.Y_ma := 1.0;
if (cmsBuildRGB2XYZtransferMatrix(@MColorants, @MaxWhite, Primaries) = false) then
begin
IEcmsCloseProfile(hICC);
result := nil;
exit;
end;
cmsAdaptMatrixToD50(@MColorants, @MaxWhite);
Colorants.Red.X := MColorants.v[0].n[0];
Colorants.Red.Y := MColorants.v[1].n[0];
Colorants.Red.Z := MColorants.v[2].n[0];
Colorants.Green.X := MColorants.v[0].n[1];
Colorants.Green.Y := MColorants.v[1].n[1];
Colorants.Green.Z := MColorants.v[2].n[1];
Colorants.Blue.X := MColorants.v[0].n[2];
Colorants.Blue.Y := MColorants.v[1].n[2];
Colorants.Blue.Z := MColorants.v[2].n[2];
cmsAddTag(hICC, icSigRedColorantTag, @Colorants.Red);
cmsAddTag(hICC, icSigBlueColorantTag, @Colorants.Blue);
cmsAddTag(hICC, icSigGreenColorantTag, @Colorants.Green);
end;
if (TransferFunction <> nil) then
begin
cmsAddTag(hICC, icSigRedTRCTag, TransferFunction[0]);
cmsAddTag(hICC, icSigGreenTRCTag, TransferFunction[1]);
cmsAddTag(hICC, icSigBlueTRCTag, TransferFunction[2]);
end;
if (Primaries <> nil) then
begin
cmsAddTag(hICC, icTagSignature(icSigChromaticityTag), Primaries);
end;
result := hICC;
end;
procedure cmsXYZ2xyY(Dest: LPcmsCIExyY; Source: LPcmsCIEXYZ);
var
ISum: double;
begin
ISum := 1 / (Source^.X + Source^.Y + Source^.Z);
Dest^.x := (Source^.X) * ISum;
Dest^.y_mi := (Source^.Y) * ISum;
Dest^.Y_ma := Source^.Y;
end;
const
D50xyY: cmsCIExyY = (x: 0; y_mi: 0; Y_ma: 0);
function cmsD50_xyY: LPcmsCIExyY;
begin
cmsXYZ2xyY(@D50xyY, cmsD50_XYZ);
result := @D50xyY;
end;
function Create3x3EmptyLUT: LPLUT;
var
AToB0: LPLUT;
begin
AToB0 := cmsAllocLUT;
AToB0^.OutputChan := 3;
AToB0^.InputChan := AToB0^.OutputChan;
result := AToB0;
end;
function cmsCreateLabProfile(WhitePoint: LPcmsCIExyY): cmsHPROFILE;
var
hProfile: cmsHPROFILE;
Lut: LPLUT;
begin
if WhitePoint = nil then
hProfile := cmsCreateRGBProfile(cmsD50_xyY, nil, nil)
else
hProfile := cmsCreateRGBProfile(WhitePoint, nil, nil);
cmsSetDeviceClass(hProfile, icSigAbstractClass);
cmsSetColorSpace(hProfile, icSigLabData);
cmsSetPCS(hProfile, icSigLabData);
cmsAddTag(hProfile, icSigDeviceMfgDescTag, PAnsiChar('(lcms internal)'));
cmsAddTag(hProfile, icSigProfileDescriptionTag, PAnsiChar('lcms Lab identity'));
cmsAddTag(hProfile, icSigDeviceModelDescTag, PAnsiChar('Lab built-in'));
Lut := Create3x3EmptyLUT;
if (Lut = nil) then
begin
result := nil;
exit;
end;
cmsAddTag(hProfile, icSigAToB0Tag, Lut);
cmsAddTag(hProfile, icSigBToA0Tag, Lut);
cmsFreeLUT(Lut);
result := hProfile;
end;
function IEcmsCreateLabProfile(WhitePoint_x, WhitePoint_y, WhitePoint_Y_: double): cmsHPROFILE;
var
xyY: cmsCIExyY;
begin
xyY.x := WhitePoint_x;
xyY.y_mi := WhitePoint_y;
xyY.Y_ma := WhitePoint_Y_;
result := cmsCreateLabProfile(@xyY);
end;
function IEcmsCreateLabProfileD50: cmsHPROFILE;
begin
result := cmsCreateLabProfile(nil);
end;
(*
function COLORSPACE_SH(s: dword): dword;
begin
result := ((s) shl 16);
end;
*)
(*
function TYPE_Lab_16: dword;
begin
result := (COLORSPACE_SH(PT_Lab) or CHANNELS_SH(3) or BYTES_SH(2))
end;
*)
function ipow(base: integer; exp: integer): integer;
var
res: integer;
begin
res := base;
dec(exp);
while (exp <> 0) do
begin
res := res * base;
dec(exp);
end;
result := res;
end;
function ComponentOf(n: integer; clut: integer; nColorant: integer): integer;
begin
if (nColorant <= 0) then
begin
result := (n mod clut);
exit;
end;
n := trunc(n / ipow(clut, nColorant) );
result := (n mod clut);
end;
function cmsReverseLinearInterpLUT16(Value: WORD; LutTable: pwordarray; p: LPL16PARAMS): word;
var
l: integer;
r: integer;
x, res: integer;
NumZeroes, NumPoles: integer;
cell0, cell1: integer;
val2: double;
y0, y1, x0, x1: double;
a, b: double;
ia, ib: integer;
begin
l := 1;
r := $10000;
x := 0;
NumZeroes := 0;
while (LutTable[NumZeroes] = 0) and (NumZeroes < p^.Domain) do
inc(NumZeroes);
NumPoles := 0;
while (LutTable[p^.Domain - NumPoles] = $FFFF) and (NumPoles < p^.Domain) do
inc(NumPoles);
if (NumZeroes > 1) or (NumPoles > 1) then
begin
if (Value = 0) then
begin
result := 0;
exit;
end;
if (Value = $FFFF) then
begin
result := $FFFF;
exit;
end;
ia := trunc(((NumZeroes - 1) * $FFFF) / p^.Domain );
ib := trunc(((p^.Domain - NumPoles) * $FFFF) / p^.Domain);
l := ia - 1;
r := ib + 1;
end;
while (r > l) do
begin
x := trunc((l + r) / 2 );
res := cmsLinearInterpLUT16((x - 1), LutTable, p);
if (res = Value) then
begin
result := (x - 1);
exit;
end;
if (res > Value) then
r := x - 1
else
l := x + 1;
end;
val2 := p^.Domain * ((x - 1) / 65535);
cell0 := Floor(val2);
cell1 := Ceil(val2);
if (cell0 = cell1) then
begin
result := x;
exit;
end;
y0 := LutTable[cell0];
x0 := (65535 * cell0) / p^.Domain;
y1 := LutTable[cell1];
x1 := (65535 * cell1) / p^.Domain;
a := (y1 - y0) / (x1 - x0);
b := y0 - a * x0;
if (a = 0) then
begin
result := x;
exit;
end;
result := floor(((Value - b) / a) + 0.5);
end;
function cmsSample3DGrid(Lut: LPLUT; Sampler: _cmsSAMPLER; Cargo: pointer; dwFlags: DWORD): longbool;
var
i, tt, nTotalPoints, Colorant, index: integer;
xIn, xOut: array[0..MAXCHANNELS - 1] of WORD;
begin
with Lut^ do
begin
nTotalPoints := ipow(cLutPoints, InputChan);
index := 0;
for i := 0 to nTotalPoints - 1 do
begin
for tt := 0 to InputChan - 1 do
begin
Colorant := ComponentOf(i, cLutPoints, (InputChan - tt - 1));
//xIn[tt] := _cmsQuantizeVal(Colorant, Lut^.cLutPoints);
xIn[tt] := floor(((Colorant * 65535) / (cLutPoints - 1)) + 0.5)
end;
if (dwFlags and SAMPLER_HASTL1) <> 0 then
begin
for tt := 0 to InputChan - 1 do
xIn[tt] := cmsReverseLinearInterpLUT16(xIn[tt], pwordarray(L1[tt]), @In16params);
end;
if (dwFlags and SAMPLER_INSPECT) <> 0 then
begin
for tt := 0 to OutputChan - 1 do
xOut[tt] := pwordarray(T)[index + tt];
end;
if (Sampler(@xIn, @xOut, Cargo)) = 0 then
begin
result := FALSE;
exit;
end;
if (dwFlags and SAMPLER_INSPECT) = 0 then
begin
if (dwFlags and SAMPLER_HASTL2) <> 0 then
begin
for tt := 0 to OutputChan - 1 do
xOut[tt] := cmsReverseLinearInterpLUT16(xOut[tt],
pwordarray(L2[tt]),
@Out16params);
end;
for tt := 0 to OutputChan - 1 do
pwordarray(T)[index + tt] := xOut[tt];
end;
inc(index, OutputChan);
end;
result := TRUE;
end;
(*
nTotalPoints := ipow(Lut^.cLutPoints, Lut^.InputChan);
index := 0;
for i := 0 to nTotalPoints - 1 do
begin
for t := 0 to Lut^.InputChan - 1 do
begin
Colorant := ComponentOf(i, Lut^.cLutPoints, (Lut^.InputChan - t - 1));
//xIn[t] := _cmsQuantizeVal(Colorant, Lut^.cLutPoints);
xIn[t] := floor(((Colorant * 65535) / (Lut^.cLutPoints - 1)) + 0.5)
end;
if (dwFlags and SAMPLER_HASTL1) <> 0 then
begin
for t := 0 to Lut^.InputChan - 1 do
xIn[t] := cmsReverseLinearInterpLUT16(xIn[t], pwordarray(Lut^.L1[t]), @Lut^.In16params);
end;
if (dwFlags and SAMPLER_INSPECT) <> 0 then
begin
for t := 0 to Lut^.OutputChan - 1 do
xOut[t] := pwordarray(Lut^.T)[index + t];
end;
if (Sampler(@xIn, @xOut, Cargo)) = 0 then
begin
result := FALSE;
exit;
end;
if (dwFlags and SAMPLER_INSPECT) = 0 then
begin
if (dwFlags and SAMPLER_HASTL2) <> 0 then
begin
for t := 0 to Lut^.OutputChan - 1 do
xOut[t] := cmsReverseLinearInterpLUT16(xOut[t],
pwordarray(Lut^.L2[t]),
@Lut^.Out16params);
end;
for t := 0 to Lut^.OutputChan - 1 do
pwordarray(Lut^.T)[index + t] := xOut[t];
end;
inc(index, Lut^.OutputChan);
end;
result := TRUE;
*)
end;
procedure IEcmsDoTransform(Transform: cmsHTRANSFORM; InputBuffer: pointer; OutputBuffer: pointer; Size: dword);
var
p: _LPcmsTRANSFORM;
begin
p := _LPcmsTRANSFORM(Transform);
p^.StrideOut := Size;
p^.StrideIn := p^.StrideOut;
p^.xform(p, InputBuffer, OutputBuffer, Size);
end;
function SoftProofSampler(xIn: pwordarray; xOut: pwordarray; Cargo: pointer): integer;
var
t: LPGAMUTCHAIN;
Colorant: array[0..MAXCHANNELS - 1] of WORD;
begin
t := LPGAMUTCHAIN(Cargo);
IEcmsDoTransform(t^.hForward, xIn, @Colorant, 1);
IEcmsDoTransform(t^.hReverse, @Colorant, xOut, 1);
result := 1;
end;
function _cmsComputeSoftProofLUT(hProfile: cmsHPROFILE; nIntent: integer): LPLUT;
var
hLab: cmsHPROFILE;
SoftProof: LPLUT;
dwFormat: DWORD;
Chain: GAMUTCHAIN;
//nErrState: integer ;
begin
ZeroMemory(@Chain, sizeof(GAMUTCHAIN));
hLab := cmsCreateLabProfile(nil);
dwFormat := ((4 shl 3) or 2);
//nErrState := cmsErrorAction(LCMS_ERROR_IGNORE);
Chain.hForward := IEcmsCreateTransform(hLab, TYPE_Lab_16,
hProfile, dwFormat,
nIntent,
cmsFLAGS_NOTPRECALC);
Chain.hReverse := IEcmsCreateTransform(hProfile, dwFormat,
hLab, TYPE_Lab_16,
INTENT_RELATIVE_COLORIMETRIC,
cmsFLAGS_NOTPRECALC);
//cmsErrorAction(nErrState);
if (Chain.hForward <> nil) and (Chain.hReverse <> nil) then
begin
SoftProof := cmsAllocLUT;
SoftProof := cmsAlloc3DGrid(SoftProof, 33, 3, 3);
cmsSample3DGrid(SoftProof, SoftProofSampler, @Chain, 0);
end
else
SoftProof := nil;
if (Chain.hForward <> nil) then
IEcmsDeleteTransform(Chain.hForward);
if (Chain.hReverse <> nil) then
IEcmsDeleteTransform(Chain.hReverse);
IEcmsCloseProfile(hLab);
result := SoftProof;
end;
function cmsDeltaE(Lab1: LPcmsCIELab; Lab2: LPcmsCIELab): double;
var
dL, da, db: double;
begin
if (Lab1^.L < 0) or (Lab2^.L < 0) then
begin
result := 65536;
exit;
end;
if (Lab1^.a < -200) or (Lab1^.a > 200) then
begin
result := 65536;
exit;
end;
if (Lab1^.b < -200) or (Lab1^.b > 200) then
begin
result := 65536.;
exit;
end;
if (Lab2^.a < -200) or (Lab2^.a > 200) then
begin
result := 65536;
exit;
end;
if (Lab2^.b < -200) or (Lab2^.b > 200) then
begin
result := 65536;
exit;
end;
if (Lab1^.L = 0) and (Lab2^.L = 0) then
begin
result := 0;
exit;
end;
dL := abs(Lab1^.L - Lab2^.L);
da := abs(Lab1^.a - Lab2^.a);
db := abs(Lab1^.b - Lab2^.b);
result := Power(dL * dL + da * da + db * db, 0.5);
end;
function GamutSampler(xIn: pwordarray; xOut: pwordarray; Cargo: pointer): integer;
var
t: LPGAMUTCHAIN;
Proof, Check: array[0..MAXCHANNELS - 1] of WORD;
Proof2, Check2: array[0..MAXCHANNELS - 1] of WORD;
LabIn1, LabOut1: cmsCIELab;
LabIn2, LabOut2: cmsCIELab;
dE1, dE2, ErrorRatio: double;
begin
t := LPGAMUTCHAIN(Cargo);
//ErrorRatio := 1.0;
IEcmsDoTransform(t^.hForward, xIn, @Proof, 1);
IEcmsDoTransform(t^.hReverse, @Proof, @Check, 1);
IEcmsDoTransform(t^.hForward, @Check, @Proof2, 1);
IEcmsDoTransform(t^.hReverse, @Proof2, @Check2, 1);
if (Check[0] = $FFFF) and (Check[1] = $FFFF) and (Check[2] = $FFFF) then
xOut[0] := $F000
else
begin
cmsLabEncoded2Float(@LabIn1, xIn);
cmsLabEncoded2Float(@LabOut1, @Check);
dE1 := cmsDeltaE(@LabIn1, @LabOut1);
cmsLabEncoded2Float(@LabIn2, @Check);
cmsLabEncoded2Float(@LabOut2, @Check2);
dE2 := cmsDeltaE(@LabIn2, @LabOut2);
if (dE1 < ERR_THERESHOLD) and (dE2 < ERR_THERESHOLD) then
xOut[0] := 0
else
begin
if (dE1 < ERR_THERESHOLD) and (dE2 > ERR_THERESHOLD) then
xOut[0] := 0
else
begin
if (dE1 > ERR_THERESHOLD) and (dE2 < ERR_THERESHOLD) then
xOut[0] := floor((dE1 - ERR_THERESHOLD) + 0.5)
else
begin
if (dE2 = 0.0) then
ErrorRatio := dE1
else
ErrorRatio := dE1 / dE2;
if (ErrorRatio > ERR_THERESHOLD) then
xOut[0] := floor((ErrorRatio - ERR_THERESHOLD) + 0.5)
else
xOut[0] := 0;
end;
end;
end;
end;
result := 1;
end;
function _cmsComputeGamutLUT(hProfile: cmsHPROFILE; Intent: integer): LPLUT;
var
hLab: cmsHPROFILE;
Gamut: LPLUT;
dwFormat: DWORD;
Chain: GAMUTCHAIN;
//nErrState: integer ;
begin
ZeroMemory(@Chain, sizeof(GAMUTCHAIN));
hLab := cmsCreateLabProfile(nil);
dwFormat := ((4 shl 3) or 2);
//nErrState := cmsErrorAction(LCMS_ERROR_IGNORE);
Chain.hForward := IEcmsCreateTransform(hLab, TYPE_Lab_16,
hProfile, dwFormat,
Intent,
cmsFLAGS_NOTPRECALC);
Chain.hReverse := IEcmsCreateTransform(hProfile, dwFormat,
hLab, TYPE_Lab_16,
Intent,
cmsFLAGS_NOTPRECALC);
//cmsErrorAction(nErrState);
if (Chain.hForward <> nil) and (Chain.hReverse <> nil) then
begin
Gamut := cmsAllocLUT;
Gamut := cmsAlloc3DGrid(Gamut, 42, 3, 1);
cmsSample3DGrid(Gamut, GamutSampler, @Chain, 0);
end
else
Gamut := nil;
if (Chain.hForward <> nil) then
IEcmsDeleteTransform(Chain.hForward);
if (Chain.hReverse <> nil) then
IEcmsDeleteTransform(Chain.hReverse);
IEcmsCloseProfile(hLab);
result := Gamut;
end;
procedure CreateProof(p: _LPcmsTRANSFORM; dwFlags: DWORD; ToTagPtr: PicTagSignature);
var
ProofTag: icTagSignature;
begin
if (dwFlags and cmsFLAGS_SOFTPROOFING) <> 0 then
begin
p^.Preview := _cmsComputeSoftProofLUT(p^.PreviewProfile, p^.Intent);
p^.Phase2 := LabRel;
ToTagPtr^ := PCS2Device[p^.ProofIntent];
if (p^.Preview = nil) then
begin
ProofTag := Preview[p^.Intent];
if (not cmsIsTag(p^.PreviewProfile, ProofTag)) then
begin
ProofTag := Preview[0];
if (not cmsIsTag(p^.PreviewProfile, ProofTag)) then
ProofTag := icTagSignature(0);
end;
if integer(ProofTag) <> 0 then
begin
p^.Preview := cmsReadICCLut(p^.PreviewProfile, ProofTag);
p^.Phase2 := GetPhase(p^.PreviewProfile);
end
else
begin
p^.Preview := nil;
p^.PreviewProfile := nil;
//cmsSignalError(LCMS_ERRC_WARNING, "Sorry, the proof profile has not previewing capabilities");
end;
end;
end;
if (dwFlags and cmsFLAGS_GAMUTCHECK) <> 0 then
begin
p^.Gamut := _cmsComputeGamutLUT(p^.PreviewProfile, p^.Intent);
if (p^.Gamut = nil) then
begin
if (cmsIsTag(p^.PreviewProfile, icSigGamutTag)) then
begin
p^.Gamut := cmsReadICCLut(p^.PreviewProfile, icSigGamutTag);
end
else
begin
//cmsSignalError(LCMS_ERRC_WARNING, "Sorry, the proof profile has not gamut checking capabilities");
p^.Gamut := nil;
end;
end;
end;
end;
procedure NC2toPCS(p: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray);
var
index: integer;
begin
index := xIn[0];
CopyMemory(xOut, @(p^.NamedColorList^.List[index].PCS), 3 * sizeof(WORD));
end;
function cmsLinearInterpFixed(Value1: WORD; LutTable: pwordarray; p: LPL16PARAMS): Fixed32;
var
y1, y0: Fixed32;
cell0: integer;
val3, Value: integer;
begin
Value := Value1;
if (Value = $FFFF) then
begin
result := LutTable[p^.Domain];
exit;
end;
val3 := p^.Domain * Value;
val3 := ToFixedDomain(val3);
cell0 := FIXED_TO_INT(val3);
y0 := LutTable[cell0];
y1 := LutTable[cell0 + 1];
result := y0 + FixedMul((y1 - y0), (val3 and $FFFF));
end;
function Clamp_XYZ(xin: integer): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
if (xin < 0) then
begin
result := 0;
exit;
end;
if (xin > $FFFF) then
begin
result := $FFFF;
exit;
end;
result := xin;
end;
procedure AllSmeltedBehaviour(MatShaper: LPMATSHAPER; xIn: pwordarray; xOut: pwordarray);
var
tmp: array[0..2] of WORD;
InVect, OutVect: WVEC3;
begin
if (MatShaper^.dwFlags and MATSHAPER_HASINPSHAPER) <> 0 then
begin
InVect.n[VX] := cmsLinearInterpFixed(xIn[0], pwordarray(MatShaper^.L2[0]), @MatShaper^.p2_16);
InVect.n[VY] := cmsLinearInterpFixed(xIn[1], pwordarray(MatShaper^.L2[1]), @MatShaper^.p2_16);
InVect.n[VZ] := cmsLinearInterpFixed(xIn[2], pwordarray(MatShaper^.L2[2]), @MatShaper^.p2_16);
end
else
begin
InVect.n[VX] := ToFixedDomain(xIn[0]);
InVect.n[VY] := ToFixedDomain(xIn[1]);
InVect.n[VZ] := ToFixedDomain(xIn[2]);
end;
if (MatShaper^.dwFlags and MATSHAPER_HASMATRIX) <> 0 then
begin
MAT3evalW(@OutVect, @MatShaper^.Matrix, @InVect);
end
else
begin
OutVect.n[VX] := InVect.n[VX];
OutVect.n[VY] := InVect.n[VY];
OutVect.n[VZ] := InVect.n[VZ];
end;
tmp[0] := Clamp_XYZ(FromFixedDomain(OutVect.n[VX]));
tmp[1] := Clamp_XYZ(FromFixedDomain(OutVect.n[VY]));
tmp[2] := Clamp_XYZ(FromFixedDomain(OutVect.n[VZ]));
if (MatShaper^.dwFlags and MATSHAPER_HASSHAPER) <> 0 then
begin
xOut[0] := cmsLinearInterpLUT16(tmp[0], pwordarray(MatShaper^.L[0]), @MatShaper^.p16);
xOut[1] := cmsLinearInterpLUT16(tmp[1], pwordarray(MatShaper^.L[1]), @MatShaper^.p16);
xOut[2] := cmsLinearInterpLUT16(tmp[2], pwordarray(MatShaper^.L[2]), @MatShaper^.p16);
end
else
begin
xOut[0] := tmp[0];
xOut[1] := tmp[1];
xOut[2] := tmp[2];
end;
end;
procedure InputBehaviour(MatShaper: LPMATSHAPER; xIn: pwordarray; xOut: pwordarray);
var
InVect, OutVect: WVEC3;
begin
if (MatShaper^.dwFlags and MATSHAPER_HASSHAPER) <> 0 then
begin
InVect.n[VX] := cmsLinearInterpFixed(xIn[0], pwordarray(MatShaper^.L[0]), @MatShaper^.p16);
InVect.n[VY] := cmsLinearInterpFixed(xIn[1], pwordarray(MatShaper^.L[1]), @MatShaper^.p16);
InVect.n[VZ] := cmsLinearInterpFixed(xIn[2], pwordarray(MatShaper^.L[2]), @MatShaper^.p16);
end
else
begin
InVect.n[VX] := ToFixedDomain(xIn[0]);
InVect.n[VY] := ToFixedDomain(xIn[1]);
InVect.n[VZ] := ToFixedDomain(xIn[2]);
end;
if (MatShaper^.dwFlags and MATSHAPER_HASMATRIX) <> 0 then
begin
MAT3evalW(@OutVect, @MatShaper^.Matrix, @InVect);
end
else
begin
OutVect := InVect;
end;
xOut[0] := Clamp_XYZ((OutVect.n[VX]) shr 1);
xOut[1] := Clamp_XYZ((OutVect.n[VY]) shr 1);
xOut[2] := Clamp_XYZ((OutVect.n[VZ]) shr 1);
end;
procedure OutputBehaviour(MatShaper: LPMATSHAPER; xIn: pwordarray; xOut: pwordarray);
var
InVect, OutVect: WVEC3;
i: integer;
begin
InVect.n[VX] := Fixed32(xIn[0] shl 1);
InVect.n[VY] := Fixed32(xIn[1] shl 1);
InVect.n[VZ] := Fixed32(xIn[2] shl 1);
if (MatShaper^.dwFlags and MATSHAPER_HASMATRIX) <> 0 then
begin
MAT3evalW(@OutVect, @MatShaper^.Matrix, @InVect);
end
else
begin
OutVect := InVect;
end;
if (MatShaper^.dwFlags and MATSHAPER_HASSHAPER) <> 0 then
begin
for i := 0 to 2 do
begin
xOut[i] := cmsLinearInterpLUT16(
Clamp_RGB(FromFixedDomain(OutVect.n[i])),
pwordarray(MatShaper^.L[i]),
@MatShaper^.p16);
end;
end
else
begin
xOut[0] := Clamp_RGB(FromFixedDomain(OutVect.n[VX]));
xOut[1] := Clamp_RGB(FromFixedDomain(OutVect.n[VY]));
xOut[2] := Clamp_RGB(FromFixedDomain(OutVect.n[VZ]));
end;
end;
procedure cmsEvalMatShaper(MatShaper: LPMATSHAPER; xIn: pwordarray; xOut: pwordarray);
begin
if ((MatShaper^.dwFlags and MATSHAPER_ALLSMELTED) = MATSHAPER_ALLSMELTED) then
begin
AllSmeltedBehaviour(MatShaper, xIn, xOut);
exit;
end;
if (MatShaper^.dwFlags and MATSHAPER_INPUT) <> 0 then
begin
InputBehaviour(MatShaper, xIn, xOut);
exit;
end;
OutputBehaviour(MatShaper, xIn, xOut);
end;
procedure MatrixShaperXFORM(p: _LPcmsTRANSFORM; xin: pointer; xout: pointer; Size: dword);
var
accum: PBYTE;
output: PBYTE;
wIn, wOut: array[0..MAXCHANNELS - 1] of WORD;
i, n: dword;
begin
accum := xin;
output := xout;
n := Size;
for i := 0 to n - 1 do
begin
accum := p^.FromInput(p, @wIn, accum);
cmsEvalMatShaper(p^.SmeltMatShaper, @wIn, @wOut);
output := p^.ToOutput(p, @wOut, output);
end;
end;
function cmsTakeColorants(Dest: LPcmsCIEXYZTRIPLE; hProfile: cmsHPROFILE): longbool;
begin
if (ReadICCXYZ(hProfile, icSigRedColorantTag, @Dest^.Red, TRUE) < 0) then
begin
result := FALSE;
exit;
end;
if (ReadICCXYZ(hProfile, icSigGreenColorantTag, @Dest^.Green, TRUE) < 0) then
begin
result := FALSE;
exit;
end;
if (ReadICCXYZ(hProfile, icSigBlueColorantTag, @Dest^.Blue, TRUE) < 0) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function cmsReadICCMatrixRGB2XYZ(r: LPMAT3; hProfile: cmsHPROFILE): longbool;
var
Primaries: cmsCIEXYZTRIPLE;
begin
if (not cmsTakeColorants(@Primaries, hProfile)) then
begin
result := FALSE;
exit;
end;
VEC3init(@r^.v[0], Primaries.Red.X, Primaries.Green.X, Primaries.Blue.X);
VEC3init(@r^.v[1], Primaries.Red.Y, Primaries.Green.Y, Primaries.Blue.Y);
VEC3init(@r^.v[2], Primaries.Red.Z, Primaries.Green.Z, Primaries.Blue.Z);
result := TRUE;
end;
function cmsDupGamma(xIn: LPGAMMATABLE): LPGAMMATABLE;
var
Ptr: LPGAMMATABLE;
begin
Ptr := cmsAllocGamma(xIn^.nEntries);
if (Ptr = nil) then
begin
result := nil;
exit;
end;
CopyMemory(@Ptr^.GammaTable,
@xIn^.GammaTable,
xIn^.nEntries * sizeof(WORD));
result := Ptr;
end;
function cmsReadICCGamma(hProfile: cmsHPROFILE; sig: icTagSignature): LPGAMMATABLE;
var
Icc: LPLCMSICCPROFILE;
offset: integer;
n: integer;
begin
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Tag not found");
result := nil;
exit;
end;
if (Icc^.stream = nil) then
begin
result := cmsDupGamma(LPGAMMATABLE(Icc^.TagPtrs[n]));
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := nil;
exit;
end;
result := ReadCurve(Icc);
end;
function cmsReverseGamma(nResultSamples: integer; InGamma: LPGAMMATABLE): LPGAMMATABLE;
var
i: integer;
L16In: L16PARAMS;
InPtr: PWORD;
p: LPGAMMATABLE;
wValIn, wValOut: WORD;
begin
p := cmsAllocGamma(nResultSamples);
if (p = nil) then
begin
result := nil;
exit;
end;
cmsCalcL16Params(InGamma^.nEntries, @L16In);
InPtr := @InGamma^.GammaTable;
for i := 0 to nResultSamples - 1 do
begin
//wValIn := _cmsQuantizeVal(i, nResultSamples);
wValIn := floor(((i * 65535) / (nResultSamples - 1)) + 0.5);
wValOut := cmsReverseLinearInterpLUT16(wValIn, pwordarray(InPtr), @L16In);
p^.GammaTable[i] := wValOut;
end;
result := p;
end;
function ReadCurveReversed(Icc: LPLCMSICCPROFILE): LPGAMMATABLE;
const
ParamsByType: array[0..4] of integer = (1, 3, 4, 5, 7);
var
Base: icTagBase;
NewGamma, ReturnGamma: LPGAMMATABLE;
Count: icUInt32Number;
n: integer;
SingleGammaFixed: WORD;
Params: array[0..9] of double;
Num: icS15Fixed16Number;
Reserved: icUInt32Number;
xType: icUInt16Number;
i: integer;
begin
Icc^.Read(@Base, 1, sizeof(icTagBase), Icc^.stream);
AdjustEndianess32(@Base.sig);
case (Base.sig) of
icTagTypeSignature($9478EE00),
icSigCurveType:
begin
Icc^.Read(@Count, sizeof(icUInt32Number), 1, Icc^.stream);
AdjustEndianess32(@Count);
case (Count) of
0:
begin
NewGamma := cmsAllocGamma(2);
if (NewGamma = nil) then
begin
result := nil;
exit;
end;
NewGamma^.GammaTable[0] := 0;
pwordarray(@NewGamma^.GammaTable)[1] := $FFFF;
result := NewGamma;
end;
1:
begin
Icc^.Read(@SingleGammaFixed, sizeof(WORD), 1, Icc^.stream);
AdjustEndianess16(@SingleGammaFixed);
result := cmsBuildGamma(4096, 1 / Convert8Fixed8(SingleGammaFixed));
end;
else
begin
NewGamma := cmsAllocGamma(Count);
if (NewGamma = nil) then
begin
result := nil;
exit;
end;
Icc^.Read(@NewGamma^.GammaTable, sizeof(WORD), Count, Icc^.stream);
AdjustEndianessArray16(@NewGamma^.GammaTable, Count);
ReturnGamma := cmsReverseGamma(Count, NewGamma);
cmsFreeGamma(NewGamma);
result := ReturnGamma;
end;
end;
end;
icTagTypeSignature(icSigParametricCurveType):
begin
Icc^.Read(@xType, sizeof(icUInt16Number), 1, Icc^.stream);
Icc^.Read(@Reserved, sizeof(icUInt16Number), 1, Icc^.stream);
AdjustEndianess16(@xType);
if (xType > 5) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Unknown parametric curve type '%d' found.", Type);
result := nil;
exit;
end;
ZeroMemory(@Params, 10 * sizeof(double));
n := ParamsByType[xType];
for i := 0 to n - 1 do
begin
Icc^.Read(@Num, sizeof(icS15Fixed16Number), 1, Icc^.stream);
Params[i] := Convert15Fixed16(Num);
end;
NewGamma := cmsBuildParametricGamma(4096, -(xType + 1), @Params);
result := NewGamma;
end;
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Bad tag signature '%lx' found.", Base.sig);
result := nil;
exit;
end;
end;
end;
function cmsReadICCGammaReversed(hProfile: cmsHPROFILE; sig: icTagSignature): LPGAMMATABLE;
var
Icc: LPLCMSICCPROFILE;
offset: integer;
n: integer;
begin
Icc := LPLCMSICCPROFILE(hProfile);
n := SearchTag(Icc, sig);
if (n < 0) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Tag not found");
result := nil;
exit;
end;
if (Icc^.stream = nil) then
begin
result := cmsReverseGamma(256, LPGAMMATABLE(Icc^.TagPtrs[n]));
exit;
end;
offset := Icc^.TagOffsets[n];
if (Icc^.Seek(Icc^.stream, offset)) then
begin
result := nil;
exit;
end;
result := ReadCurveReversed(Icc);
end;
function ComputeTables(Table: LPGAMMATABLEarray; xOut: PPWORDARRAY; p16: LPL16PARAMS): integer;
var
i, AllLinear: integer;
PtrW: PWORD;
begin
cmsCalcL16Params(Table[0]^.nEntries, p16);
AllLinear := 0;
for i := 0 to 2 do
begin
getmem(PtrW, sizeof(WORD) * p16^.nSamples);
if (PtrW = nil) then
begin
result := -1;
exit;
end;
CopyMemory(PtrW, @Table[i]^.GammaTable, sizeof(WORD) * Table[i]^.nEntries);
xOut[i] := PtrW;
inc(AllLinear, cmsIsLinear(pwordarray(PtrW), p16^.nSamples));
end;
if (AllLinear <> 3) then
result := 1
else
result := 0;
end;
function cmsAllocMatShaper2(Matrix: LPMAT3; xIn: LPGAMMATABLEArray; xOut: LPGAMMATABLEArray; Behaviour: DWORD): LPMATSHAPER;
var
NewMatShaper: LPMATSHAPER;
rc: integer;
begin
getmem(NewMatShaper, sizeof(MATSHAPER));
if (NewMatShaper <> nil) then
ZeroMemory(NewMatShaper, sizeof(MATSHAPER));
NewMatShaper^.dwFlags := Behaviour and (MATSHAPER_ALLSMELTED);
MAT3toFix(@NewMatShaper^.Matrix, Matrix);
if (not MAT3isIdentity(@NewMatShaper^.Matrix, 0.00001)) then
NewMatShaper^.dwFlags := NewMatShaper^.dwFlags or MATSHAPER_HASMATRIX;
if (xOut <> nil) then
begin
rc := ComputeTables(xOut, @NewMatShaper^.L, @NewMatShaper^.p16);
if (rc < 0) then
begin
cmsFreeMatShaper(NewMatShaper);
result := nil;
exit;
end;
if (rc = 1) then
NewMatShaper^.dwFlags := NewMatShaper^.dwFlags or MATSHAPER_HASSHAPER;
end;
if (xIn <> nil) then
begin
rc := ComputeTables(xIn, @NewMatShaper^.L2, @NewMatShaper^.p2_16);
if (rc < 0) then
begin
cmsFreeMatShaper(NewMatShaper);
result := nil;
exit;
end;
if (rc = 1) then
NewMatShaper^.dwFlags := NewMatShaper^.dwFlags or MATSHAPER_HASINPSHAPER;
end;
result := NewMatShaper;
end;
procedure cmsFreeGammaTriple(Gamma: LPGAMMATABLEarray);
begin
cmsFreeGamma(Gamma[0]);
cmsFreeGamma(Gamma[1]);
cmsFreeGamma(Gamma[2]);
Gamma[2] := nil;
Gamma[1] := Gamma[2];
Gamma[0] := Gamma[1];
end;
function cmsBuildSmeltMatShaper(p: _LPcmsTRANSFORM): longbool;
var
From, xTo, ToInv, Transfer: MAT3;
xIn, InverseOut: array[0..2] of LPGAMMATABLE;
begin
if (not cmsReadICCMatrixRGB2XYZ(@From, p^.InputProfile)) then
begin
result := FALSE;
exit;
end;
if (not cmsReadICCMatrixRGB2XYZ(@xTo, p^.OutputProfile)) then
begin
result := FALSE;
exit;
end;
if (MAT3inverse(@xTo, @ToInv) < 0) then
begin
result := FALSE;
exit;
end;
MAT3per(@Transfer, @ToInv, @From);
xIn[0] := cmsReadICCGamma(p^.InputProfile, icSigRedTRCTag);
xIn[1] := cmsReadICCGamma(p^.InputProfile, icSigGreenTRCTag);
xIn[2] := cmsReadICCGamma(p^.InputProfile, icSigBlueTRCTag);
if (xIn[0] = nil) or (xIn[1] = nil) or (xIn[2] = nil) then
begin
result := FALSE;
exit;
end;
InverseOut[0] := cmsReadICCGammaReversed(p^.OutputProfile, icSigRedTRCTag);
InverseOut[1] := cmsReadICCGammaReversed(p^.OutputProfile, icSigGreenTRCTag);
InverseOut[2] := cmsReadICCGammaReversed(p^.OutputProfile, icSigBlueTRCTag);
p^.SmeltMatShaper := cmsAllocMatShaper2(@Transfer, @xIn, @InverseOut, MATSHAPER_ALLSMELTED);
cmsFreeGammaTriple(@xIn);
cmsFreeGammaTriple(@InverseOut);
result := (p^.SmeltMatShaper <> nil);
end;
procedure LUTtoPCS(p: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray);
begin
cmsEvalLUT(p^.Device2PCS, xIn, xOut);
end;
procedure ShaperMatrixToPCS(p: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
cmsEvalMatShaper(p^.InMatShaper, xIn, xOut);
end;
function cmsTakeIluminant(Dest: LPcmsCIEXYZ; hProfile: cmsHPROFILE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Dest^ := Icc^.Illuminant;
result := true;
end;
function cmsAllocMatShaper(Matrix: LPMAT3; Tables: LPGAMMATABLEarray; Behaviour: DWORD): LPMATSHAPER;
var
NewMatShaper: LPMATSHAPER;
i, AllLinear: integer;
PtrW: PWORD;
begin
getmem(NewMatShaper, sizeof(MATSHAPER));
if (NewMatShaper <> nil) then
ZeroMemory(NewMatShaper, sizeof(MATSHAPER));
NewMatShaper^.dwFlags := Behaviour and (MATSHAPER_ALLSMELTED);
MAT3toFix(@NewMatShaper^.Matrix, Matrix);
if (not MAT3isIdentity(@NewMatShaper^.Matrix, 0.00001)) then
NewMatShaper^.dwFlags := NewMatShaper^.dwFlags or MATSHAPER_HASMATRIX;
cmsCalcL16Params(Tables[0]^.nEntries, @NewMatShaper^.p16);
AllLinear := 0;
for i := 0 to 2 do
begin
getmem(PtrW, sizeof(WORD) * NewMatShaper^.p16.nSamples);
if (PtrW = nil) then
begin
cmsFreeMatShaper(NewMatShaper);
result := nil;
exit;
end;
CopyMemory(PtrW, @Tables[i]^.GammaTable,
sizeof(WORD) * Tables[i]^.nEntries);
NewMatShaper^.L[i] := PtrW;
inc(AllLinear, cmsIsLinear(pwordarray(PtrW), NewMatShaper^.p16.nSamples));
end;
if (AllLinear <> 3) then
NewMatShaper^.dwFlags := NewMatShaper^.dwFlags or MATSHAPER_HASSHAPER;
result := NewMatShaper;
end;
function cmsBuildGrayInputMatrixShaper(hProfile: cmsHPROFILE): LPMATSHAPER;
var
Illuminant: cmsCIEXYZ;
GrayTRC: LPGAMMATABLE;
Shapes: array[0..2] of LPGAMMATABLE;
MatShaper: LPMATSHAPER;
Scale: MAT3;
begin
GrayTRC := cmsReadICCGamma(hProfile, icSigGrayTRCTag);
cmsTakeIluminant(@Illuminant, hProfile);
Shapes[0] := cmsDupGamma(GrayTRC);
Shapes[1] := cmsDupGamma(GrayTRC);
Shapes[2] := cmsDupGamma(GrayTRC);
if (Shapes[0] = nil) or (Shapes[1] = nil) or (Shapes[2] = nil) then
begin
result := nil;
exit;
end;
cmsFreeGamma(GrayTRC);
VEC3init(@Scale.v[0], Illuminant.X / 3, Illuminant.X / 3, Illuminant.X / 3);
VEC3init(@Scale.v[1], Illuminant.Y / 3, Illuminant.Y / 3, Illuminant.Y / 3);
VEC3init(@Scale.v[2], Illuminant.Z / 3, Illuminant.Z / 3, Illuminant.Z / 3);
MatShaper := cmsAllocMatShaper(@Scale, @Shapes, MATSHAPER_INPUT);
cmsFreeGammaTriple(@Shapes);
result := MatShaper;
end;
function cmsBuildInputMatrixShaper(InputProfile: cmsHPROFILE; dwFlags: PDWORD): LPMATSHAPER;
var
DoubleMat: MAT3;
Shapes: array[0..2] of LPGAMMATABLE;
InMatSh: LPMATSHAPER;
begin
if (cmsGetColorSpace(InputProfile) = icSigGrayData) then
begin
if (dwFlags) <> nil then
dwFlags^ := dwFlags^ or cmsFLAGS_NOTPRECALC;
result := cmsBuildGrayInputMatrixShaper(InputProfile);
exit;
end;
if (not cmsReadICCMatrixRGB2XYZ(@DoubleMat, InputProfile)) then
begin
result := nil;
exit;
end;
Shapes[0] := cmsReadICCGamma(InputProfile, icSigRedTRCTag);
Shapes[1] := cmsReadICCGamma(InputProfile, icSigGreenTRCTag);
Shapes[2] := cmsReadICCGamma(InputProfile, icSigBlueTRCTag);
if (Shapes[0] = nil) or (Shapes[1] = nil) or (Shapes[2] = nil) then
begin
result := nil;
exit;
end;
InMatSh := cmsAllocMatShaper(@DoubleMat, @Shapes, MATSHAPER_INPUT);
cmsFreeGammaTriple(@Shapes);
result := InMatSh;
end;
procedure PCStoLUT(p: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray);
begin
cmsEvalLUT(p^.PCS2Device, xIn, xOut);
end;
procedure PCStoShaperMatrix(p: _LPcmsTRANSFORM; xIn: pwordarray; xOut: pwordarray); {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
cmsEvalMatShaper(p^.OutMatShaper, xIn, xOut);
end;
function cmsBuildGrayOutputMatrixShaper(hProfile: cmsHPROFILE): LPMATSHAPER;
var
Illuminant: cmsCIEXYZ;
GrayTRC: LPGAMMATABLE;
Shapes: array[0..2] of LPGAMMATABLE;
MatShaper: LPMATSHAPER;
Scale: MAT3;
begin
GrayTRC := cmsReadICCGammaReversed(hProfile, icSigGrayTRCTag);
cmsTakeIluminant(@Illuminant, hProfile);
Shapes[0] := cmsDupGamma(GrayTRC);
Shapes[1] := cmsDupGamma(GrayTRC);
Shapes[2] := cmsDupGamma(GrayTRC);
if (Shapes[0] = nil) or (Shapes[1] = nil) or (Shapes[2] = nil) then
begin
result := nil;
exit;
end;
cmsFreeGamma(GrayTRC);
VEC3init(@Scale.v[0], 0, 1.0 / Illuminant.Y, 0);
VEC3init(@Scale.v[1], 0, 1.0 / Illuminant.Y, 0);
VEC3init(@Scale.v[2], 0, 1.0 / Illuminant.Y, 0);
MatShaper := cmsAllocMatShaper(@Scale, @Shapes, MATSHAPER_OUTPUT);
cmsFreeGammaTriple(@Shapes);
result := MatShaper;
end;
function cmsBuildOutputMatrixShaper(OutputProfile: cmsHPROFILE; dwFlags: PDWORD): LPMATSHAPER;
var
DoubleMat, DoubleInv: MAT3;
InverseShapes: array[0..2] of LPGAMMATABLE;
OutMatSh: LPMATSHAPER;
begin
if (cmsGetColorSpace(OutputProfile) = icSigGrayData) then
begin
if (dwFlags <> nil) then
dwFlags^ := dwFlags^ or cmsFLAGS_NOTPRECALC;
result := cmsBuildGrayOutputMatrixShaper(OutputProfile);
exit;
end;
if (not cmsReadICCMatrixRGB2XYZ(@DoubleMat, OutputProfile)) then
begin
result := nil;
exit;
end;
if (MAT3inverse(@DoubleMat, @DoubleInv) < 0) then
begin
result := nil;
exit;
end;
InverseShapes[0] := cmsReadICCGammaReversed(OutputProfile, icSigRedTRCTag);
InverseShapes[1] := cmsReadICCGammaReversed(OutputProfile, icSigGreenTRCTag);
InverseShapes[2] := cmsReadICCGammaReversed(OutputProfile, icSigBlueTRCTag);
OutMatSh := cmsAllocMatShaper(@DoubleInv, @InverseShapes, MATSHAPER_OUTPUT);
cmsFreeGammaTriple(@InverseShapes);
result := OutMatSh;
end;
function PickTransformRoutine(p: _LPcmsTRANSFORM; dwFlagsPtr: PDWORD; FromTagPtr: PicTagSignature; ToTagPtr: PicTagSignature): _LPcmsTRANSFORM;
begin
if (cmsGetDeviceClass(p^.InputProfile) = icSigNamedColorClass) then
begin
p^.FromDevice := NC2toPCS;
end
else
begin
if (FromTagPtr^ = icTagSignature(0)) and (ToTagPtr^ = icTagSignature(0)) and (p^.PreviewProfile <> nil) and
(p^.Intent <> INTENT_ABSOLUTE_COLORIMETRIC) and (p^.EntryColorSpace = icSigRgbData) and
(p^.ExitColorSpace = icSigRgbData) then
begin
p^.xform := MatrixShaperXFORM;
dwFlagsPtr^ := dwFlagsPtr^ or cmsFLAGS_NOTPRECALC;
if (not cmsBuildSmeltMatShaper(p)) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "unable to smelt shaper-matrix, required tags missing");
result := nil;
exit;
end;
p^.Phase3 := XYZRel;
p^.Phase1 := p^.Phase3;
result := p;
exit;
end;
if (FromTagPtr^ <> icTagSignature(0)) then
begin
p^.FromDevice := LUTtoPCS;
p^.Device2PCS := cmsReadICCLut(p^.InputProfile, FromTagPtr^);
if (p^.Device2PCS = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "profile is unsuitable for input");
result := nil;
exit;
end;
end
else
begin
p^.FromDevice := ShaperMatrixToPCS;
p^.InMatShaper := cmsBuildInputMatrixShaper(p^.InputProfile, dwFlagsPtr);
if (p^.InMatShaper = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "profile is unsuitable for input");
result := nil;
exit;
end;
p^.Phase1 := XYZRel;
end;
end;
if (ToTagPtr^ <> icTagSignature(0)) then
begin
p^.ToDevice := PCStoLUT;
p^.PCS2Device := cmsReadICCLut(p^.OutputProfile, ToTagPtr^);
if (p^.PCS2Device = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "profile is unsuitable for output");
result := nil;
exit;
end;
end
else
begin
p^.ToDevice := PCStoShaperMatrix;
p^.OutMatShaper := cmsBuildOutputMatrixShaper(p^.OutputProfile, dwFlagsPtr);
if (p^.OutMatShaper = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "profile is unsuitable for output");
result := nil;
exit;
end;
p^.Phase3 := XYZRel;
end;
result := p;
end;
function cmsTakeMediaWhitePoint(Dest: LPcmsCIEXYZ; hProfile: cmsHPROFILE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Dest^ := Icc^.MediaWhitePoint;
result := TRUE;
end;
function cmsTakeMediaBlackPoint(Dest: LPcmsCIEXYZ; hProfile: cmsHPROFILE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
Dest^ := Icc^.MediaBlackPoint;
result := TRUE;
end;
function cmsTakeHeaderFlags(hProfile: cmsHPROFILE): dword;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := Icc^.flags;
end;
function cmsReadChromaticAdaptationMatrix(r: LPMAT3; hProfile: cmsHPROFILE): longbool;
var
Icc: LPLCMSICCPROFILE;
begin
if (ReadICCXYZArray(hProfile, icTagSignature(icSigChromaticAdaptationTag), r) < 0) then
begin
Icc := LPLCMSICCPROFILE(hProfile);
MAT3identity(r);
if ((cmsGetDeviceClass(hProfile) = icSigDisplayClass)) or
((cmsTakeHeaderFlags(hProfile) and icTransparency) <> 0) then
begin
cmsAdaptationMatrix(r, nil, @Icc^.MediaWhitePoint, @Icc^.Illuminant);
end;
end;
result := TRUE;
end;
function cmsGetProfileICCversion(hProfile: cmsHPROFILE): dword;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := Icc^.Version;
end;
function cmsAdaptToIlluminant(xResult: LPcmsCIEXYZ;
SourceWhitePt: LPcmsCIEXYZ;
Illuminant: LPcmsCIEXYZ;
Value: LPcmsCIEXYZ): longbool;
var
Bradford: MAT3;
xIn, xOut: VEC3;
begin
cmsAdaptationMatrix(@Bradford, nil, SourceWhitePt, Illuminant);
VEC3init(@xIn, Value^.X, Value^.Y, Value^.Z);
MAT3eval(@xOut, @Bradford, @xIn);
xResult^.X := xOut.n[0];
xResult^.Y := xOut.n[1];
xResult^.Z := xOut.n[2];
result := TRUE;
end;
function GetV4PerceptualBlack(BlackPoint: LPcmsCIEXYZ; hProfile: cmsHPROFILE; dwFlags: DWORD): integer;
var
D50BlackPoint, MediaWhite: cmsCIEXYZ;
begin
if (dwFlags and LCMS_BPFLAGS_D50_ADAPTED) <> 0 then
begin
BlackPoint^.X := PERCEPTUAL_BLACK_X;
BlackPoint^.Y := PERCEPTUAL_BLACK_Y;
BlackPoint^.Z := PERCEPTUAL_BLACK_Z;
end
else
begin
cmsTakeMediaWhitePoint(@MediaWhite, hProfile);
D50BlackPoint.X := PERCEPTUAL_BLACK_X;
D50BlackPoint.Y := PERCEPTUAL_BLACK_Y;
D50BlackPoint.Z := PERCEPTUAL_BLACK_Z;
cmsAdaptToIlluminant(BlackPoint, cmsD50_XYZ, @MediaWhite, @D50BlackPoint);
end;
result := 1;
end;
function c_frexp(value: extended; eptr: pinteger): extended; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
frexp(value, result, eptr^);
end;
function CubeRoot(x: double): double;
var
fr, r: double;
ex, shx: integer;
begin
fr := c_frexp(x, @ex);
shx := ex mod 3;
if (shx > 0) then
shx := shx - 3;
ex := (ex - shx) div 3;
fr := ldexp(fr, shx);
fr := (((((45.2548339756803022511987494 * fr +
192.2798368355061050458134625) * fr +
119.1654824285581628956914143) * fr +
13.43250139086239872172837314) * fr +
0.1636161226585754240958355063)
/
((((14.80884093219134573786480845 * fr +
151.9714051044435648658557668) * fr +
168.5254414101568283957668343) * fr +
33.9905941350215598754191872) * fr +
1.0));
r := ldexp(fr, ex);
result := r;
end;
function f(t: double): double; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
if (t <= 0.008856) then
result := 7.787037037037037037037037037037 * t + (16 / 116)
else
result := CubeRoot(t);
end;
procedure cmsXYZ2Lab(WhitePoint: LPcmsCIEXYZ; Lab: LPcmsCIELab; xyz: LPcmsCIEXYZ);
var
fx, fy, fz: double;
begin
if (xyz^.X = 0) and (xyz^.Y = 0) and (xyz^.Z = 0) then
begin
Lab^.L := 0;
Lab^.a := 0;
Lab^.b := 0;
exit;
end;
if (WhitePoint = nil) then
WhitePoint := cmsD50_XYZ;
fx := f(xyz^.X / WhitePoint^.X);
fy := f(xyz^.Y / WhitePoint^.Y);
fz := f(xyz^.Z / WhitePoint^.Z);
Lab^.L := 116. * fy - 16.;
Lab^.a := 500. * (fx - fy);
Lab^.b := 200. * (fy - fz);
end;
function f_1(t: double): double;
var
tmp: double;
begin
if (t <= ((7.787 * 0.008856) + (16 / 116))) then
begin
tmp := ((t - (16 / 116)) / 7.787037037037037037037037037037);
if (tmp <= 0.0) then
begin
result := 0.0;
exit;
end
else
begin
result := tmp;
exit;
end;
end;
result := t * t * t;
end;
procedure cmsLab2XYZ(WhitePoint: LPcmsCIEXYZ; xyz: LPcmsCIEXYZ; Lab: LPcmsCIELab);
var
x, y, z: double;
begin
if (Lab^.L <= 0) then
begin
xyz^.X := 0;
xyz^.Y := 0;
xyz^.Z := 0;
exit;
end;
if (WhitePoint = nil) then
WhitePoint := cmsD50_XYZ;
y := (Lab^.L + 16) / 116.0;
x := y + 0.002 * Lab^.a;
z := y - 0.005 * Lab^.b;
xyz^.X := f_1(x) * WhitePoint^.X;
xyz^.Y := f_1(y) * WhitePoint^.Y;
xyz^.Z := f_1(z) * WhitePoint^.Z;
end;
function cmsTakeRenderingIntent(hProfile: cmsHPROFILE): integer;
var
Icc: LPLCMSICCPROFILE;
begin
Icc := LPLCMSICCPROFILE(hProfile);
result := integer(Icc^.RenderingIntent);
end;
function cmsIsIntentSupported(hProfile: cmsHPROFILE;
Intent: integer; UsedDirection: integer): longbool;
var
TagTable: PicTagSignature;
begin
if (cmsGetDeviceClass(hProfile) <> icSigLinkClass) then
begin
case (UsedDirection) of
LCMS_USED_AS_INPUT: TagTable := @Device2PCS;
LCMS_USED_AS_OUTPUT: TagTable := @PCS2Device;
LCMS_USED_AS_PROOF: TagTable := @Preview;
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Unexpected direction (%d)", UsedDirection);
result := FALSE;
exit;
end;
end;
inc(TagTable, Intent);
result := cmsIsTag(hProfile, TagTable^);
exit;
end;
result := (cmsTakeRenderingIntent(hProfile) = Intent);
end;
(*
function TYPE_Lab_DBL: dword;
begin
result := (COLORSPACE_SH(PT_Lab) or CHANNELS_SH(3) or BYTES_SH(0));
end;
*)
(*
function TYPE_CMYK_16: dword;
begin
result := (COLORSPACE_SH(PT_CMYK) or CHANNELS_SH(4) or BYTES_SH(2));
end;
*)
function BlackPointUsingPerceptualBlack(BlackPoint: LPcmsCIEXYZ;
hProfile: cmsHPROFILE;
dwFlags: DWORD): integer;
var
hPercLab2CMYK, hRelColCMYK2Lab: cmsHTRANSFORM;
hLab: cmsHPROFILE;
LabIn, LabOut: cmsCIELab;
CMYK: array[0..MAXCHANNELS - 1] of WORD;
BlackXYZ, MediaWhite: cmsCIEXYZ;
begin
if (not cmsIsIntentSupported(hProfile, INTENT_PERCEPTUAL, LCMS_USED_AS_INPUT)) then
begin
BlackPoint^.Z := 0.0;
BlackPoint^.Y := BlackPoint^.Z;
BlackPoint^.X := BlackPoint^.Y;
result := 0;
exit;
end;
hLab := cmsCreateLabProfile(nil);
hPercLab2CMYK := IEcmsCreateTransform(hLab, TYPE_Lab_DBL,
hProfile, TYPE_CMYK_16,
INTENT_PERCEPTUAL, cmsFLAGS_NOTPRECALC);
hRelColCMYK2Lab := IEcmsCreateTransform(hProfile, TYPE_CMYK_16,
hLab, TYPE_Lab_DBL,
INTENT_RELATIVE_COLORIMETRIC, cmsFLAGS_NOTPRECALC);
LabIn.b := 0;
LabIn.a := LabIn.b;
LabIn.L := LabIn.a;
IEcmsDoTransform(hPercLab2CMYK, @LabIn, @CMYK, 1);
IEcmsDoTransform(hRelColCMYK2Lab, @CMYK, @LabOut, 1);
if (LabOut.L > 50) then
LabOut.L := 50;
LabOut.b := 0;
LabOut.a := LabOut.b;
IEcmsDeleteTransform(hPercLab2CMYK);
IEcmsDeleteTransform(hRelColCMYK2Lab);
IEcmsCloseProfile(hLab);
cmsLab2XYZ(nil, @BlackXYZ, @LabOut);
if ((dwFlags and LCMS_BPFLAGS_D50_ADAPTED) = 0) then
begin
cmsTakeMediaWhitePoint(@MediaWhite, hProfile);
cmsAdaptToIlluminant(BlackPoint, cmsD50_XYZ(), @MediaWhite, @BlackXYZ);
end
else
BlackPoint^ := BlackXYZ;
result := 1;
end;
function BlackPointAsDarkerColorant(hInput: cmsHPROFILE;
Intent: integer;
BlackPoint: LPcmsCIEXYZ;
dwFlags: DWORD): integer;
var
White, Black: pWORD;
xform: cmsHTRANSFORM;
Space: icColorSpaceSignature;
nChannels: integer;
dwFormat: DWORD;
hLab: cmsHPROFILE;
Lab: cmsCIELab;
BlackXYZ, MediaWhite: cmsCIEXYZ;
begin
if (not cmsIsIntentSupported(hInput, Intent, LCMS_USED_AS_INPUT)) then
begin
BlackPoint^.Z := 0.0;
BlackPoint^.Y := BlackPoint^.Z;
BlackPoint^.X := BlackPoint^.Y;
result := 0;
exit;
end;
Space := cmsGetColorSpace(hInput);
if (not _cmsEndPointsBySpace(Space, White, Black, @nChannels)) then
begin
BlackPoint^.Z := 0.0;
BlackPoint^.Y := BlackPoint^.Z;
BlackPoint^.X := BlackPoint^.Y;
result := 0;
exit;
end;
dwFormat := (nChannels shl 3) or 2;
hLab := cmsCreateLabProfile(nil);
xform := IEcmsCreateTransform(hInput, dwFormat,
hLab, TYPE_Lab_DBL, Intent, cmsFLAGS_NOTPRECALC);
IEcmsDoTransform(xform, Black, @Lab, 1);
Lab.b := 0;
Lab.a := Lab.b;
if (Lab.L > 50) then
Lab.L := 50;
IEcmsCloseProfile(hLab);
IEcmsDeleteTransform(xform);
cmsLab2XYZ(nil, @BlackXYZ, @Lab);
if (Intent = INTENT_ABSOLUTE_COLORIMETRIC) then
begin
BlackPoint^ := BlackXYZ;
end
else
begin
if ((dwFlags and LCMS_BPFLAGS_D50_ADAPTED) = 0) then
begin
cmsTakeMediaWhitePoint(@MediaWhite, hInput);
cmsAdaptToIlluminant(BlackPoint, cmsD50_XYZ(), @MediaWhite, @BlackXYZ);
end
else
BlackPoint^ := BlackXYZ;
end;
result := 1;
end;
function cmsDetectBlackPoint(BlackPoint: LPcmsCIEXYZ; hProfile: cmsHPROFILE; Intent: integer; dwFlags: DWORD): integer;
var
BlackXYZ, UntrustedBlackPoint, TrustedBlackPoint, MediaWhite: cmsCIEXYZ;
Lab: cmsCIELab;
begin
if ((cmsGetProfileICCversion(hProfile) >= $4000000) and
((Intent = INTENT_PERCEPTUAL) or (Intent = INTENT_SATURATION))) then
begin
result := GetV4PerceptualBlack(BlackPoint, hProfile, dwFlags);
exit;
end;
if (cmsIsTag(hProfile, icSigMediaBlackPointTag) and
(Intent = INTENT_RELATIVE_COLORIMETRIC)) then
begin
cmsTakeMediaBlackPoint(@BlackXYZ, hProfile);
cmsTakeMediaWhitePoint(@MediaWhite, hProfile);
cmsAdaptToIlluminant(@UntrustedBlackPoint, @MediaWhite, cmsD50_XYZ, @BlackXYZ);
cmsXYZ2Lab(nil, @Lab, @UntrustedBlackPoint);
Lab.b := 0;
Lab.a := Lab.b;
if (Lab.L > 50) then
Lab.L := 50;
cmsLab2XYZ(nil, @TrustedBlackPoint, @Lab);
if ((dwFlags and LCMS_BPFLAGS_D50_ADAPTED) = 0) then
cmsAdaptToIlluminant(BlackPoint, cmsD50_XYZ, @MediaWhite, @TrustedBlackPoint)
else
BlackPoint^ := TrustedBlackPoint;
end;
if (Intent = INTENT_RELATIVE_COLORIMETRIC) and
(cmsGetDeviceClass(hProfile) = icSigOutputClass) and
(cmsGetColorSpace(hProfile) = icSigCmykData) then
begin
result := BlackPointUsingPerceptualBlack(BlackPoint, hProfile, dwFlags);
exit;
end;
result := BlackPointAsDarkerColorant(hProfile, Intent, BlackPoint, dwFlags);
end;
procedure Rel2RelStepAbsCoefs(BlackPointIn: LPcmsCIEXYZ;
WhitePointIn: LPcmsCIEXYZ;
IlluminantIn: LPcmsCIEXYZ;
ChromaticAdaptationMatrixIn: LPMAT3;
BlackPointOut: LPcmsCIEXYZ;
WhitePointOut: LPcmsCIEXYZ;
IlluminantOut: LPcmsCIEXYZ;
ChromaticAdaptationMatrixOut: LPMAT3;
m: LPMAT3; xof: LPVEC3);
var
WtPtIn, WtPtInAdapted: VEC3;
WtPtOut, WtPtOutAdapted: VEC3;
Scale, m1, m2, m3: MAT3;
begin
VEC3init(@WtPtIn, WhitePointIn^.X, WhitePointIn^.Y, WhitePointIn^.Z);
MAT3eval(@WtPtInAdapted, ChromaticAdaptationMatrixIn, @WtPtIn);
VEC3init(@WtPtOut, WhitePointOut^.X, WhitePointOut^.Y, WhitePointOut^.Z);
MAT3eval(@WtPtOutAdapted, ChromaticAdaptationMatrixOut, @WtPtOut);
VEC3init(@Scale.v[0], WtPtInAdapted.n[0] / WtPtOutAdapted.n[0], 0, 0);
VEC3init(@Scale.v[1], 0, WtPtInAdapted.n[1] / WtPtOutAdapted.n[1], 0);
VEC3init(@Scale.v[2], 0, 0, WtPtInAdapted.n[2] / WtPtOutAdapted.n[2]);
m1 := ChromaticAdaptationMatrixIn^;
MAT3inverse(@m1, @m2);
MAT3per(@m3, @m2, @Scale);
MAT3per(m, @m3, ChromaticAdaptationMatrixOut);
VEC3init(xof, 0.0, 0.0, 0.0);
end;
procedure XYZ2XYZ(xIn: pwordarray; xOut: pwordarray; m: LPWMAT3; xof: LPWVEC3);
var
a, r: WVEC3;
begin
a.n[0] := xIn[0] shl 1;
a.n[1] := xIn[1] shl 1;
a.n[2] := xIn[2] shl 1;
MAT3evalW(@r, m, @a);
xOut[0] := Clamp_XYZ((r.n[VX] + xof^.n[VX]) shr 1);
xOut[1] := Clamp_XYZ((r.n[VY] + xof^.n[VY]) shr 1);
xOut[2] := Clamp_XYZ((r.n[VZ] + xof^.n[VZ]) shr 1);
end;
procedure ComputeBlackPointCompensationFactors(BlackPointIn: LPcmsCIEXYZ;
WhitePointIn: LPcmsCIEXYZ;
IlluminantIn: LPcmsCIEXYZ;
BlackPointOut: LPcmsCIEXYZ;
WhitePointOut: LPcmsCIEXYZ;
IlluminantOut: LPcmsCIEXYZ;
m: LPMAT3; xof: LPVEC3);
var
RelativeBlackPointIn, RelativeBlackPointOut: cmsCIEXYZ;
ax, ay, az, bx, by, bz, tx, ty, tz: double;
begin
cmsAdaptToIlluminant(@RelativeBlackPointIn, WhitePointIn, IlluminantIn, BlackPointIn);
cmsAdaptToIlluminant(@RelativeBlackPointOut, WhitePointOut, IlluminantOut, BlackPointOut);
tx := RelativeBlackPointIn.X - IlluminantIn^.X;
ty := RelativeBlackPointIn.Y - IlluminantIn^.Y;
tz := RelativeBlackPointIn.Z - IlluminantIn^.Z;
ax := (RelativeBlackPointOut.X - IlluminantOut^.X) / tx;
ay := (RelativeBlackPointOut.Y - IlluminantOut^.Y) / ty;
az := (RelativeBlackPointOut.Z - IlluminantOut^.Z) / tz;
bx := -IlluminantOut^.X * (RelativeBlackPointOut.X - RelativeBlackPointIn.X) / tx;
by := -IlluminantOut^.Y * (RelativeBlackPointOut.Y - RelativeBlackPointIn.Y) / ty;
bz := -IlluminantOut^.Z * (RelativeBlackPointOut.Z - RelativeBlackPointIn.Z) / tz;
MAT3identity(m);
m^.v[VX].n[0] := ax;
m^.v[VY].n[1] := ay;
m^.v[VZ].n[2] := az;
VEC3init(xof, bx, by, bz);
end;
function Clamp_L(xin: Fixed32): word;
begin
if (xin = $FFFF) then
begin
result := $FFFF;
exit;
end;
if (xin > $FF00) then
begin
result := $FF00;
exit;
end;
result := xin;
end;
function ENCODE_AB(x: double): word; {$ifdef IESUPPORTINLINE} inline; {$endif}
begin
result := round(((x) + 128.0) * 256.0 );
end;
function Clamp_ab(xin: Fixed32): word;
begin
if (xin = $FFFF) then
begin
result := $FFFF;
exit;
end;
if (xin < 0) then
begin
result := ENCODE_AB(-128.0);
exit;
end;
if (xin > $FFFF) then
begin
result := ENCODE_AB(+127.9961);
exit;
end;
result := xin;
end;
procedure cmsXYZ2LabEncoded(XYZ: pwordarray; Lab: pwordarray);
var
X_ma, Y_ma, Z_ma: Fixed32;
x_mi, y_mi, z_mi, L, a, b: double;
fx, fy, fz: double;
wL, wa, wb: Fixed32;
begin
X_ma := XYZ[0] shl 1;
Y_ma := XYZ[1] shl 1;
Z_ma := XYZ[2] shl 1;
if (X_ma = 0) and (Y_ma = 0) and (Z_ma = 0) then
begin
Lab[0] := 0;
Lab[2] := $8000;
Lab[1] := Lab[2];
exit;
end;
x_mi := FIXED_TO_DOUBLE(X_ma) / D50X;
y_mi := FIXED_TO_DOUBLE(Y_ma) / D50Y;
z_mi := FIXED_TO_DOUBLE(Z_ma) / D50Z;
fx := f(x_mi);
fy := f(y_mi);
fz := f(z_mi);
L := 116 * fy - 16;
a := 500 * (fx - fy);
b := 200 * (fy - fz);
a := a + 128;
b := b + 128;
wL := round(L * 652.800 );
wa := round(a * 256.0 );
wb := round(b * 256.0 );
Lab[0] := Clamp_L(wL);
Lab[1] := Clamp_ab(wa);
Lab[2] := Clamp_ab(wb);
end;
procedure XYZ2Lab(xIn: pwordarray; xOut: pwordarray; m: LPWMAT3; xof: LPWVEC3);
var
XYZ: array[0..2] of WORD;
begin
XYZ2XYZ(xIn, @XYZ, m, xof);
cmsXYZ2LabEncoded(@XYZ, xOut);
end;
function FromXYZRelLUT(xAbsolute: integer;
BlackPointIn: LPcmsCIEXYZ;
WhitePointIn: LPcmsCIEXYZ;
IlluminantIn: LPcmsCIEXYZ;
ChromaticAdaptationMatrixIn: LPMAT3;
Phase2: integer; BlackPointOut: LPcmsCIEXYZ;
WhitePointOut: LPcmsCIEXYZ;
IlluminantOut: LPcmsCIEXYZ;
ChromaticAdaptationMatrixOut: LPMAT3;
DoBlackPointCompensation: integer;
var fn1: _cmsADJFN;
m: LPMAT3; xof: LPVEC3): integer;
begin
case (Phase2) of
XYZRel:
if (xAbsolute <> 0) then
begin
Rel2RelStepAbsCoefs(BlackPointIn,
WhitePointIn,
IlluminantIn,
ChromaticAdaptationMatrixIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
ChromaticAdaptationMatrixOut,
m, xof);
fn1 := XYZ2XYZ;
end
else
begin
fn1 := nil;
if (DoBlackPointCompensation <> 0) then
begin
fn1 := XYZ2XYZ;
ComputeBlackPointCompensationFactors(BlackPointIn,
WhitePointIn,
IlluminantIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
m, xof);
end;
end;
LabRel:
if (xAbsolute <> 0) then
begin
Rel2RelStepAbsCoefs(BlackPointIn,
WhitePointIn,
IlluminantIn,
ChromaticAdaptationMatrixIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
ChromaticAdaptationMatrixOut,
m, xof);
fn1 := XYZ2Lab;
end
else
begin
MAT3identity(m);
VEC3init(xof, 0, 0, 0);
fn1 := XYZ2Lab;
if (DoBlackPointCompensation <> 0) then
begin
ComputeBlackPointCompensationFactors(BlackPointIn,
WhitePointIn,
IlluminantIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
m, xof);
end;
end;
else
begin
result := 0;
exit;
end;
end;
result := 1;
end;
procedure cmsLab2XYZEncoded(Lab: pwordarray; XYZ: pwordarray);
var
L, a, b: double;
X_ma, Y_ma, Z_ma, x_mi, y_mi, z_mi: double;
begin
L := (Lab[0] * 100) / 65280;
if (L = 0) then
begin
XYZ[0] := 0;
XYZ[1] := 0;
XYZ[2] := 0;
exit;
end;
a := (Lab[1] / 256.0) - 128;
b := (Lab[2] / 256.0) - 128;
y_mi := (L + 16) / 116;
x_mi := y_mi + 0.002 * a;
z_mi := y_mi - 0.005 * b;
X_ma := f_1(x_mi) * D50X;
Y_ma := f_1(y_mi) * D50Y;
Z_ma := f_1(z_mi) * D50Z;
XYZ[0] := Clamp_XYZ(floor(X_ma * 32768 + 0.5));
XYZ[1] := Clamp_XYZ(floor(Y_ma * 32768 + 0.5));
XYZ[2] := Clamp_XYZ(floor(Z_ma * 32768 + 0.5));
end;
procedure Lab2XYZ(xIn: pwordarray; xOut: pwordarray; m: LPWMAT3; xof: LPWVEC3);
var
XYZ: array[0..2] of word;
begin
cmsLab2XYZEncoded(xIn, @XYZ);
XYZ2XYZ(@XYZ, xOut, m, xof);
end;
procedure Lab2XYZ2Lab(xIn: pwordarray; xOut: pwordarray; m: LPWMAT3; xof: LPWVEC3);
var
XYZ, XYZ2: array[0..2] of WORD;
begin
cmsLab2XYZEncoded(xIn, @XYZ);
XYZ2XYZ(@XYZ, @XYZ2, m, xof);
cmsXYZ2LabEncoded(@XYZ2, xOut);
end;
function FromLabRelLUT(xAbsolute: integer;
BlackPointIn: LPcmsCIEXYZ;
WhitePointIn: LPcmsCIEXYZ;
IlluminantIn: LPcmsCIEXYZ;
ChromaticAdaptationMatrixIn: LPMAT3;
Phase2: integer; BlackPointOut: LPcmsCIEXYZ;
WhitePointOut: LPcmsCIEXYZ;
IlluminantOut: LPcmsCIEXYZ;
ChromaticAdaptationMatrixOut: LPMAT3;
DoBlackPointCompensation: integer;
var fn1: _cmsADJFN;
m: LPMAT3; xof: LPVEC3): integer;
begin
case (Phase2) of
XYZRel:
if (xAbsolute <> 0) then
begin
Rel2RelStepAbsCoefs(BlackPointIn,
WhitePointIn,
cmsD50_XYZ(),
ChromaticAdaptationMatrixIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
ChromaticAdaptationMatrixOut,
m, xof);
fn1 := Lab2XYZ;
end
else
begin
fn1 := Lab2XYZ;
if (DoBlackPointCompensation <> 0) then
begin
ComputeBlackPointCompensationFactors(BlackPointIn,
WhitePointIn,
IlluminantIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
m, xof);
end;
end;
LabRel:
if (xAbsolute <> 0) then
begin
Rel2RelStepAbsCoefs(BlackPointIn,
WhitePointIn, IlluminantIn,
ChromaticAdaptationMatrixIn,
BlackPointOut,
WhitePointOut, cmsD50_XYZ(),
ChromaticAdaptationMatrixOut,
m, xof);
fn1 := Lab2XYZ2Lab;
end
else
begin
fn1 := nil;
if (DoBlackPointCompensation <> 0) then
begin
fn1 := Lab2XYZ2Lab;
ComputeBlackPointCompensationFactors(BlackPointIn,
WhitePointIn,
IlluminantIn,
BlackPointOut,
WhitePointOut,
IlluminantOut,
m, xof);
end;
end;
else
begin
result := 0;
exit;
end;
end;
result := 1;
end;
procedure VEC3initF(r: LPWVEC3; x, y, z: double);
begin
r^.n[VX] := DOUBLE_TO_FIXED(x);
r^.n[VY] := DOUBLE_TO_FIXED(y);
r^.n[VZ] := DOUBLE_TO_FIXED(z);
end;
function IdentityParameters(m: LPWMAT3; xof: LPWVEC3): longbool;
var
wv0: WVEC3;
begin
VEC3initF(@wv0, 0, 0, 0);
if (not MAT3isIdentity(m, 0.00001)) then
begin
result := FALSE;
exit;
end;
if (not VEC3equal(xof, @wv0, 0.00001)) then
begin
result := FALSE;
exit;
end;
result := TRUE;
end;
function cmsChooseCnvrt(xAbsolute: integer;
Phase1: integer; BlackPointIn: LPcmsCIEXYZ;
WhitePointIn: LPcmsCIEXYZ;
IlluminantIn: LPcmsCIEXYZ;
ChromaticAdaptationMatrixIn: LPMAT3;
Phase2: integer; BlackPointOut: LPcmsCIEXYZ;
WhitePointOut: LPcmsCIEXYZ;
IlluminantOut: LPcmsCIEXYZ;
ChromaticAdaptationMatrixOut: LPMAT3;
DoBlackPointCompensation: integer;
var fn1: _cmsADJFN;
wm: LPWMAT3; wof: LPWVEC3): integer;
var
rc: integer;
m: MAT3;
xof: VEC3;
begin
MAT3identity(@m);
VEC3init(@xof, 0, 0, 0);
case (Phase1) of
XYZRel: rc := FromXYZRelLUT(xAbsolute,
BlackPointIn,
WhitePointIn,
IlluminantIn,
ChromaticAdaptationMatrixIn,
Phase2,
BlackPointOut,
WhitePointOut,
IlluminantOut,
ChromaticAdaptationMatrixOut,
DoBlackPointCompensation,
fn1, @m, @xof);
LabRel: rc := FromLabRelLUT(xAbsolute,
BlackPointIn,
WhitePointIn,
IlluminantIn,
ChromaticAdaptationMatrixIn,
Phase2,
BlackPointOut,
WhitePointOut,
IlluminantOut,
ChromaticAdaptationMatrixOut,
DoBlackPointCompensation,
fn1, @m, @xof);
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "(internal) Phase error");
result := 0;
exit;
end;
end;
MAT3toFix(wm, @m);
VEC3toFix(wof, @xof);
if (@fn1 = @XYZ2XYZ) or (@fn1 = @Lab2XYZ2Lab) then
begin
if (IdentityParameters(wm, wof)) then
fn1 := nil;
end;
result := rc;
end;
procedure TakeConversionRoutines(p: _LPcmsTRANSFORM; DoBPC: integer);
var
BlackPointIn, WhitePointIn, IlluminantIn: cmsCIEXYZ;
BlackPointOut, WhitePointOut, IlluminantOut: cmsCIEXYZ;
BlackPointProof, WhitePointProof, IlluminantProof: cmsCIEXYZ;
ChromaticAdaptationMatrixIn, ChromaticAdaptationMatrixOut: MAT3;
ChromaticAdaptationMatrixProof: MAT3;
begin
cmsTakeIluminant(@IlluminantIn, p^.InputProfile);
cmsTakeMediaWhitePoint(@WhitePointIn, p^.InputProfile);
cmsTakeMediaBlackPoint(@BlackPointIn, p^.InputProfile);
cmsReadChromaticAdaptationMatrix(@ChromaticAdaptationMatrixIn, p^.InputProfile);
cmsTakeIluminant(@IlluminantOut, p^.OutputProfile);
cmsTakeMediaWhitePoint(@WhitePointOut, p^.OutputProfile);
cmsTakeMediaBlackPoint(@BlackPointOut, p^.OutputProfile);
cmsReadChromaticAdaptationMatrix(@ChromaticAdaptationMatrixOut, p^.OutputProfile);
if (p^.Preview = nil) then
begin
if (p^.Intent = INTENT_PERCEPTUAL) or
(p^.Intent = INTENT_SATURATION) then
begin
if ((cmsGetProfileICCversion(p^.InputProfile) >= $4000000) or
(cmsGetProfileICCversion(p^.OutputProfile) >= $4000000)) then
begin
DoBPC := 1;
end;
end;
if (p^.Intent = INTENT_ABSOLUTE_COLORIMETRIC) then
DoBPC := 0;
if ((cmsGetDeviceClass(p^.InputProfile) = icSigAbstractClass) or
(cmsGetDeviceClass(p^.InputProfile) = icSigLinkClass)) then
DoBPC := 0;
if ((cmsGetDeviceClass(p^.OutputProfile) = icSigAbstractClass) or
(cmsGetDeviceClass(p^.OutputProfile) = icSigLinkClass)) then
DoBPC := 0;
if (DoBPC <> 0) then
begin
cmsDetectBlackPoint(@BlackPointIn, p^.InputProfile, p^.Intent, 0);
cmsDetectBlackPoint(@BlackPointOut, p^.OutputProfile, p^.Intent, 0);
if (BlackPointIn.X = BlackPointOut.X) and
(BlackPointIn.Y = BlackPointOut.Y) and
(BlackPointIn.Z = BlackPointOut.Z) then
DoBPC := 0;
end;
cmsChooseCnvrt(integer(p^.Intent = INTENT_ABSOLUTE_COLORIMETRIC),
p^.Phase1,
@BlackPointIn,
@WhitePointIn,
@IlluminantIn,
@ChromaticAdaptationMatrixIn,
p^.Phase3,
@BlackPointOut,
@WhitePointOut,
@IlluminantOut,
@ChromaticAdaptationMatrixOut,
DoBPC,
p^.Stage1,
@p^.m1, @p^.of1);
end
else
begin
cmsTakeIluminant(@IlluminantProof, p^.PreviewProfile);
cmsTakeMediaWhitePoint(@WhitePointProof, p^.PreviewProfile);
cmsTakeMediaBlackPoint(@BlackPointProof, p^.PreviewProfile);
cmsReadChromaticAdaptationMatrix(@ChromaticAdaptationMatrixProof, p^.PreviewProfile);
if (DoBPC <> 0) then
begin
cmsDetectBlackPoint(@BlackPointProof, p^.PreviewProfile, p^.Intent, 0);
cmsDetectBlackPoint(@BlackPointIn, p^.InputProfile, p^.Intent, 0);
cmsDetectBlackPoint(@BlackPointOut, p^.OutputProfile, p^.Intent, 0);
if (BlackPointIn.X = BlackPointProof.X) and
(BlackPointIn.Y = BlackPointProof.Y) and
(BlackPointIn.Z = BlackPointProof.Z) then
DoBPC := 0;
end;
cmsChooseCnvrt(integer(p^.Intent = INTENT_ABSOLUTE_COLORIMETRIC),
p^.Phase1,
@BlackPointIn,
@WhitePointIn,
@IlluminantIn,
@ChromaticAdaptationMatrixIn,
p^.Phase2,
@BlackPointProof,
@WhitePointProof,
@IlluminantProof,
@ChromaticAdaptationMatrixProof,
DoBPC,
p^.Stage1,
@p^.m1, @p^.of1);
cmsChooseCnvrt(integer(p^.ProofIntent = INTENT_ABSOLUTE_COLORIMETRIC),
p^.Phase2,
@BlackPointProof,
@WhitePointProof,
@IlluminantProof,
@ChromaticAdaptationMatrixProof,
p^.Phase3,
@BlackPointOut,
@WhitePointOut,
@IlluminantOut,
@ChromaticAdaptationMatrixOut,
0,
p^.Stage2,
@p^.m2, @p^.of2);
end;
end;
function _cmsChannelsOf(ColorSpace: icColorSpaceSignature): integer;
begin
case (ColorSpace) of
icSigGrayData: result := 1;
icSig2colorData: result := 2;
icSigXYZData,
icSigLabData,
icSigLuvData,
icSigYCbCrData,
icSigYxyData,
icSigRgbData,
icSigHsvData,
icSigHlsData,
icSigCmyData,
icSig3colorData: result := 3;
icColorSpaceSignature(icSigLuvKData),
icSigCmykData,
icSig4colorData: result := 4;
icSig5colorData: result := 5;
icColorSpaceSignature(icSigHexachromeData),
icSig6colorData: result := 6;
icColorSpaceSignature(icSigHeptachromeData),
icSig7colorData: result := 7;
icColorSpaceSignature(icSigOctachromeData),
icSig8colorData: result := 8;
icSig9colorData: result := 9;
icSig10colorData: result := 10;
icSig11colorData: result := 11;
icSig12colorData: result := 12;
icSig13colorData: result := 13;
icSig14colorData: result := 14;
icSig15colorData: result := 15;
else
result := 3;
end;
end;
function _cmsReasonableGridpointsByColorspace(Colorspace: icColorSpaceSignature; dwFlags: DWORD): integer;
var
nChannels: integer;
begin
nChannels := _cmsChannelsOf(Colorspace);
if (dwFlags and cmsFLAGS_HIGHRESPRECALC) <> 0 then
begin
if (nChannels > 4) then
begin
result := 7;
exit;
end;
if (nChannels = 4) then
begin
result := 23;
exit;
end;
result := 48;
exit;
end;
if (dwFlags and cmsFLAGS_LOWRESPRECALC) <> 0 then
begin
if (nChannels > 4) then
begin
result := 6;
exit;
end;
if (nChannels = 1) then
begin
result := 33;
exit;
end;
result := 17;
exit;
end;
if (nChannels > 4) then
begin
result := 7;
exit;
end;
if (nChannels = 4) then
begin
result := 17;
exit;
end;
result := 33;
end;
function MostlyLinear(Table: pwordarray; nEntries: integer): integer;
var
i: integer;
diff: integer;
begin
for i := 5 to nEntries - 1 do
begin
diff := abs(Table[i] - _cmsQuantizeVal(i, nEntries));
if (diff > $0300) then
begin
result := 0;
exit;
end;
end;
result := 1;
end;
function IsMonotonic(t: LPGAMMATABLE): longbool;
var
n: integer;
i, last: integer;
begin
n := t^.nEntries;
last := t^.GammaTable[n - 1];
for i := n - 2 downto 0 do
begin
if (t^.GammaTable[i] > last) then
begin
result := FALSE;
exit;
end
else
last := t^.GammaTable[i];
end;
result := TRUE;
end;
procedure SlopeLimiting(Table: pwordarray; nEntries: integer);
var
At: integer;
Val, Slope: double;
i: integer;
begin
At := floor(nEntries * 0.02 + 0.5);
Val := Table[At];
Slope := Val / At;
for i := 0 to At - 1 do
Table[i] := floor(i * Slope + 0.5);
end;
const
PRELINEARIZATION_POINTS = 4096;
procedure _cmsComputePrelinearizationTablesFromXFORM(h: PcmsHTRANSFORM; nTransforms: integer; Grid: LPLUT);
var
Trans: array[0..MAXCHANNELS - 1] of LPGAMMATABLE;
t, i, v: dword;
j: integer;
xIn, xOut: array[0..MAXCHANNELS - 1] of WORD;
lIsSuitable: longBOOL;
hh: PcmsHTRANSFORM;
begin
hh := h;
for t := 0 to Grid^.InputChan - 1 do
Trans[t] := cmsAllocGamma(PRELINEARIZATION_POINTS);
for i := 0 to PRELINEARIZATION_POINTS - 1 do
begin
h := hh;
v := _cmsQuantizeVal(i, PRELINEARIZATION_POINTS);
for t := 0 to Grid^.InputChan - 1 do
xIn[t] := v;
IEcmsDoTransform(h^, @xIn, @xOut, 1);
inc(h);
for j := 1 to nTransforms - 1 do
begin
IEcmsDoTransform(h^, @xOut, @xOut, 1);
inc(h);
end;
for t := 0 to Grid^.InputChan - 1 do
Trans[t]^.GammaTable[i] := xOut[t];
end;
lIsSuitable := TRUE;
t := 0;
while (lIsSuitable and (t < Grid^.InputChan)) do
begin
if (MostlyLinear(@Trans[t]^.GammaTable, PRELINEARIZATION_POINTS)) <> 0 then
lIsSuitable := FALSE;
if (not IsMonotonic(Trans[t])) then
lIsSuitable := FALSE;
inc(t);
end;
if (lIsSuitable) then
begin
for t := 0 to Grid^.InputChan - 1 do
SlopeLimiting(@Trans[t]^.GammaTable, Trans[t]^.nEntries);
end;
if (lIsSuitable) then
cmsAllocLinearTable(Grid, @Trans, 1);
for t := 0 to Grid^.InputChan - 1 do
cmsFreeGamma(Trans[t]);
end;
function XFormSampler(xIn: pwordarray; xOut: pwordarray; Cargo: pointer): integer;
begin
IEcmsDoTransform(cmsHTRANSFORM(Cargo), xIn, xOut, 1);
result := 1;
end;
function _cmsPrecalculateDeviceLink(h: cmsHTRANSFORM; dwFlags: DWORD): LPLUT;
var
p: _LPcmsTRANSFORM;
Grid: LPLUT;
nGridPoints: integer;
dwFormatIn, dwFormatOut: DWORD;
ChannelsIn, ChannelsOut: integer;
hOne: array[0..0] of cmsHTRANSFORM;
begin
p := _LPcmsTRANSFORM(h);
ChannelsIn := _cmsChannelsOf(p^.EntryColorSpace);
ChannelsOut := _cmsChannelsOf(p^.ExitColorSpace);
if (dwFlags and $00FF0000) <> 0 then
begin
nGridPoints := (dwFlags shr 16) and $FF;
end
else
begin
nGridPoints := _cmsReasonableGridpointsByColorspace(p^.EntryColorSpace, dwFlags);
end;
Grid := cmsAllocLUT();
if (Grid = nil) then
begin
result := nil;
exit;
end;
Grid := cmsAlloc3DGrid(Grid, nGridPoints, ChannelsIn, ChannelsOut);
dwFormatIn := ((ChannelsIn shl 3) or 2);
dwFormatOut := ((ChannelsOut shl 3) or 2);
p^.FromInput := _cmsIdentifyInputFormat(p, dwFormatIn);
p^.ToOutput := _cmsIdentifyOutputFormat(p, dwFormatOut);
if (p^.EntryColorSpace = icSigRgbData) and
(p^.ExitColorSpace = icSigRgbData) and
((dwFlags and cmsFLAGS_NOPRELINEARIZATION) = 0) then
begin
hOne[0] := h;
_cmsComputePrelinearizationTablesFromXFORM(@hOne, 1, Grid);
end;
if (not cmsSample3DGrid(Grid, XFormSampler, p, Grid^.wFlags)) then
begin
cmsFreeLUT(Grid);
result := nil;
exit;
end;
result := Grid;
end;
procedure cmsTetrahedralInterp8(Input: pwordarray;
Output: pwordarray;
LutTable: pwordarray;
p: LPL16PARAMS);
var
r, g, b: integer;
rx, ry, rz: Fixed32;
c1, c2, c3, Rest: Fixed32;
OutChan: integer;
X0, X1, Y0, Y1, Z0, Z1: Fixed32;
TotalOut: integer;
p8: LPL8PARAMS;
function DENS(i, j, k: Fixed32): Fixed32;
begin
result := (LutTable[(i) + (j) + (k) + OutChan])
end;
begin
TotalOut := p^.nOutputs;
p8 := p^.p8;
r := Input[0] shr 8;
g := Input[1] shr 8;
b := Input[2] shr 8;
X1 := p8^.X0[r];
X0 := X1;
Y1 := p8^.Y0[g];
Y0 := Y1;
Z1 := p8^.Z0[b];
Z0 := Z1;
if (r <> 255) then
X1 := X1 + p^.opta3;
if (g <> 255) then
Y1 := Y1 + p^.opta2;
if (b <> 255) then
Z1 := Z1 + p^.opta1;
rx := p8^.rx[r];
ry := p8^.ry[g];
rz := p8^.rz[b];
for OutChan := 0 to TotalOut - 1 do
begin
if (rx >= ry) and (ry >= rz) then
begin
c1 := DENS(X1, Y0, Z0) - DENS(X0, Y0, Z0);
c2 := DENS(X1, Y1, Z0) - DENS(X1, Y0, Z0);
c3 := DENS(X1, Y1, Z1) - DENS(X1, Y1, Z0);
end
else
if (rx >= rz) and (rz >= ry) then
begin
c1 := DENS(X1, Y0, Z0) - DENS(X0, Y0, Z0);
c2 := DENS(X1, Y1, Z1) - DENS(X1, Y0, Z1);
c3 := DENS(X1, Y0, Z1) - DENS(X1, Y0, Z0);
end
else
if (rz >= rx) and (rx >= ry) then
begin
c1 := DENS(X1, Y0, Z1) - DENS(X0, Y0, Z1);
c2 := DENS(X1, Y1, Z1) - DENS(X1, Y0, Z1);
c3 := DENS(X0, Y0, Z1) - DENS(X0, Y0, Z0);
end
else
if (ry >= rx) and (rx >= rz) then
begin
c1 := DENS(X1, Y1, Z0) - DENS(X0, Y1, Z0);
c2 := DENS(X0, Y1, Z0) - DENS(X0, Y0, Z0);
c3 := DENS(X1, Y1, Z1) - DENS(X1, Y1, Z0);
end
else
if (ry >= rz) and (rz >= rx) then
begin
c1 := DENS(X1, Y1, Z1) - DENS(X0, Y1, Z1);
c2 := DENS(X0, Y1, Z0) - DENS(X0, Y0, Z0);
c3 := DENS(X0, Y1, Z1) - DENS(X0, Y1, Z0);
end
else
if (rz >= ry) and (ry >= rx) then
begin
c1 := DENS(X1, Y1, Z1) - DENS(X0, Y1, Z1);
c2 := DENS(X0, Y1, Z1) - DENS(X0, Y0, Z1);
c3 := DENS(X0, Y0, Z1) - DENS(X0, Y0, Z0);
end
else
begin
c3 := 0;
c2 := c3;
c1 := c2;
end;
Rest := c1 * rx + c2 * ry + c3 * rz;
Output[OutChan] := (DENS(X0, Y0, Z0) + ((ToFixedDomain(Rest)) + $8000) shr 16);
end;
end;
function _cmsBlessLUT8(Lut: LPLUT): LPLUT;
var
i, j: integer;
StageABC: array[0..2] of WORD;
v1, v2, v3: Fixed32;
p8: LPL8PARAMS;
p: LPL16PARAMS;
begin
p := @Lut^.CLut16params;
getmem(p8, sizeof(L8PARAMS));
if (p8 = nil) then
begin
result := nil;
exit;
end;
for i := 0 to 255 do
begin
StageABC[2] := RGB_8_TO_16(i);
StageABC[1] := StageABC[2];
StageABC[0] := StageABC[1];
if (Lut^.wFlags and LUT_HASTL1) <> 0 then
begin
for j := 0 to 2 do
StageABC[i] := cmsLinearInterpLUT16(StageABC[i],
pwordarray(Lut^.L1[i]),
@Lut^.In16params);
Lut^.wFlags := Lut^.wFlags and (not LUT_HASTL1);
end;
v1 := ToFixedDomain(StageABC[0] * p^.Domain);
v2 := ToFixedDomain(StageABC[1] * p^.Domain);
v3 := ToFixedDomain(StageABC[2] * p^.Domain);
p8^.X0[i] := p^.opta3 * FIXED_TO_INT(v1);
p8^.Y0[i] := p^.opta2 * FIXED_TO_INT(v2);
p8^.Z0[i] := p^.opta1 * FIXED_TO_INT(v3);
p8^.rx[i] := FIXED_REST_TO_INT(v1);
p8^.ry[i] := FIXED_REST_TO_INT(v2);
p8^.rz[i] := FIXED_REST_TO_INT(v3);
end;
Lut^.CLut16params.p8 := p8;
Lut^.CLut16params.Interp3D := cmsTetrahedralInterp8;
result := Lut;
end;
// Create a transform.
function cmsCreateProofingTransform(InputProfile: cmsHPROFILE; InputFormat: DWORD; OutputProfile: cmsHPROFILE; OutputFormat: DWORD; ProofingProfile: cmsHPROFILE; nIntent: integer; ProofingIntent: integer; dwFlags: DWORD): cmsHTRANSFORM;
var
p: _LPcmsTRANSFORM;
FromTag: icTagSignature;
ToTag: icTagSignature;
DeviceLink: LPLUT;
begin
if (nIntent < 0) or (nIntent > 3) or (ProofingIntent < 0) or (ProofingIntent > 3) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "cmsCreateTransform: intent mismatch");
result := nil;
exit;
end;
p := AllocEmptyTransform;
if (p = nil) then
begin
result := nil;
exit;
end;
p^.xform := NormalXFORM;
p^.Intent := nIntent;
p^.ProofIntent := ProofingIntent;
p^.DoGamutCheck := 0;
p^.InputProfile := InputProfile;
p^.OutputProfile := OutputProfile;
p^.PreviewProfile := ProofingProfile;
p^.InputFormat := InputFormat;
p^.OutputFormat := OutputFormat;
p^.lOutputV4Lab := false;
p^.lInputV4Lab := p^.lOutputV4Lab;
p^.FromInput := _cmsIdentifyInputFormat(p, InputFormat);
p^.ToOutput := _cmsIdentifyOutputFormat(p, OutputFormat);
if (((dwFlags and cmsFLAGS_NULLTRANSFORM) <> 0) or ((InputProfile = nil) and (OutputProfile = nil))) then
begin
p^.xform := NullXFORM;
result := cmsHTRANSFORM(p);
exit;
end;
if (InputProfile = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Input profile cannot be NULL!");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
if (cmsGetDeviceClass(InputProfile) = icSigLinkClass) then
begin
result := CreateDeviceLinkTransform(p, dwFlags);
exit;
end;
if (not IsProperColorSpace(InputProfile, InputFormat, FALSE)) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Input profile is operating on wrong colorspace");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
p^.EntryColorSpace := cmsGetColorSpace(InputProfile);
if (cmsGetDeviceClass(InputProfile) = icSigNamedColorClass) then
begin
if (p^.NamedColorList = nil) then
p^.NamedColorList := cmsAllocNamedColorList(0);
cmsReadICCnamedColorList(p, InputProfile, icSigNamedColor2Tag);
if (OutputProfile = nil) then
begin
p^.ExitColorSpace := p^.EntryColorSpace;
p^.xform := @NC2deviceXform;
result := cmsHTRANSFORM(p);
exit;
end;
dwFlags := dwFlags or cmsFLAGS_NOTPRECALC;
end;
if (OutputProfile = nil) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Output profile cannot be NULL!");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
if (not IsProperColorSpace(OutputProfile, OutputFormat, FALSE)) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Output profile is operating on wrong colorspace");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
p^.ExitColorSpace := cmsGetColorSpace(OutputProfile);
if (cmsGetDeviceClass(OutputProfile) = icSigNamedColorClass) then
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Named color profiles are not supported as output");
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
p^.Phase1 := GetPhase(InputProfile);
p^.Phase2 := -1;
p^.Phase3 := GetPhase(OutputProfile);
FromTag := Device2PCS[nIntent];
ToTag := PCS2Device[nIntent];
if (not cmsIsTag(InputProfile, FromTag)) then
begin
FromTag := Device2PCS[0];
if (not cmsIsTag(InputProfile, FromTag)) then
begin
FromTag := icTagSignature(0);
end;
end;
if (ProofingProfile <> nil) then
CreateProof(p, dwFlags, @ToTag);
if (not cmsIsTag(OutputProfile, ToTag)) then
begin
ToTag := PCS2Device[0];
if (cmsGetDeviceClass(OutputProfile) = icSigAbstractClass) then
begin
if (not cmsIsTag(OutputProfile, ToTag)) then
begin
ToTag := icTagSignature(icSigAToB0Tag);
end;
end;
if (not cmsIsTag(OutputProfile, ToTag)) then
ToTag := icTagSignature(0);
end;
if (dwFlags and cmsFLAGS_MATRIXINPUT) <> 0 then
FromTag := icTagSignature(0);
if (dwFlags and cmsFLAGS_MATRIXOUTPUT) <> 0 then
ToTag := icTagSignature(0);
if (dwFlags and cmsFLAGS_GAMUTCHECK) <> 0 then
begin
p^.DoGamutCheck := 1;
dwFlags := dwFlags or cmsFLAGS_NOTPRECALC;
end;
if (PickTransformRoutine(p, @dwFlags, @FromTag, @ToTag) = nil) then
begin
IEcmsDeleteTransform(cmsHTRANSFORM(p));
result := nil;
exit;
end;
TakeConversionRoutines(p, dwFlags and cmsFLAGS_BLACKPOINTCOMPENSATION);
if ((dwFlags and cmsFLAGS_NOTPRECALC) = 0) then
begin
DeviceLink := _cmsPrecalculateDeviceLink(cmsHTRANSFORM(p), dwFlags);
if (p^.EntryColorSpace = icSigRgbData) or (p^.EntryColorSpace = icSigCmyData) then
begin
DeviceLink^.CLut16params.Interp3D := cmsTetrahedralInterp16;
end;
if (((InputFormat and 7) = 1) and (T_CHANNELS(InputFormat) = 3)) then
begin
DeviceLink := _cmsBlessLUT8(DeviceLink);
if (DeviceLink = nil) then
begin
result := nil;
exit;
end;
end;
if (DeviceLink <> nil) then
begin
p^.DeviceLink := DeviceLink;
end
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "Cannot precalculate %d->%d channels transform!", T_CHANNELS(InputFormat), T_CHANNELS(OutputFormat));
IEcmsDeleteTransform(p);
result := nil;
exit;
end;
SetPrecalculatedTransform(p, dwFlags);
end;
p^.FromInput := _cmsIdentifyInputFormat(p, InputFormat);
p^.ToOutput := _cmsIdentifyOutputFormat(p, OutputFormat);
result := p;
end;
// Wrapper por simpler non-proofing transforms.
function IEcmsCreateTransform(Input: cmsHPROFILE; InputFormat: DWORD; Output: cmsHPROFILE; OutputFormat: DWORD; Intent: integer; dwFlags: DWORD): cmsHTRANSFORM;
begin
result := cmsCreateProofingTransform(Input, InputFormat, Output, OutputFormat, nil, Intent, INTENT_ABSOLUTE_COLORIMETRIC, dwFlags);
end;
function cmsWhitePointFromTemp(TempK: integer; WhitePoint: LPcmsCIExyY): longbool;
var
x, y: double;
T, T2, T3: double;
begin
T := TempK;
T2 := T * T;
T3 := T2 * T;
if (T >= 4000) and (T <= 7000) then
begin
x := -4.6070 * (1E9 / T3) + 2.9678 * (1E6 / T2) + 0.09911 * (1E3 / T) + 0.244063;
end
else
if (T > 7000.0) and (T <= 25000.0) then
begin
x := -2.0064 * (1E9 / T3) + 1.9018 * (1E6 / T2) + 0.24748 * (1E3 / T) + 0.237040;
end
else
begin
//cmsSignalError(LCMS_ERRC_ABORTED, "cmsWhitePointFromTemp: invalid temp");
result := FALSE;
exit;
end;
y := -3.000 * (x * x) + 2.870 * x - 0.275;
WhitePoint^.x := x;
WhitePoint^.y_mi := y;
WhitePoint^.Y_ma := 1.0;
result := TRUE;
end;
function IEcmsWhitePointFromTemp(TempK: integer; var WhitePoint_x, WhitePoint_y, WhitePoint_Y_: double): boolean;
var
xyY: cmsCIExyY;
begin
result := cmsWhitePointFromTemp(tempK, @xyY);
WhitePoint_x := xyY.x;
WhitePoint_y := xyY.y_mi;
WhitePoint_Y_ := xyY.Y_ma;
end;
function Build_sRGBGamma: LPGAMMATABLE;
var
Parameters: array[0..4] of double;
begin
Parameters[0] := 2.4;
Parameters[1] := 1. / 1.055;
Parameters[2] := 0.055 / 1.055;
Parameters[3] := 1. / 12.92;
Parameters[4] := 0.04045;
result := cmsBuildParametricGamma(1024, 4, @Parameters);
end;
function IEcmsCreate_sRGBProfile: cmsHPROFILE;
const
Rec709Primaries: cmsCIExyYTRIPLE = (
Red: (x: 0.6400; y_mi: 0.3300; Y_ma: 1.0);
Green: (x: 0.3000; y_mi: 0.6000; Y_ma: 1.0);
Blue: (x: 0.1500; y_mi: 0.0600; Y_ma: 1.0)
);
var
D65: cmsCIExyY;
Gamma22: array[0..2] of LPGAMMATABLE;
hsRGB: cmsHPROFILE;
begin
cmsWhitePointFromTemp(6504, @D65);
Gamma22[2] := Build_sRGBGamma();
Gamma22[1] := Gamma22[2];
Gamma22[0] := Gamma22[1];
hsRGB := cmsCreateRGBProfile(@D65, @Rec709Primaries, @Gamma22);
cmsFreeGamma(Gamma22[0]);
cmsAddTag(hsRGB, icSigDeviceMfgDescTag, PAnsiChar('(lcms internal)'));
cmsAddTag(hsRGB, icSigDeviceModelDescTag, PAnsiChar('sRGB built-in'));
cmsAddTag(hsRGB, icSigProfileDescriptionTag, PAnsiChar('sRGB built-in'));
result := hsRGB;
end;
function IEcmsCreateXYZProfile: cmsHPROFILE;
var
hProfile: cmsHPROFILE;
Lut: LPLUT;
begin
hProfile := cmsCreateRGBProfile(cmsD50_xyY, nil, nil);
cmsSetDeviceClass(hProfile, icSigAbstractClass);
cmsSetColorSpace(hProfile, icSigXYZData);
cmsSetPCS(hProfile, icSigXYZData);
cmsAddTag(hProfile, icSigDeviceMfgDescTag, PAnsiChar('(lcms internal)'));
cmsAddTag(hProfile, icSigProfileDescriptionTag, PAnsiChar('lcms XYZ identity'));
cmsAddTag(hProfile, icSigDeviceModelDescTag, PAnsiChar('XYZ built-in'));
Lut := Create3x3EmptyLUT;
if (Lut = nil) then
begin
result := nil;
exit;
end;
cmsAddTag(hProfile, icSigAToB0Tag, Lut);
cmsAddTag(hProfile, icSigBToA0Tag, Lut);
cmsAddTag(hProfile, icSigPreview0Tag, Lut);
cmsFreeLUT(Lut);
result := hProfile;
end;
{$ELSE} // IEINCLUDECMS
implementation
{$ENDIF}
end.