Subversion Repositories spacemission

Compare Revisions

Regard whitespace Rev 4 → Rev 16

/VCL_DELPHIX_D6/DIB.pas
28,7 → 28,9
 
uses
Windows, SysUtils, Classes, Graphics, Controls,
{$IFDEF VER17UP} Types, UITypes,{$ENDIF}
{$IFDEF VER7UP} Types, {$ENDIF}
{$IFDEF VER9UP} GraphUtil, {$ENDIF}
{$IFDEF VER17UP} UITypes,{$ENDIF}
Math;
 
type
39,6 → 41,13
 
TPaletteEntries = array[0..255] of TPaletteEntry;
 
PBGRA = ^TBGRA;
TBGRA = packed record
B, G, R, A: Byte;
end;
TLinesA = array[0..0] of TBGRA;
PLinesA = ^TLinesA;
 
PBGR = ^TBGR;
TBGR = packed record
B, G, R: Byte;
55,16 → 64,16
{ End of type's }
 
PArrayBGR = ^TArrayBGR;
TArrayBGR = array[0..10000] of TBGR;
TArrayBGR = array[0..0] of TBGR;
 
PArrayByte = ^TArrayByte;
TArrayByte = array[0..10000] of Byte;
TArrayByte = array[0..0] of Byte;
 
PArrayWord = ^TArrayWord;
TArrayWord = array[0..10000] of Word;
TArrayWord = array[0..0] of Word;
 
PArrayDWord = ^TArrayDWord;
TArrayDWord = array[0..10000] of DWord;
TArrayDWord = array[0..0] of DWord;
 
{ TDIBPixelFormat }
 
214,6 → 223,10
procedure SetPalette(Value: HPalette); override;
procedure SetWidth(Value: Integer); override;
procedure WriteData(Stream: TStream); override;
{$IFDEF VER16UP}
function GetSupportsPartialTransparency: Boolean; override;
{$ENDIF}
function GetTransparent: Boolean; override;
public
ColorTable: TRGBQuads;
PixelFormat: TDIBPixelFormat;
239,7 → 252,7
procedure Blur(ABitCount: Integer; Radius: Integer);
procedure Greyscale(ABitCount: Integer);
procedure Mirror(MirrorX, MirrorY: Boolean);
procedure Negative;
procedure Negative; {$IFDEF VER9UP}inline;{$ENDIF}
 
{ Added New Special Effect }
procedure Spray(Amount: Integer);
306,7 → 319,7
procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
procedure DoColorize(ForeColor, BackColor: TColor);
{Simple explosion spoke effect}
procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
procedure DoNovaEffect(const sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
 
{Simple Mandelbrot-set drawing}
379,11 → 392,11
//
// effect for special purpose
//
procedure FadeOut(DIB2: TDIB; Step: Byte);
procedure FadeOut(DIB2: TDIB; Step: Byte); {$IFDEF VER9UP} inline; {$ENDIF}
procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
procedure DoBlur(DIB2: TDIB);
procedure FadeIn(DIB2: TDIB; Step: Byte);
procedure FillDIB8(Color: Byte);
procedure FadeIn(DIB2: TDIB; Step: Byte); {$IFDEF VER9UP} inline; {$ENDIF}
procedure FillDIB8(Color: Byte); {$IFDEF VER9UP} inline; {$ENDIF}
procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
565,11 → 578,46
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
procedure MakeDIB32MaskByColor(var D: TDIB; const MaskColor: TColor{$IFDEF VER4UP} = clWhite{$ENDIF});
 
function BGR(B, G, R: Byte): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
 
implementation
 
uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
 
function BGR(B, G, R: Byte): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := (B shl 16) or (G shl 8) or R;
end;
 
procedure MakeDIB32MaskByColor(var D: TDIB; const MaskColor: TColor{$IFDEF VER4UP} = clWhite{$ENDIF});
type
PRGBA = ^TRGBA;
TRGBA = array[0..0] of Windows.TRGBQuad;
var
p: PRGBA;
y: Integer;
x: Integer;
B: TDIB;
begin
MakeDib(B, D.Width, D.Height, 32, $FFFFFF);
B.RGBChannel := D.RGBChannel;
if B.BitCount = 32 then
for Y := 0 to B.Height - 1 do
begin
p := B.ScanLine[Y];
for X := 0 to B.Width - 1 do
begin
if (p[X].rgbBlue = GetBValue(MaskColor)) and (p[X].rgbGreen = GetGValue(MaskColor)) and (p[X].rgbRed = GetRValue(MaskColor)) then
p[X].rgbReserved := 0
else
p[X].rgbReserved := $FF
end
end;
d.Assign(B);
end;
 
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
var
XScale, YScale: Single;
985,11 → 1033,13
biCompression := BI_BITFIELDS
else
begin
biCompression := 0; //none
if (FBitCount = 4) and (Compressed) then
biCompression := BI_RLE4
else if (FBitCount = 8) and (Compressed) then
biCompression := BI_RLE8
else
if FBitCount = 24 then
biCompression := BI_RGB;
end;
biSizeImage := FSize;
1712,8 → 1762,10
try
D := TDIB(FFreeList[0]);
FFreeList.Remove(D);
if (D <> nil) and (D.Height > 0) and (D.Width > 0) then //is really pointed to image?
D.Free;
except
// it is silent exception, but it can through outer (abstract) exception
end;
FFreeList.Free;
 
2133,7 → 2185,7
X, Y: Integer;
begin
oDIB := nil;
if not HasAlphaChannel then exit;
if not HasAlphaChannel then Exit;
oDIB := TDIB.Create;
oDIB.SetSize(Width, Height, 8);
for Y := 0 to Height - 1 do
2233,6 → 2285,13
Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
end;
 
{$IFDEF VER16UP}
function TDIB.GetSupportsPartialTransparency: Boolean;
begin
Result := (FBitCount = 32) and HasAlphaChannel;
end;
{$ENDIF}
 
function TDIB.GetTopPBits: Pointer;
begin
Changing(True);
2249,6 → 2308,11
Result := FTopPBits;
end;
 
function TDIB.GetTransparent: Boolean;
begin
Result := (FBitCount = 32) and HasAlphaChannel;
end;
 
function TDIB.GetWidth: Integer;
begin
Result := FWidth;
2483,7 → 2547,9
bfSize := bfOffBits + FImage.FBitmapInfo^.bmiHeader.biSizeImage;
bfReserved1 := 0;
bfReserved2 := 0;
if (FBitCount = 32) and (FImage.FBitmapInfo^.bmiHeader.biCompression <> 0) then FImage.FBitmapInfo^.bmiHeader.biCompression := 0; //corrext RGB error to RGBA
end;
 
Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader));
 
