564 lines
13 KiB
Plaintext
564 lines
13 KiB
Plaintext
(* ImageEn Build 7.0.0.06.2637 @ 7-4-17 14:58:42.679 *)
|
|
(*
|
|
Copyright (c) 1998-2017 by Carlotta Calandra. All rights reserved.
|
|
Copyright (c) 2011-2017 by Xequte Software.
|
|
|
|
This software comes without express or implied warranty.
|
|
In no case shall the author be liable for any damage or unwanted behavior of any
|
|
computer hardware and/or software.
|
|
|
|
Author grants you the right to include the component
|
|
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE.
|
|
|
|
ImageEn, IEvolution and ImageEn ActiveX may not be included in any
|
|
commercial, shareware or freeware libraries or components.
|
|
|
|
www.ImageEn.com
|
|
*)
|
|
|
|
(*
|
|
File version 1001
|
|
*)
|
|
|
|
unit stdquant;
|
|
|
|
{$IFDEF FPC}
|
|
{$MODE DELPHI}
|
|
{$ENDIF}
|
|
|
|
|
|
{$R-}
|
|
{$Q-}
|
|
|
|
{$I ie.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Graphics, classes, sysutils, ImageEnProc, hyiedefs;
|
|
|
|
function CreateMedianCutQuantizer(SrcBitmap: TObject; var ColorMap: array of TRGB; NCol: integer): pointer;
|
|
procedure FreeMedianCutQuantizer(mq: pointer);
|
|
function MedianCutFindIndex(mq: pointer; const rgb: TRGB): integer;
|
|
|
|
implementation
|
|
|
|
uses
|
|
iexBitmaps;
|
|
|
|
{$R-}
|
|
|
|
const
|
|
ERR_CANCEL = 128;
|
|
ERR_NOMEMORY = 139;
|
|
RedI = 0;
|
|
GreenI = 1;
|
|
BlueI = 2;
|
|
Bits = 5;
|
|
cBits = 8 - Bits;
|
|
ColorMaxI = 1 shl Bits;
|
|
cHistogramm = ColorMaxI * ColorMaxI * ColorMaxI;
|
|
|
|
type
|
|
|
|
TTrueColor = record
|
|
Blue: byte;
|
|
Green: byte;
|
|
Red: Byte;
|
|
end;
|
|
|
|
PRGBByteArray = ^TRGBByteArray;
|
|
TRGBByteArray = array[0..32767] of TTrueColor;
|
|
|
|
tDMCoSi = record
|
|
pqBMI: TObject;
|
|
cqWid: word;
|
|
cqHei: word;
|
|
czWid: word;
|
|
czHei: word;
|
|
end;
|
|
|
|
tMean = array[RedI..BlueI] of double;
|
|
tFreqZeile = array[0..ColorMaxI - 1] of longint;
|
|
tFreqArray = array[RedI..BlueI] of tFreqZeile;
|
|
tLowHigh = array[RedI..BlueI] of integer;
|
|
pBox = ^tBox;
|
|
tBox = record
|
|
WeiVar: double;
|
|
mean: tMean;
|
|
weight: longint;
|
|
Freq: tFreqArray;
|
|
low: tLowHigh;
|
|
high: tLowHigh;
|
|
end;
|
|
|
|
pBoxes = ^tBoxes;
|
|
tBoxes = array[0..255] of tBox;
|
|
pHistogramm = ^tHistogramm;
|
|
tHistogramm = array[0..cHistogramm - 1] of longint;
|
|
|
|
pRGBmap = ^tRGBmap;
|
|
tRGBmap = array[0..cHistogramm - 1] of byte;
|
|
|
|
PGVar = ^TGVar;
|
|
TGVar = record
|
|
pHisto: pHistogramm;
|
|
pBoxArr: pBoxes;
|
|
pMap: pRGBmap;
|
|
cHBRPix: longint;
|
|
cHBRCol: longint;
|
|
cHBROutCol: longint;
|
|
DMCoSi: tDMCoSi;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function Histogramm(gvar: PGVar): boolean;
|
|
var
|
|
p24: PRGBByteArray;
|
|
h: integer;
|
|
r, g, b: byte;
|
|
y, x: integer;
|
|
begin
|
|
p24 := nil;
|
|
with gvar^ do
|
|
begin
|
|
with pBoxArr^[0] do
|
|
begin
|
|
fillchar(Freq[RedI], sizeof(tFreqZeile), #0);
|
|
fillchar(Freq[GreenI], sizeof(tFreqZeile), #0);
|
|
fillchar(Freq[BlueI], sizeof(tFreqZeile), #0);
|
|
for y := 0 to DMCoSi.czHei - 1 do
|
|
begin
|
|
if DMCoSi.pqBMi is TBitmap then
|
|
p24 := (DMCoSi.pqBMi as TBitmap).Scanline[y]
|
|
else
|
|
if DMCoSi.pqBMi is TIEBitmap then
|
|
p24 := (DMCoSi.pqBMi as TIEBitmap).Scanline[y];
|
|
for x := 0 to DMCoSi.czWid - 1 do
|
|
begin
|
|
r := p24[x].Red shr cBits;
|
|
inc(Freq[RedI, r]);
|
|
g := p24[x].Green shr cBits;
|
|
inc(Freq[GreenI, g]);
|
|
b := p24[x].Blue shr cBits;
|
|
inc(Freq[BlueI, b]);
|
|
h := r shl Bits;
|
|
h := (h or g) shl Bits;
|
|
h := h or b;
|
|
inc(pHisto^[h]);
|
|
end;
|
|
end;
|
|
end;
|
|
Result := true;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
procedure BoxStats(gvar: pgvar; var pn: tBox);
|
|
var
|
|
mean1, vari1: double;
|
|
hw: double;
|
|
i, col: integer;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
pn.WeiVar := 0.0;
|
|
if (pn.Weight = 0) then
|
|
exit;
|
|
for col := RedI to BlueI do
|
|
begin
|
|
vari1 := 0.0;
|
|
mean1 := 0.0;
|
|
for i := pn.Low[col] to pn.High[col] - 1 do
|
|
begin
|
|
hw := pn.Freq[col, i];
|
|
hw := hw * i;
|
|
mean1 := mean1 + hw;
|
|
hw := hw * i;
|
|
vari1 := vari1 + hw;
|
|
end;
|
|
pn.Mean[col] := mean1 / pn.Weight;
|
|
hw := pn.mean[col];
|
|
hw := hw * hw * pn.Weight;
|
|
hw := vari1 - hw;
|
|
pn.WeiVar := pn.WeiVar + hw;
|
|
end;
|
|
pn.WeiVar := pn.WeiVar / cHBRPix;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function FindCutPoint(gvar: pgvar; var pn, nBox1, nBox2: tBox; RGB: byte): boolean;
|
|
var
|
|
u, v, max: double;
|
|
hw: double;
|
|
OptWei: longint;
|
|
CurWei: longint;
|
|
myfreq: longint;
|
|
h: integer;
|
|
rOff, gOff: integer;
|
|
i, CutPt: integer;
|
|
maxIdx, minIdx: integer;
|
|
l1, l2, h1, h2: integer;
|
|
b, g, r: byte;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
Result := false;
|
|
if (pn.Low[RGB] + 1 = pn.High[RGB]) then
|
|
exit;
|
|
MinIdx := round((pn.Mean[RGB] + pn.Low[RGB]) * 0.5);
|
|
MaxIdx := round((pn.Mean[RGB] + pn.High[RGB]) * 0.5);
|
|
CutPt := MinIdx;
|
|
OptWei := pn.Weight;
|
|
CurWei := 0;
|
|
for i := pn.Low[RGB] to MinIdx - 1 do
|
|
CurWei := CurWei + longint(pn.Freq[RGB, i]);
|
|
u := 0.0;
|
|
Max := -1.0;
|
|
for i := MinIdx to MaxIdx do
|
|
begin
|
|
inc(CurWei, pn.Freq[RGB, i]);
|
|
if (CurWei = pn.Weight) then
|
|
break;
|
|
hw := i;
|
|
hw := (hw * pn.Freq[RGB, i]) / pn.Weight;
|
|
u := u + hw;
|
|
hw := pn.Mean[RGB];
|
|
hw := hw - u;
|
|
hw := hw * hw;
|
|
v := CurWei;
|
|
v := (v / (pn.Weight - CurWei)) * hw;
|
|
if (v > max) then
|
|
begin
|
|
max := v;
|
|
CutPt := i;
|
|
OptWei := CurWei;
|
|
end;
|
|
end;
|
|
inc(CutPt);
|
|
Move(pn, nBox1, sizeof(tBox));
|
|
Move(pn, nBox2, sizeof(tBox));
|
|
nBox1.Weight := OptWei;
|
|
nBox2.Weight := nBox2.Weight - OptWei;
|
|
if (nBox1.Weight = 0) or (nBox2.Weight = 0) then
|
|
begin
|
|
exit;
|
|
end;
|
|
nBox1.High[RGB] := CutPt;
|
|
nBox2.Low[RGB] := CutPt;
|
|
fillchar(nBox1.Freq[RedI], sizeof(tFreqZeile), #0);
|
|
fillchar(nBox1.Freq[GreenI], sizeof(tFreqZeile), #0);
|
|
fillchar(nBox1.Freq[BlueI], sizeof(tFreqZeile), #0);
|
|
for r := nBox1.Low[RedI] to nBox1.High[RedI] - 1 do
|
|
begin
|
|
rOff := r shl Bits;
|
|
for g := nBox1.Low[GreenI] to nBox1.High[GreenI] - 1 do
|
|
begin
|
|
gOff := (rOff or g) shl Bits;
|
|
for b := nBox1.Low[BlueI] to nBox1.High[BlueI] - 1 do
|
|
begin
|
|
h := gOff or b;
|
|
myfreq := pHisto^[h];
|
|
if (myfreq <> 0) then
|
|
begin
|
|
inc(nBox1.Freq[RedI, r], myfreq);
|
|
inc(nBox1.Freq[GreenI, g], myfreq);
|
|
inc(nBox1.Freq[BlueI, b], myfreq);
|
|
dec(nBox2.Freq[RedI, r], myfreq);
|
|
dec(nBox2.Freq[GreenI, g], myfreq);
|
|
dec(nBox2.Freq[BlueI, b], myfreq);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
for r := RedI to BlueI do
|
|
begin
|
|
l1 := ColorMaxI;
|
|
l2 := ColorMaxI;
|
|
h1 := 0;
|
|
h2 := 0;
|
|
for g := 0 to ColorMaxI - 1 do
|
|
begin
|
|
if (nBox1.Freq[r, g] <> 0) then
|
|
begin
|
|
if (g < l1) then
|
|
l1 := g;
|
|
if (g > h1) then
|
|
h1 := g;
|
|
end;
|
|
if (nBox2.Freq[r, g] <> 0) then
|
|
begin
|
|
if (g < l2) then
|
|
l2 := g;
|
|
if (g > h2) then
|
|
h2 := g;
|
|
end;
|
|
end;
|
|
nBox1.Low[r] := l1;
|
|
nBox2.Low[r] := l2;
|
|
nBox1.High[r] := h1 + 1;
|
|
nBox2.High[r] := h2 + 1;
|
|
end;
|
|
BoxStats(gvar, nBox1);
|
|
BoxStats(gvar, nBox2);
|
|
Result := true;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function CutBox(gvar: pgvar; var pn, nBox1: tBox): boolean;
|
|
const
|
|
Hugo = 1.7 * 10308;
|
|
var
|
|
i: integer;
|
|
TotVar: array[RedI..BlueI] of double;
|
|
nBoxes: array[RedI..BlueI, 0..1] of tBox;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
if (pn.WeiVar = 0.0) or (pn.Weight = 0) then
|
|
begin
|
|
pn.WeiVar := 0.0;
|
|
Result := false;
|
|
exit;
|
|
end
|
|
else
|
|
Result := true;
|
|
for i := RedI to BlueI do
|
|
begin
|
|
if (FindCutPoint(gvar, pn, nBoxes[i, 0], nBoxes[i, 1], i)) then
|
|
TotVar[i] := nBoxes[i, 0].WeiVar + nBoxes[i, 1].WeiVar
|
|
else
|
|
TotVar[i] := Hugo;
|
|
end;
|
|
if (TotVar[RedI] < Hugo)
|
|
and (TotVar[RedI] <= TotVar[GreenI])
|
|
and (TotVar[RedI] <= TotVar[BlueI]) then
|
|
begin
|
|
Move((nBoxes[RedI, 0]), pn, sizeof(tBox));
|
|
Move((nBoxes[RedI, 1]), nBox1, sizeof(tBox));
|
|
exit;
|
|
end
|
|
else
|
|
if (TotVar[GreenI] < Hugo)
|
|
and (TotVar[GreenI] <= TotVar[RedI])
|
|
and (TotVar[GreenI] <= TotVar[BlueI]) then
|
|
begin
|
|
Move((nBoxes[GreenI, 0]), pn, sizeof(tBox));
|
|
Move((nBoxes[GreenI, 1]), nBox1, sizeof(tBox));
|
|
exit;
|
|
end
|
|
else
|
|
if (TotVar[BlueI] < Hugo) then
|
|
begin
|
|
Move((nBoxes[BlueI, 0]), pn, sizeof(tBox));
|
|
Move((nBoxes[BlueI, 1]), nBox1, sizeof(tBox));
|
|
exit;
|
|
end;
|
|
pn.WeiVar := 0.0;
|
|
Result := false;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function CutBoxes(gvar: pgvar): integer;
|
|
var
|
|
CurBox, n, i: integer;
|
|
Max: double;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
with pBoxArr^[0] do
|
|
begin
|
|
Low[RedI] := 0;
|
|
Low[GreenI] := 0;
|
|
Low[BlueI] := 0;
|
|
High[RedI] := ColorMaxI;
|
|
High[GreenI] := ColorMaxI;
|
|
High[BlueI] := ColorMaxI;
|
|
Weight := cHBRPix;
|
|
end;
|
|
BoxStats(gvar, pBoxArr^[0]);
|
|
CurBox := 1;
|
|
while (CurBox < cHBRCol) do
|
|
begin
|
|
n := CurBox;
|
|
max := 0.0;
|
|
for i := 0 to CurBox - 1 do
|
|
with pBoxArr^[i] do
|
|
begin
|
|
if (WeiVar > Max) then
|
|
begin
|
|
Max := WeiVar;
|
|
n := i;
|
|
end;
|
|
end;
|
|
if (n = CurBox) then
|
|
break;
|
|
if (CutBox(gvar, pBoxArr^[n], pBoxArr^[CurBox])) then
|
|
inc(CurBox);
|
|
end;
|
|
Result := CurBox;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function MakeRGBmap(gvar: pgvar): boolean;
|
|
var
|
|
i, p: integer;
|
|
r, g, b: integer;
|
|
rOff, gOff: integer;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
for i := 0 to cHBROutCol - 1 do
|
|
with pBoxArr^[i] do
|
|
begin
|
|
for r := Low[RedI] to High[RedI] - 1 do
|
|
begin
|
|
rOff := r shl Bits;
|
|
for g := Low[GreenI] to High[GreenI] - 1 do
|
|
begin
|
|
gOff := (rOff or g) shl Bits;
|
|
for b := Low[BlueI] to High[BlueI] - 1 do
|
|
begin
|
|
p := gOff or b;
|
|
pMap^[p] := i;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := true;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function GetHBRmem(gvar: pgvar): boolean;
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
GetMem(pHisto, sizeof(tHistogramm));
|
|
GetMem(pBoxArr, sizeof(tBoxes));
|
|
GetMem(pMap, sizeof(tRGBmap));
|
|
fillchar(pHisto^, sizeof(tHistogramm), #0);
|
|
fillchar(pBoxArr^, sizeof(tBoxes), #0);
|
|
fillchar(pMap^, sizeof(tRGBmap), #0);
|
|
Result := true;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
procedure FreeHBRmem(gvar: pgvar);
|
|
begin
|
|
with gvar^ do
|
|
begin
|
|
if (pHisto <> nil) then
|
|
begin
|
|
FreeMem(pHisto);
|
|
pHisto := nil;
|
|
end;
|
|
if (pBoxArr <> nil) then
|
|
begin
|
|
FreeMem(pBoxArr);
|
|
pBoxArr := nil;
|
|
end;
|
|
if (pMap <> nil) then
|
|
begin
|
|
FreeMem(pMap);
|
|
pMap := nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
// SrcBitmap can be TIEBitmap or TBitmap
|
|
|
|
function CreateMedianCutQuantizer(SrcBitmap: TObject; var ColorMap: array of TRGB; NCol: integer): pointer;
|
|
var
|
|
gvar: PGVar;
|
|
i: integer;
|
|
begin
|
|
getmem(gvar, sizeof(TGVar));
|
|
with gvar^ do
|
|
begin
|
|
fillchar(DMCoSi, sizeof(tDMCoSi), #0);
|
|
pHisto := nil;
|
|
pBoxArr := nil;
|
|
pMap := nil;
|
|
with DMCoSi do
|
|
begin
|
|
pqBMI := SrcBitmap;
|
|
if pqBMi is TBitmap then
|
|
begin
|
|
with pqBMI as TBitmap do
|
|
begin
|
|
czWid := Width;
|
|
czHei := Height;
|
|
end;
|
|
end
|
|
else
|
|
if pqBMi is TIEBitmap then
|
|
begin
|
|
with pqBMI as TIEBitmap do
|
|
begin
|
|
czWid := Width;
|
|
czHei := Height;
|
|
end;
|
|
end;
|
|
cHBRPix := czWid;
|
|
cHBRPix := cHBRPix * czHei;
|
|
cHBRCol := ncol;
|
|
end;
|
|
GetHBRmem(gvar);
|
|
Histogramm(gvar);
|
|
cHBROutCol := CutBoxes(gvar);
|
|
for i := 0 to cHBROutCol - 1 do
|
|
with pBoxArr^[i] do
|
|
begin
|
|
ColorMap[i].r := round(Mean[RedI]) shl cBits;
|
|
ColorMap[i].g := round(Mean[GreenI]) shl cBits;
|
|
ColorMap[i].b := round(Mean[BlueI]) shl cBits;
|
|
end;
|
|
end;
|
|
MakeRGBmap(gvar);
|
|
result := gvar;
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
procedure FreeMedianCutQuantizer(mq: pointer);
|
|
begin
|
|
with PGVar(mq)^ do
|
|
FreeHBRmem(PGVar(mq));
|
|
freemem(mq);
|
|
end;
|
|
|
|
/////////////////////////////////////////////////////////////////////////////
|
|
|
|
function MedianCutFindIndex(mq: pointer; const rgb: TRGB): integer;
|
|
var
|
|
b, g, r, p: integer;
|
|
begin
|
|
with PGVar(mq)^ do
|
|
begin
|
|
r := (rgb.r and $F8) shl (Bits + Bits - cBits);
|
|
g := (rgb.g and $F8) shl (Bits - cBits);
|
|
b := (rgb.b and $F8) shr cBits;
|
|
p := r or g or b;
|
|
result := pmap^[p];
|
|
end;
|
|
end;
|
|
|
|
end.
|
|
|
|
|