WriteData(Stream);
3545,7 → 3611,7
EndProgress;
end;
end;
 
(*
procedure TDIB.Negative;
var
i, i2: Integer;
3603,7 → 3669,37
end;
end;
end;
*)
procedure TDIB.Negative;
var
i: Integer;
P: Pointer;
i2: Integer;
begin
if Empty then Exit;
 
if BitCount <= 8 then
begin
for i := 0 to 255 do
with ColorTable[i] do
begin
rgbRed := 255 - rgbRed;
rgbGreen := 255 - rgbGreen;
rgbBlue := 255 - rgbBlue;
end;
UpdatePalette;
end
else
begin
P := PBits;
i2 := Size;
for i := 0 to i2-1 do
begin
PByteArray(P)^[i] := not PByteArray(P)^[i];
end;
end;
end;
 
procedure TDIB.Greyscale(ABitCount: Integer);
var
YTblR, YTblG, YTblB: array[0..255] of Byte;
4763,7 → 4859,7
weight_x, weight_y: array[0..1] of Double;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
D: Pointer;
//D: Pointer;
begin
Result := True;
case BitCount of
5282,9 → 5378,16
//--------------------------------------------------------------------------------------------------
 
function TDIB.GetAlphaChannel: TDIB;
var
I: Integer;
begin
RetAlphaChannel(Result);
if Result = nil then Exit;
 
if FFreeList.Count > 0 then
for I := 0 to FFreeList.Count - 1 do
if FFreeList[I] = Result then Exit;
 
FFreeList.Add(Result);
end;
 
5295,10 → 5398,26
end;
 
procedure TDIB.Fill(aColor: TColor);
var
p: PRGBA;
y: Integer;
x: Integer;
begin
Canvas.Brush.Color := aColor;
Canvas.FillRect(ClientRect);
if Self.BitCount = 32 then
begin
//fill alpha chanell too with $FF
for Y := 0 to Self.Height - 1 do
begin
p := Self.ScanLine[Y];
for X := 0 to Self.Width - 1 do
begin
p[X].rgbReserved := $FF
end;
end;
end;
end;
 
function TDIB.GetClientRect: TRect;
begin
5527,33 → 5646,70
procedure TDIB.CreateDIBFromBitmap(const Bitmap: TBitmap);
var
pf: Integer;
X, Y: Integer;
P: PLinesA;
q: PRGBA;
begin
if Bitmap.PixelFormat = pf32bit then pf := 32 else pf := 24;
SetSize(Bitmap.Width, Bitmap.Height, pf); {always >=24}
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Bounds(0, 0, Width, Height));
Canvas.Draw(0, 0, Bitmap);
//Note. Transparent background from bitmap is not drawed when is alphalayer active
if (pf = 32) {and (Bitmap.AlphaFormat <> afIgnored)} then
begin
for y := 0 to Bitmap.Height-1 do
begin
p := Bitmap.ScanLine[y]; //BGRA
q := Self.ScanLine[y]; //ARGB
for x := 0 to Width-1 do //copy only alphachannel
q[x].rgbReserved := P[x].A;
end;
end;
end;
 
function TDIB.CreateBitmapFromDIB: TBitmap;
//var
// X, Y: Integer;
var
ach: Boolean;
X, Y: Integer;
P: PLinesA;
q: PRGBA;
begin
ach := False;
Result := TBitmap.Create;
if BitCount = 32 then
Result.PixelFormat := pf32bit
else if BitCount = 24 then
Result.PixelFormat := pf24bit
else if BitCount = 16 then
Result.PixelFormat := pf16bit
else if BitCount = 8 then
Result.PixelFormat := pf8bit
else Result.PixelFormat := pf24bit;
case BitCount of
32:
begin
Result.PixelFormat := pf32bit;
ach := HasAlphaChannel;
end;
24: Result.PixelFormat := pf24bit;
15: Result.PixelFormat := pf16bit;
8: Result.PixelFormat := pf8bit;
else
Result.PixelFormat := pf24bit;
end;
 
Result.Width := Width;
Result.Height := Height;
Result.Canvas.Draw(0, 0, Self);
// for Y := 0 to Height - 1 do
// for X := 0 to Width - 1 do
// Result.Canvas.Pixels[X, Y] := Canvas.Pixels[X, Y];
if (BitCount = 32) then
begin
if ach then
begin
{$IFDEF VER16UP}
Result.AlphaFormat := afDefined;
{$ENDIF}
for y := 0 to Height-1 do
begin
p := Result.ScanLine[y]; //BGRA
q := Self.ScanLine[y]; //ARGB
for x := 0 to Width-1 do //copy only alphachannel
P[x].A := q[x].rgbReserved;
end;
end;
end;
end;
 
procedure TDIB.DrawTo(SrcDIB: TDIB; X, Y, Width, Height,
SourceX, SourceY: Integer);
6504,7 → 6660,7
 
procedure TDIB.DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
var
Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
Top, Bottom, eww, nsw, fx, fy: Extended;
cAngle, sAngle: Double;
xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
nw, ne, sw, se: TBGR;
7726,7 → 7882,7
// -----------------------------------------------------------------------------
 
// Hermite filter
function HermiteFilter(Value: Single): Single;
function HermiteFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if (Value < 0.0) then
7741,7 → 7897,7
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
function BoxFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
7751,7 → 7907,7
 
// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value: Single): Single;
function TriangleFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (Value < 0.0) then
Value := -Value;
7762,7 → 7918,7
end;
 
// Bell filter
function BellFilter(Value: Single): Single;
function BellFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (Value < 0.0) then
Value := -Value;
7779,7 → 7935,7
end;
 
// B-spline filter
function SplineFilter(Value: Single): Single;
function SplineFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
var
tt: single;
begin
7802,7 → 7958,7
 
// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
function SinC(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (Value <> 0.0) then
begin
7821,7 → 7977,7
Result := 0.0;
end;
 
function MitchellFilter(Value: Single): Single;
function MitchellFilter(Value: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
7858,7 → 8014,7
// -----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
TContributor = packed record
pixel: Integer; // Source pixel
weight: single; // Pixel weight
end;
7867,7 → 8023,7
PContributorList = ^TContributorList;
 
// List of source pixels contributing to a destination pixel
TCList = record
TCList = packed record
n: Integer;
p: PContributorList;
end;
7903,7 → 8059,7
{$IFDEF USE_SCANLINE}
SourceLine,
DestLine: PRGBList;
SourcePixel,
//SourcePixel,
DestPixel: PColorRGB;
Delta,
DestDelta: Integer;
7913,7 → 8069,7
DstWidth,
DstHeight: Integer;
 
function Color2RGB(Color: TColor): TColorRGB;
function Color2RGB(Color: TColor): TColorRGB; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result.r := Color and $000000FF;
Result.g := (Color and $0000FF00) shr 8;
7920,7 → 8076,7
Result.b := (Color and $00FF0000) shr 16;
end;
 
function RGB2Color(Color: TColorRGB): TColor;
function RGB2Color(Color: TColorRGB): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := Color.r or (Color.g shl 8) or (Color.b shl 16);
end;
8228,7 → 8384,8
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := PColorRGB(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
//color := PColorRGB(PByte(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
Move(Pointer(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^, Color, SizeOf(Color));
{$ELSE}
color := Color2RGB(Work.Canvas.Pixels[k, contrib^[i].p^[j].pixel]);
{$ENDIF}
8259,7 → 8416,11
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
DestPixel^ := color;
{$IFDEF WIN64}
inc(PByte(DestPixel), DestDelta);
{$ELSE}
inc(Integer(DestPixel), DestDelta);
{$ENDIF}
{$ELSE}
Dst.Canvas.Pixels[k, i] := RGB2Color(color);
{$ENDIF}
8400,7 → 8561,7
end;
 
{ procedure for special purpose }
 
(*
procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
8435,6 → 8596,22
POP ESI
end;
end;
*)
procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H, i: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
for i := 0 to W * H - 1 do
begin
if P1[i] < Step then P2[i] := P1[i]
else P2[i] := Step;
end;
end;
 
procedure TDIB.DoZoom(DIB2: TDIB; ZoomRatio: Real);
var
8501,7 → 8678,7
end;
end;
end;
 
(*
procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
8536,7 → 8713,24
POP ESI
end;
end;
*)
procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H, i: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
for i := 0 to W * H - 1 do
begin
if P1[i] > Step then P2[i] := P1[i]
else P2[i] := Step;
end;
end;
 
(*
procedure TDIB.FillDIB8(Color: Byte);
var
P: PByteArray;
8561,7 → 8755,21
POP ESI
end;
end;
*)
 
procedure TDIB.FillDIB8(Color: Byte);
var
P: PByteArray;
W, H, I: Integer;
begin
P := ScanLine[Height - 1];
W := WidthBytes;
H := Height;
for I := 0 to W * H - 1 do
P[I] := Color;
end;
 
 
procedure TDIB.DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
type
T3Byte = array[0..2] of Byte;
9186,7 → 9394,7
end;
end;
end;
 
(*
function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
9251,7 → 9459,56
mov @result, EAX
end;
end;
*)
function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue, FromPoint, ToPoint: Extended): TColor;
var
F: Extended;
r1, g1, b1, r2, g2, b2, r3, g3, b3: Byte;
 
function CalcColorBytes(const factor: Extended; const fb1, fb2: Byte): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := fb1;
if fb1 < fb2 then Result := fb1 + Trunc(factor * (fb2 - fb1));
if fb1 > fb2 then Result := fb1 - Trunc(factor * (fb1 - fb2));
end;
 
procedure GetRGB(const AColor: TColor; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
begin
R := AColor and $FF;
G := (AColor shr 8) and $FF;
B := (AColor shr 16) and $FF;
end;
 
begin
if Pointvalue <= FromPoint then
begin
Result := StartColor;
Exit;
end;
if Pointvalue >= ToPoint then
begin
Result := EndColor;
Exit;
end;
 
F := (Pointvalue - FromPoint) / (ToPoint - FromPoint);
 
GetRGB(StartColor, r1, g1, b1);
// r1 := StartColor and $FF;
// g1 := (StartColor shr 8) and $FF;
// b1 := (StartColor shr 16) and $FF;
GetRGB(StartColor, r2, g2, b2);
// r2 := EndColor and $FF;
// g2 := (EndColor shr 8) and $FF;
// b2 := (EndColor shr 16) and $FF;
 
r3 := CalcColorBytes(F, r1, r2);
g3 := CalcColorBytes(F, g1, g2);
b3 := CalcColorBytes(F, b1, b2);
 
Result := (b3 shl 16) or (g3 shl 8) or r3;
end;
 
procedure TDIB.ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry; iRadius: Word);
var
9459,7 → 9716,7
end
end {Line};
 
procedure TDIB.DoNovaEffect(sr, sg, sb, cx, cy, radius,
procedure TDIB.DoNovaEffect(const sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
// Copyright (c) 2000 by Keith Murray (kmurray@hotfreeware.com)
// All rights reserved.
9468,9 → 9725,9
PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
PDoubleArray = ^TDoubleArray;
TDoubleArray = array[0..32767] of Double;
TDoubleArray = array[0..0] of Double;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array[0..32767] of Integer;
TIntegerArray = array[0..0] of Integer;
type
TProgressEvent = procedure(progress: Integer; message: string;
var cancel: Boolean) of object;
9478,7 → 9735,7
M_PI = 3.14159265358979323846;
RAND_MAX = 2147483647;
 
function Gauss: double;
function Gauss(const randgauss: Integer): double; {$IFDEF VER9UP}inline;{$ENDIF}
const magnitude = 6;
var
sum: double;
9490,7 → 9747,7
result := sum / magnitude;
end;
 
function Clamp(i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
function Clamp(const i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
9501,7 → 9758,7
result := i;
end;
 
function IClamp(i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function IClamp(const i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
9509,8 → 9766,8
result := h
else result := i;
end;
 
procedure rgb_to_hsl(r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
{$IFNDEF VER9UP}
procedure rgb_to_hsl(const r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
{$IFNDEF VER4UP}
function Max(a, b: Double): Double;
begin
9622,7 → 9879,27
end;
end;
end;
{$ELSE}
procedure rgb_to_hsl(const r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
var
h0, s0, l0: Word;
begin //procedure ColorRGBToHLS(clrRGB: TColorRef; var Hue, Luminance, Saturation: Word);
GraphUtil.ColorRGBToHLS(RGB(Trunc(r),Trunc(g),Trunc(b)), h0, s0, l0);
h := h0;
s := s0;
l := l0;
end;
 
procedure hsl_to_rgb(h, sl, l: Double; var r, g, b: Double); {$IFDEF VER9UP}inline;{$ENDIF}
var X: TColorRef;
begin //function ColorHLSToRGB(Hue, Luminance, Saturation: Word): TColorRef;
X := GraphUtil.ColorHLSToRGB(Trunc(h), Trunc(l), Trunc(sl));
r := GetRValue(X);
g := GetGValue(X);
b := GetBValue(X);
end;
{$ENDIF}
 
var
src_row, dest_row: PByte;
src, dest: PByteArray;
9629,8 → 9906,8
color, colors: array[0..3] of Integer;
SpokeColor: PIntegerArray;
spoke: PDoubleArray;
x1, y1, x2, y2, row, col, x, y, alpha, has_alpha, bpp, progress, max_progress, xc, yc, i, j: Integer;
u, v, l, l0, w, w1, c, nova_alpha, src_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
x2, row, col, x, y, alpha, has_alpha, bpp, xc, yc, i, j: Integer;
u, v, l, l0, w, w1, c, nova_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
dstDIB: TDIB;
begin
colors[0] := sr;
9641,15 → 9918,16
GetMem(spoke, NSpokes * sizeof(Double));
GetMem(spokecolor, NSpokes * sizeof(Integer) * 3);
dstDIB := TDIB.Create;
try
dstDIB.Assign(Self);
dstDIB.Canvas.Brush.Color := clBlack;
dstDIB.Canvas.FillRect(dstDIB.Canvas.ClipRect);
try
// R G B
rgb_to_hsl(colors[0] / 255.0, colors[1] / 255.0, colors[2] / 255.0, h, s, lu);
 
for i := 0 to NSpokes - 1 do
begin
spoke[i] := gauss;
spoke[i] := gauss(randgauss);
h := h + randomhue / 360.0 * ({Random(RAND_MAX)}RandomSpok / RAND_MAX - 0.5);
if h < 0 then
h := h + 1.0
9668,16 → 9946,18
has_alpha := 0;
alpha := bpp;
y := 0;
for row := 0 to Self.Height - 1 do begin
for row := 0 to Self.Height - 1 do
begin
src_row := Self.ScanLine[row];
dest_row := dstDIB.ScanLine[row];
src := Pointer(src_row);
dest := Pointer(dest_row);
x := 0;
for col := 0 to Self.Width - 1 do begin
for col := 0 to Self.Width - 1 do
begin
u := (x - xc) / radius;
v := (y - yc) / radius;
l := sqrt((u * u) + (v * v));
l := sqrt(sqr(u) + sqr(v));
c := (arctan2(u, v) / (2 * M_PI) + 0.51) * NSpokes;
i := floor(c);
c := c - i;
9698,14 → 9978,19
color[j] := Trunc(color[j] + 255 * Clamp(w1 * w, 0.0, 1.0));
dest[j] := IClamp(color[j], 0, 255);
end;
inc(Integer(src), bpp);
inc(Integer(dest), bpp);
inc(x);
{$IFDEF WIN64}
Inc(PByte(src), bpp);
Inc(PBYTE(dest), bpp);
{$ELSE}
Inc(Integer(src), bpp);
Inc(Integer(dest), bpp);
{$ENDIF}
Inc(x);
end;
inc(y);
Inc(y);
end;
Self.Assign(dstDIB);
finally
Self.Assign(dstDIB);
dstDIB.Free;
FreeMem(Spoke);
FreeMem(SpokeColor);
9766,10 → 10051,10
procedure TDIB.SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
{Note: when depth parameter set to 0 will produce black and white picture only}
var
color, color2: longint;
color, color2: LongInt;
r, g, b, rr, gg: byte;
h, w: Integer;
p0: pbytearray;
p0: PByteArray;
x, y: Integer;
begin
if Self.BitCount = 24 then