WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DIB.pas

Rev	Author	Line No.	Line
4	daniel-mar	1	{*******************************************************}
		2	{ }
		3	{ DIB and PAINTBOX componets }
		4	{ }
		5	{ Copyright (C) 1997-2000 Hiroyuki Hori }
		6	{ base components and effects }
		7	{ Copyright (C) 2000 Keith Murray }
		8	{ supernova effect }
		9	{ Copyright (C) 2000 Michel Hibon }
		10	{ new special effects added for DIB }
		11	{ Copyright (C) 2001 Joakim Back }
		12	{ conFusion effects (as DxFusion) }
		13	{ Copyright (C) 2003 Babak Sateli }
		14	{ 24-bit DIB effect as supplement ones }
		15	{ Copyright (C) 2004-2012 Jaro Benes }
		16	{ 32-bit DIB effect with alphachannel }
		17	{ direct works with texture buffer }
		18	{ modified and adapted all adopted functions }
		19	{ }
		20	{*******************************************************}
		21
1	daniel-mar	22	unit DIB;
		23
		24	interface
		25
		26	{$INCLUDE DelphiXcfg.inc}
4	daniel-mar	27	{$DEFINE USE_SCANLINE}
1	daniel-mar	28
		29	uses
4	daniel-mar	30	Windows, SysUtils, Classes, Graphics, Controls,
		31	{$IFDEF VER17UP} Types, UITypes,{$ENDIF}
		32	Math;
1	daniel-mar	33
		34	type
4	daniel-mar	35	TColorLineStyle = (csSolid, csGradient, csRainbow);
		36	TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
		37	PRGBQuads = ^TRGBQuads;
1	daniel-mar	38	TRGBQuads = array[0..255] of TRGBQuad;
		39
		40	TPaletteEntries = array[0..255] of TPaletteEntry;
		41
		42	PBGR = ^TBGR;
		43	TBGR = packed record
		44	B, G, R: Byte;
		45	end;
		46
4	daniel-mar	47	{ Added this type for New SPecial Effect }
		48	TFilter = array[0..2, 0..2] of SmallInt;
		49	TLines = array[0..0] of TBGR;
		50	PLines = ^TLines;
		51	TBytes = array[0..0] of Byte;
		52	PBytes = ^TBytes;
		53	TPBytes = array[0..0] of PBytes;
		54	PPBytes = ^TPBytes;
		55	{ End of type's }
		56
1	daniel-mar	57	PArrayBGR = ^TArrayBGR;
		58	TArrayBGR = array[0..10000] of TBGR;
		59
		60	PArrayByte = ^TArrayByte;
		61	TArrayByte = array[0..10000] of Byte;
		62
		63	PArrayWord = ^TArrayWord;
		64	TArrayWord = array[0..10000] of Word;
		65
		66	PArrayDWord = ^TArrayDWord;
		67	TArrayDWord = array[0..10000] of DWord;
		68
4	daniel-mar	69	{ TDIBPixelFormat }
1	daniel-mar	70
		71	TDIBPixelFormat = record
		72	RBitMask, GBitMask, BBitMask: DWORD;
		73	RBitCount, GBitCount, BBitCount: DWORD;
		74	RShift, GShift, BShift: DWORD;
		75	RBitCount2, GBitCount2, BBitCount2: DWORD;
		76	end;
		77
4	daniel-mar	78	{ TDIBSharedImage }
		79
1	daniel-mar	80	TDIBSharedImage = class(TSharedImage)
4	daniel-mar	81	private
1	daniel-mar	82	FBitCount: Integer;
		83	FBitmapInfo: PBitmapInfo;
		84	FBitmapInfoSize: Integer;
		85	FChangePalette: Boolean;
		86	FColorTable: TRGBQuads;
		87	FColorTablePos: Integer;
		88	FCompressed: Boolean;
		89	FDC: THandle;
		90	FHandle: THandle;
		91	FHeight: Integer;
		92	FMemoryImage: Boolean;
		93	FNextLine: Integer;
		94	FOldHandle: THandle;
		95	FPalette: HPalette;
		96	FPaletteCount: Integer;
		97	FPBits: Pointer;
		98	FPixelFormat: TDIBPixelFormat;
		99	FSize: Integer;
		100	FTopPBits: Pointer;
		101	FWidth: Integer;
		102	FWidthBytes: Integer;
		103	constructor Create;
		104	procedure NewImage(AWidth, AHeight, ABitCount: Integer;
		105	const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
4	daniel-mar	106	procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
1	daniel-mar	107	procedure Compress(Source: TDIBSharedImage);
		108	procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
		109	procedure ReadData(Stream: TStream; MemoryImage: Boolean);
		110	function GetPalette: THandle;
		111	procedure SetColorTable(const Value: TRGBQuads);
		112	protected
		113	procedure FreeHandle; override;
		114	public
		115	destructor Destroy; override;
		116	end;
		117
4	daniel-mar	118	{ TFilterTypeResample }
		119
		120	TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
		121	ftrLanczos3, ftrMitchell);
		122
		123	TDistortType = (dtFast, dtSlow);
		124	{DXFusion effect type}
		125	TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);
		126
		127	{ TLightSource }
		128
		129	TLightSource = record
		130	X, Y: Integer;
		131	Size1, Size2: Integer;
		132	Color: TColor;
		133	end;
		134
		135	{ TLightArray }
		136
		137	TLightArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TLightsource;
		138
		139	{ TMatrixSetting }
		140
		141	TMatrixSetting = array[0..9] of Integer;
		142
		143	{ TDIB }
		144
1	daniel-mar	145	TDIB = class(TGraphic)
		146	private
		147	FCanvas: TCanvas;
4	daniel-mar	148	FImage: TDIBSharedImage;
1	daniel-mar	149
		150	FProgressName: string;
		151	FProgressOldY: DWORD;
		152	FProgressOldTime: DWORD;
		153	FProgressOld: DWORD;
		154	FProgressY: DWORD;
		155	{ For speed-up }
		156	FBitCount: Integer;
		157	FHeight: Integer;
		158	FNextLine: Integer;
		159	FNowPixelFormat: TDIBPixelFormat;
		160	FPBits: Pointer;
		161	FSize: Integer;
		162	FTopPBits: Pointer;
		163	FWidth: Integer;
		164	FWidthBytes: Integer;
4	daniel-mar	165	FLUTDist: array[0..255, 0..255] of Integer;
		166	LG_COUNT: Integer;
		167	LG_DETAIL: Integer;
		168	FFreeList: TList;
1	daniel-mar	169	procedure AllocHandle;
		170	procedure CanvasChanging(Sender: TObject);
		171	procedure Changing(MemoryImage: Boolean);
		172	procedure ConvertBitCount(ABitCount: Integer);
		173	function GetBitmapInfo: PBitmapInfo;
		174	function GetBitmapInfoSize: Integer;
		175	function GetCanvas: TCanvas;
		176	function GetHandle: THandle;
		177	function GetPaletteCount: Integer;
		178	function GetPixel(X, Y: Integer): DWORD;
		179	function GetPBits: Pointer;
		180	function GetPBitsReadOnly: Pointer;
		181	function GetScanLine(Y: Integer): Pointer;
		182	function GetScanLineReadOnly(Y: Integer): Pointer;
		183	function GetTopPBits: Pointer;
		184	function GetTopPBitsReadOnly: Pointer;
		185	procedure SetBitCount(Value: Integer);
4	daniel-mar	186	procedure SetImage(Value: TDIBSharedImage); {$IFDEF VER9UP}inline;{$ENDIF}
1	daniel-mar	187	procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
		188	procedure SetPixel(X, Y: Integer; Value: DWORD);
		189	procedure StartProgress(const Name: string);
		190	procedure EndProgress;
		191	procedure UpdateProgress(PercentY: Integer);
4	daniel-mar	192
		193	{ Added these 3 functions for New Specials Effects }
		194	function Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		195	function IntToByte(i: Integer): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
		196	function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		197	{ End of 3 functions for New Special Effect }
		198
		199	procedure Darkness(Amount: Integer);
		200	function GetAlphaChannel: TDIB;
		201	procedure SetAlphaChannel(const Value: TDIB);
		202	function GetClientRect: TRect;
		203	function GetRGBChannel: TDIB;
		204	procedure SetRGBChannel(const Value: TDIB);
1	daniel-mar	205	protected
		206	procedure DefineProperties(Filer: TFiler); override;
4	daniel-mar	207	procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
1	daniel-mar	208	function GetEmpty: Boolean; override;
		209	function GetHeight: Integer; override;
		210	function GetPalette: HPalette; override;
		211	function GetWidth: Integer; override;
		212	procedure ReadData(Stream: TStream); override;
		213	procedure SetHeight(Value: Integer); override;
		214	procedure SetPalette(Value: HPalette); override;
		215	procedure SetWidth(Value: Integer); override;
		216	procedure WriteData(Stream: TStream); override;
		217	public
		218	ColorTable: TRGBQuads;
		219	PixelFormat: TDIBPixelFormat;
		220	constructor Create; override;
		221	destructor Destroy; override;
		222	procedure Assign(Source: TPersistent); override;
		223	procedure Clear;
		224	procedure Compress;
		225	procedure Decompress;
		226	procedure FreeHandle;
4	daniel-mar	227	function HasAlphaChannel: Boolean;
		228	function AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
		229	procedure RetAlphaChannel(out oDIB: TDIB);
1	daniel-mar	230	procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
		231	APalette: HPALETTE); override;
		232	procedure LoadFromStream(Stream: TStream); override;
		233	procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
		234	var APalette: HPALETTE); override;
		235	procedure SaveToStream(Stream: TStream); override;
4	daniel-mar	236	procedure SetSize(AWidth, AHeight, ABitCount: Integer); {$IFDEF VER5UP}reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
1	daniel-mar	237	procedure UpdatePalette;
		238	{ Special effect }
		239	procedure Blur(ABitCount: Integer; Radius: Integer);
		240	procedure Greyscale(ABitCount: Integer);
		241	procedure Mirror(MirrorX, MirrorY: Boolean);
		242	procedure Negative;
		243
4	daniel-mar	244	{ Added New Special Effect }
		245	procedure Spray(Amount: Integer);
		246	procedure Emboss;
		247	procedure AddMonoNoise(Amount: Integer);
		248	procedure AddGradiantNoise(Amount: byte);
		249	function Twist(bmp: TDIB; Amount: byte): Boolean;
		250	function FishEye(bmp: TDIB): Boolean;
		251	function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
		252	procedure Lightness(Amount: Integer);
		253	procedure Saturation(Amount: Integer);
		254	procedure Contrast(Amount: Integer);
		255	procedure AddRGB(aR, aG, aB: Byte);
		256	function Filter(Dest: TDIB; Filter: TFilter): Boolean;
		257	procedure Sharpen(Amount: Integer);
		258	function IntToColor(i: Integer): TBGR; {$IFDEF VER9UP}inline;{$ENDIF}
		259	function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
		260	procedure SplitBlur(Amount: Integer);
		261	procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
		262	{ End of New Special Effect }
		263	{
		264	New effect for TDIB
		265	with Some Effects like AntiAlias, Contrast,
		266	Lightness, Saturation, GaussianBlur, Mosaic,
		267	Twist, Splitlight, Trace, Emboss, etc.
		268	Works with 24bit color DIBs.
		269
		270	This component is based on TProEffectImage component version 1.0 by
		271	Written By Babak Sateli (babak_sateli@yahoo.com, http://raveland.netfirms.com)
		272
		273	and modified by (c) 2004 Jaro Benes
		274	for DelphiX use.
		275
		276	Demo was modified into DXForm with function like original
		277
		278	DISCLAIMER
		279	This component is provided AS-IS without any warranty of any kind, either express or
		280	implied. This component is freeware and can be used in any software product.
		281	}
		282	procedure DoInvert;
		283	procedure DoAddColorNoise(Amount: Integer);
		284	procedure DoAddMonoNoise(Amount: Integer);
		285	procedure DoAntiAlias;
		286	procedure DoContrast(Amount: Integer);
		287	procedure DoFishEye(Amount: Integer);
		288	procedure DoGrayScale;
		289	procedure DoLightness(Amount: Integer);
		290	procedure DoDarkness(Amount: Integer);
		291	procedure DoSaturation(Amount: Integer);
		292	procedure DoSplitBlur(Amount: Integer);
		293	procedure DoGaussianBlur(Amount: Integer);
		294	procedure DoMosaic(Size: Integer);
		295	procedure DoTwist(Amount: Integer);
		296	procedure DoSplitlight(Amount: Integer);
		297	procedure DoTile(Amount: Integer);
		298	procedure DoSpotLight(Amount: Integer; Spot: TRect);
		299	procedure DoTrace(Amount: Integer);
		300	procedure DoEmboss;
		301	procedure DoSolorize(Amount: Integer);
		302	procedure DoPosterize(Amount: Integer);
		303	procedure DoBrightness(Amount: Integer);
		304	procedure DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
		305	{rotate}
		306	procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
		307	procedure DoColorize(ForeColor, BackColor: TColor);
		308	{Simple explosion spoke effect}
		309	procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
		310	nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
		311
		312	{Simple Mandelbrot-set drawing}
		313	procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);
		314
		315	{Sephia effect}
		316	procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
		317
		318	{Simple blend pixel}
		319	procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
		320	{Line in polar system}
		321	procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
		322	Color: cardinal);
		323
		324	{special version Dark/Light procedure in percent}
		325	procedure Darker(Percent: Integer);
		326	procedure Lighter(Percent: Integer);
		327
		328	{Simple graphical crypt}
		329	procedure EncryptDecrypt(const Key: Integer);
		330
		331	{ Standalone DXFusion }
		332	{--- c o n F u s i o n ---}
		333	{By Joakim Back, www.back.mine.nu}
		334	{Huge thanks to Ilkka Tuomioja for helping out with the project.}
		335
		336	{
		337	modified by (c) 2005 Jaro Benes for DelphiX use.
		338	}
		339
		340	procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
		341	{Drawing Methods.}
		342	procedure DrawOn(Dest: TRect; DestCanvas: TCanvas;
		343	Xsrc, Ysrc: Integer);
		344	procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
		345	SourceY: Integer);
		346	procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
		347	SourceX, SourceY: Integer; const Color: TColor); {$IFDEF VER5UP} reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
		348	procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
		349	FilterMode: TFilterMode);
		350	procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
		351	Alpha: Byte);
		352	procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
		353	Frame: Integer);
		354	procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
		355	Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
		356	procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
		357	SourceX, SourceY: Integer; const Color: TColor;
		358	FilterMode: TFilterMode);
		359	procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
		360	SourceX, SourceY: Integer; const Color: TColor);
		361	procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
		362	SourceY: Integer; const Color: TColor);
		363	procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
		364	SourceY, Alpha: Integer; const Color: TColor);
		365	procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
		366	Height, SourceX, SourceY: Integer);
		367	procedure DrawAntialias(SrcDIB: TDIB);
		368	procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
		369	procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
		370	SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
		371	{One-color Filters.}
		372	procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
		373	FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
		374	procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
		375	FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
		376	{ Lightsource. }
		377	procedure InitLight(Count, Detail: Integer);
		378	procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
		379	//
		380	// effect for special purpose
		381	//
		382	procedure FadeOut(DIB2: TDIB; Step: Byte);
		383	procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
		384	procedure DoBlur(DIB2: TDIB);
		385	procedure FadeIn(DIB2: TDIB; Step: Byte);
		386	procedure FillDIB8(Color: Byte);
		387	procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
		388	procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
		389	function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
		390	// lines
		391	procedure AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor); {$IFDEF VER9UP} inline; {$ENDIF}
		392	function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
		393	FromPoint, ToPoint: Extended): TColor;
		394	procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
		395	iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
		396	iRadius: WORD);
		397	// standard property
1	daniel-mar	398	property BitCount: Integer read FBitCount write SetBitCount;
		399	property BitmapInfo: PBitmapInfo read GetBitmapInfo;
		400	property BitmapInfoSize: Integer read GetBitmapInfoSize;
		401	property Canvas: TCanvas read GetCanvas;
		402	property Handle: THandle read GetHandle;
		403	property Height: Integer read FHeight write SetHeight;
		404	property NextLine: Integer read FNextLine;
		405	property NowPixelFormat: TDIBPixelFormat read FNowPixelFormat write SetNowPixelFormat;
		406	property PaletteCount: Integer read GetPaletteCount;
		407	property PBits: Pointer read GetPBits;
		408	property PBitsReadOnly: Pointer read GetPBitsReadOnly;
		409	property Pixels[X, Y: Integer]: DWORD read GetPixel write SetPixel;
		410	property ScanLine[Y: Integer]: Pointer read GetScanLine;
		411	property ScanLineReadOnly[Y: Integer]: Pointer read GetScanLineReadOnly;
		412	property Size: Integer read FSize;
		413	property TopPBits: Pointer read GetTopPBits;
		414	property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
		415	property Width: Integer read FWidth write SetWidth;
		416	property WidthBytes: Integer read FWidthBytes;
4	daniel-mar	417	property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
		418	property RGBChannel: TDIB read GetRGBChannel write SetRGBChannel;
		419	function CreateBitmapFromDIB: TBitmap;
		420	procedure Fill(aColor: TColor);
		421	property ClientRect: TRect read GetClientRect;
1	daniel-mar	422	end;
		423
4	daniel-mar	424	{ TDIBitmap }
		425
1	daniel-mar	426	TDIBitmap = class(TDIB) end;
		427
		428	{ TCustomDXDIB }
		429
		430	TCustomDXDIB = class(TComponent)
		431	private
		432	FDIB: TDIB;
		433	procedure SetDIB(Value: TDIB);
		434	public
		435	constructor Create(AOnwer: TComponent); override;
		436	destructor Destroy; override;
		437	property DIB: TDIB read FDIB write SetDIB;
		438	end;
		439
		440	{ TDXDIB }
		441
		442	TDXDIB = class(TCustomDXDIB)
		443	published
		444	property DIB;
		445	end;
		446
		447	{ TCustomDXPaintBox }
		448
		449	TCustomDXPaintBox = class(TGraphicControl)
		450	private
		451	FAutoStretch: Boolean;
		452	FCenter: Boolean;
		453	FDIB: TDIB;
		454	FKeepAspect: Boolean;
		455	FStretch: Boolean;
		456	FViewWidth: Integer;
		457	FViewHeight: Integer;
		458	procedure SetAutoStretch(Value: Boolean);
		459	procedure SetCenter(Value: Boolean);
		460	procedure SetDIB(Value: TDIB);
		461	procedure SetKeepAspect(Value: Boolean);
		462	procedure SetStretch(Value: Boolean);
		463	procedure SetViewWidth(Value: Integer);
		464	procedure SetViewHeight(Value: Integer);
		465	protected
		466	function GetPalette: HPALETTE; override;
		467	public
		468	constructor Create(AOwner: TComponent); override;
		469	destructor Destroy; override;
		470	procedure Paint; override;
		471	property AutoStretch: Boolean read FAutoStretch write SetAutoStretch;
		472	property Canvas;
		473	property Center: Boolean read FCenter write SetCenter;
		474	property DIB: TDIB read FDIB write SetDIB;
		475	property KeepAspect: Boolean read FKeepAspect write SetKeepAspect;
		476	property Stretch: Boolean read FStretch write SetStretch;
		477	property ViewWidth: Integer read FViewWidth write SetViewWidth;
		478	property ViewHeight: Integer read FViewHeight write SetViewHeight;
		479	end;
		480
		481	{ TDXPaintBox }
		482
		483	TDXPaintBox = class(TCustomDXPaintBox)
		484	published
4	daniel-mar	485	{$IFDEF VER4UP}property Anchors; {$ENDIF}
1	daniel-mar	486	property AutoStretch;
		487	property Center;
4	daniel-mar	488	{$IFDEF VER4UP}property Constraints; {$ENDIF}
1	daniel-mar	489	property DIB;
		490	property KeepAspect;
		491	property Stretch;
		492	property ViewWidth;
		493	property ViewHeight;
		494
		495	property Align;
		496	property DragCursor;
		497	property DragMode;
		498	property Enabled;
		499	property ParentShowHint;
		500	property PopupMenu;
		501	property ShowHint;
		502	property Visible;
		503	property OnClick;
		504	property OnDblClick;
		505	property OnDragDrop;
		506	property OnDragOver;
		507	property OnEndDrag;
		508	property OnMouseDown;
		509	property OnMouseMove;
		510	property OnMouseUp;
4	daniel-mar	511	{$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
		512	{$IFDEF VER9UP}property OnResize; {$ENDIF}
		513	{$IFDEF VER9UP}property OnCanResize; {$ENDIF}
		514	{$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
1	daniel-mar	515	property OnStartDrag;
		516	end;
		517
4	daniel-mar	518	const
		519	DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);
1	daniel-mar	520
4	daniel-mar	521	function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
		522	function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
		523	function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
		524	procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
		525	function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
		526	function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
		527	function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
		528
1	daniel-mar	529	function GreyscaleColorTable: TRGBQuads;
		530
4	daniel-mar	531	function RGBQuad(R, G, B: Byte): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
		532	function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
		533	function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; {$IFDEF VER9UP}inline;{$ENDIF}
		534	function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; {$IFDEF VER9UP}inline;{$ENDIF}
		535	function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; {$IFDEF VER9UP}inline;{$ENDIF}
1	daniel-mar	536
4	daniel-mar	537	function PosValue(Value: Integer): Integer;
		538
		539	type
		540	TOC = 0..511;
		541	function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
		542	function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
		543
		544	{ Added Constants for TFilter Type }
		545	const
		546	EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
		547	StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
		548	Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
		549	LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
		550	GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
		551	SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
		552	{ End of constants }
		553
		554	{ Added Constants for DXFusion Type }
		555	const
		556	{ 3x3 Matrix Presets. }
		557	msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
		558	msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
		559	msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
		560	msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
		561	msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);
		562
		563	{Proportionaly scale of size, for recountin image sizes}
		564	function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single; {$IFDEF VER9UP}inline;{$ENDIF}
		565
		566	procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
		567	procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
		568
1	daniel-mar	569	implementation
		570
4	daniel-mar	571	uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
1	daniel-mar	572
4	daniel-mar	573	function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
		574	var
		575	XScale, YScale: Single;
		576	begin
		577	XScale := 1;
		578	YScale := 1;
		579	if TargetWidth < SourceWidth then
		580	XScale := TargetWidth / SourceWidth;
		581	if TargetHeight < SourceHeight then
		582	YScale := TargetHeight / SourceHeight;
		583	Result := XScale;
		584	if YScale < Result then
		585	Result := YScale;
		586	end;
		587
		588	{$IFNDEF VER4UP}
1	daniel-mar	589	function Max(B1, B2: Integer): Integer;
		590	begin
4	daniel-mar	591	if B1 >= B2 then Result := B1 else Result := B2;
1	daniel-mar	592	end;
		593
4	daniel-mar	594	function Min(B1, B2: Integer): Integer;
		595	begin
		596	if B1 <= B2 then Result := B1 else Result := B2;
		597	end;
		598	{$ENDIF}
		599
		600	function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
		601	begin
		602	Result := sin(((c * 360) / 511) * Pi / 180);
		603	end;
		604
		605	function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
		606	begin
		607	Result := cos(((c * 360) / 511) * Pi / 180);
		608	end;
		609
1	daniel-mar	610	function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
		611	begin
4	daniel-mar	612	Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
		613	Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
		614	Result.BBitMask := (1 shl BBitCount) - 1;
1	daniel-mar	615	Result.RBitCount := RBitCount;
		616	Result.GBitCount := GBitCount;
		617	Result.BBitCount := BBitCount;
4	daniel-mar	618	Result.RBitCount2 := 8 - RBitCount;
		619	Result.GBitCount2 := 8 - GBitCount;
		620	Result.BBitCount2 := 8 - BBitCount;
		621	Result.RShift := (GBitCount + BBitCount) - (8 - RBitCount);
		622	Result.GShift := BBitCount - (8 - GBitCount);
		623	Result.BShift := 8 - BBitCount;
1	daniel-mar	624	end;
		625
4	daniel-mar	626	function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		627	var
		628	i: Integer;
		629	begin
		630	i := 0;
		631	while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
1	daniel-mar	632
4	daniel-mar	633	Result := 0;
		634	while ((1 shl i) and b) <> 0 do
1	daniel-mar	635	begin
4	daniel-mar	636	Inc(i);
		637	Inc(Result);
1	daniel-mar	638	end;
4	daniel-mar	639	end;
1	daniel-mar	640
4	daniel-mar	641	function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
1	daniel-mar	642	begin
		643	Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
		644	GetBitCount(BBitMask));
		645	end;
		646
		647	function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
		648	begin
		649	with PixelFormat do
		650	Result := ((R shl RShift) and RBitMask) or ((G shl GShift) and GBitMask) or
		651	((B shr BShift) and BBitMask);
		652	end;
		653
		654	procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
		655	begin
		656	with PixelFormat do
		657	begin
		658	R := (Color and RBitMask) shr RShift;
		659	R := R or (R shr RBitCount2);
		660	G := (Color and GBitMask) shr GShift;
		661	G := G or (G shr GBitCount2);
		662	B := (Color and BBitMask) shl BShift;
		663	B := B or (B shr BBitCount2);
		664	end;
		665	end;
		666
		667	function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		668	begin
		669	with PixelFormat do
		670	begin
		671	Result := (Color and RBitMask) shr RShift;
4	daniel-mar	672	Result := Result or (Result shr RBitCount2);
1	daniel-mar	673	end;
		674	end;
		675
		676	function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		677	begin
		678	with PixelFormat do
		679	begin
		680	Result := (Color and GBitMask) shr GShift;
4	daniel-mar	681	Result := Result or (Result shr GBitCount2);
1	daniel-mar	682	end;
		683	end;
		684
		685	function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
		686	begin
		687	with PixelFormat do
		688	begin
		689	Result := (Color and BBitMask) shl BShift;
4	daniel-mar	690	Result := Result or (Result shr BBitCount2);
1	daniel-mar	691	end;
		692	end;
		693
		694	function GreyscaleColorTable: TRGBQuads;
		695	var
		696	i: Integer;
		697	begin
4	daniel-mar	698	for i := 0 to 255 do
1	daniel-mar	699	with Result[i] do
		700	begin
		701	rgbRed := i;
		702	rgbGreen := i;
		703	rgbBlue := i;
		704	rgbReserved := 0;
		705	end;
		706	end;
		707
		708	function RGBQuad(R, G, B: Byte): TRGBQuad;
		709	begin
		710	with Result do
		711	begin
		712	rgbRed := R;
		713	rgbGreen := G;
		714	rgbBlue := B;
		715	rgbReserved := 0;
		716	end;
		717	end;
		718
		719	function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
		720	begin
		721	with Result do
		722	with Entry do
		723	begin
		724	rgbRed := peRed;
		725	rgbGreen := peGreen;
		726	rgbBlue := peBlue;
		727	rgbReserved := 0;
		728	end;
		729	end;
		730
		731	function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
		732	var
		733	i: Integer;
		734	begin
4	daniel-mar	735	for i := 0 to 255 do
1	daniel-mar	736	Result[i] := PaletteEntryToRGBQuad(Entries[i]);
		737	end;
		738
		739	function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
		740	begin
		741	with Result do
		742	with RGBQuad do
		743	begin
		744	peRed := rgbRed;
		745	peGreen := rgbGreen;
		746	peBlue := rgbBlue;
		747	peFlags := 0;
		748	end;
		749	end;
		750
		751	function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
		752	var
		753	i: Integer;
		754	begin
4	daniel-mar	755	for i := 0 to 255 do
1	daniel-mar	756	Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]);
		757	end;
		758
		759	{ TDIBSharedImage }
		760
		761	type
		762	PLocalDIBPixelFormat = ^TLocalDIBPixelFormat;
		763	TLocalDIBPixelFormat = packed record
		764	RBitMask, GBitMask, BBitMask: DWORD;
		765	end;
		766
4	daniel-mar	767	{ TPaletteItem }
		768
1	daniel-mar	769	TPaletteItem = class(TCollectionItem)
		770	private
		771	ID: Integer;
		772	Palette: HPalette;
		773	RefCount: Integer;
		774	ColorTable: TRGBQuads;
		775	ColorTableCount: Integer;
		776	destructor Destroy; override;
		777	procedure AddRef;
4	daniel-mar	778	procedure Release; {$IFDEF VER17UP}reintroduce;{$ENDIF}
1	daniel-mar	779	end;
		780
4	daniel-mar	781	{ TPaletteManager }
		782
1	daniel-mar	783	TPaletteManager = class
		784	private
		785	FList: TCollection;
		786	constructor Create;
		787	destructor Destroy; override;
		788	function CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
		789	procedure DeletePalette(var Palette: HPalette);
		790	end;
		791
4	daniel-mar	792	{ TPaletteItem }
		793
1	daniel-mar	794	destructor TPaletteItem.Destroy;
		795	begin
		796	DeleteObject(Palette);
		797	inherited Destroy;
		798	end;
		799
		800	procedure TPaletteItem.AddRef;
		801	begin
		802	Inc(RefCount);
		803	end;
		804
		805	procedure TPaletteItem.Release;
		806	begin
		807	Dec(RefCount);
4	daniel-mar	808	if RefCount <= 0 then Free;
1	daniel-mar	809	end;
		810
4	daniel-mar	811	{ TPaletteManager }
		812
1	daniel-mar	813	constructor TPaletteManager.Create;
		814	begin
		815	inherited Create;
		816	FList := TCollection.Create(TPaletteItem);
		817	end;
		818
		819	destructor TPaletteManager.Destroy;
		820	begin
		821	FList.Free;
		822	inherited Destroy;
		823	end;
		824
		825	function TPaletteManager.CreatePalette(const ColorTable: TRGBQuads; ColorTableCount: Integer): HPalette;
		826	type
		827	TMyLogPalette = record
		828	palVersion: Word;
		829	palNumEntries: Word;
		830	palPalEntry: TPaletteEntries;
		831	end;
		832	var
		833	i, ID: Integer;
		834	Item: TPaletteItem;
		835	LogPalette: TMyLogPalette;
		836	begin
		837	{ Hash key making }
		838	ID := ColorTableCount;
4	daniel-mar	839	for i := 0 to ColorTableCount - 1 do
1	daniel-mar	840	with ColorTable[i] do
		841	begin
		842	Inc(ID, rgbRed);
		843	Inc(ID, rgbGreen);
		844	Inc(ID, rgbBlue);
		845	end;
		846
		847	{ Does the same palette already exist? }
4	daniel-mar	848	for i := 0 to FList.Count - 1 do
1	daniel-mar	849	begin
		850	Item := TPaletteItem(FList.Items[i]);
4	daniel-mar	851	if (Item.ID = ID) and (Item.ColorTableCount = ColorTableCount) and
		852	CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount * SizeOf(TRGBQuad)) then
1	daniel-mar	853	begin
		854	Item.AddRef; Result := Item.Palette;
		855	Exit;
		856	end;
		857	end;
		858
		859	{ New palette making }
		860	Item := TPaletteItem.Create(FList);
		861	Item.ID := ID;
4	daniel-mar	862	Move(ColorTable, Item.ColorTable, ColorTableCount * SizeOf(TRGBQuad));
1	daniel-mar	863	Item.ColorTableCount := ColorTableCount;
		864
		865	with LogPalette do
		866	begin
		867	palVersion := $300;
		868	palNumEntries := ColorTableCount;
		869	palPalEntry := RGBQuadsToPaletteEntries(ColorTable);
		870	end;
		871
		872	Item.Palette := Windows.CreatePalette(PLogPalette(@LogPalette)^);
		873	Item.AddRef; Result := Item.Palette;
		874	end;
		875
		876	procedure TPaletteManager.DeletePalette(var Palette: HPalette);
		877	var
		878	i: Integer;
		879	Item: TPaletteItem;
		880	begin
4	daniel-mar	881	if Palette = 0 then Exit;
1	daniel-mar	882
4	daniel-mar	883	for i := 0 to FList.Count - 1 do
1	daniel-mar	884	begin
		885	Item := TPaletteItem(FList.Items[i]);
4	daniel-mar	886	if (Item.Palette = Palette) then
1	daniel-mar	887	begin
		888	Palette := 0;
		889	Item.Release;
		890	Exit;
		891	end;
		892	end;
		893	end;
		894
		895	var
		896	FPaletteManager: TPaletteManager;
		897
		898	function PaletteManager: TPaletteManager;
		899	begin
4	daniel-mar	900	if FPaletteManager = nil then
1	daniel-mar	901	FPaletteManager := TPaletteManager.Create;
		902	Result := FPaletteManager;
		903	end;
		904
4	daniel-mar	905	{ TDIBSharedImage }
		906
1	daniel-mar	907	constructor TDIBSharedImage.Create;
		908	begin
		909	inherited Create;
		910	FMemoryImage := True;
		911	SetColorTable(GreyscaleColorTable);
		912	FColorTable := GreyscaleColorTable;
		913	FPixelFormat := MakeDIBPixelFormat(8, 8, 8);
		914	end;
		915
		916	procedure TDIBSharedImage.NewImage(AWidth, AHeight, ABitCount: Integer;
		917	const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
		918	var
		919	InfoOfs: Integer;
		920	UsePixelFormat: Boolean;
		921	begin
4	daniel-mar	922	{$IFNDEF D17UP}
		923	{self recreation is not allowed here}
1	daniel-mar	924	Create;
4	daniel-mar	925	{$ENDIF}
1	daniel-mar	926	{ Pixel format check }
		927	case ABitCount of
4	daniel-mar	928	1: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
		929	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		930	4: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
		931	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		932	8: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
		933	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		934	16:
		935	begin
		936	if not (((PixelFormat.RBitMask = $7C00) and (PixelFormat.GBitMask = $03E0) and (PixelFormat.BBitMask = $001F)) or
		937	((PixelFormat.RBitMask = $F800) and (PixelFormat.GBitMask = $07E0) and (PixelFormat.BBitMask = $001F))) then
		938	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		939	end;
		940	24:
		941	begin
		942	if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
		943	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		944	end;
		945	32:
		946	begin
		947	if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
		948	raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
		949	end;
1	daniel-mar	950	else
		951	raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
		952	end;
		953
		954	FBitCount := ABitCount;
		955	FHeight := AHeight;
		956	FWidth := AWidth;
4	daniel-mar	957	FWidthBytes := (((AWidth * ABitCount) + 31) shr 5) * 4;
1	daniel-mar	958	FNextLine := -FWidthBytes;
4	daniel-mar	959	FSize := FWidthBytes * FHeight;
1	daniel-mar	960	UsePixelFormat := ABitCount in [16, 32];
		961
		962	FPixelFormat := PixelFormat;
		963
		964	FPaletteCount := 0;
4	daniel-mar	965	if FBitCount <= 8 then
1	daniel-mar	966	FPaletteCount := 1 shl FBitCount;
		967
		968	FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
		969	if UsePixelFormat then
		970	Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
4	daniel-mar	971	Inc(FBitmapInfoSize, SizeOf(TRGBQuad) * FPaletteCount);
1	daniel-mar	972
		973	GetMem(FBitmapInfo, FBitmapInfoSize);
		974	FillChar(FBitmapInfo^, FBitmapInfoSize, 0);
		975
		976	{ BitmapInfo setting. }
		977	with FBitmapInfo^.bmiHeader do
		978	begin
		979	biSize := SizeOf(TBitmapInfoHeader);
		980	biWidth := FWidth;
		981	biHeight := FHeight;
		982	biPlanes := 1;
		983	biBitCount := FBitCount;
		984	if UsePixelFormat then
		985	biCompression := BI_BITFIELDS
		986	else
		987	begin
4	daniel-mar	988	if (FBitCount = 4) and (Compressed) then
1	daniel-mar	989	biCompression := BI_RLE4
4	daniel-mar	990	else if (FBitCount = 8) and (Compressed) then
1	daniel-mar	991	biCompression := BI_RLE8
		992	else
		993	biCompression := BI_RGB;
		994	end;
		995	biSizeImage := FSize;
		996	biXPelsPerMeter := 0;
		997	biYPelsPerMeter := 0;
		998	biClrUsed := 0;
		999	biClrImportant := 0;
		1000	end;
		1001	InfoOfs := SizeOf(TBitmapInfoHeader);
		1002
		1003	if UsePixelFormat then
		1004	begin
4	daniel-mar	1005	with PLocalDIBPixelFormat(Integer(FBitmapInfo) + InfoOfs)^ do
1	daniel-mar	1006	begin
		1007	RBitMask := PixelFormat.RBitMask;
		1008	GBitMask := PixelFormat.GBitMask;
		1009	BBitMask := PixelFormat.BBitMask;
		1010	end;
		1011
		1012	Inc(InfoOfs, SizeOf(TLocalDIBPixelFormat));
		1013	end;
		1014
		1015	FColorTablePos := InfoOfs;
		1016
		1017	FColorTable := ColorTable;
4	daniel-mar	1018	Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
1	daniel-mar	1019
		1020	FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
		1021	FMemoryImage := MemoryImage or FCompressed;
		1022
		1023	{ DIB making. }
		1024	if not Compressed then
		1025	begin
		1026	if MemoryImage then
		1027	begin
		1028	FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
4	daniel-mar	1029	if FPBits = nil then
1	daniel-mar	1030	OutOfMemoryError;
4	daniel-mar	1031	end
		1032	else
1	daniel-mar	1033	begin
		1034	FDC := CreateCompatibleDC(0);
		1035
		1036	FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
4	daniel-mar	1037	if FHandle = 0 then
1	daniel-mar	1038	raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);
		1039
		1040	FOldHandle := SelectObject(FDC, FHandle);
		1041	end;
		1042	end;
		1043
4	daniel-mar	1044	FTopPBits := Pointer(Integer(FPBits) + (FHeight - 1) * FWidthBytes);
1	daniel-mar	1045	end;
		1046
		1047	procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
		1048	begin
4	daniel-mar	1049	if Source = nil then Exit; //no source
		1050
		1051	if Source.FSize = 0 then
1	daniel-mar	1052	begin
4	daniel-mar	1053	{$IFNDEF D17UP}
		1054	{self recreation is not allowed here}
1	daniel-mar	1055	Create;
4	daniel-mar	1056	{$ENDIF}
1	daniel-mar	1057	FMemoryImage := MemoryImage;
4	daniel-mar	1058	end
		1059	else
1	daniel-mar	1060	begin
		1061	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		1062	Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
		1063	if FCompressed then
		1064	begin
		1065	FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
		1066	GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
		1067	Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
4	daniel-mar	1068	end
		1069	else
1	daniel-mar	1070	begin
		1071	Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
		1072	end;
		1073	end;
		1074	end;
		1075
		1076	procedure TDIBSharedImage.Compress(Source: TDIBSharedImage);
		1077
		1078	procedure EncodeRLE4;
		1079	var
		1080	Size: Integer;
		1081
		1082	function AllocByte: PByte;
		1083	begin
4	daniel-mar	1084	if Size mod 4096 = 0 then
		1085	ReAllocMem(FPBits, Size + 4095);
		1086	Result := Pointer(Integer(FPBits) + Size);
1	daniel-mar	1087	Inc(Size);
		1088	end;
		1089
		1090	var
		1091	B1, B2, C: Byte;
		1092	PB1, PB2: Integer;
		1093	Src: PByte;
		1094	X, Y: Integer;
		1095
		1096	function GetPixel(x: Integer): Integer;
		1097	begin
4	daniel-mar	1098	if X and 1 = 0 then
1	daniel-mar	1099	Result := PArrayByte(Src)[X shr 1] shr 4
		1100	else
		1101	Result := PArrayByte(Src)[X shr 1] and $0F;
		1102	end;
		1103
		1104	begin
		1105	Size := 0;
		1106
4	daniel-mar	1107	for y := 0 to Source.FHeight - 1 do
1	daniel-mar	1108	begin
		1109	x := 0;
4	daniel-mar	1110	Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
		1111	while x < Source.FWidth do
1	daniel-mar	1112	begin
4	daniel-mar	1113	if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) then
1	daniel-mar	1114	begin
		1115	{ Encoding mode }
		1116	B1 := 2;
4	daniel-mar	1117	B2 := (GetPixel(x) shl 4) or GetPixel(x + 1);
1	daniel-mar	1118
		1119	Inc(x, 2);
		1120
		1121	C := B2;
		1122
4	daniel-mar	1123	while (x < Source.FWidth) and (C and $F = GetPixel(x)) and (B1 < 255) do
1	daniel-mar	1124	begin
		1125	Inc(B1);
		1126	Inc(x);
		1127	C := (C shr 4) or (C shl 4);
		1128	end;
		1129
		1130	AllocByte^ := B1;
		1131	AllocByte^ := B2;
4	daniel-mar	1132	end
		1133	else
		1134	if (Source.FWidth - x > 5) and ((GetPixel(x) <> GetPixel(x + 2)) or (GetPixel(x + 1) <> GetPixel(x + 3))) and
		1135	((GetPixel(x + 2) = GetPixel(x + 4)) and (GetPixel(x + 3) = GetPixel(x + 5))) then
		1136	begin
1	daniel-mar	1137	{ Encoding mode }
4	daniel-mar	1138	AllocByte^ := 2;
		1139	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
		1140	Inc(x, 2);
		1141	end
		1142	else
1	daniel-mar	1143	begin
4	daniel-mar	1144	if (Source.FWidth - x < 4) then
		1145	begin
1	daniel-mar	1146	{ Encoding mode }
4	daniel-mar	1147	while Source.FWidth - x >= 2 do
		1148	begin
		1149	AllocByte^ := 2;
		1150	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
		1151	Inc(x, 2);
		1152	end;
1	daniel-mar	1153
4	daniel-mar	1154	if Source.FWidth - x = 1 then
		1155	begin
		1156	AllocByte^ := 1;
		1157	AllocByte^ := GetPixel(x) shl 4;
		1158	Inc(x);
		1159	end;
		1160	end
		1161	else
1	daniel-mar	1162	begin
		1163	{ Absolute mode }
4	daniel-mar	1164	PB1 := Size; AllocByte;
		1165	PB2 := Size; AllocByte;
1	daniel-mar	1166
4	daniel-mar	1167	B1 := 0;
		1168	B2 := 4;
1	daniel-mar	1169
4	daniel-mar	1170	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
		1171	AllocByte^ := (GetPixel(x + 2) shl 4) or GetPixel(x + 3);
1	daniel-mar	1172
4	daniel-mar	1173	Inc(x, 4);
1	daniel-mar	1174
4	daniel-mar	1175	while (x + 1 < Source.FWidth) and (B2 < 254) do
		1176	begin
		1177	if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) and (GetPixel(x + 1) = GetPixel(x + 3)) then
		1178	Break;
1	daniel-mar	1179
4	daniel-mar	1180	AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
		1181	Inc(B2, 2);
		1182	Inc(x, 2);
		1183	end;
		1184
		1185	PByte(Integer(FPBits) + PB1)^ := B1;
		1186	PByte(Integer(FPBits) + PB2)^ := B2;
1	daniel-mar	1187	end;
		1188	end;
		1189
4	daniel-mar	1190	if Size and 1 = 1 then AllocByte;
1	daniel-mar	1191	end;
		1192
		1193	{ End of line }
		1194	AllocByte^ := 0;
		1195	AllocByte^ := 0;
		1196	end;
		1197
		1198	{ End of bitmap }
		1199	AllocByte^ := 0;
		1200	AllocByte^ := 1;
		1201
		1202	FBitmapInfo.bmiHeader.biSizeImage := Size;
		1203	FSize := Size;
		1204	end;
		1205
		1206	procedure EncodeRLE8;
		1207	var
		1208	Size: Integer;
		1209
		1210	function AllocByte: PByte;
		1211	begin
4	daniel-mar	1212	if Size mod 4096 = 0 then
		1213	ReAllocMem(FPBits, Size + 4095);
		1214	Result := Pointer(Integer(FPBits) + Size);
1	daniel-mar	1215	Inc(Size);
		1216	end;
		1217
		1218	var
		1219	B1, B2: Byte;
		1220	PB1, PB2: Integer;
		1221	Src: PByte;
		1222	X, Y: Integer;
		1223	begin
		1224	Size := 0;
		1225
4	daniel-mar	1226	for y := 0 to Source.FHeight - 1 do
1	daniel-mar	1227	begin
		1228	x := 0;
4	daniel-mar	1229	Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
		1230	while x < Source.FWidth do
1	daniel-mar	1231	begin
4	daniel-mar	1232	if (Source.FWidth - x > 2) and (Src^ = PByte(Integer(Src) + 1)^) then
1	daniel-mar	1233	begin
		1234	{ Encoding mode }
		1235	B1 := 2;
		1236	B2 := Src^;
		1237
		1238	Inc(x, 2);
		1239	Inc(Src, 2);
		1240
4	daniel-mar	1241	while (x < Source.FWidth) and (Src^ = B2) and (B1 < 255) do
1	daniel-mar	1242	begin
		1243	Inc(B1);
		1244	Inc(x);
		1245	Inc(Src);
		1246	end;
		1247
		1248	AllocByte^ := B1;
		1249	AllocByte^ := B2;
4	daniel-mar	1250	end
		1251	else
		1252	if (Source.FWidth - x > 2) and (Src^ <> PByte(Integer(Src) + 1)^) and (PByte(Integer(Src) + 1)^ = PByte(Integer(Src) + 2)^) then
		1253	begin
1	daniel-mar	1254	{ Encoding mode }
4	daniel-mar	1255	AllocByte^ := 1;
		1256	AllocByte^ := Src^; Inc(Src);
		1257	Inc(x);
		1258	end
		1259	else
1	daniel-mar	1260	begin
4	daniel-mar	1261	if (Source.FWidth - x < 4) then
		1262	begin
1	daniel-mar	1263	{ Encoding mode }
4	daniel-mar	1264	if Source.FWidth - x = 2 then
		1265	begin
		1266	AllocByte^ := 1;
		1267	AllocByte^ := Src^; Inc(Src);
1	daniel-mar	1268
4	daniel-mar	1269	AllocByte^ := 1;
		1270	AllocByte^ := Src^; Inc(Src);
		1271	Inc(x, 2);
		1272	end
		1273	else
		1274	begin
		1275	AllocByte^ := 1;
		1276	AllocByte^ := Src^; Inc(Src);
		1277	Inc(x);
		1278	end;
		1279	end
		1280	else
1	daniel-mar	1281	begin
		1282	{ Absolute mode }
4	daniel-mar	1283	PB1 := Size; AllocByte;
		1284	PB2 := Size; AllocByte;
1	daniel-mar	1285
4	daniel-mar	1286	B1 := 0;
		1287	B2 := 3;
1	daniel-mar	1288
4	daniel-mar	1289	Inc(x, 3);
1	daniel-mar	1290
4	daniel-mar	1291	AllocByte^ := Src^; Inc(Src);
		1292	AllocByte^ := Src^; Inc(Src);
		1293	AllocByte^ := Src^; Inc(Src);
1	daniel-mar	1294
4	daniel-mar	1295	while (x < Source.FWidth) and (B2 < 255) do
		1296	begin
		1297	if (Source.FWidth - x > 3) and (Src^ = PByte(Integer(Src) + 1)^) and (Src^ = PByte(Integer(Src) + 2)^) and (Src^ = PByte(Integer(Src) + 3)^) then
		1298	Break;
1	daniel-mar	1299
4	daniel-mar	1300	AllocByte^ := Src^; Inc(Src);
		1301	Inc(B2);
		1302	Inc(x);
		1303	end;
		1304
		1305	PByte(Integer(FPBits) + PB1)^ := B1;
		1306	PByte(Integer(FPBits) + PB2)^ := B2;
1	daniel-mar	1307	end;
		1308	end;
		1309
4	daniel-mar	1310	if Size and 1 = 1 then AllocByte;
1	daniel-mar	1311	end;
		1312
		1313	{ End of line }
		1314	AllocByte^ := 0;
		1315	AllocByte^ := 0;
		1316	end;
		1317
		1318	{ End of bitmap }
		1319	AllocByte^ := 0;
		1320	AllocByte^ := 1;
		1321
		1322	FBitmapInfo.bmiHeader.biSizeImage := Size;
		1323	FSize := Size;
		1324	end;
		1325
		1326	begin
		1327	if Source.FCompressed then
		1328	Duplicate(Source, Source.FMemoryImage)
4	daniel-mar	1329	else
		1330	begin
1	daniel-mar	1331	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		1332	Source.FPixelFormat, Source.FColorTable, True, True);
		1333	case FBitmapInfo.bmiHeader.biCompression of
		1334	BI_RLE4: EncodeRLE4;
		1335	BI_RLE8: EncodeRLE8;
		1336	else
		1337	Duplicate(Source, Source.FMemoryImage);
		1338	end;
		1339	end;
		1340	end;
		1341
		1342	procedure TDIBSharedImage.Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
		1343
		1344	procedure DecodeRLE4;
		1345	var
		1346	B1, B2, C: Byte;
		1347	Dest, Src, P: PByte;
		1348	X, Y, i: Integer;
		1349	begin
		1350	Src := Source.FPBits;
		1351	X := 0;
		1352	Y := 0;
		1353
		1354	while True do
		1355	begin
		1356	B1 := Src^; Inc(Src);
		1357	B2 := Src^; Inc(Src);
		1358
4	daniel-mar	1359	if B1 = 0 then
1	daniel-mar	1360	begin
		1361	case B2 of
4	daniel-mar	1362	0: begin { End of line }
		1363	X := 0;
		1364	Inc(Y);
		1365	end;
1	daniel-mar	1366	1: Break; { End of bitmap }
4	daniel-mar	1367	2: begin { Difference of coordinates }
		1368	Inc(X, B1);
		1369	Inc(Y, B2); Inc(Src, 2);
		1370	end;
1	daniel-mar	1371	else
		1372	{ Absolute mode }
4	daniel-mar	1373	Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
1	daniel-mar	1374
		1375	C := 0;
4	daniel-mar	1376	for i := 0 to B2 - 1 do
1	daniel-mar	1377	begin
4	daniel-mar	1378	if i and 1 = 0 then
1	daniel-mar	1379	begin
		1380	C := Src^; Inc(Src);
4	daniel-mar	1381	end
		1382	else
1	daniel-mar	1383	begin
		1384	C := C shl 4;
		1385	end;
		1386
4	daniel-mar	1387	P := Pointer(Integer(Dest) + X shr 1);
		1388	if X and 1 = 0 then
1	daniel-mar	1389	P^ := (P^ and $0F) or (C and $F0)
		1390	else
		1391	P^ := (P^ and $F0) or ((C and $F0) shr 4);
		1392
		1393	Inc(X);
		1394	end;
		1395	end;
4	daniel-mar	1396	end
		1397	else
1	daniel-mar	1398	begin
		1399	{ Encoding mode }
4	daniel-mar	1400	Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
1	daniel-mar	1401
4	daniel-mar	1402	for i := 0 to B1 - 1 do
1	daniel-mar	1403	begin
4	daniel-mar	1404	P := Pointer(Integer(Dest) + X shr 1);
		1405	if X and 1 = 0 then
1	daniel-mar	1406	P^ := (P^ and $0F) or (B2 and $F0)
		1407	else
		1408	P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
		1409
		1410	Inc(X);
		1411
		1412	// Swap nibble
		1413	B2 := (B2 shr 4) or (B2 shl 4);
		1414	end;
		1415	end;
		1416
		1417	{ Word arrangement }
		1418	Inc(Src, Longint(Src) and 1);
		1419	end;
		1420	end;
		1421
		1422	procedure DecodeRLE8;
		1423	var
		1424	B1, B2: Byte;
		1425	Dest, Src: PByte;
		1426	X, Y: Integer;
		1427	begin
		1428	Dest := FPBits;
		1429	Src := Source.FPBits;
		1430	X := 0;
		1431	Y := 0;
		1432
		1433	while True do
		1434	begin
		1435	B1 := Src^; Inc(Src);
		1436	B2 := Src^; Inc(Src);
		1437
4	daniel-mar	1438	if B1 = 0 then
1	daniel-mar	1439	begin
		1440	case B2 of
4	daniel-mar	1441	0: begin { End of line }
		1442	X := 0; Inc(Y);
		1443	Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
		1444	end;
1	daniel-mar	1445	1: Break; { End of bitmap }
4	daniel-mar	1446	2: begin { Difference of coordinates }
		1447	Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
		1448	Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
		1449	end;
1	daniel-mar	1450	else
		1451	{ Absolute mode }
		1452	Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
		1453	end;
4	daniel-mar	1454	end
		1455	else
1	daniel-mar	1456	begin
		1457	{ Encoding mode }
		1458	FillChar(Dest^, B1, B2); Inc(Dest, B1);
		1459	end;
		1460
		1461	{ Word arrangement }
		1462	Inc(Src, Longint(Src) and 1);
		1463	end;
		1464	end;
		1465
		1466	begin
		1467	if not Source.FCompressed then
		1468	Duplicate(Source, MemoryImage)
4	daniel-mar	1469	else
		1470	begin
1	daniel-mar	1471	NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
		1472	Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
		1473	case Source.FBitmapInfo.bmiHeader.biCompression of
		1474	BI_RLE4: DecodeRLE4;
		1475	BI_RLE8: DecodeRLE8;
		1476	else
		1477	Duplicate(Source, MemoryImage);
4	daniel-mar	1478	end;
1	daniel-mar	1479	end;
		1480	end;
		1481
		1482	procedure TDIBSharedImage.ReadData(Stream: TStream; MemoryImage: Boolean);
		1483	var
		1484	BI: TBitmapInfoHeader;
		1485	BC: TBitmapCoreHeader;
		1486	BCRGB: array[0..255] of TRGBTriple;
		1487
		1488	procedure LoadRLE4;
		1489	begin
		1490	FSize := BI.biSizeImage;
4	daniel-mar	1491	//GetMem(FPBits, FSize);
1	daniel-mar	1492	FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
		1493	FBitmapInfo.bmiHeader.biSizeImage := FSize;
		1494	Stream.ReadBuffer(FPBits^, FSize);
		1495	end;
		1496
		1497	procedure LoadRLE8;
		1498	begin
		1499	FSize := BI.biSizeImage;
4	daniel-mar	1500	//GetMem(FPBits, FSize);
1	daniel-mar	1501	FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
		1502	FBitmapInfo.bmiHeader.biSizeImage := FSize;
		1503	Stream.ReadBuffer(FPBits^, FSize);
		1504	end;
		1505
		1506	procedure LoadRGB;
		1507	var
		1508	y: Integer;
		1509	begin
4	daniel-mar	1510	if BI.biHeight < 0 then
1	daniel-mar	1511	begin
4	daniel-mar	1512	for y := 0 to Abs(BI.biHeight) - 1 do
		1513	Stream.ReadBuffer(Pointer(Integer(FTopPBits) + y * FNextLine)^, FWidthBytes);
		1514	end
		1515	else
1	daniel-mar	1516	begin
		1517	Stream.ReadBuffer(FPBits^, FSize);
		1518	end;
		1519	end;
		1520
		1521	var
		1522	i, PalCount: Integer;
		1523	OS2: Boolean;
		1524	Localpf: TLocalDIBPixelFormat;
		1525	AColorTable: TRGBQuads;
		1526	APixelFormat: TDIBPixelFormat;
		1527	begin
4	daniel-mar	1528	if not Assigned(Stream) then Exit;
		1529
1	daniel-mar	1530	{ Header size reading }
		1531	i := Stream.Read(BI.biSize, 4);
		1532
4	daniel-mar	1533	if i = 0 then
1	daniel-mar	1534	begin
4	daniel-mar	1535	{$IFNDEF D17UP}
		1536	{self recreation is not allowed here}
1	daniel-mar	1537	Create;
4	daniel-mar	1538	{$ENDIF}
1	daniel-mar	1539	Exit;
		1540	end;
4	daniel-mar	1541	if i <> 4 then
1	daniel-mar	1542	raise EInvalidGraphic.Create(SInvalidDIB);
		1543
		1544	{ Kind check of DIB }
		1545	OS2 := False;
		1546
		1547	case BI.biSize of
		1548	SizeOf(TBitmapCoreHeader):
		1549	begin
		1550	{ OS/2 type }
4	daniel-mar	1551	Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
1	daniel-mar	1552
		1553	with BI do
		1554	begin
		1555	biClrUsed := 0;
		1556	biCompression := BI_RGB;
		1557	biBitCount := BC.bcBitCount;
		1558	biHeight := BC.bcHeight;
		1559	biWidth := BC.bcWidth;
		1560	end;
		1561
		1562	OS2 := True;
		1563	end;
		1564	SizeOf(TBitmapInfoHeader):
		1565	begin
		1566	{ Windows type }
4	daniel-mar	1567	Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
1	daniel-mar	1568	end;
		1569	else
		1570	raise EInvalidGraphic.Create(SInvalidDIB);
		1571	end;
		1572
		1573	{ Bit mask reading. }
		1574	if BI.biCompression = BI_BITFIELDS then
		1575	begin
		1576	Stream.ReadBuffer(Localpf, SizeOf(Localpf));
		1577	with Localpf do
		1578	APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
4	daniel-mar	1579	end
		1580	else
1	daniel-mar	1581	begin
4	daniel-mar	1582	if BI.biBitCount = 16 then
1	daniel-mar	1583	APixelFormat := MakeDIBPixelFormat(5, 5, 5)
4	daniel-mar	1584	else if BI.biBitCount = 32 then
1	daniel-mar	1585	APixelFormat := MakeDIBPixelFormat(8, 8, 8)
		1586	else
		1587	APixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1588	end;
		1589
		1590	{ Palette reading }
		1591	PalCount := BI.biClrUsed;
4	daniel-mar	1592	if (PalCount = 0) and (BI.biBitCount <= 8) then
1	daniel-mar	1593	PalCount := 1 shl BI.biBitCount;
4	daniel-mar	1594	if PalCount > 256 then PalCount := 256;
1	daniel-mar	1595
		1596	FillChar(AColorTable, SizeOf(AColorTable), 0);
		1597
		1598	if OS2 then
		1599	begin
		1600	{ OS/2 type }
4	daniel-mar	1601	Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple) * PalCount);
		1602	for i := 0 to PalCount - 1 do
1	daniel-mar	1603	begin
		1604	with BCRGB[i] do
		1605	AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
		1606	end;
4	daniel-mar	1607	end
		1608	else
1	daniel-mar	1609	begin
		1610	{ Windows type }
4	daniel-mar	1611	Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad) * PalCount);
1	daniel-mar	1612	end;
		1613
4	daniel-mar	1614	{ DIB compilation }
1	daniel-mar	1615	NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
		1616	MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
		1617
		1618	{ Pixel data reading }
		1619	case BI.biCompression of
4	daniel-mar	1620	BI_RGB: LoadRGB;
		1621	BI_RLE4: LoadRLE4;
		1622	BI_RLE8: LoadRLE8;
1	daniel-mar	1623	BI_BITFIELDS: LoadRGB;
		1624	else
		1625	raise EInvalidGraphic.Create(SInvalidDIB);
		1626	end;
		1627	end;
		1628
		1629	destructor TDIBSharedImage.Destroy;
		1630	begin
4	daniel-mar	1631	if FHandle <> 0 then
1	daniel-mar	1632	begin
4	daniel-mar	1633	if FOldHandle <> 0 then SelectObject(FDC, FOldHandle);
1	daniel-mar	1634	DeleteObject(FHandle);
4	daniel-mar	1635	end
		1636	else
		1637	// GlobalFree(THandle(FPBits));
1	daniel-mar	1638	begin
4	daniel-mar	1639	if FPBits <> nil then
1	daniel-mar	1640	GlobalFreePtr(FPBits);
		1641	end;
		1642
		1643	PaletteManager.DeletePalette(FPalette);
4	daniel-mar	1644	if FDC <> 0 then DeleteDC(FDC);
1	daniel-mar	1645
		1646	FreeMem(FBitmapInfo);
		1647	inherited Destroy;
		1648	end;
		1649
		1650	procedure TDIBSharedImage.FreeHandle;
		1651	begin
		1652	end;
		1653
		1654	function TDIBSharedImage.GetPalette: THandle;
		1655	begin
4	daniel-mar	1656	if FPaletteCount > 0 then
1	daniel-mar	1657	begin
		1658	if FChangePalette then
		1659	begin
		1660	FChangePalette := False;
		1661	PaletteManager.DeletePalette(FPalette);
		1662	FPalette := PaletteManager.CreatePalette(FColorTable, FPaletteCount);
		1663	end;
		1664	Result := FPalette;
		1665	end else
		1666	Result := 0;
		1667	end;
		1668
		1669	procedure TDIBSharedImage.SetColorTable(const Value: TRGBQuads);
		1670	begin
		1671	FColorTable := Value;
		1672	FChangePalette := True;
		1673
4	daniel-mar	1674	if (FSize > 0) and (FPaletteCount > 0) then
1	daniel-mar	1675	begin
		1676	SetDIBColorTable(FDC, 0, 256, FColorTable);
4	daniel-mar	1677	Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
1	daniel-mar	1678	end;
		1679	end;
		1680
		1681	{ TDIB }
		1682
		1683	var
		1684	FEmptyDIBImage: TDIBSharedImage;
		1685
		1686	function EmptyDIBImage: TDIBSharedImage;
		1687	begin
4	daniel-mar	1688	if FEmptyDIBImage = nil then
1	daniel-mar	1689	begin
		1690	FEmptyDIBImage := TDIBSharedImage.Create;
		1691	FEmptyDIBImage.Reference;
		1692	end;
		1693	Result := FEmptyDIBImage;
		1694	end;
		1695
		1696	constructor TDIB.Create;
		1697	begin
		1698	inherited Create;
		1699	SetImage(EmptyDIBImage);
4	daniel-mar	1700
		1701	FFreeList := TList.Create;
1	daniel-mar	1702	end;
		1703
		1704	destructor TDIB.Destroy;
4	daniel-mar	1705	var
		1706	D: TDIB;
1	daniel-mar	1707	begin
		1708	SetImage(EmptyDIBImage);
		1709	FCanvas.Free;
4	daniel-mar	1710
		1711	while FFreeList.Count > 0 do
		1712	try
		1713	D := TDIB(FFreeList[0]);
		1714	FFreeList.Remove(D);
		1715	D.Free;
		1716	except
		1717	end;
		1718	FFreeList.Free;
		1719
1	daniel-mar	1720	inherited Destroy;
		1721	end;
		1722
		1723	procedure TDIB.Assign(Source: TPersistent);
		1724
		1725	procedure AssignBitmap(Source: TBitmap);
		1726	var
		1727	Data: array[0..1023] of Byte;
		1728	BitmapRec: Windows.PBitmap;
		1729	DIBSectionRec: PDIBSection;
		1730	PaletteEntries: TPaletteEntries;
		1731	begin
		1732	GetPaletteEntries(Source.Palette, 0, 256, PaletteEntries);
		1733	ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
		1734	UpdatePalette;
		1735
		1736	case GetObject(Source.Handle, SizeOf(Data), @Data) of
		1737	SizeOf(Windows.TBitmap):
4	daniel-mar	1738	begin
		1739	BitmapRec := @Data;
		1740	case BitmapRec^.bmBitsPixel of
		1741	16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
		1742	else
		1743	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
1	daniel-mar	1744	end;
4	daniel-mar	1745	SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
		1746	end;
1	daniel-mar	1747	SizeOf(TDIBSection):
4	daniel-mar	1748	begin
		1749	DIBSectionRec := @Data;
		1750	if DIBSectionRec^.dsBm.bmBitsPixel >= 24 then
1	daniel-mar	1751	begin
4	daniel-mar	1752	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1753	end
		1754	else
		1755	if DIBSectionRec^.dsBm.bmBitsPixel > 8 then
1	daniel-mar	1756	begin
4	daniel-mar	1757	PixelFormat := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
1	daniel-mar	1758	DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
4	daniel-mar	1759	end
		1760	else
1	daniel-mar	1761	begin
		1762	PixelFormat := MakeDIBPixelFormat(8, 8, 8);
		1763	end;
4	daniel-mar	1764	SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
		1765	DIBSectionRec^.dsBm.bmBitsPixel);
		1766	end;
1	daniel-mar	1767	else
		1768	Exit;
		1769	end;
		1770
		1771	FillChar(PBits^, Size, 0);
		1772	Canvas.Draw(0, 0, Source);
		1773	end;
		1774
		1775	procedure AssignGraphic(Source: TGraphic);
4	daniel-mar	1776	{$IFDEF PNG_GRAPHICS}
		1777	var
		1778	alpha: TDIB;
		1779	png: {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF};
		1780	i, j: Integer;
		1781	q: pByteArray;
		1782	{$ENDIF}
1	daniel-mar	1783	begin
4	daniel-mar	1784	{$IFDEF PNG_GRAPHICS}
		1785	if Source is {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF} then
		1786	begin
		1787	alpha := TDIB.Create;
		1788	try
		1789	{png image}
		1790	png := {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF}.Create;
		1791	try
		1792	png.Assign(Source);
		1793	if png.TransparencyMode = ptmPartial then
		1794	begin
		1795	Alpha.SetSize(png.Width, png.Height, 8);
		1796	{separate alpha}
		1797	for i := 0 to png.Height - 1 do
		1798	begin
		1799	q := png.AlphaScanline[i];
		1800	for j := 0 to png.Width - 1 do
		1801	alpha.Pixels[j,i] := q[j];
		1802	end;
		1803	end;
		1804	SetSize(png.Width, png.Height, 32);
		1805	FillChar(PBits^, Size, 0);
		1806	Canvas.Draw(0, 0, png);
		1807	Transparent := png.Transparent;
		1808	finally
		1809	png.Free;
		1810	end;
		1811	if not alpha.Empty then
		1812	AssignAlphaChannel(alpha);
		1813	finally
		1814	alpha.Free;
		1815	end;
		1816	end
		1817	else
		1818	{$ENDIF}
1	daniel-mar	1819	if Source is TBitmap then
		1820	AssignBitmap(TBitmap(Source))
		1821	else
		1822	begin
4	daniel-mar	1823	SetSize(Source.Width, Source.Height, 32);
1	daniel-mar	1824	FillChar(PBits^, Size, 0);
		1825	Canvas.Draw(0, 0, Source);
4	daniel-mar	1826	Transparent := Source.Transparent;
		1827	if not HasAlphaChannel then
		1828	begin
		1829	SetSize(Source.Width, Source.Height, 24);
		1830	FillChar(PBits^, Size, 0);
		1831	Canvas.Draw(0, 0, Source);
		1832	Transparent := Source.Transparent;
		1833	end
1	daniel-mar	1834	end;
		1835	end;
		1836
		1837	begin
4	daniel-mar	1838	if Source = nil then
1	daniel-mar	1839	begin
		1840	Clear;
		1841	end else if Source is TDIB then
		1842	begin
4	daniel-mar	1843	if Source <> Self then
1	daniel-mar	1844	SetImage(TDIB(Source).FImage);
		1845	end else if Source is TGraphic then
		1846	begin
		1847	AssignGraphic(TGraphic(Source));
		1848	end else if Source is TPicture then
		1849	begin
4	daniel-mar	1850	if TPicture(Source).Graphic <> nil then
1	daniel-mar	1851	AssignGraphic(TPicture(Source).Graphic)
		1852	else
		1853	Clear;
4	daniel-mar	1854	end else
1	daniel-mar	1855	inherited Assign(Source);
		1856	end;
		1857
4	daniel-mar	1858	procedure TDIB.Draw(ACanvas: TCanvas; const ARect: TRect);
1	daniel-mar	1859	var
		1860	OldPalette: HPalette;
		1861	OldMode: Integer;
		1862	begin
4	daniel-mar	1863	if Size > 0 then
1	daniel-mar	1864	begin
4	daniel-mar	1865	if PaletteCount > 0 then
1	daniel-mar	1866	begin
		1867	OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
		1868	RealizePalette(ACanvas.Handle);
4	daniel-mar	1869	end
		1870	else
1	daniel-mar	1871	OldPalette := 0;
		1872	try
		1873	OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
		1874	try
		1875	GdiFlush;
		1876	if FImage.FMemoryImage then
		1877	begin
4	daniel-mar	1878	with ARect do
		1879	begin
		1880	if StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
		1881	0, 0, Self.Width, Self.Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS, ACanvas.CopyMode) = 0 then
		1882	MessageBeep(1);
		1883	end;
		1884	end
		1885	else
1	daniel-mar	1886	begin
4	daniel-mar	1887	with ARect do
1	daniel-mar	1888	StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
4	daniel-mar	1889	FImage.FDC, 0, 0, Self.Width, Self.Height, ACanvas.CopyMode);
1	daniel-mar	1890	end;
		1891	finally
		1892	SetStretchBltMode(ACanvas.Handle, OldMode);
		1893	end;
		1894	finally
		1895	SelectPalette(ACanvas.Handle, OldPalette, False);
		1896	end;
		1897	end;
		1898	end;
		1899
		1900	procedure TDIB.Clear;
		1901	begin
		1902	SetImage(EmptyDIBImage);
		1903	end;
		1904
		1905	procedure TDIB.CanvasChanging(Sender: TObject);
		1906	begin
		1907	Changing(False);
		1908	end;
		1909
		1910	procedure TDIB.Changing(MemoryImage: Boolean);
		1911	var
		1912	TempImage: TDIBSharedImage;
		1913	begin
4	daniel-mar	1914	if (FImage.RefCount > 1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
1	daniel-mar	1915	begin
		1916	TempImage := TDIBSharedImage.Create;
		1917	try
		1918	TempImage.Decompress(FImage, FImage.FMemoryImage and MemoryImage);
		1919	except
		1920	TempImage.Free;
		1921	raise;
		1922	end;
		1923	SetImage(TempImage);
		1924	end;
		1925	end;
		1926
		1927	procedure TDIB.AllocHandle;
		1928	var
		1929	TempImage: TDIBSharedImage;
		1930	begin
		1931	if FImage.FMemoryImage then
		1932	begin
		1933	TempImage := TDIBSharedImage.Create;
		1934	try
		1935	TempImage.Decompress(FImage, False);
		1936	except
		1937	TempImage.Free;
		1938	raise;
		1939	end;
		1940	SetImage(TempImage);
		1941	end;
		1942	end;
		1943
		1944	procedure TDIB.Compress;
		1945	var
		1946	TempImage: TDIBSharedImage;
		1947	begin
		1948	if (not FImage.FCompressed) and (BitCount in [4, 8]) then
		1949	begin
		1950	TempImage := TDIBSharedImage.Create;
		1951	try
		1952	TempImage.Compress(FImage);
		1953	except
		1954	TempImage.Free;
		1955	raise;
		1956	end;
		1957	SetImage(TempImage);
		1958	end;
		1959	end;
		1960
		1961	procedure TDIB.Decompress;
		1962	var
		1963	TempImage: TDIBSharedImage;
		1964	begin
		1965	if FImage.FCompressed then
		1966	begin
		1967	TempImage := TDIBSharedImage.Create;
		1968	try
		1969	TempImage.Decompress(FImage, FImage.FMemoryImage);
		1970	except
		1971	TempImage.Free;
		1972	raise;
		1973	end;
		1974	SetImage(TempImage);
		1975	end;
		1976	end;
		1977
		1978	procedure TDIB.FreeHandle;
		1979	var
		1980	TempImage: TDIBSharedImage;
		1981	begin
		1982	if not FImage.FMemoryImage then
		1983	begin
		1984	TempImage := TDIBSharedImage.Create;
		1985	try
		1986	TempImage.Duplicate(FImage, True);
		1987	except
		1988	TempImage.Free;
		1989	raise;
		1990	end;
		1991	SetImage(TempImage);
		1992	end;
		1993	end;
		1994
4	daniel-mar	1995	type
		1996	PRGBA = ^TRGBA;
		1997	TRGBA = array[0..0] of Windows.TRGBQuad;
		1998
		1999	function TDIB.HasAlphaChannel: Boolean;
		2000	{give that DIB contain the alphachannel}
		2001	var
		2002	p: PRGBA;
		2003	X, Y: Integer;
		2004	begin
		2005	Result := True;
		2006	if BitCount = 32 then
		2007	for Y := 0 to Height - 1 do
		2008	begin
		2009	p := ScanLine[Y];
		2010	for X := 0 to Width - 1 do
		2011	begin
		2012	if p[X].rgbReserved <> $0 then Exit;
		2013	end
		2014	end;
		2015	Result := False;
		2016	end;
		2017
		2018	function TDIB.AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
		2019	{copy alphachannel from other DIB or add from DIB8}
		2020	var
		2021	p32_0, p32_1: PRGBA;
		2022	p24: Pointer;
		2023	pB: PArrayByte;
		2024	X, Y: Integer;
		2025	tmpDIB, qAlpha: TDIB;
		2026	begin
		2027	Result := False;
		2028	if GetEmpty then Exit;
		2029	{Alphachannel can be copy into 32bit DIB only!}
		2030	if BitCount <> 32 then
		2031	begin
		2032	tmpDIB := TDIB.Create;
		2033	try
		2034	tmpDIB.Assign(Self);
		2035	Clear;
		2036	SetSize(tmpDIB.Width, tmpDIB.Height, 32);
		2037	Canvas.Draw(0, 0, tmpDIB);
		2038	finally
		2039	tmpDIB.Free;
		2040	end;
		2041	end;
		2042	qAlpha := TDIB.Create;
		2043	try
		2044	if not Assigned(Alpha) then Exit;
		2045	if ForceResize then
		2046	begin
		2047	{create temp}
		2048	tmpDIB := TDIB.Create;
		2049	try
		2050	{picture}
		2051	tmpDIB.Assign(ALPHA);
		2052	{resample size}
		2053	tmpDIB.DoResample(Width, Height, ftrBSpline);
		2054	{convert to greyscale}
		2055	tmpDIB.Greyscale(8);
		2056	{return picture to qAlpha}
		2057	qAlpha.Assign(tmpDIB);
		2058	finally
		2059	tmpDIB.Free;
		2060	end;
		2061	end
		2062	else
		2063	{Must be the same size!}
		2064	if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
		2065	else qAlpha.Assign(ALPHA);
		2066	{It works now with qAlpha only}
		2067	case qAlpha.BitCount of
		2068	24:
		2069	begin
		2070	for Y := 0 to Height - 1 do
		2071	begin
		2072	p32_0 := ScanLine[Y];
		2073	p24 := qAlpha.ScanLine[Y];
		2074	for X := 0 to Width - 1 do with PBGR(p24)^ do
		2075	begin
		2076	p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
		2077	end
		2078	end;
		2079	end;
		2080	32:
		2081	begin
		2082	for Y := 0 to Height - 1 do
		2083	begin
		2084	p32_0 := ScanLine[Y];
		2085	p32_1 := qAlpha.ScanLine[Y];
		2086	for X := 0 to Width - 1 do
		2087	begin
		2088	p32_0[X].rgbReserved := p32_1[X].rgbReserved;
		2089	end
		2090	end;
		2091	end;
		2092	8:
		2093	begin
		2094	for Y := 0 to Height - 1 do
		2095	begin
		2096	p32_0 := ScanLine[Y];
		2097	pB := qAlpha.ScanLine[Y];
		2098	for X := 0 to Width - 1 do
		2099	begin
		2100	p32_0[X].rgbReserved := pB[X];
		2101	end
		2102	end;
		2103	end;
		2104	1:
		2105	begin
		2106	for Y := 0 to Height - 1 do
		2107	begin
		2108	p32_0 := ScanLine[Y];
		2109	pB := qAlpha.ScanLine[Y];
		2110	for X := 0 to Width - 1 do
		2111	begin
		2112	if pB[X] = 0 then
		2113	p32_0[X].rgbReserved := $FF
		2114	else
		2115	p32_0[X].rgbReserved := 0
		2116	end
		2117	end;
		2118	end;
		2119	else
		2120	Exit;
		2121	end;
		2122	Result := True;
		2123	finally
		2124	qAlpha.Free;
		2125	end;
		2126	end;
		2127
		2128	procedure TDIB.RetAlphaChannel(out oDIB: TDIB);
		2129	{Store alphachannel information into DIB8}
		2130	var
		2131	p0: PRGBA;
		2132	pB: PArrayByte;
		2133	X, Y: Integer;
		2134	begin
		2135	oDIB := nil;
		2136	if not HasAlphaChannel then exit;
		2137	oDIB := TDIB.Create;
		2138	oDIB.SetSize(Width, Height, 8);
		2139	for Y := 0 to Height - 1 do
		2140	begin
		2141	p0 := ScanLine[Y];
		2142	pB := oDIB.ScanLine[Y];
		2143	for X := 0 to Width - 1 do
		2144	begin
		2145	pB[X] := p0[X].rgbReserved;
		2146	end
		2147	end;
		2148	end;
		2149
1	daniel-mar	2150	function TDIB.GetBitmapInfo: PBitmapInfo;
		2151	begin
		2152	Result := FImage.FBitmapInfo;
		2153	end;
		2154
		2155	function TDIB.GetBitmapInfoSize: Integer;
		2156	begin
		2157	Result := FImage.FBitmapInfoSize;
		2158	end;
		2159
		2160	function TDIB.GetCanvas: TCanvas;
		2161	begin
4	daniel-mar	2162	if (FCanvas = nil) or (FCanvas.Handle = 0) then
1	daniel-mar	2163	begin
		2164	AllocHandle;
		2165
		2166	FCanvas := TCanvas.Create;
		2167	FCanvas.Handle := FImage.FDC;
		2168	FCanvas.OnChanging := CanvasChanging;
		2169	end;
		2170	Result := FCanvas;
		2171	end;
		2172
		2173	function TDIB.GetEmpty: Boolean;
		2174	begin
4	daniel-mar	2175	Result := Size = 0;
1	daniel-mar	2176	end;
		2177
		2178	function TDIB.GetHandle: THandle;
		2179	begin
		2180	Changing(True);
		2181	Result := FImage.FHandle;
		2182	end;
		2183
		2184	function TDIB.GetHeight: Integer;
		2185	begin
		2186	Result := FHeight;
		2187	end;
		2188
		2189	function TDIB.GetPalette: HPalette;
		2190	begin
		2191	Result := FImage.GetPalette;
		2192	end;
		2193
		2194	function TDIB.GetPaletteCount: Integer;
		2195	begin
		2196	Result := FImage.FPaletteCount;
		2197	end;
		2198
		2199	function TDIB.GetPBits: Pointer;
		2200	begin
		2201	Changing(True);
		2202
		2203	if not FImage.FMemoryImage then
		2204	GDIFlush;
		2205	Result := FPBits;
		2206	end;
		2207
		2208	function TDIB.GetPBitsReadOnly: Pointer;
		2209	begin
		2210	if not FImage.FMemoryImage then
		2211	GDIFlush;
		2212	Result := FPBits;
		2213	end;
		2214
		2215	function TDIB.GetScanLine(Y: Integer): Pointer;
		2216	begin
		2217	Changing(True);
4	daniel-mar	2218	if (Y < 0) or (Y >= FHeight) then
1	daniel-mar	2219	raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
		2220
		2221	if not FImage.FMemoryImage then
		2222	GDIFlush;
4	daniel-mar	2223	Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
1	daniel-mar	2224	end;
		2225
		2226	function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
		2227	begin
4	daniel-mar	2228	if (Y < 0) or (Y >= FHeight) then
1	daniel-mar	2229	raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
		2230
		2231	if not FImage.FMemoryImage then
		2232	GDIFlush;
4	daniel-mar	2233	Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
1	daniel-mar	2234	end;
		2235
		2236	function TDIB.GetTopPBits: Pointer;
		2237	begin
		2238	Changing(True);
		2239
		2240	if not FImage.FMemoryImage then
		2241	GDIFlush;
		2242	Result := FTopPBits;
		2243	end;
		2244
		2245	function TDIB.GetTopPBitsReadOnly: Pointer;
		2246	begin
		2247	if not FImage.FMemoryImage then
		2248	GDIFlush;
		2249	Result := FTopPBits;
4	daniel-mar	2250	end;
1	daniel-mar	2251
		2252	function TDIB.GetWidth: Integer;
		2253	begin
		2254	Result := FWidth;
		2255	end;
		2256
		2257	const
		2258	Mask1: array[0..7] of DWORD = ($80, $40, $20, $10, $08, $04, $02, $01);
		2259	Mask1n: array[0..7] of DWORD = ($FFFFFF7F, $FFFFFFBF, $FFFFFFDF, $FFFFFFEF,
		2260	$FFFFFFF7, $FFFFFFFB, $FFFFFFFD, $FFFFFFFE);
		2261	Mask4: array[0..1] of DWORD = ($F0, $0F);
		2262	Mask4n: array[0..1] of DWORD = ($FFFFFF0F, $FFFFFFF0);
		2263
		2264	Shift1: array[0..7] of DWORD = (7, 6, 5, 4, 3, 2, 1, 0);
		2265	Shift4: array[0..1] of DWORD = (4, 0);
		2266
		2267	function TDIB.GetPixel(X, Y: Integer): DWORD;
		2268	begin
		2269	Decompress;
		2270
		2271	Result := 0;
4	daniel-mar	2272	if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
1	daniel-mar	2273	begin
		2274	case FBitCount of
4	daniel-mar	2275	1: Result := (PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
		2276	4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
		2277	8: Result := PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X];
		2278	16: Result := PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X];
		2279	24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
		2280	Result := R or (G shl 8) or (B shl 16);
		2281	32: Result := PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X];
1	daniel-mar	2282	end;
		2283	end;
		2284	end;
		2285
4	daniel-mar	2286	function TDIB.GetRGBChannel: TDIB;
		2287	{Store RGB channel information into DIB24}
		2288	begin
		2289	Result := nil;
		2290	if Self.Empty then Exit;
		2291	Result := TDIB.Create;
		2292	Result.SetSize(Width, Height, 24);
		2293	Self.DrawOn(Bounds(0,0, Self.Width, Self.Height), Result.Canvas, 0, 0);
		2294	FFreeList.Add(Result);
		2295	end;
		2296
1	daniel-mar	2297	procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
		2298	var
		2299	P: PByte;
		2300	begin
		2301	Changing(True);
		2302
4	daniel-mar	2303	if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
1	daniel-mar	2304	begin
		2305	case FBitCount of
4	daniel-mar	2306	1: begin
		2307	P := @PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3];
		2308	P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
		2309	end;
		2310	4: begin
		2311	P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
		2312	P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
		2313	end;
		2314	8: PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
		2315	16: PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
		2316	24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
		2317	begin
		2318	B := Byte(Value shr 16);
		2319	G := Byte(Value shr 8);
		2320	R := Byte(Value);
		2321	end;
		2322	32: PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
1	daniel-mar	2323	end;
		2324	end;
		2325	end;
4	daniel-mar	2326
		2327	procedure TDIB.SetRGBChannel(const Value: TDIB);
		2328	var
		2329	alpha: TDIB;
		2330	begin
		2331	if Self.HasAlphaChannel then
		2332	try
		2333	RetAlphaChannel(alpha);
		2334	Self.SetSize(Value.Width, Value.Height, 32);
		2335	Value.DrawOn(Bounds(0,0,Value.Width, Value.Height), Self.Canvas, 0, 0);
		2336	Self.AssignAlphaChannel(alpha, True);
		2337	finally
		2338	alpha.Free;
		2339	end
		2340	else
		2341	Self.Assign(Value);
		2342	end;
		2343
1	daniel-mar	2344	procedure TDIB.DefineProperties(Filer: TFiler);
		2345	begin
		2346	inherited DefineProperties(Filer);
		2347	{ For interchangeability with an old version. }
		2348	Filer.DefineBinaryProperty('DIB', LoadFromStream, nil, False);
		2349	end;
		2350
		2351	type
4	daniel-mar	2352	{ TGlobalMemoryStream }
		2353
1	daniel-mar	2354	TGlobalMemoryStream = class(TMemoryStream)
		2355	private
		2356	FHandle: THandle;
		2357	public
		2358	constructor Create(AHandle: THandle);
		2359	destructor Destroy; override;
		2360	end;
		2361
		2362	constructor TGlobalMemoryStream.Create(AHandle: THandle);
		2363	begin
		2364	inherited Create;
		2365	FHandle := AHandle;
		2366	SetPointer(GlobalLock(AHandle), GlobalSize(AHandle));
		2367	end;
		2368
		2369	destructor TGlobalMemoryStream.Destroy;
		2370	begin
		2371	GlobalUnLock(FHandle);
		2372	SetPointer(nil, 0);
		2373	inherited Destroy;
		2374	end;
		2375
		2376	procedure TDIB.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
		2377	APalette: HPALETTE);
		2378	var
		2379	Stream: TGlobalMemoryStream;
		2380	begin
		2381	Stream := TGlobalMemoryStream.Create(AData);
		2382	try
		2383	ReadData(Stream);
		2384	finally
		2385	Stream.Free;
		2386	end;
		2387	end;
		2388
		2389	const
4	daniel-mar	2390	BitmapFileType = Ord('B') + Ord('M') * $100;
1	daniel-mar	2391
		2392	procedure TDIB.LoadFromStream(Stream: TStream);
		2393	var
		2394	BF: TBitmapFileHeader;
		2395	i: Integer;
4	daniel-mar	2396	ImageJPEG: TJPEGImage;
1	daniel-mar	2397	begin
		2398	{ File header reading }
		2399	i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
4	daniel-mar	2400	if i = 0 then Exit;
		2401	if i <> SizeOf(TBitmapFileHeader) then
1	daniel-mar	2402	raise EInvalidGraphic.Create(SInvalidDIB);
		2403
4	daniel-mar	2404	{ Is the head jpeg ?}
		2405
		2406	if BF.bfType = $D8FF then
		2407	begin
		2408	ImageJPEG := TJPEGImage.Create;
		2409	try
		2410	try
		2411	Stream.Position := 0;
		2412	ImageJPEG.LoadFromStream(Stream);
		2413	except
		2414	on EInvalidGraphic do ImageJPEG := nil;
		2415	end;
		2416	if ImageJPEG <> nil then
		2417	begin
		2418	{set size and bitcount in natural units of jpeg}
		2419	SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
		2420	Canvas.Draw(0, 0, ImageJPEG);
		2421	Exit
		2422	end;
		2423	finally
		2424	ImageJPEG.Free;
		2425	end;
		2426	end
		2427	else
1	daniel-mar	2428	{ Is the head 'BM'? }
4	daniel-mar	2429	if BF.bfType <> BitmapFileType then
		2430	raise EInvalidGraphic.Create(SInvalidDIB);
1	daniel-mar	2431
		2432	ReadData(Stream);
		2433	end;
		2434
		2435	procedure TDIB.ReadData(Stream: TStream);
		2436	var
		2437	TempImage: TDIBSharedImage;
		2438	begin
		2439	TempImage := TDIBSharedImage.Create;
		2440	try
		2441	TempImage.ReadData(Stream, FImage.FMemoryImage);
		2442	except
		2443	TempImage.Free;
		2444	raise;
		2445	end;
		2446	SetImage(TempImage);
		2447	end;
		2448
		2449	procedure TDIB.SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
		2450	var APalette: HPALETTE);
		2451	var
		2452	P: Pointer;
		2453	Stream: TMemoryStream;
		2454	begin
		2455	AFormat := CF_DIB;
		2456	APalette := 0;
		2457
		2458	Stream := TMemoryStream.Create;
		2459	try
		2460	WriteData(Stream);
		2461
		2462	AData := GlobalAlloc(GHND, Stream.Size);
4	daniel-mar	2463	if AData = 0 then OutOfMemoryError;
1	daniel-mar	2464
		2465	P := GlobalLock(AData);
		2466	Move(Stream.Memory^, P^, Stream.Size);
		2467	GlobalUnLock(AData);
		2468	finally
		2469	Stream.Free;
		2470	end;
		2471	end;
		2472
		2473	procedure TDIB.SaveToStream(Stream: TStream);
		2474	var
		2475	BF: TBitmapFileHeader;
		2476	begin
		2477	if Empty then Exit;
		2478
		2479	with BF do
		2480	begin
4	daniel-mar	2481	bfType := BitmapFileType;
		2482	bfOffBits := SizeOf(TBitmapFileHeader) + BitmapInfoSize;
		2483	bfSize := bfOffBits + FImage.FBitmapInfo^.bmiHeader.biSizeImage;
1	daniel-mar	2484	bfReserved1 := 0;
		2485	bfReserved2 := 0;
		2486	end;
		2487	Stream.WriteBuffer(BF, SizeOf(TBitmapFileHeader));
		2488
		2489	WriteData(Stream);
		2490	end;
		2491
		2492	procedure TDIB.WriteData(Stream: TStream);
		2493	begin
		2494	if Empty then Exit;
		2495
		2496	if not FImage.FMemoryImage then
		2497	GDIFlush;
		2498
		2499	Stream.WriteBuffer(FImage.FBitmapInfo^, FImage.FBitmapInfoSize);
		2500	Stream.WriteBuffer(FImage.FPBits^, FImage.FBitmapInfo.bmiHeader.biSizeImage);
		2501	end;
		2502
		2503	procedure TDIB.SetBitCount(Value: Integer);
		2504	begin
4	daniel-mar	2505	if Value <= 0 then
1	daniel-mar	2506	Clear
		2507	else
		2508	begin
		2509	if Empty then
		2510	begin
		2511	SetSize(Max(Width, 1), Max(Height, 1), Value)
4	daniel-mar	2512	end
		2513	else
1	daniel-mar	2514	begin
		2515	ConvertBitCount(Value);
		2516	end;
		2517	end;
		2518	end;
		2519
		2520	procedure TDIB.SetHeight(Value: Integer);
		2521	begin
4	daniel-mar	2522	if Value <= 0 then
1	daniel-mar	2523	Clear
		2524	else
		2525	begin
		2526	if Empty then
		2527	SetSize(Max(Width, 1), Value, 8)
		2528	else
		2529	SetSize(Width, Value, BitCount);
		2530	end;
		2531	end;
		2532
		2533	procedure TDIB.SetWidth(Value: Integer);
		2534	begin
4	daniel-mar	2535	if Value <= 0 then
1	daniel-mar	2536	Clear
		2537	else
		2538	begin
		2539	if Empty then
		2540	SetSize(Value, Max(Height, 1), 8)
		2541	else
		2542	SetSize(Value, Height, BitCount);
		2543	end;
		2544	end;
		2545
		2546	procedure TDIB.SetImage(Value: TDIBSharedImage);
		2547	begin
4	daniel-mar	2548	if FImage <> Value then
1	daniel-mar	2549	begin
4	daniel-mar	2550	if FCanvas <> nil then
1	daniel-mar	2551	FCanvas.Handle := 0;
4	daniel-mar	2552
1	daniel-mar	2553	FImage.Release;
		2554	FImage := Value;
		2555	FImage.Reference;
		2556
4	daniel-mar	2557	if FCanvas <> nil then
1	daniel-mar	2558	FCanvas.Handle := FImage.FDC;
		2559
		2560	ColorTable := FImage.FColorTable;
		2561	PixelFormat := FImage.FPixelFormat;
		2562
		2563	FBitCount := FImage.FBitCount;
		2564	FHeight := FImage.FHeight;
		2565	FNextLine := FImage.FNextLine;
		2566	FNowPixelFormat := FImage.FPixelFormat;
		2567	FPBits := FImage.FPBits;
		2568	FSize := FImage.FSize;
		2569	FTopPBits := FImage.FTopPBits;
		2570	FWidth := FImage.FWidth;
		2571	FWidthBytes := FImage.FWidthBytes;
		2572	end;
		2573	end;
		2574
		2575	procedure TDIB.SetNowPixelFormat(const Value: TDIBPixelFormat);
		2576	var
		2577	Temp: TDIB;
		2578	begin
		2579	if CompareMem(@Value, @FImage.FPixelFormat, SizeOf(TDIBPixelFormat)) then exit;
		2580
		2581	PixelFormat := Value;
		2582
		2583	Temp := TDIB.Create;
		2584	try
		2585	Temp.Assign(Self);
		2586	SetSize(Width, Height, BitCount);
		2587	Canvas.Draw(0, 0, Temp);
		2588	finally
		2589	Temp.Free;
		2590	end;
		2591	end;
		2592
		2593	procedure TDIB.SetPalette(Value: HPalette);
		2594	var
		2595	PaletteEntries: TPaletteEntries;
		2596	begin
		2597	GetPaletteEntries(Value, 0, 256, PaletteEntries);
		2598	DeleteObject(Value);
		2599
		2600	ColorTable := PaletteEntriesToRGBQuads(PaletteEntries);
		2601	UpdatePalette;
		2602	end;
		2603
		2604	procedure TDIB.SetSize(AWidth, AHeight, ABitCount: Integer);
		2605	var
		2606	TempImage: TDIBSharedImage;
		2607	begin
4	daniel-mar	2608	if (AWidth = Width) and (AHeight = Height) and (ABitCount = BitCount) and
		2609	(NowPixelFormat.RBitMask = PixelFormat.RBitMask) and
		2610	(NowPixelFormat.GBitMask = PixelFormat.GBitMask) and
		2611	(NowPixelFormat.BBitMask = PixelFormat.BBitMask) then Exit;
1	daniel-mar	2612
4	daniel-mar	2613	if (AWidth <= 0) or (AHeight <= 0) then
1	daniel-mar	2614	begin
		2615	Clear;
		2616	Exit;
		2617	end;
		2618
		2619	TempImage := TDIBSharedImage.Create;
		2620	try
		2621	TempImage.NewImage(AWidth, AHeight, ABitCount,
		2622	PixelFormat, ColorTable, FImage.FMemoryImage, False);
		2623	except
		2624	TempImage.Free;
		2625	raise;
		2626	end;
		2627	SetImage(TempImage);
		2628
		2629	PaletteModified := True;
		2630	end;
		2631
		2632	procedure TDIB.UpdatePalette;
		2633	var
		2634	Col: TRGBQuads;
		2635	begin
		2636	if CompareMem(@ColorTable, @FImage.FColorTable, SizeOf(ColorTable)) then Exit;
		2637
		2638	Col := ColorTable;
		2639	Changing(True);
		2640	ColorTable := Col;
		2641	FImage.SetColorTable(ColorTable);
		2642
		2643	PaletteModified := True;
		2644	end;
		2645
		2646	procedure TDIB.ConvertBitCount(ABitCount: Integer);
		2647	var
		2648	Temp: TDIB;
		2649
		2650	procedure CreateHalftonePalette(R, G, B: Integer);
		2651	var
		2652	i: Integer;
		2653	begin
4	daniel-mar	2654	for i := 0 to 255 do
1	daniel-mar	2655	with ColorTable[i] do
		2656	begin
4	daniel-mar	2657	rgbRed := ((i shr (G + B - 1)) and (1 shl R - 1)) * 255 div (1 shl R - 1);
		2658	rgbGreen := ((i shr (B - 1)) and (1 shl G - 1)) * 255 div (1 shl G - 1);
		2659	rgbBlue := ((i shr 0) and (1 shl B - 1)) * 255 div (1 shl B - 1);
1	daniel-mar	2660	end;
		2661	end;
		2662
		2663	procedure PaletteToPalette_Inc;
		2664	var
		2665	x, y: Integer;
		2666	i: DWORD;
		2667	SrcP, DestP: Pointer;
		2668	P: PByte;
		2669	begin
		2670	i := 0;
		2671
4	daniel-mar	2672	for y := 0 to Height - 1 do
1	daniel-mar	2673	begin
		2674	SrcP := Temp.ScanLine[y];
		2675	DestP := ScanLine[y];
		2676
4	daniel-mar	2677	for x := 0 to Width - 1 do
1	daniel-mar	2678	begin
		2679	case Temp.BitCount of
4	daniel-mar	2680	1:
		2681	begin
		2682	i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
		2683	end;
		2684	4:
		2685	begin
		2686	i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
		2687	end;
		2688	8:
		2689	begin
		2690	i := PByte(SrcP)^;
		2691	Inc(PByte(SrcP));
		2692	end;
1	daniel-mar	2693	end;
		2694
		2695	case BitCount of
4	daniel-mar	2696	1:
		2697	begin
		2698	P := @PArrayByte(DestP)[X shr 3];
		2699	P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
		2700	end;
		2701	4:
		2702	begin
		2703	P := @PArrayByte(DestP)[X shr 1];
		2704	P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
		2705	end;
		2706	8:
		2707	begin
		2708	PByte(DestP)^ := i;
		2709	Inc(PByte(DestP));
		2710	end;
1	daniel-mar	2711	end;
		2712	end;
		2713	end;
		2714	end;
		2715
		2716	procedure PaletteToRGB_or_RGBToRGB;
		2717	var
		2718	x, y: Integer;
		2719	SrcP, DestP: Pointer;
		2720	cR, cG, cB: Byte;
		2721	begin
		2722	cR := 0;
		2723	cG := 0;
		2724	cB := 0;
		2725
4	daniel-mar	2726	for y := 0 to Height - 1 do
1	daniel-mar	2727	begin
		2728	SrcP := Temp.ScanLine[y];
		2729	DestP := ScanLine[y];
		2730
4	daniel-mar	2731	for x := 0 to Width - 1 do
1	daniel-mar	2732	begin
		2733	case Temp.BitCount of
4	daniel-mar	2734	1:
		2735	begin
		2736	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
		2737	begin
		2738	cR := rgbRed;
		2739	cG := rgbGreen;
		2740	cB := rgbBlue;
1	daniel-mar	2741	end;
4	daniel-mar	2742	end;
		2743	4:
		2744	begin
		2745	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
		2746	begin
		2747	cR := rgbRed;
		2748	cG := rgbGreen;
		2749	cB := rgbBlue;
1	daniel-mar	2750	end;
4	daniel-mar	2751	end;
		2752	8:
		2753	begin
		2754	with Temp.ColorTable[PByte(SrcP)^] do
		2755	begin
		2756	cR := rgbRed;
		2757	cG := rgbGreen;
		2758	cB := rgbBlue;
1	daniel-mar	2759	end;
4	daniel-mar	2760	Inc(PByte(SrcP));
		2761	end;
		2762	16:
		2763	begin
		2764	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
		2765	Inc(PWord(SrcP));
		2766	end;
		2767	24:
		2768	begin
		2769	with PBGR(SrcP)^ do
		2770	begin
		2771	cR := R;
		2772	cG := G;
		2773	cB := B;
1	daniel-mar	2774	end;
		2775
4	daniel-mar	2776	Inc(PBGR(SrcP));
		2777	end;
		2778	32:
		2779	begin
		2780	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
		2781	Inc(PDWORD(SrcP));
		2782	end;
1	daniel-mar	2783	end;
		2784
		2785	case BitCount of
4	daniel-mar	2786	16:
		2787	begin
		2788	PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
		2789	Inc(PWord(DestP));
		2790	end;
		2791	24:
		2792	begin
		2793	with PBGR(DestP)^ do
		2794	begin
		2795	R := cR;
		2796	G := cG;
		2797	B := cB;
1	daniel-mar	2798	end;
4	daniel-mar	2799	Inc(PBGR(DestP));
		2800	end;
		2801	32:
		2802	begin
		2803	PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
		2804	Inc(PDWORD(DestP));
		2805	end;
1	daniel-mar	2806	end;
		2807	end;
		2808	end;
		2809	end;
		2810
		2811	begin
4	daniel-mar	2812	if Size = 0 then exit;
1	daniel-mar	2813
		2814	Temp := TDIB.Create;
		2815	try
		2816	Temp.Assign(Self);
		2817	SetSize(Temp.Width, Temp.Height, ABitCount);
		2818
4	daniel-mar	2819	if FImage = Temp.FImage then Exit;
1	daniel-mar	2820
4	daniel-mar	2821	if (Temp.BitCount <= 8) and (BitCount <= 8) then
1	daniel-mar	2822	begin
		2823	{ The image is converted from the palette color image into the palette color image. }
4	daniel-mar	2824	if Temp.BitCount <= BitCount then
1	daniel-mar	2825	begin
		2826	PaletteToPalette_Inc;
4	daniel-mar	2827	end
		2828	else
1	daniel-mar	2829	begin
		2830	case BitCount of
		2831	1: begin
4	daniel-mar	2832	ColorTable[0] := RGBQuad(0, 0, 0);
		2833	ColorTable[1] := RGBQuad(255, 255, 255);
		2834	end;
1	daniel-mar	2835	4: CreateHalftonePalette(1, 2, 1);
		2836	8: CreateHalftonePalette(3, 3, 2);
		2837	end;
		2838	UpdatePalette;
		2839
		2840	Canvas.Draw(0, 0, Temp);
		2841	end;
4	daniel-mar	2842	end
		2843	else
		2844	if (Temp.BitCount <= 8) and (BitCount > 8) then
		2845	begin
		2846	{ The image is converted from the palette color image into the rgb color image. }
		2847	PaletteToRGB_or_RGBToRGB;
		2848	end
		2849	else
		2850	if (Temp.BitCount > 8) and (BitCount <= 8) then
		2851	begin
		2852	{ The image is converted from the rgb color image into the palette color image. }
		2853	case BitCount of
		2854	1: begin
		2855	ColorTable[0] := RGBQuad(0, 0, 0);
		2856	ColorTable[1] := RGBQuad(255, 255, 255);
		2857	end;
		2858	4: CreateHalftonePalette(1, 2, 1);
		2859	8: CreateHalftonePalette(3, 3, 2);
		2860	end;
		2861	UpdatePalette;
1	daniel-mar	2862
4	daniel-mar	2863	Canvas.Draw(0, 0, Temp);
		2864	end
		2865	else
		2866	if (Temp.BitCount > 8) and (BitCount > 8) then
		2867	begin
		2868	{ The image is converted from the rgb color image into the rgb color image. }
		2869	PaletteToRGB_or_RGBToRGB;
		2870	end;
1	daniel-mar	2871	finally
		2872	Temp.Free;
		2873	end;
		2874	end;
		2875
		2876	{ Special effect }
		2877
		2878	procedure TDIB.StartProgress(const Name: string);
		2879	begin
		2880	FProgressName := Name;
		2881	FProgressOld := 0;
		2882	FProgressOldTime := GetTickCount;
		2883	FProgressY := 0;
		2884	FProgressOldY := 0;
		2885	Progress(Self, psStarting, 0, False, Rect(0, 0, Width, Height), FProgressName);
		2886	end;
		2887
		2888	procedure TDIB.EndProgress;
		2889	begin
		2890	Progress(Self, psEnding, 100, True, Rect(0, FProgressOldY, Width, Height), FProgressName);
		2891	end;
		2892
		2893	procedure TDIB.UpdateProgress(PercentY: Integer);
		2894	var
		2895	Redraw: Boolean;
		2896	Percent: DWORD;
		2897	begin
4	daniel-mar	2898	Redraw := (GetTickCount - FProgressOldTime > 200) and (FProgressY - FProgressOldY > 32) and
		2899	(((Height div 3 > Integer(FProgressY)) and (FProgressOldY = 0)) or (FProgressOldY <> 0));
1	daniel-mar	2900
4	daniel-mar	2901	Percent := PercentY * 100 div Height;
1	daniel-mar	2902
4	daniel-mar	2903	if (Percent <> FProgressOld) or (Redraw) then
1	daniel-mar	2904	begin
		2905	Progress(Self, psRunning, Percent, Redraw,
		2906	Rect(0, FProgressOldY, Width, FProgressY), FProgressName);
		2907	if Redraw then
		2908	begin
		2909	FProgressOldY := FProgressY;
		2910	FProgressOldTime := GetTickCount;
		2911	end;
		2912
		2913	FProgressOld := Percent;
		2914	end;
		2915
		2916	Inc(FProgressY);
		2917	end;
		2918
4	daniel-mar	2919	procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
		2920	var
		2921	x, y, Width2, c: Integer;
		2922	P1, P2, TempBuf: Pointer;
		2923	begin
		2924	if Empty then Exit;
		2925	if (not MirrorX) and (not MirrorY) then Exit;
		2926
		2927	if (not MirrorX) and (MirrorY) then
		2928	begin
		2929	GetMem(TempBuf, WidthBytes);
		2930	try
		2931	StartProgress('Mirror');
		2932	try
		2933	for y := 0 to Height shr 1 - 1 do
		2934	begin
		2935	P1 := ScanLine[y];
		2936	P2 := ScanLine[Height - y - 1];
		2937
		2938	Move(P1^, TempBuf^, WidthBytes);
		2939	Move(P2^, P1^, WidthBytes);
		2940	Move(TempBuf^, P2^, WidthBytes);
		2941
		2942	UpdateProgress(y * 2);
		2943	end;
		2944	finally
		2945	EndProgress;
		2946	end;
		2947	finally
		2948	FreeMem(TempBuf, WidthBytes);
		2949	end;
		2950	end
		2951	else
		2952	if (MirrorX) and (not MirrorY) then
		2953	begin
		2954	Width2 := Width shr 1;
		2955
		2956	StartProgress('Mirror');
		2957	try
		2958	for y := 0 to Height - 1 do
		2959	begin
		2960	P1 := ScanLine[y];
		2961
		2962	case BitCount of
		2963	1:
		2964	begin
		2965	for x := 0 to Width2 - 1 do
		2966	begin
		2967	c := Pixels[x, y];
		2968	Pixels[x, y] := Pixels[Width - x - 1, y];
		2969	Pixels[Width - x - 1, y] := c;
		2970	end;
		2971	end;
		2972	4:
		2973	begin
		2974	for x := 0 to Width2 - 1 do
		2975	begin
		2976	c := Pixels[x, y];
		2977	Pixels[x, y] := Pixels[Width - x - 1, y];
		2978	Pixels[Width - x - 1, y] := c;
		2979	end;
		2980	end;
		2981	8:
		2982	begin
		2983	P2 := Pointer(Integer(P1) + Width - 1);
		2984	for x := 0 to Width2 - 1 do
		2985	begin
		2986	PByte(@c)^ := PByte(P1)^;
		2987	PByte(P1)^ := PByte(P2)^;
		2988	PByte(P2)^ := PByte(@c)^;
		2989	Inc(PByte(P1));
		2990	Dec(PByte(P2));
		2991	end;
		2992	end;
		2993	16:
		2994	begin
		2995	P2 := Pointer(Integer(P1) + (Width - 1) * 2);
		2996	for x := 0 to Width2 - 1 do
		2997	begin
		2998	PWord(@c)^ := PWord(P1)^;
		2999	PWord(P1)^ := PWord(P2)^;
		3000	PWord(P2)^ := PWord(@c)^;
		3001	Inc(PWord(P1));
		3002	Dec(PWord(P2));
		3003	end;
		3004	end;
		3005	24:
		3006	begin
		3007	P2 := Pointer(Integer(P1) + (Width - 1) * 3);
		3008	for x := 0 to Width2 - 1 do
		3009	begin
		3010	PBGR(@c)^ := PBGR(P1)^;
		3011	PBGR(P1)^ := PBGR(P2)^;
		3012	PBGR(P2)^ := PBGR(@c)^;
		3013	Inc(PBGR(P1));
		3014	Dec(PBGR(P2));
		3015	end;
		3016	end;
		3017	32:
		3018	begin
		3019	P2 := Pointer(Integer(P1) + (Width - 1) * 4);
		3020	for x := 0 to Width2 - 1 do
		3021	begin
		3022	PDWORD(@c)^ := PDWORD(P1)^;
		3023	PDWORD(P1)^ := PDWORD(P2)^;
		3024	PDWORD(P2)^ := PDWORD(@c)^;
		3025	Inc(PDWORD(P1));
		3026	Dec(PDWORD(P2));
		3027	end;
		3028	end;
		3029	end;
		3030
		3031	UpdateProgress(y);
		3032	end;
		3033	finally
		3034	EndProgress;
		3035	end;
		3036	end
		3037	else
		3038	if (MirrorX) and (MirrorY) then
		3039	begin
		3040	StartProgress('Mirror');
		3041	try
		3042	for y := 0 to Height shr 1 - 1 do
		3043	begin
		3044	P1 := ScanLine[y];
		3045	P2 := ScanLine[Height - y - 1];
		3046
		3047	case BitCount of
		3048	1:
		3049	begin
		3050	for x := 0 to Width - 1 do
		3051	begin
		3052	c := Pixels[x, y];
		3053	Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
		3054	Pixels[Width - x - 1, Height - y - 1] := c;
		3055	end;
		3056	end;
		3057	4:
		3058	begin
		3059	for x := 0 to Width - 1 do
		3060	begin
		3061	c := Pixels[x, y];
		3062	Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
		3063	Pixels[Width - x - 1, Height - y - 1] := c;
		3064	end;
		3065	end;
		3066	8:
		3067	begin
		3068	P2 := Pointer(Integer(P2) + Width - 1);
		3069	for x := 0 to Width - 1 do
		3070	begin
		3071	PByte(@c)^ := PByte(P1)^;
		3072	PByte(P1)^ := PByte(P2)^;
		3073	PByte(P2)^ := PByte(@c)^;
		3074	Inc(PByte(P1));
		3075	Dec(PByte(P2));
		3076	end;
		3077	end;
		3078	16:
		3079	begin
		3080	P2 := Pointer(Integer(P2) + (Width - 1) * 2);
		3081	for x := 0 to Width - 1 do
		3082	begin
		3083	PWord(@c)^ := PWord(P1)^;
		3084	PWord(P1)^ := PWord(P2)^;
		3085	PWord(P2)^ := PWord(@c)^;
		3086	Inc(PWord(P1));
		3087	Dec(PWord(P2));
		3088	end;
		3089	end;
		3090	24:
		3091	begin
		3092	P2 := Pointer(Integer(P2) + (Width - 1) * 3);
		3093	for x := 0 to Width - 1 do
		3094	begin
		3095	PBGR(@c)^ := PBGR(P1)^;
		3096	PBGR(P1)^ := PBGR(P2)^;
		3097	PBGR(P2)^ := PBGR(@c)^;
		3098	Inc(PBGR(P1));
		3099	Dec(PBGR(P2));
		3100	end;
		3101	end;
		3102	32:
		3103	begin
		3104	P2 := Pointer(Integer(P2) + (Width - 1) * 4);
		3105	for x := 0 to Width - 1 do
		3106	begin
		3107	PDWORD(@c)^ := PDWORD(P1)^;
		3108	PDWORD(P1)^ := PDWORD(P2)^;
		3109	PDWORD(P2)^ := PDWORD(@c)^;
		3110	Inc(PDWORD(P1));
		3111	Dec(PDWORD(P2));
		3112	end;
		3113	end;
		3114	end;
		3115
		3116	UpdateProgress(y * 2);
		3117	end;
		3118	finally
		3119	EndProgress;
		3120	end;
		3121	end;
		3122	end;
		3123
1	daniel-mar	3124	procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
		3125	type
		3126	TAve = record
		3127	cR, cG, cB: DWORD;
		3128	c: DWORD;
		3129	end;
		3130	TArrayAve = array[0..0] of TAve;
		3131
		3132	var
		3133	Temp: TDIB;
		3134
		3135	procedure AddAverage(Y, XCount: Integer; var Ave: TArrayAve);
		3136	var
		3137	X: Integer;
		3138	SrcP: Pointer;
		3139	AveP: ^TAve;
		3140	R, G, B: Byte;
		3141	begin
		3142	case Temp.BitCount of
4	daniel-mar	3143	1:
		3144	begin
		3145	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3146	AveP := @Ave;
		3147	for x := 0 to XCount - 1 do
		3148	begin
		3149	with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
1	daniel-mar	3150	begin
4	daniel-mar	3151	Inc(cR, rgbRed);
		3152	Inc(cG, rgbGreen);
		3153	Inc(cB, rgbBlue);
		3154	Inc(c);
1	daniel-mar	3155	end;
4	daniel-mar	3156	Inc(AveP);
1	daniel-mar	3157	end;
4	daniel-mar	3158	end;
		3159	4:
		3160	begin
		3161	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3162	AveP := @Ave;
		3163	for x := 0 to XCount - 1 do
		3164	begin
		3165	with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
1	daniel-mar	3166	begin
4	daniel-mar	3167	Inc(cR, rgbRed);
		3168	Inc(cG, rgbGreen);
		3169	Inc(cB, rgbBlue);
		3170	Inc(c);
1	daniel-mar	3171	end;
4	daniel-mar	3172	Inc(AveP);
1	daniel-mar	3173	end;
4	daniel-mar	3174	end;
		3175	8:
		3176	begin
		3177	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3178	AveP := @Ave;
		3179	for x := 0 to XCount - 1 do
		3180	begin
		3181	with Temp.ColorTable[PByte(SrcP)^], AveP^ do
1	daniel-mar	3182	begin
4	daniel-mar	3183	Inc(cR, rgbRed);
		3184	Inc(cG, rgbGreen);
		3185	Inc(cB, rgbBlue);
		3186	Inc(c);
1	daniel-mar	3187	end;
4	daniel-mar	3188	Inc(PByte(SrcP));
		3189	Inc(AveP);
1	daniel-mar	3190	end;
4	daniel-mar	3191	end;
		3192	16:
		3193	begin
		3194	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3195	AveP := @Ave;
		3196	for x := 0 to XCount - 1 do
		3197	begin
		3198	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		3199	with AveP^ do
1	daniel-mar	3200	begin
4	daniel-mar	3201	Inc(cR, R);
		3202	Inc(cG, G);
		3203	Inc(cB, B);
		3204	Inc(c);
1	daniel-mar	3205	end;
4	daniel-mar	3206	Inc(PWord(SrcP));
		3207	Inc(AveP);
1	daniel-mar	3208	end;
4	daniel-mar	3209	end;
		3210	24:
		3211	begin
		3212	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3213	AveP := @Ave;
		3214	for x := 0 to XCount - 1 do
		3215	begin
		3216	with PBGR(SrcP)^, AveP^ do
1	daniel-mar	3217	begin
4	daniel-mar	3218	Inc(cR, R);
		3219	Inc(cG, G);
		3220	Inc(cB, B);
		3221	Inc(c);
1	daniel-mar	3222	end;
4	daniel-mar	3223	Inc(PBGR(SrcP));
		3224	Inc(AveP);
1	daniel-mar	3225	end;
4	daniel-mar	3226	end;
		3227	32:
		3228	begin
		3229	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3230	AveP := @Ave;
		3231	for x := 0 to XCount - 1 do
		3232	begin
		3233	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		3234	with AveP^ do
1	daniel-mar	3235	begin
4	daniel-mar	3236	Inc(cR, R);
		3237	Inc(cG, G);
		3238	Inc(cB, B);
		3239	Inc(c);
1	daniel-mar	3240	end;
4	daniel-mar	3241	Inc(PDWORD(SrcP));
		3242	Inc(AveP);
1	daniel-mar	3243	end;
4	daniel-mar	3244	end;
1	daniel-mar	3245	end;
		3246	end;
		3247
		3248	procedure DeleteAverage(Y, XCount: Integer; var Ave: TArrayAve);
		3249	var
		3250	X: Integer;
		3251	SrcP: Pointer;
		3252	AveP: ^TAve;
		3253	R, G, B: Byte;
		3254	begin
		3255	case Temp.BitCount of
4	daniel-mar	3256	1:
		3257	begin
		3258	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3259	AveP := @Ave;
		3260	for x := 0 to XCount - 1 do
		3261	begin
		3262	with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
1	daniel-mar	3263	begin
4	daniel-mar	3264	Dec(cR, rgbRed);
		3265	Dec(cG, rgbGreen);
		3266	Dec(cB, rgbBlue);
		3267	Dec(c);
1	daniel-mar	3268	end;
4	daniel-mar	3269	Inc(AveP);
1	daniel-mar	3270	end;
4	daniel-mar	3271	end;
		3272	4:
		3273	begin
		3274	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3275	AveP := @Ave;
		3276	for x := 0 to XCount - 1 do
		3277	begin
		3278	with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
1	daniel-mar	3279	begin
4	daniel-mar	3280	Dec(cR, rgbRed);
		3281	Dec(cG, rgbGreen);
		3282	Dec(cB, rgbBlue);
		3283	Dec(c);
1	daniel-mar	3284	end;
4	daniel-mar	3285	Inc(AveP);
1	daniel-mar	3286	end;
4	daniel-mar	3287	end;
		3288	8:
		3289	begin
		3290	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3291	AveP := @Ave;
		3292	for x := 0 to XCount - 1 do
		3293	begin
		3294	with Temp.ColorTable[PByte(SrcP)^], AveP^ do
1	daniel-mar	3295	begin
4	daniel-mar	3296	Dec(cR, rgbRed);
		3297	Dec(cG, rgbGreen);
		3298	Dec(cB, rgbBlue);
		3299	Dec(c);
1	daniel-mar	3300	end;
4	daniel-mar	3301	Inc(PByte(SrcP));
		3302	Inc(AveP);
1	daniel-mar	3303	end;
4	daniel-mar	3304	end;
		3305	16:
		3306	begin
		3307	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3308	AveP := @Ave;
		3309	for x := 0 to XCount - 1 do
		3310	begin
		3311	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		3312	with AveP^ do
1	daniel-mar	3313	begin
4	daniel-mar	3314	Dec(cR, R);
		3315	Dec(cG, G);
		3316	Dec(cB, B);
		3317	Dec(c);
1	daniel-mar	3318	end;
4	daniel-mar	3319	Inc(PWord(SrcP));
		3320	Inc(AveP);
1	daniel-mar	3321	end;
4	daniel-mar	3322	end;
		3323	24:
		3324	begin
		3325	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3326	AveP := @Ave;
		3327	for x := 0 to XCount - 1 do
		3328	begin
		3329	with PBGR(SrcP)^, AveP^ do
1	daniel-mar	3330	begin
4	daniel-mar	3331	Dec(cR, R);
		3332	Dec(cG, G);
		3333	Dec(cB, B);
		3334	Dec(c);
1	daniel-mar	3335	end;
4	daniel-mar	3336	Inc(PBGR(SrcP));
		3337	Inc(AveP);
1	daniel-mar	3338	end;
4	daniel-mar	3339	end;
		3340	32:
		3341	begin
		3342	SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
		3343	AveP := @Ave;
		3344	for x := 0 to XCount - 1 do
		3345	begin
		3346	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		3347	with AveP^ do
1	daniel-mar	3348	begin
4	daniel-mar	3349	Dec(cR, R);
		3350	Dec(cG, G);
		3351	Dec(cB, B);
		3352	Dec(c);
1	daniel-mar	3353	end;
4	daniel-mar	3354	Inc(PDWORD(SrcP));
		3355	Inc(AveP);
1	daniel-mar	3356	end;
4	daniel-mar	3357	end;
1	daniel-mar	3358	end;
		3359	end;
		3360
		3361	procedure Blur_Radius_Other;
		3362	var
		3363	FirstX, LastX, FirstX2, LastX2, FirstY, LastY: Integer;
		3364	x, y, x2, y2, jx, jy: Integer;
		3365	Ave: TAve;
		3366	AveX: ^TArrayAve;
		3367	DestP: Pointer;
		3368	P: PByte;
		3369	begin
4	daniel-mar	3370	GetMem(AveX, Width * SizeOf(TAve));
1	daniel-mar	3371	try
4	daniel-mar	3372	FillChar(AveX^, Width * SizeOf(TAve), 0);
1	daniel-mar	3373
		3374	FirstX2 := -1;
		3375	LastX2 := -1;
		3376	FirstY := -1;
		3377	LastY := -1;
		3378
		3379	x := 0;
4	daniel-mar	3380	for x2 := -Radius to Radius do
1	daniel-mar	3381	begin
4	daniel-mar	3382	jx := x + x2;
		3383	if (jx >= 0) and (jx < Width) then
1	daniel-mar	3384	begin
4	daniel-mar	3385	if FirstX2 = -1 then FirstX2 := jx;
		3386	if LastX2 < jx then LastX2 := jx;
1	daniel-mar	3387	end;
		3388	end;
		3389
		3390	y := 0;
4	daniel-mar	3391	for y2 := -Radius to Radius do
1	daniel-mar	3392	begin
4	daniel-mar	3393	jy := y + y2;
		3394	if (jy >= 0) and (jy < Height) then
1	daniel-mar	3395	begin
4	daniel-mar	3396	if FirstY = -1 then FirstY := jy;
		3397	if LastY < jy then LastY := jy;
1	daniel-mar	3398	end;
		3399	end;
		3400
4	daniel-mar	3401	for y := FirstY to LastY do
1	daniel-mar	3402	AddAverage(y, Temp.Width, AveX^);
		3403
4	daniel-mar	3404	for y := 0 to Height - 1 do
1	daniel-mar	3405	begin
		3406	DestP := ScanLine[y];
		3407
		3408	{ The average is updated. }
4	daniel-mar	3409	if y - FirstY = Radius + 1 then
1	daniel-mar	3410	begin
		3411	DeleteAverage(FirstY, Temp.Width, AveX^);
		3412	Inc(FirstY);
		3413	end;
		3414
4	daniel-mar	3415	if LastY - y = Radius - 1 then
1	daniel-mar	3416	begin
4	daniel-mar	3417	Inc(LastY); if LastY >= Height then LastY := Height - 1;
1	daniel-mar	3418	AddAverage(LastY, Temp.Width, AveX^);
		3419	end;
		3420
		3421	{ The average is calculated again. }
		3422	FirstX := FirstX2;
		3423	LastX := LastX2;
		3424
		3425	FillChar(Ave, SizeOf(Ave), 0);
4	daniel-mar	3426	for x := FirstX to LastX do
1	daniel-mar	3427	with AveX[x] do
		3428	begin
		3429	Inc(Ave.cR, cR);
		3430	Inc(Ave.cG, cG);
		3431	Inc(Ave.cB, cB);
		3432	Inc(Ave.c, c);
		3433	end;
		3434
4	daniel-mar	3435	for x := 0 to Width - 1 do
1	daniel-mar	3436	begin
		3437	{ The average is updated. }
4	daniel-mar	3438	if x - FirstX = Radius + 1 then
1	daniel-mar	3439	begin
		3440	with AveX[FirstX] do
		3441	begin
		3442	Dec(Ave.cR, cR);
		3443	Dec(Ave.cG, cG);
		3444	Dec(Ave.cB, cB);
		3445	Dec(Ave.c, c);
		3446	end;
		3447	Inc(FirstX);
		3448	end;
		3449
4	daniel-mar	3450	if LastX - x = Radius - 1 then
1	daniel-mar	3451	begin
4	daniel-mar	3452	Inc(LastX); if LastX >= Width then LastX := Width - 1;
1	daniel-mar	3453	with AveX[LastX] do
		3454	begin
		3455	Inc(Ave.cR, cR);
		3456	Inc(Ave.cG, cG);
		3457	Inc(Ave.cB, cB);
		3458	Inc(Ave.c, c);
		3459	end;
		3460	end;
		3461
		3462	{ The average is written. }
		3463	case BitCount of
4	daniel-mar	3464	1:
		3465	begin
		3466	P := @PArrayByte(DestP)[X shr 3];
		3467	with Ave do
		3468	P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR + cG + cB) div c) div 3 > 127)) shl Shift1[X and 7]);
		3469	end;
		3470	4:
		3471	begin
		3472	P := @PArrayByte(DestP)[X shr 1];
		3473	with Ave do
		3474	P^ := (P^ and Mask4n[X and 1]) or (((((cR + cG + cB) div c) div 3) shr 4) shl Shift4[X and 1]);
		3475	end;
		3476	8:
		3477	begin
		3478	with Ave do
		3479	PByte(DestP)^ := ((cR + cG + cB) div c) div 3;
		3480	Inc(PByte(DestP));
		3481	end;
		3482	16:
		3483	begin
		3484	with Ave do
		3485	PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
		3486	Inc(PWORD(DestP));
		3487	end;
		3488	24:
		3489	begin
		3490	with PBGR(DestP)^, Ave do
		3491	begin
		3492	R := cR div c;
		3493	G := cG div c;
		3494	B := cB div c;
1	daniel-mar	3495	end;
4	daniel-mar	3496	Inc(PBGR(DestP));
		3497	end;
		3498	32:
		3499	begin
		3500	with Ave do
		3501	PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
		3502	Inc(PDWORD(DestP));
		3503	end;
1	daniel-mar	3504	end;
		3505	end;
		3506
		3507	UpdateProgress(y);
		3508	end;
		3509	finally
		3510	FreeMem(AveX);
		3511	end;
		3512	end;
		3513
		3514	var
		3515	i, j: Integer;
		3516	begin
4	daniel-mar	3517	if Empty or (Radius = 0) then Exit;
1	daniel-mar	3518
		3519	Radius := Abs(Radius);
		3520
		3521	StartProgress('Blur');
		3522	try
		3523	Temp := TDIB.Create;
		3524	try
		3525	Temp.Assign(Self);
		3526	SetSize(Width, Height, ABitCount);
		3527
4	daniel-mar	3528	if ABitCount <= 8 then
1	daniel-mar	3529	begin
		3530	FillChar(ColorTable, SizeOf(ColorTable), 0);
4	daniel-mar	3531	for i := 0 to (1 shl ABitCount) - 1 do
1	daniel-mar	3532	begin
4	daniel-mar	3533	j := i * (1 shl (8 - ABitCount));
1	daniel-mar	3534	j := j or (j shr ABitCount);
		3535	ColorTable[i] := RGBQuad(j, j, j);
		3536	end;
		3537	UpdatePalette;
		3538	end;
		3539
		3540	Blur_Radius_Other;
		3541	finally
		3542	Temp.Free;
		3543	end;
		3544	finally
		3545	EndProgress;
		3546	end;
		3547	end;
		3548
4	daniel-mar	3549	procedure TDIB.Negative;
		3550	var
		3551	i, i2: Integer;
		3552	P: Pointer;
		3553	begin
		3554	if Empty then exit;
		3555
		3556	if BitCount <= 8 then
		3557	begin
		3558	for i := 0 to 255 do
		3559	with ColorTable[i] do
		3560	begin
		3561	rgbRed := 255 - rgbRed;
		3562	rgbGreen := 255 - rgbGreen;
		3563	rgbBlue := 255 - rgbBlue;
		3564	end;
		3565	UpdatePalette;
		3566	end else
		3567	begin
		3568	P := PBits;
		3569	i2 := Size;
		3570	asm
		3571	mov ecx,i2
		3572	mov eax,P
		3573	mov edx,ecx
		3574
		3575	{ Unit of DWORD. }
		3576	@@qword_skip:
		3577	shr ecx,2
		3578	jz @@dword_skip
		3579
		3580	dec ecx
		3581	@@dword_loop:
		3582	not dword ptr [eax+ecx*4]
		3583	dec ecx
		3584	jnl @@dword_loop
		3585
		3586	mov ecx,edx
		3587	shr ecx,2
		3588	add eax,ecx*4
		3589
		3590	{ Unit of Byte. }
		3591	@@dword_skip:
		3592	mov ecx,edx
		3593	and ecx,3
		3594	jz @@byte_skip
		3595
		3596	dec ecx
		3597	@@loop_byte:
		3598	not byte ptr [eax+ecx]
		3599	dec ecx
		3600	jnl @@loop_byte
		3601
		3602	@@byte_skip:
		3603	end;
		3604	end;
		3605	end;
		3606
1	daniel-mar	3607	procedure TDIB.Greyscale(ABitCount: Integer);
		3608	var
		3609	YTblR, YTblG, YTblB: array[0..255] of Byte;
		3610	i, j, x, y: Integer;
		3611	c: DWORD;
		3612	R, G, B: Byte;
		3613	Temp: TDIB;
		3614	DestP, SrcP: Pointer;
		3615	P: PByte;
		3616	begin
4	daniel-mar	3617	if Empty then Exit;
1	daniel-mar	3618
		3619	Temp := TDIB.Create;
		3620	try
		3621	Temp.Assign(Self);
		3622	SetSize(Width, Height, ABitCount);
		3623
4	daniel-mar	3624	if ABitCount <= 8 then
1	daniel-mar	3625	begin
		3626	FillChar(ColorTable, SizeOf(ColorTable), 0);
4	daniel-mar	3627	for i := 0 to (1 shl ABitCount) - 1 do
1	daniel-mar	3628	begin
4	daniel-mar	3629	j := i * (1 shl (8 - ABitCount));
1	daniel-mar	3630	j := j or (j shr ABitCount);
		3631	ColorTable[i] := RGBQuad(j, j, j);
		3632	end;
		3633	UpdatePalette;
		3634	end;
		3635
4	daniel-mar	3636	for i := 0 to 255 do
1	daniel-mar	3637	begin
4	daniel-mar	3638	YTblR[i] := Trunc(0.3588 * i);
		3639	YTblG[i] := Trunc(0.4020 * i);
		3640	YTblB[i] := Trunc(0.2392 * i);
1	daniel-mar	3641	end;
		3642
		3643	c := 0;
		3644
		3645	StartProgress('Greyscale');
		3646	try
4	daniel-mar	3647	for y := 0 to Height - 1 do
1	daniel-mar	3648	begin
		3649	DestP := ScanLine[y];
		3650	SrcP := Temp.ScanLine[y];
		3651
4	daniel-mar	3652	for x := 0 to Width - 1 do
1	daniel-mar	3653	begin
		3654	case Temp.BitCount of
4	daniel-mar	3655	1:
		3656	begin
		3657	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
		3658	c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
		3659	end;
		3660	4:
		3661	begin
		3662	with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
		3663	c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
		3664	end;
		3665	8:
		3666	begin
		3667	with Temp.ColorTable[PByte(SrcP)^] do
		3668	c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
		3669	Inc(PByte(SrcP));
		3670	end;
		3671	16:
		3672	begin
		3673	pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
		3674	c := YTblR[R] + YTblR[G] + YTblR[B];
		3675	Inc(PWord(SrcP));
		3676	end;
		3677	24:
		3678	begin
		3679	with PBGR(SrcP)^ do
		3680	c := YTblR[R] + YTblG[G] + YTblB[B];
		3681	Inc(PBGR(SrcP));
		3682	end;
		3683	32:
		3684	begin
		3685	pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
		3686	c := YTblR[R] + YTblR[G] + YTblR[B];
		3687	Inc(PDWORD(SrcP));
		3688	end;
1	daniel-mar	3689	end;
		3690
		3691	case BitCount of
4	daniel-mar	3692	1:
		3693	begin
		3694	P := @PArrayByte(DestP)[X shr 3];
		3695	P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c > 127)) shl Shift1[X and 7]);
		3696	end;
		3697	4:
		3698	begin
		3699	P := @PArrayByte(DestP)[X shr 1];
		3700	P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
		3701	end;
		3702	8:
		3703	begin
		3704	PByte(DestP)^ := c;
		3705	Inc(PByte(DestP));
		3706	end;
		3707	16:
		3708	begin
		3709	PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
		3710	Inc(PWord(DestP));
		3711	end;
		3712	24:
		3713	begin
		3714	with PBGR(DestP)^ do
		3715	begin
		3716	R := c;
		3717	G := c;
		3718	B := c;
1	daniel-mar	3719	end;
4	daniel-mar	3720	Inc(PBGR(DestP));
		3721	end;
		3722	32:
		3723	begin
		3724	PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
		3725	Inc(PDWORD(DestP));
		3726	end;
1	daniel-mar	3727	end;
		3728	end;
		3729
		3730	UpdateProgress(y);
		3731	end;
		3732	finally
		3733	EndProgress;
		3734	end;
		3735	finally
		3736	Temp.Free;
		3737	end;
		3738	end;
		3739
4	daniel-mar	3740	//--------------------------------------------------------------------------------------------------
		3741	// Version : 0.1 - 26/06/2000 //
		3742	// Version : 0.2 - 04/07/2000 //
		3743	// At someone's request, i have added 3 news effects : //
		3744	// 1 - Rotate //
		3745	// 2 - SplitBlur //
		3746	// 3 - GaussianBlur //
		3747	//--------------------------------------------------------------------------------------------------
		3748	// - NEW SPECIAL EFFECT - (English) //
		3749	//--------------------------------------------------------------------------------------------------
		3750	// At the start, my idea was to create a component derived from TCustomDXDraw. Unfortunately, //
		3751	// it's impossible to run a graphic component (derived from TCustomDXDraw) in a conception's //
		3752	// mode (i don't success, but perhaps, somebody know how doing ! In that case, please help me !!!)//
		3753	// Then, i'm used the DIB's unit for my work, but this unit is poor in special effect. Knowing a //
		3754	// library with more effect, i'm undertaked to import this library in DIB's unit. You can see the //
		3755	// FastLib library at : //
		3756	// //
		3757	// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
		3758	// //
		3759	// It was very difficult, because implementation's graphic was very different that DIB's unit. //
		3760	// Sometimes, i'm deserted the possibility of original effect, particularly in conversion of DIB //
		3761	// whith 256, 16 and 2 colors. If someone can implement this fonctionnality, thanks to tell me //
		3762	// how this miracle is possible !!! //
		3763	// All these procedures are translated and adapted by : //
		3764	// //
		3765	// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
		3766	// //
		3767	// IMPORTANT : These procedures don't modify the DIB's unit structure //
		3768	// Nota Bene : I don't implement these type of graphics (32 and 16 bit per pixels), //
		3769	// for one reason : I haven't bitmaps of this type !!! //
		3770	//--------------------------------------------------------------------------------------------------
		3771	//--------------------------------------------------------------------------------------------------
		3772	// - NOUVEAUX EFFETS SPECIAUX - (Fran�ais) //
		3773	//--------------------------------------------------------------------------------------------------
		3774	// Au commencement, mon id�e �tait de d�river un composant de TCustomDXDraw. Malheureusement, //
		3775	// c'est impossible de faire fonctionner un composant graphique (deriv� de TCustomDXDraw) en mode //
		3776	// conception (je n'y suis pas parvenu, mais peut-�tre, que quelqu'un sait comment faire ! Dans //
		3777	// ce cas, vous seriez aimable de m'aider !!!) //
		3778	// Alors, j'ai utilis� l'unit� DIB pour mon travail,mais celle-ci est pauvre en effet sp�ciaux. //
		3779	// Connaissant une librairie avec beaucoup plus d'effets sp�ciaux, j'ai entrepris d'importer //
		3780	// cette librairie dans l'unit� DIB. Vous pouvez voir la librairie FastLib � : //
		3781	// //
		3782	// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
		3783	// //
		3784	// C'�tait tr�s difficile car l'impl�mentation graphique est tr�s diff�rente de l'unit� DIB. //
		3785	// Parfois, j'ai abandonn� les possibilit�s de l'effet original, particuli�rement dans la //
		3786	// conversion des DIB avec 256, 16 et 2 couleurs. Si quelqu'un arrive � impl�menter ces //
		3787	// fonctionnalit�s, merci de me dire comment ce miracle est possible !!! //
		3788	// Toutes ces proc�dures ont �t� traduites et adapt�es par: //
		3789	// //
		3790	// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
		3791	// //
		3792	// IMPORTANT : Ces proc�dures ne modifient pas la structure de l'unit� DIB //
		3793	// Nota Bene : Je n'ai pas impl�ment� ces types de graphiques (32 et 16 bit par pixels), //
		3794	// pour une raison : je n'ai pas de bitmap de ce type !!! //
		3795	//--------------------------------------------------------------------------------------------------
		3796
		3797	function TDIB.IntToColor(i: Integer): TBGR;
		3798	begin
		3799	Result.b := i shr 16;
		3800	Result.g := i shr 8;
		3801	Result.r := i;
		3802	end;
		3803
		3804	function TDIB.Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer;
		3805	begin
		3806	if iMark then
		3807	begin
		3808	if iValue < iMin then
		3809	Result := iMin
		3810	else
		3811	if iValue > iMax then
		3812	Result := iMax
		3813	else
		3814	Result := iValue;
		3815	end
		3816	else
		3817	begin
		3818	if iValue < iMin then
		3819	Result := iMin
		3820	else
		3821	if iValue > iMax then
		3822	Result := iMin
		3823	else
		3824	Result := iValue;
		3825	end;
		3826	end;
		3827
		3828	procedure TDIB.Contrast(Amount: Integer);
1	daniel-mar	3829	var
4	daniel-mar	3830	x, y: Integer;
		3831	Table1: array[0..255] of Byte;
		3832	i: Byte;
		3833	S, D: pointer;
		3834	Temp1: TDIB;
		3835	color: DWORD;
		3836	P: PByte;
		3837	R, G, B: Byte;
1	daniel-mar	3838	begin
4	daniel-mar	3839	D := nil;
		3840	S := nil;
		3841	Temp1 := nil;
		3842	for i := 0 to 126 do
		3843	begin
		3844	y := (Abs(128 - i) * Amount) div 256;
		3845	Table1[i] := IntToByte(i - y);
		3846	end;
		3847	for i := 127 to 255 do
		3848	begin
		3849	y := (Abs(128 - i) * Amount) div 256;
		3850	Table1[i] := IntToByte(i + y);
		3851	end;
		3852	case BitCount of
		3853	32: Exit; // I haven't bitmap of this type ! Sorry
		3854	24: ; // nothing to do
		3855	16: ; // I have an artificial bitmap for this type ! i don't sure that it works
		3856	8, 4:
		3857	begin
		3858	Temp1 := TDIB.Create;
		3859	Temp1.Assign(self);
		3860	Temp1.SetSize(Width, Height, BitCount);
		3861	for i := 0 to 255 do
		3862	begin
		3863	with ColorTable[i] do
		3864	begin
		3865	rgbRed := IntToByte(Table1[rgbRed]);
		3866	rgbGreen := IntToByte(Table1[rgbGreen]);
		3867	rgbBlue := IntToByte(Table1[rgbBlue]);
		3868	end;
		3869	end;
		3870	UpdatePalette;
		3871	end;
		3872	else
		3873	// if the number of pixel is equal to 1 then exit of procedure
		3874	Exit;
		3875	end;
		3876	for y := 0 to Pred(Height) do
		3877	begin
		3878	case BitCount of
		3879	24, 16: D := ScanLine[y];
		3880	8, 4:
		3881	begin
		3882	D := Temp1.ScanLine[y];
		3883	S := Temp1.ScanLine[y];
		3884	end;
		3885	else
		3886	end;
		3887	for x := 0 to Pred(Width) do
		3888	begin
		3889	case BitCount of
		3890	32: ;
		3891	24:
		3892	begin
		3893	PBGR(D)^.B := Table1[PBGR(D)^.B];
		3894	PBGR(D)^.G := Table1[PBGR(D)^.G];
		3895	PBGR(D)^.R := Table1[PBGR(D)^.R];
		3896	Inc(PBGR(D));
		3897	end;
		3898	16:
		3899	begin
		3900	pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
		3901	PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
		3902	Inc(PWord(D));
		3903	end;
		3904	8:
		3905	begin
		3906	with Temp1.ColorTable[PByte(S)^] do
		3907	color := rgbRed + rgbGreen + rgbBlue;
		3908	Inc(PByte(S));
		3909	PByte(D)^ := color;
		3910	Inc(PByte(D));
		3911	end;
		3912	4:
		3913	begin
		3914	with Temp1.ColorTable[PByte(S)^] do
		3915	color := rgbRed + rgbGreen + rgbBlue;
		3916	Inc(PByte(S));
		3917	P := @PArrayByte(D)[X shr 1];
		3918	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		3919	end;
		3920	else
		3921	end;
		3922	end;
		3923	end;
		3924	case BitCount of
		3925	8, 4: Temp1.Free;
		3926	else
		3927	end;
		3928	end;
1	daniel-mar	3929
4	daniel-mar	3930	procedure TDIB.Saturation(Amount: Integer);
		3931	var
		3932	Grays: array[0..767] of Integer;
		3933	Alpha: array[0..255] of Word;
		3934	Gray, x, y: Integer;
		3935	i: Byte;
		3936	S, D: pointer;
		3937	Temp1: TDIB;
		3938	color: DWORD;
		3939	P: PByte;
		3940	R, G, B: Byte;
		3941	begin
		3942	D := nil;
		3943	S := nil;
		3944	Temp1 := nil;
		3945	for i := 0 to 255 do
		3946	Alpha[i] := (i * Amount) shr 8;
		3947	x := 0;
		3948	for i := 0 to 255 do
1	daniel-mar	3949	begin
4	daniel-mar	3950	Gray := i - Alpha[i];
		3951	Grays[x] := Gray;
		3952	Inc(x);
		3953	Grays[x] := Gray;
		3954	Inc(x);
		3955	Grays[x] := Gray;
		3956	Inc(x);
		3957	end;
		3958	case BitCount of
		3959	32: Exit; // I haven't bitmap of this type ! Sorry
		3960	24: ; // nothing to do
		3961	16: ; // I have an artificial bitmap for this type ! i don't sure that it works
		3962	8, 4:
		3963	begin
		3964	Temp1 := TDIB.Create;
		3965	Temp1.Assign(self);
		3966	Temp1.SetSize(Width, Height, BitCount);
		3967	for i := 0 to 255 do
1	daniel-mar	3968	begin
4	daniel-mar	3969	with ColorTable[i] do
		3970	begin
		3971	Gray := Grays[rgbRed + rgbGreen + rgbBlue];
		3972	rgbRed := IntToByte(Gray + Alpha[rgbRed]);
		3973	rgbGreen := IntToByte(Gray + Alpha[rgbGreen]);
		3974	rgbBlue := IntToByte(Gray + Alpha[rgbBlue]);
		3975	end;
		3976	end;
		3977	UpdatePalette;
		3978	end;
		3979	else
		3980	// if the number of pixel is equal to 1 then exit of procedure
		3981	Exit;
		3982	end;
		3983	for y := 0 to Pred(Height) do
		3984	begin
		3985	case BitCount of
		3986	24, 16: D := ScanLine[y];
		3987	8, 4:
		3988	begin
		3989	D := Temp1.ScanLine[y];
		3990	S := Temp1.ScanLine[y];
		3991	end;
		3992	else
		3993	end;
		3994	for x := 0 to Pred(Width) do
		3995	begin
		3996	case BitCount of
		3997	32: ;
		3998	24:
		3999	begin
		4000	Gray := Grays[PBGR(D)^.R + PBGR(D)^.G + PBGR(D)^.B];
		4001	PBGR(D)^.B := IntToByte(Gray + Alpha[PBGR(D)^.B]);
		4002	PBGR(D)^.G := IntToByte(Gray + Alpha[PBGR(D)^.G]);
		4003	PBGR(D)^.R := IntToByte(Gray + Alpha[PBGR(D)^.R]);
		4004	Inc(PBGR(D));
		4005	end;
		4006	16:
		4007	begin
		4008	pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
		4009	PWord(D)^ := IntToByte(Gray + Alpha[B]) + IntToByte(Gray + Alpha[G]) +
		4010	IntToByte(Gray + Alpha[R]);
		4011	Inc(PWord(D));
		4012	end;
		4013	8:
		4014	begin
		4015	with Temp1.ColorTable[PByte(S)^] do
		4016	color := rgbRed + rgbGreen + rgbBlue;
		4017	Inc(PByte(S));
		4018	PByte(D)^ := color;
		4019	Inc(PByte(D));
		4020	end;
		4021	4:
		4022	begin
		4023	with Temp1.ColorTable[PByte(S)^] do
		4024	color := rgbRed + rgbGreen + rgbBlue;
		4025	Inc(PByte(S));
		4026	P := @PArrayByte(D)[X shr 1];
		4027	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		4028	end;
		4029	else
		4030	end;
		4031	end;
		4032	end;
		4033	case BitCount of
		4034	8, 4: Temp1.Free;
		4035	else
		4036	end;
		4037	end;
1	daniel-mar	4038
4	daniel-mar	4039	procedure TDIB.Lightness(Amount: Integer);
		4040	var
		4041	x, y: Integer;
		4042	Table1: array[0..255] of Byte;
		4043	i: Byte;
		4044	S, D: pointer;
		4045	Temp1: TDIB;
		4046	color: DWORD;
		4047	P: PByte;
		4048	R, G, B: Byte;
		4049	begin
		4050	D := nil;
		4051	S := nil;
		4052	Temp1 := nil;
		4053	if Amount < 0 then
		4054	begin
		4055	Amount := -Amount;
		4056	for i := 0 to 255 do
		4057	Table1[i] := IntToByte(i - ((Amount * i) shr 8));
		4058	end
		4059	else
		4060	for i := 0 to 255 do
		4061	Table1[i] := IntToByte(i + ((Amount * (i xor 255)) shr 8));
		4062	case BitCount of
		4063	32: Exit; // I haven't bitmap of this type ! Sorry
		4064	24: ; // nothing to do
		4065	16: ; // I have an artificial bitmap for this type ! i don't sure that it works
		4066	8, 4:
		4067	begin
		4068	Temp1 := TDIB.Create;
		4069	Temp1.Assign(self);
		4070	Temp1.SetSize(Width, Height, BitCount);
		4071	for i := 0 to 255 do
		4072	begin
		4073	with ColorTable[i] do
		4074	begin
		4075	rgbRed := IntToByte(Table1[rgbRed]);
		4076	rgbGreen := IntToByte(Table1[rgbGreen]);
		4077	rgbBlue := IntToByte(Table1[rgbBlue]);
		4078	end;
1	daniel-mar	4079	end;
4	daniel-mar	4080	UpdatePalette;
1	daniel-mar	4081	end;
4	daniel-mar	4082	else
		4083	// if the number of pixel is equal to 1 then exit of procedure
		4084	Exit;
		4085	end;
		4086	for y := 0 to Pred(Height) do
		4087	begin
		4088	case BitCount of
		4089	24, 16: D := ScanLine[y];
		4090	8, 4:
		4091	begin
		4092	D := Temp1.ScanLine[y];
		4093	S := Temp1.ScanLine[y];
		4094	end;
		4095	else
1	daniel-mar	4096	end;
4	daniel-mar	4097	for x := 0 to Pred(Width) do
		4098	begin
		4099	case BitCount of
		4100	32: ;
		4101	24:
		4102	begin
		4103	PBGR(D)^.B := Table1[PBGR(D)^.B];
		4104	PBGR(D)^.G := Table1[PBGR(D)^.G];
		4105	PBGR(D)^.R := Table1[PBGR(D)^.R];
		4106	Inc(PBGR(D));
		4107	end;
		4108	16:
		4109	begin
		4110	pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
		4111	PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
		4112	Inc(PWord(D));
		4113	end;
		4114	8:
		4115	begin
		4116	with Temp1.ColorTable[PByte(S)^] do
		4117	color := rgbRed + rgbGreen + rgbBlue;
		4118	Inc(PByte(S));
		4119	PByte(D)^ := color;
		4120	Inc(PByte(D));
		4121	end;
		4122	4:
		4123	begin
		4124	with Temp1.ColorTable[PByte(S)^] do
		4125	color := rgbRed + rgbGreen + rgbBlue;
		4126	Inc(PByte(S));
		4127	P := @PArrayByte(D)[X shr 1];
		4128	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		4129	end;
		4130	else
		4131	end;
		4132	end;
		4133	end;
		4134	case BitCount of
		4135	8, 4: Temp1.Free;
		4136	else
		4137	end;
		4138	end;
1	daniel-mar	4139
4	daniel-mar	4140	procedure TDIB.AddRGB(aR, aG, aB: Byte);
		4141	var
		4142	Table: array[0..255] of TBGR;
		4143	x, y: Integer;
		4144	i: Byte;
		4145	D: pointer;
		4146	P: PByte;
		4147	color: DWORD;
		4148	Temp1: TDIB;
		4149	R, G, B: Byte;
		4150	begin
		4151	color := 0;
		4152	D := nil;
		4153	Temp1 := nil;
		4154	case BitCount of
		4155	32: Exit; // I haven't bitmap of this type ! Sorry
		4156	24, 16:
1	daniel-mar	4157	begin
4	daniel-mar	4158	for i := 0 to 255 do
		4159	begin
		4160	Table[i].b := IntToByte(i + aB);
		4161	Table[i].g := IntToByte(i + aG);
		4162	Table[i].r := IntToByte(i + aR);
		4163	end;
		4164	end;
		4165	8, 4:
		4166	begin
		4167	Temp1 := TDIB.Create;
		4168	Temp1.Assign(self);
		4169	Temp1.SetSize(Width, Height, BitCount);
		4170	for i := 0 to 255 do
		4171	begin
		4172	with ColorTable[i] do
		4173	begin
		4174	rgbRed := IntToByte(rgbRed + aR);
		4175	rgbGreen := IntToByte(rgbGreen + aG);
		4176	rgbBlue := IntToByte(rgbBlue + aB);
		4177	end;
		4178	end;
		4179	UpdatePalette;
		4180	end;
		4181	else
		4182	// if the number of pixel is equal to 1 then exit of procedure
		4183	Exit;
		4184	end;
		4185	for y := 0 to Pred(Height) do
		4186	begin
		4187	case BitCount of
		4188	24, 16: D := ScanLine[y];
		4189	8, 4:
		4190	begin
		4191	D := Temp1.ScanLine[y];
		4192	end;
		4193	else
		4194	end;
		4195	for x := 0 to Pred(Width) do
		4196	begin
		4197	case BitCount of
		4198	32: ; // I haven't bitmap of this type ! Sorry
		4199	24:
		4200	begin
		4201	PBGR(D)^.B := Table[PBGR(D)^.B].b;
		4202	PBGR(D)^.G := Table[PBGR(D)^.G].g;
		4203	PBGR(D)^.R := Table[PBGR(D)^.R].r;
		4204	Inc(PBGR(D));
		4205	end;
		4206	16:
		4207	begin
		4208	pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
		4209	PWord(D)^ := Table[R].r + Table[G].g + Table[B].b;
		4210	Inc(PWord(D));
		4211	end;
		4212	8:
		4213	begin
		4214	Inc(PByte(D));
		4215	end;
		4216	4:
		4217	begin
		4218	P := @PArrayByte(D)[X shr 1];
		4219	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		4220	end;
		4221	else
		4222	end;
		4223	end;
		4224	end;
		4225	case BitCount of
		4226	8, 4: Temp1.Free;
		4227	else
		4228	end;
		4229	end;
1	daniel-mar	4230
4	daniel-mar	4231	function TDIB.Filter(Dest: TDIB; Filter: TFilter): Boolean;
		4232	var
		4233	Sum, r, g, b, x, y: Integer;
		4234	a, i, j: byte;
		4235	tmp: TBGR;
		4236	Col: PBGR;
		4237	D: Pointer;
		4238	begin
		4239	Result := True;
		4240	Sum := Filter[0, 0] + Filter[1, 0] + Filter[2, 0] +
		4241	Filter[0, 1] + Filter[1, 1] + Filter[2, 1] +
		4242	Filter[0, 2] + Filter[1, 2] + Filter[2, 2];
		4243	if Sum = 0 then
		4244	Sum := 1;
		4245	Col := PBits;
		4246	for y := 0 to Pred(Height) do
		4247	begin
		4248	D := Dest.ScanLine[y];
		4249	for x := 0 to Pred(Width) do
		4250	begin
		4251	r := 0; g := 0; b := 0;
		4252	case BitCount of
		4253	32, 16, 4, 1:
		4254	begin
		4255	Result := False;
		4256	Exit;
		4257	end;
		4258	24:
		4259	begin
		4260	for i := 0 to 2 do
		4261	begin
		4262	for j := 0 to 2 do
		4263	begin
		4264	Tmp := IntToColor(Pixels[Interval(0, Pred(Width), x + Pred(i), True),
		4265	Interval(0, Pred(Height), y + Pred(j), True)]);
		4266	Inc(b, Filter[i, j] * Tmp.b);
		4267	Inc(g, Filter[i, j] * Tmp.g);
		4268	Inc(r, Filter[i, j] * Tmp.r);
1	daniel-mar	4269	end;
4	daniel-mar	4270	end;
		4271	Col.b := IntToByte(b div Sum);
		4272	Col.g := IntToByte(g div Sum);
		4273	Col.r := IntToByte(r div Sum);
		4274	Dest.Pixels[x, y] := rgb(Col.r, Col.g, Col.b);
		4275	end;
		4276	8:
		4277	begin
		4278	for i := 0 to 2 do
		4279	begin
		4280	for j := 0 to 2 do
		4281	begin
		4282	a := (Pixels[Interval(0, Pred(Width), x + Pred(i), True),
		4283	Interval(0, Pred(Height), y + Pred(j), True)]);
		4284	tmp.r := ColorTable[a].rgbRed;
		4285	tmp.g := ColorTable[a].rgbGreen;
		4286	tmp.b := ColorTable[a].rgbBlue;
		4287	Inc(b, Filter[i, j] * Tmp.b);
		4288	Inc(g, Filter[i, j] * Tmp.g);
		4289	Inc(r, Filter[i, j] * Tmp.r);
1	daniel-mar	4290	end;
4	daniel-mar	4291	end;
		4292	Col.b := IntToByte(b div Sum);
		4293	Col.g := IntToByte(g div Sum);
		4294	Col.r := IntToByte(r div Sum);
		4295	PByte(D)^ := rgb(Col.r, Col.g, Col.b);
		4296	Inc(PByte(D));
		4297	end;
		4298	end;
		4299	end;
		4300	end;
		4301	end;
1	daniel-mar	4302
4	daniel-mar	4303	procedure TDIB.Spray(Amount: Integer);
		4304	var
		4305	value, x, y: Integer;
		4306	D: Pointer;
		4307	color: DWORD;
		4308	P: PByte;
		4309	begin
		4310	for y := Pred(Height) downto 0 do
		4311	begin
		4312	D := ScanLine[y];
		4313	for x := 0 to Pred(Width) do
		4314	begin
		4315	value := Random(Amount);
		4316	color := Pixels[Interval(0, Pred(Width), x + (value - Random(value * 2)), True),
		4317	Interval(0, Pred(Height), y + (value - Random(value * 2)), True)];
		4318	case BitCount of
		4319	32:
		4320	begin
		4321	PDWord(D)^ := color;
		4322	Inc(PDWord(D));
		4323	end;
		4324	24:
		4325	begin
		4326	PBGR(D)^ := IntToColor(color);
		4327	Inc(PBGR(D));
		4328	end;
		4329	16:
		4330	begin
		4331	PWord(D)^ := color;
		4332	Inc(PWord(D));
		4333	end;
		4334	8:
		4335	begin
		4336	PByte(D)^ := color;
		4337	Inc(PByte(D));
		4338	end;
		4339	4:
		4340	begin
		4341	P := @PArrayByte(D)[X shr 1];
		4342	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		4343	end;
		4344	1:
		4345	begin
		4346	P := @PArrayByte(D)[X shr 3];
		4347	P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
		4348	end;
		4349	else
1	daniel-mar	4350	end;
		4351	end;
4	daniel-mar	4352	end;
		4353	end;
		4354
		4355	procedure TDIB.Sharpen(Amount: Integer);
		4356	var
		4357	Lin0, Lin1, Lin2: PLines;
		4358	pc: PBGR;
		4359	cx, x, y: Integer;
		4360	Buf: array[0..8] of TBGR;
		4361	D: pointer;
		4362	c: DWORD;
		4363	i: byte;
		4364	P1: PByte;
		4365	Temp1: TDIB;
		4366
		4367	begin
		4368	D := nil;
		4369	GetMem(pc, SizeOf(TBGR));
		4370	c := 0;
		4371	Temp1 := nil;
		4372	case Bitcount of
		4373	32, 16, 1: Exit;
		4374	24:
		4375	begin
		4376	Temp1 := TDIB.Create;
		4377	Temp1.Assign(self);
		4378	Temp1.SetSize(Width, Height, bitCount);
		4379	end;
		4380	8:
		4381	begin
		4382	Temp1 := TDIB.Create;
		4383	Temp1.Assign(self);
		4384	Temp1.SetSize(Width, Height, bitCount);
		4385	for i := 0 to 255 do
		4386	begin
		4387	with Temp1.ColorTable[i] do
		4388	begin
		4389	Buf[0].B := ColorTable[i - Amount].rgbBlue;
		4390	Buf[0].G := ColorTable[i - Amount].rgbGreen;
		4391	Buf[0].R := ColorTable[i - Amount].rgbRed;
		4392	Buf[1].B := ColorTable[i].rgbBlue;
		4393	Buf[1].G := ColorTable[i].rgbGreen;
		4394	Buf[1].R := ColorTable[i].rgbRed;
		4395	Buf[2].B := ColorTable[i + Amount].rgbBlue;
		4396	Buf[2].G := ColorTable[i + Amount].rgbGreen;
		4397	Buf[2].R := ColorTable[i + Amount].rgbRed;
		4398	Buf[3].B := ColorTable[i - Amount].rgbBlue;
		4399	Buf[3].G := ColorTable[i - Amount].rgbGreen;
		4400	Buf[3].R := ColorTable[i - Amount].rgbRed;
		4401	Buf[4].B := ColorTable[i].rgbBlue;
		4402	Buf[4].G := ColorTable[i].rgbGreen;
		4403	Buf[4].R := ColorTable[i].rgbRed;
		4404	Buf[5].B := ColorTable[i + Amount].rgbBlue;
		4405	Buf[5].G := ColorTable[i + Amount].rgbGreen;
		4406	Buf[5].R := ColorTable[i + Amount].rgbRed;
		4407	Buf[6].B := ColorTable[i - Amount].rgbBlue;
		4408	Buf[6].G := ColorTable[i - Amount].rgbGreen;
		4409	Buf[6].R := ColorTable[i - Amount].rgbRed;
		4410	Buf[7].B := ColorTable[i].rgbBlue;
		4411	Buf[7].G := ColorTable[i].rgbGreen;
		4412	Buf[7].R := ColorTable[i].rgbRed;
		4413	Buf[8].B := ColorTable[i + Amount].rgbBlue;
		4414	Buf[8].G := ColorTable[i + Amount].rgbGreen;
		4415	Buf[8].R := ColorTable[i + Amount].rgbRed;
		4416	Temp1.colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
		4417	Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
		4418	Temp1.colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
		4419	Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
		4420	Temp1.colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
		4421	Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
		4422
		4423	end;
		4424	end;
		4425	Temp1.UpdatePalette;
		4426	end;
		4427	4:
		4428	begin
		4429	Temp1 := TDIB.Create;
		4430	Temp1.Assign(self);
		4431	Temp1.SetSize(Width, Height, bitCount);
		4432	for i := 0 to 255 do
		4433	begin
		4434	with Temp1.ColorTable[i] do
		4435	begin
		4436	Buf[0].B := ColorTable[i - Amount].rgbBlue;
		4437	Buf[0].G := ColorTable[i - Amount].rgbGreen;
		4438	Buf[0].R := ColorTable[i - Amount].rgbRed;
		4439	Buf[1].B := ColorTable[i].rgbBlue;
		4440	Buf[1].G := ColorTable[i].rgbGreen;
		4441	Buf[1].R := ColorTable[i].rgbRed;
		4442	Buf[2].B := ColorTable[i + Amount].rgbBlue;
		4443	Buf[2].G := ColorTable[i + Amount].rgbGreen;
		4444	Buf[2].R := ColorTable[i + Amount].rgbRed;
		4445	Buf[3].B := ColorTable[i - Amount].rgbBlue;
		4446	Buf[3].G := ColorTable[i - Amount].rgbGreen;
		4447	Buf[3].R := ColorTable[i - Amount].rgbRed;
		4448	Buf[4].B := ColorTable[i].rgbBlue;
		4449	Buf[4].G := ColorTable[i].rgbGreen;
		4450	Buf[4].R := ColorTable[i].rgbRed;
		4451	Buf[5].B := ColorTable[i + Amount].rgbBlue;
		4452	Buf[5].G := ColorTable[i + Amount].rgbGreen;
		4453	Buf[5].R := ColorTable[i + Amount].rgbRed;
		4454	Buf[6].B := ColorTable[i - Amount].rgbBlue;
		4455	Buf[6].G := ColorTable[i - Amount].rgbGreen;
		4456	Buf[6].R := ColorTable[i - Amount].rgbRed;
		4457	Buf[7].B := ColorTable[i].rgbBlue;
		4458	Buf[7].G := ColorTable[i].rgbGreen;
		4459	Buf[7].R := ColorTable[i].rgbRed;
		4460	Buf[8].B := ColorTable[i + Amount].rgbBlue;
		4461	Buf[8].G := ColorTable[i + Amount].rgbGreen;
		4462	Buf[8].R := ColorTable[i + Amount].rgbRed;
		4463	colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
		4464	Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
		4465	colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
		4466	Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
		4467	colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
		4468	Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
		4469	end;
		4470	end;
		4471	UpdatePalette;
		4472	end;
		4473	end;
		4474	for y := 0 to Pred(Height) do
1	daniel-mar	4475	begin
4	daniel-mar	4476	Lin0 := ScanLine[Interval(0, Pred(Height), y - Amount, True)];
		4477	Lin1 := ScanLine[y];
		4478	Lin2 := ScanLine[Interval(0, Pred(Height), y + Amount, True)];
		4479	case Bitcount of
		4480	24, 8, 4: D := Temp1.ScanLine[y];
		4481	end;
		4482	for x := 0 to Pred(Width) do
		4483	begin
		4484	case BitCount of
		4485	24:
		4486	begin
		4487	cx := Interval(0, Pred(Width), x - Amount, True);
		4488	Buf[0] := Lin0[cx];
		4489	Buf[1] := Lin1[cx];
		4490	Buf[2] := Lin2[cx];
		4491	Buf[3] := Lin0[x];
		4492	Buf[4] := Lin1[x];
		4493	Buf[5] := Lin2[x];
		4494	cx := Interval(0, Pred(Width), x + Amount, true);
		4495	Buf[6] := Lin0[cx];
		4496	Buf[7] := Lin1[cx];
		4497	Buf[8] := Lin0[cx];
		4498	pc.b := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
		4499	Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
		4500	pc.g := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
		4501	Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
		4502	pc.r := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
		4503	Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
		4504	PBGR(D)^.B := pc.b;
		4505	PBGR(D)^.G := pc.g;
		4506	PBGR(D)^.R := pc.r;
		4507	Inc(PBGR(D));
		4508	end;
		4509	8:
		4510	begin
		4511	Inc(PByte(D));
		4512	end;
		4513	4:
		4514	begin
		4515	P1 := @PArrayByte(D)[X shr 1];
		4516	P1^ := ((P1^ and Mask4n[X and 1]) or ((c shl Shift4[X and 1])));
		4517	end;
		4518	end;
		4519	end;
		4520	end;
		4521	case BitCount of
		4522	24, 8:
1	daniel-mar	4523	begin
4	daniel-mar	4524	Assign(Temp1);
		4525	Temp1.Free;
		4526	end;
		4527	4: Temp1.Free;
		4528	end;
		4529	FreeMem(pc, SizeOf(TBGR));
		4530	end;
1	daniel-mar	4531
4	daniel-mar	4532	procedure TDIB.Emboss;
		4533	var
		4534	x, y: longint;
		4535	D, D1, P: pointer;
		4536	color: TBGR;
		4537	c: DWORD;
		4538	P1: PByte;
		4539
		4540	begin
		4541	D := nil;
		4542	D1 := nil;
		4543	P := nil;
		4544	case BitCount of
		4545	32, 16, 1: Exit;
		4546	24:
		4547	begin
		4548	D := PBits;
		4549	D1 := Ptr(Integer(D) + 3);
		4550	end;
		4551	else
		4552	end;
		4553	for y := 0 to Pred(Height) do
		4554	begin
		4555	case Bitcount of
		4556	8, 4:
		4557	begin
		4558	P := ScanLine[y];
1	daniel-mar	4559	end;
4	daniel-mar	4560	end;
		4561	for x := 0 to Pred(Width) do
		4562	begin
		4563	case BitCount of
		4564	24:
		4565	begin
		4566	PBGR(D)^.B := ((PBGR(D)^.B + (PBGR(D1)^.B xor $FF)) shr 1);
		4567	PBGR(D)^.G := ((PBGR(D)^.G + (PBGR(D1)^.G xor $FF)) shr 1);
		4568	PBGR(D)^.R := ((PBGR(D)^.R + (PBGR(D1)^.R xor $FF)) shr 1);
		4569	Inc(PBGR(D));
		4570	if (y < Height - 2) and (x < Width - 2) then
		4571	Inc(PBGR(D1));
		4572	end;
		4573	8:
		4574	begin
		4575	color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
		4576	color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
		4577	color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
		4578	c := (color.R + color.G + color.B) shr 1;
		4579	PByte(P)^ := c;
		4580	Inc(PByte(P));
		4581	end;
		4582	4:
		4583	begin
		4584	color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
		4585	color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) - 1) shr 1) + 30) div 3;
		4586	color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
		4587	c := (color.R + color.G + color.B) shr 1;
		4588	if c > 64 then
		4589	c := c - 8;
		4590	P1 := @PArrayByte(P)[X shr 1];
		4591	P1^ := (P1^ and Mask4n[X and 1]) or ((c) shl Shift4[X and 1]);
		4592	end;
		4593	else
		4594	end;
		4595	end;
		4596	case BitCount of
		4597	24:
		4598	begin
		4599	D := Ptr(Integer(D1));
		4600	if y < Height - 2 then
		4601	D1 := Ptr(Integer(D1) + 6)
		4602	else
		4603	D1 := Ptr(Integer(ScanLine[Pred(Height)]) + 3);
		4604	end;
		4605	else
		4606	end;
		4607	end;
		4608	end;
1	daniel-mar	4609
4	daniel-mar	4610	procedure TDIB.AddMonoNoise(Amount: Integer);
		4611	var
		4612	value: cardinal;
		4613	x, y: longint;
		4614	a: byte;
		4615	D: pointer;
		4616	color: DWORD;
		4617	P: PByte;
		4618	begin
		4619	for y := 0 to Pred(Height) do
		4620	begin
		4621	D := ScanLine[y];
		4622	for x := 0 to Pred(Width) do
		4623	begin
		4624	case BitCount of
		4625	32: Exit; // I haven't bitmap of this type ! Sorry
		4626	24:
		4627	begin
		4628	value := Random(Amount) - (Amount shr 1);
		4629	PBGR(D)^.B := IntToByte(PBGR(D)^.B + value);
		4630	PBGR(D)^.G := IntToByte(PBGR(D)^.G + value);
		4631	PBGR(D)^.R := IntToByte(PBGR(D)^.R + value);
		4632	Inc(PBGR(D));
		4633	end;
		4634	16: Exit; // I haven't bitmap of this type ! Sorry
		4635	8:
		4636	begin
		4637	a := ((Random(Amount shr 1) - (Amount div 4))) div 8;
		4638	color := Interval(0, 255, (pixels[x, y] - a), True);
		4639	PByte(D)^ := color;
		4640	Inc(PByte(D));
		4641	end;
		4642	4:
		4643	begin
		4644	a := ((Random(Amount shr 1) - (Amount div 4))) div 16;
		4645	color := Interval(0, 15, (pixels[x, y] - a), True);
		4646	P := @PArrayByte(D)[X shr 1];
		4647	P^ := ((P^ and Mask4n[X and 1]) or ((color shl Shift4[X and 1])));
		4648	end;
		4649	1:
		4650	begin
		4651	a := ((Random(Amount shr 1) - (Amount div 4))) div 32;
		4652	color := Interval(0, 1, (pixels[x, y] - a), True);
		4653	P := @PArrayByte(D)[X shr 3];
		4654	P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
		4655	end;
		4656	else
1	daniel-mar	4657	end;
		4658	end;
		4659	end;
		4660	end;
		4661
4	daniel-mar	4662	procedure TDIB.AddGradiantNoise(Amount: byte);
1	daniel-mar	4663	var
4	daniel-mar	4664	a, i: byte;
		4665	x, y: Integer;
		4666	Table: array[0..255] of TBGR;
		4667	S, D: pointer;
		4668	color: DWORD;
		4669	Temp1: TDIB;
		4670	P: PByte;
		4671
1	daniel-mar	4672	begin
4	daniel-mar	4673	D := nil;
		4674	S := nil;
		4675	Temp1 := nil;
		4676	case BitCount of
		4677	32: Exit; // I haven't bitmap of this type ! Sorry
		4678	24:
		4679	begin
		4680	for i := 0 to 255 do
		4681	begin
		4682	a := Random(Amount);
		4683	Table[i].b := IntToByte(i + a);
		4684	Table[i].g := IntToByte(i + a);
		4685	Table[i].r := IntToByte(i + a);
		4686	end;
		4687	end;
		4688	16: Exit; // I haven't bitmap of this type ! Sorry
		4689	8, 4:
		4690	begin
		4691	Temp1 := TDIB.Create;
		4692	Temp1.Assign(self);
		4693	Temp1.SetSize(Width, Height, BitCount);
		4694	for i := 0 to 255 do
		4695	begin
		4696	with ColorTable[i] do
		4697	begin
		4698	a := Random(Amount);
		4699	rgbRed := IntToByte(rgbRed + a);
		4700	rgbGreen := IntToByte(rgbGreen + a);
		4701	rgbBlue := IntToByte(rgbBlue + a);
		4702	end;
		4703	end;
		4704	UpdatePalette;
		4705	end;
		4706	else
		4707	// if the number of pixel is equal to 1 then exit of procedure
		4708	Exit;
		4709	end;
		4710	for y := 0 to Pred(Height) do
		4711	begin
		4712	case BitCount of
		4713	24: D := ScanLine[y];
		4714	8, 4:
		4715	begin
		4716	D := Temp1.ScanLine[y];
		4717	S := Temp1.ScanLine[y];
		4718	end;
		4719	else
		4720	end;
		4721	for x := 0 to Pred(Width) do
		4722	begin
		4723	case BitCount of
		4724	32: ; // I haven't bitmap of this type ! Sorry
		4725	24:
		4726	begin
		4727	PBGR(D)^.B := Table[PBGR(D)^.B].b;
		4728	PBGR(D)^.G := Table[PBGR(D)^.G].g;
		4729	PBGR(D)^.R := Table[PBGR(D)^.R].r;
		4730	Inc(PBGR(D));
		4731	end;
		4732	16: ; // I haven't bitmap of this type ! Sorry
		4733	8:
		4734	begin
		4735	with Temp1.ColorTable[PByte(S)^] do
		4736	color := rgbRed + rgbGreen + rgbBlue;
		4737	Inc(PByte(S));
		4738	PByte(D)^ := color;
		4739	Inc(PByte(D));
		4740	end;
		4741	4:
		4742	begin
		4743	with Temp1.ColorTable[PByte(S)^] do
		4744	color := rgbRed + rgbGreen + rgbBlue;
		4745	Inc(PByte(S));
		4746	P := @PArrayByte(D)[X shr 1];
		4747	P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
		4748	end;
		4749	else
		4750	end;
		4751	end;
		4752	end;
		4753	case BitCount of
		4754	8, 4: Temp1.Free;
		4755	else
		4756	end;
		4757	end;
1	daniel-mar	4758
4	daniel-mar	4759	function TDIB.FishEye(bmp: TDIB): Boolean;
		4760	var
		4761	weight, xmid, ymid, fx, fy, r1, r2, dx, dy, rmax: Double;
		4762	Amount, ifx, ify, ty, tx, new_red, new_green, new_blue, ix, iy: Integer;
		4763	weight_x, weight_y: array[0..1] of Double;
		4764	total_red, total_green, total_blue: Double;
		4765	sli, slo: PLines;
		4766	D: Pointer;
		4767	begin
		4768	Result := True;
		4769	case BitCount of
		4770	32, 16, 8, 4, 1:
		4771	begin
		4772	Result := False;
		4773	Exit;
		4774	end;
		4775	end;
		4776	Amount := 1;
		4777	xmid := Width / 2;
		4778	ymid := Height / 2;
		4779	rmax := Max(Bmp.Width, Bmp.Height) * Amount;
		4780	for ty := 0 to Pred(Height) do
1	daniel-mar	4781	begin
4	daniel-mar	4782	for tx := 0 to Pred(Width) do
		4783	begin
		4784	dx := tx - xmid;
		4785	dy := ty - ymid;
		4786	r1 := Sqrt(Sqr(dx) + Sqr(dy));
		4787	if r1 <> 0 then
1	daniel-mar	4788	begin
4	daniel-mar	4789	r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
		4790	fx := dx * r2 / r1 + xmid;
		4791	fy := dy * r2 / r1 + ymid;
		4792	end
		4793	else
		4794	begin
		4795	fx := xmid;
		4796	fy := ymid;
1	daniel-mar	4797	end;
4	daniel-mar	4798	ify := Trunc(fy);
		4799	ifx := Trunc(fx);
		4800	if fy >= 0 then
		4801	begin
		4802	weight_y[1] := fy - ify;
		4803	weight_y[0] := 1 - weight_y[1];
		4804	end
		4805	else
		4806	begin
		4807	weight_y[0] := -(fy - ify);
		4808	weight_y[1] := 1 - weight_y[0];
		4809	end;
		4810	if fx >= 0 then
		4811	begin
		4812	weight_x[1] := fx - ifx;
		4813	weight_x[0] := 1 - weight_x[1];
		4814	end
		4815	else
		4816	begin
		4817	weight_x[0] := -(fx - ifx);
		4818	Weight_x[1] := 1 - weight_x[0];
		4819	end;
		4820	if ifx < 0 then
		4821	ifx := Pred(Width) - (-ifx mod Width)
		4822	else
		4823	if ifx > Pred(Width) then
		4824	ifx := ifx mod Width;
		4825	if ify < 0 then
		4826	ify := Pred(Height) - (-ify mod Height)
		4827	else
		4828	if ify > Pred(Height) then
		4829	ify := ify mod Height;
		4830	total_red := 0.0;
		4831	total_green := 0.0;
		4832	total_blue := 0.0;
		4833	for ix := 0 to 1 do
		4834	begin
		4835	for iy := 0 to 1 do
		4836	begin
		4837	if ify + iy < Height then
		4838	sli := ScanLine[ify + iy]
		4839	else
		4840	sli := ScanLine[Height - ify - iy];
		4841	if ifx + ix < Width then
		4842	begin
		4843	new_red := sli^[ifx + ix].r;
		4844	new_green := sli^[ifx + ix].g;
		4845	new_blue := sli^[ifx + ix].b;
		4846	end
		4847	else
		4848	begin
		4849	new_red := sli^[Width - ifx - ix].r;
		4850	new_green := sli^[Width - ifx - ix].g;
		4851	new_blue := sli^[Width - ifx - ix].b;
		4852	end;
		4853	weight := weight_x[ix] * weight_y[iy];
		4854	total_red := total_red + new_red * weight;
		4855	total_green := total_green + new_green * weight;
		4856	total_blue := total_blue + new_blue * weight;
		4857	end;
		4858	end;
		4859	case bitCount of
		4860	24:
		4861	begin
		4862	slo := Bmp.ScanLine[ty];
		4863	slo^[tx].r := Round(total_red);
		4864	slo^[tx].g := Round(total_green);
		4865	slo^[tx].b := Round(total_blue);
		4866	end;
		4867	else
		4868	// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
		4869	Exit;
		4870	end;
		4871	end;
		4872	end;
		4873	end;
		4874
		4875	function TDIB.SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
		4876	var
		4877	weight, Theta, cosTheta, sinTheta, sfrom_y, sfrom_x: Double;
		4878	ifrom_y, ifrom_x, xDiff, yDiff, to_y, to_x: Integer;
		4879	weight_x, weight_y: array[0..1] of Double;
		4880	ix, iy, new_red, new_green, new_blue: Integer;
		4881	total_red, total_green, total_blue: Double;
		4882	sli, slo: PLines;
		4883	begin
		4884	Result := True;
		4885	case BitCount of
		4886	32, 16, 8, 4, 1:
		4887	begin
		4888	Result := False;
		4889	Exit;
		4890	end;
		4891	end;
		4892	Theta := -Degree * Pi / 180;
		4893	sinTheta := Sin(Theta);
		4894	cosTheta := Cos(Theta);
		4895	xDiff := (Bmp.Width - Width) div 2;
		4896	yDiff := (Bmp.Height - Height) div 2;
		4897	for to_y := 0 to Pred(Bmp.Height) do
1	daniel-mar	4898	begin
4	daniel-mar	4899	for to_x := 0 to Pred(Bmp.Width) do
		4900	begin
		4901	sfrom_x := (cx + (to_x - cx) * cosTheta - (to_y - cy) * sinTheta) - xDiff;
		4902	ifrom_x := Trunc(sfrom_x);
		4903	sfrom_y := (cy + (to_x - cx) * sinTheta + (to_y - cy) * cosTheta) - yDiff;
		4904	ifrom_y := Trunc(sfrom_y);
		4905	if sfrom_y >= 0 then
		4906	begin
		4907	weight_y[1] := sfrom_y - ifrom_y;
		4908	weight_y[0] := 1 - weight_y[1];
		4909	end
		4910	else
		4911	begin
		4912	weight_y[0] := -(sfrom_y - ifrom_y);
		4913	weight_y[1] := 1 - weight_y[0];
		4914	end;
		4915	if sfrom_x >= 0 then
		4916	begin
		4917	weight_x[1] := sfrom_x - ifrom_x;
		4918	weight_x[0] := 1 - weight_x[1];
		4919	end
		4920	else
		4921	begin
		4922	weight_x[0] := -(sfrom_x - ifrom_x);
		4923	Weight_x[1] := 1 - weight_x[0];
		4924	end;
		4925	if ifrom_x < 0 then
		4926	ifrom_x := Pred(Width) - (-ifrom_x mod Width)
		4927	else
		4928	if ifrom_x > Pred(Width) then
		4929	ifrom_x := ifrom_x mod Width;
		4930	if ifrom_y < 0 then
		4931	ifrom_y := Pred(Height) - (-ifrom_y mod Height)
		4932	else
		4933	if ifrom_y > Pred(Height) then
		4934	ifrom_y := ifrom_y mod Height;
		4935	total_red := 0.0;
		4936	total_green := 0.0;
		4937	total_blue := 0.0;
		4938	for ix := 0 to 1 do
		4939	begin
		4940	for iy := 0 to 1 do
		4941	begin
		4942	if ifrom_y + iy < Height then
		4943	sli := ScanLine[ifrom_y + iy]
		4944	else
		4945	sli := ScanLine[Height - ifrom_y - iy];
		4946	if ifrom_x + ix < Width then
		4947	begin
		4948	new_red := sli^[ifrom_x + ix].r;
		4949	new_green := sli^[ifrom_x + ix].g;
		4950	new_blue := sli^[ifrom_x + ix].b;
		4951	end
		4952	else
		4953	begin
		4954	new_red := sli^[Width - ifrom_x - ix].r;
		4955	new_green := sli^[Width - ifrom_x - ix].g;
		4956	new_blue := sli^[Width - ifrom_x - ix].b;
		4957	end;
		4958	weight := weight_x[ix] * weight_y[iy];
		4959	total_red := total_red + new_red * weight;
		4960	total_green := total_green + new_green * weight;
		4961	total_blue := total_blue + new_blue * weight;
		4962	end;
		4963	end;
		4964	case bitCount of
		4965	24:
		4966	begin
		4967	slo := Bmp.ScanLine[to_y];
		4968	slo^[to_x].r := Round(total_red);
		4969	slo^[to_x].g := Round(total_green);
		4970	slo^[to_x].b := Round(total_blue);
		4971	end;
		4972	else
		4973	// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
		4974	Exit;
		4975	end;
		4976	end;
		4977	end;
		4978	end;
1	daniel-mar	4979
4	daniel-mar	4980	function TDIB.Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
		4981	var
		4982	x, y, dx, dy, sdx, sdy, xDiff, yDiff, isinTheta, icosTheta: Integer;
		4983	D, S: Pointer;
		4984	sinTheta, cosTheta, Theta: Double;
		4985	Col: TBGR;
		4986	i: byte;
		4987	color: DWORD;
		4988	P: PByte;
		4989	begin
		4990	D := nil;
		4991	S := nil;
		4992	Result := True;
		4993	dst.SetSize(Width, Height, Bitcount);
		4994	dst.Canvas.Brush.Color := clBlack;
		4995	Dst.Canvas.FillRect(Bounds(0, 0, Width, Height));
		4996	case BitCount of
		4997	32, 16:
		4998	begin
		4999	Result := False;
		5000	Exit;
		5001	end;
		5002	8, 4, 1:
		5003	begin
		5004	for i := 0 to 255 do
		5005	Dst.ColorTable[i] := ColorTable[i];
		5006	Dst.UpdatePalette;
		5007	end;
		5008	end;
		5009	Theta := -Angle * Pi / 180;
		5010	sinTheta := Sin(Theta);
		5011	cosTheta := Cos(Theta);
		5012	xDiff := (Dst.Width - Width) div 2;
		5013	yDiff := (Dst.Height - Height) div 2;
		5014	isinTheta := Round(sinTheta * $10000);
		5015	icosTheta := Round(cosTheta * $10000);
		5016	for y := 0 to Pred(Dst.Height) do
		5017	begin
		5018	case BitCount of
		5019	4, 1:
		5020	begin
		5021	D := Dst.ScanLine[y];
		5022	S := ScanLine[y];
		5023	end;
		5024	else
		5025	end;
		5026	sdx := Round(((cx + (-cx) * cosTheta - (y - cy) * sinTheta) - xDiff) * $10000);
		5027	sdy := Round(((cy + (-cy) * sinTheta + (y - cy) * cosTheta) - yDiff) * $10000);
		5028	for x := 0 to Pred(Dst.Width) do
		5029	begin
		5030	dx := (sdx shr 16);
		5031	dy := (sdy shr 16);
		5032	if (dx > -1) and (dx < Width) and (dy > -1) and (dy < Height) then
		5033	begin
		5034	case bitcount of
		5035	8, 24: Dst.pixels[x, y] := Pixels[dx, dy];
		5036	4:
		5037	begin
		5038	pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
		5039	color := col.r + col.g + col.b;
		5040	Inc(PByte(S));
		5041	P := @PArrayByte(D)[x shr 1];
		5042	P^ := (P^ and Mask4n[x and 1]) or (color shl Shift4[x and 1]);
		5043	end;
		5044	1:
		5045	begin
		5046	pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
		5047	color := col.r + col.g + col.b;
		5048	Inc(PByte(S));
		5049	P := @PArrayByte(D)[X shr 3];
		5050	P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
		5051	end;
		5052	end;
		5053	end;
		5054	Inc(sdx, icosTheta);
		5055	Inc(sdy, isinTheta);
		5056	end;
		5057	end;
		5058	end;
1	daniel-mar	5059
4	daniel-mar	5060	procedure TDIB.GaussianBlur(Bmp: TDIB; Amount: Integer);
		5061	var
		5062	i: Integer;
		5063	begin
		5064	for i := 1 to Amount do
		5065	Bmp.SplitBlur(i);
		5066	end;
1	daniel-mar	5067
4	daniel-mar	5068	procedure TDIB.SplitBlur(Amount: Integer);
		5069	var
		5070	Lin1, Lin2: PLines;
		5071	cx, x, y: Integer;
		5072	Buf: array[0..3] of TBGR;
		5073	D: Pointer;
1	daniel-mar	5074
4	daniel-mar	5075	begin
		5076	case Bitcount of
		5077	32, 16, 8, 4, 1: Exit;
		5078	end;
		5079	for y := 0 to Pred(Height) do
		5080	begin
		5081	Lin1 := ScanLine[TrimInt(y + Amount, 0, Pred(Height))];
		5082	Lin2 := ScanLine[TrimInt(y - Amount, 0, Pred(Height))];
		5083	D := ScanLine[y];
		5084	for x := 0 to Pred(Width) do
		5085	begin
		5086	cx := TrimInt(x + Amount, 0, Pred(Width));
		5087	Buf[0] := Lin1[cx];
		5088	Buf[1] := Lin2[cx];
		5089	cx := TrimInt(x - Amount, 0, Pred(Width));
		5090	Buf[2] := Lin1[cx];
		5091	Buf[3] := Lin2[cx];
		5092	PBGR(D)^.b := (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b) shr 2;
		5093	PBGR(D)^.g := (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g) shr 2;
		5094	PBGR(D)^.r := (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r) shr 2;
		5095	Inc(PBGR(D));
		5096	end;
		5097	end;
		5098	end;
1	daniel-mar	5099
4	daniel-mar	5100	function TDIB.Twist(bmp: TDIB; Amount: byte): Boolean;
		5101	var
		5102	fxmid, fymid: Single;
		5103	txmid, tymid: Single;
		5104	fx, fy: Single;
		5105	tx2, ty2: Single;
		5106	r: Single;
		5107	theta: Single;
		5108	ifx, ify: Integer;
		5109	dx, dy: Single;
		5110	OFFSET: Single;
		5111	ty, tx, ix, iy: Integer;
		5112	weight_x, weight_y: array[0..1] of Single;
		5113	weight: Single;
		5114	new_red, new_green, new_blue: Integer;
		5115	total_red, total_green, total_blue: Single;
		5116	sli, slo: PLines;
1	daniel-mar	5117
4	daniel-mar	5118	function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
		5119	begin
		5120	if xt = 0 then
		5121	if yt > 0 then
		5122	Result := Pi / 2
		5123	else
		5124	Result := -(Pi / 2)
		5125	else
		5126	begin
		5127	Result := ArcTan(yt / xt);
		5128	if xt < 0 then
		5129	Result := Pi + ArcTan(yt / xt);
1	daniel-mar	5130	end;
		5131	end;
4	daniel-mar	5132
		5133	begin
		5134	Result := True;
		5135	case BitCount of
		5136	32, 16, 8, 4, 1:
		5137	begin
		5138	Result := False;
		5139	Exit;
		5140	end;
		5141	end;
		5142	if Amount = 0 then
		5143	Amount := 1;
		5144	OFFSET := -(Pi / 2);
		5145	dx := Pred(Width);
		5146	dy := Pred(Height);
		5147	r := Sqrt(dx * dx + dy * dy);
		5148	tx2 := r;
		5149	ty2 := r;
		5150	txmid := (Pred(Width)) / 2;
		5151	tymid := (Pred(Height)) / 2;
		5152	fxmid := (Pred(Width)) / 2;
		5153	fymid := (Pred(Height)) / 2;
		5154	if tx2 >= Width then
		5155	tx2 := Pred(Width);
		5156	if ty2 >= Height then
		5157	ty2 := Pred(Height);
		5158	for ty := 0 to Round(ty2) do
		5159	begin
		5160	for tx := 0 to Round(tx2) do
		5161	begin
		5162	dx := tx - txmid;
		5163	dy := ty - tymid;
		5164	r := Sqrt(dx * dx + dy * dy);
		5165	if r = 0 then
		5166	begin
		5167	fx := 0;
		5168	fy := 0;
		5169	end
		5170	else
		5171	begin
		5172	theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
		5173	fx := r * Cos(theta);
		5174	fy := r * Sin(theta);
		5175	end;
		5176	fx := fx + fxmid;
		5177	fy := fy + fymid;
		5178	ify := Trunc(fy);
		5179	ifx := Trunc(fx);
		5180	if fy >= 0 then
		5181	begin
		5182	weight_y[1] := fy - ify;
		5183	weight_y[0] := 1 - weight_y[1];
		5184	end
		5185	else
		5186	begin
		5187	weight_y[0] := -(fy - ify);
		5188	weight_y[1] := 1 - weight_y[0];
		5189	end;
		5190	if fx >= 0 then
		5191	begin
		5192	weight_x[1] := fx - ifx;
		5193	weight_x[0] := 1 - weight_x[1];
		5194	end
		5195	else
		5196	begin
		5197	weight_x[0] := -(fx - ifx);
		5198	Weight_x[1] := 1 - weight_x[0];
		5199	end;
		5200	if ifx < 0 then
		5201	ifx := Pred(Width) - (-ifx mod Width)
		5202	else
		5203	if ifx > Pred(Width) then
		5204	ifx := ifx mod Width;
		5205	if ify < 0 then
		5206	ify := Pred(Height) - (-ify mod Height)
		5207	else
		5208	if ify > Pred(Height) then
		5209	ify := ify mod Height;
		5210	total_red := 0.0;
		5211	total_green := 0.0;
		5212	total_blue := 0.0;
		5213	for ix := 0 to 1 do
		5214	begin
		5215	for iy := 0 to 1 do
		5216	begin
		5217	if ify + iy < Height then
		5218	sli := ScanLine[ify + iy]
		5219	else
		5220	sli := ScanLine[Height - ify - iy];
		5221	if ifx + ix < Width then
		5222	begin
		5223	new_red := sli^[ifx + ix].r;
		5224	new_green := sli^[ifx + ix].g;
		5225	new_blue := sli^[ifx + ix].b;
		5226	end
		5227	else
		5228	begin
		5229	new_red := sli^[Width - ifx - ix].r;
		5230	new_green := sli^[Width - ifx - ix].g;
		5231	new_blue := sli^[Width - ifx - ix].b;
		5232	end;
		5233	weight := weight_x[ix] * weight_y[iy];
		5234	total_red := total_red + new_red * weight;
		5235	total_green := total_green + new_green * weight;
		5236	total_blue := total_blue + new_blue * weight;
		5237	end;
		5238	end;
		5239	case bitCount of
		5240	24:
		5241	begin
		5242	slo := bmp.ScanLine[ty];
		5243	slo^[tx].r := Round(total_red);
		5244	slo^[tx].g := Round(total_green);
		5245	slo^[tx].b := Round(total_blue);
		5246	end;
		5247	else
		5248	// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
		5249	Exit;
		5250	end;
		5251	end;
		5252	end;
1	daniel-mar	5253	end;
		5254
4	daniel-mar	5255	function TDIB.TrimInt(i, Min, Max: Integer): Integer;
		5256	begin
		5257	if i > Max then
		5258	Result := Max
		5259	else
		5260	if i < Min then
		5261	Result := Min
		5262	else
		5263	Result := i;
		5264	end;
		5265
		5266	function TDIB.IntToByte(i: Integer): Byte;
		5267	begin
		5268	if i > 255 then
		5269	Result := 255
		5270	else
		5271	if i < 0 then
		5272	Result := 0
		5273	else
		5274	Result := i;
		5275	end;
		5276
		5277	//--------------------------------------------------------------------------------------------------
		5278	// End of these New Special Effect //
		5279	// Please contributes to add effects and filters to this collection //
		5280	// Please, work to implement 32,16,8,4,2 BitCount's DIB //
		5281	// Have fun - Mickey - Good job //
		5282	//--------------------------------------------------------------------------------------------------
		5283
		5284	function TDIB.GetAlphaChannel: TDIB;
		5285	begin
		5286	RetAlphaChannel(Result);
		5287
		5288	FFreeList.Add(Result);
		5289	end;
		5290
		5291	procedure TDIB.SetAlphaChannel(const Value: TDIB);
		5292	begin
		5293	if not AssignAlphaChannel(Value{$IFNDEF VER4UP}, False{$ENDIF}) then
		5294	Exception.Create('Cannot set alphachannel from DIB.');
		5295	end;
		5296
		5297	procedure TDIB.Fill(aColor: TColor);
		5298	begin
		5299	Canvas.Brush.Color := aColor;
		5300	Canvas.FillRect(ClientRect);
		5301	end;
		5302
		5303	function TDIB.GetClientRect: TRect;
		5304	begin
		5305	Result := Bounds(0, 0, Width, Height);
		5306	end;
		5307
1	daniel-mar	5308	{ TCustomDXDIB }
		5309
		5310	constructor TCustomDXDIB.Create(AOnwer: TComponent);
		5311	begin
		5312	inherited Create(AOnwer);
		5313	FDIB := TDIB.Create;
		5314	end;
		5315
		5316	destructor TCustomDXDIB.Destroy;
		5317	begin
		5318	FDIB.Free;
		5319	inherited Destroy;
		5320	end;
		5321
		5322	procedure TCustomDXDIB.SetDIB(Value: TDIB);
		5323	begin
		5324	FDIB.Assign(Value);
		5325	end;
		5326
		5327	{ TCustomDXPaintBox }
		5328
		5329	constructor TCustomDXPaintBox.Create(AOwner: TComponent);
		5330	begin
		5331	inherited Create(AOwner);
		5332	FDIB := TDIB.Create;
		5333
		5334	ControlStyle := ControlStyle + [csReplicatable];
		5335	Height := 105;
		5336	Width := 105;
		5337	end;
		5338
		5339	destructor TCustomDXPaintBox.Destroy;
		5340	begin
		5341	FDIB.Free;
		5342	inherited Destroy;
		5343	end;
		5344
		5345	function TCustomDXPaintBox.GetPalette: HPALETTE;
		5346	begin
		5347	Result := FDIB.Palette;
		5348	end;
		5349
		5350	procedure TCustomDXPaintBox.Paint;
		5351
		5352	procedure Draw2(Width, Height: Integer);
		5353	begin
4	daniel-mar	5354	if (Width <> FDIB.Width) or (Height <> FDIB.Height) then
1	daniel-mar	5355	begin
		5356	if FCenter then
		5357	begin
4	daniel-mar	5358	inherited Canvas.StretchDraw(Bounds(-(Width - ClientWidth) div 2,
		5359	-(Height - ClientHeight) div 2, Width, Height), FDIB);
		5360	end
		5361	else
1	daniel-mar	5362	begin
		5363	inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
		5364	end;
4	daniel-mar	5365	end
		5366	else
1	daniel-mar	5367	begin
		5368	if FCenter then
		5369	begin
4	daniel-mar	5370	inherited Canvas.Draw(-(Width - ClientWidth) div 2, -(Height - ClientHeight) div 2,
1	daniel-mar	5371	FDIB);
4	daniel-mar	5372	end
		5373	else
1	daniel-mar	5374	begin
		5375	inherited Canvas.Draw(0, 0, FDIB);
		5376	end;
		5377	end;
		5378	end;
		5379
		5380	var
		5381	r, r2: Single;
		5382	ViewWidth2, ViewHeight2: Integer;
		5383	begin
		5384	inherited Paint;
		5385
		5386	with inherited Canvas do
		5387	begin
		5388	if (csDesigning in ComponentState) then
		5389	begin
		5390	Pen.Style := psDash;
		5391	Brush.Style := bsClear;
		5392	Rectangle(0, 0, Width, Height);
		5393	end;
		5394
		5395	if FDIB.Empty then Exit;
		5396
4	daniel-mar	5397	if (FViewWidth > 0) or (FViewHeight > 0) then
1	daniel-mar	5398	begin
		5399	ViewWidth2 := FViewWidth;
4	daniel-mar	5400	if ViewWidth2 = 0 then ViewWidth2 := FDIB.Width;
1	daniel-mar	5401	ViewHeight2 := FViewHeight;
4	daniel-mar	5402	if ViewHeight2 = 0 then ViewHeight2 := FDIB.Height;
1	daniel-mar	5403
		5404	if FAutoStretch then
		5405	begin
4	daniel-mar	5406	if (ClientWidth < ViewWidth2) or (ClientHeight < ViewHeight2) then
1	daniel-mar	5407	begin
4	daniel-mar	5408	r := ViewWidth2 / ClientWidth;
		5409	r2 := ViewHeight2 / ClientHeight;
		5410	if r > r2 then
1	daniel-mar	5411	r := r2;
4	daniel-mar	5412	Draw2(Round(r * ClientWidth), Round(r * ClientHeight));
		5413	end
		5414	else
1	daniel-mar	5415	Draw2(ViewWidth2, ViewHeight2);
4	daniel-mar	5416	end
		5417	else
1	daniel-mar	5418	Draw2(ViewWidth2, ViewHeight2);
4	daniel-mar	5419	end
		5420	else
1	daniel-mar	5421	begin
		5422	if FAutoStretch then
		5423	begin
4	daniel-mar	5424	if (FDIB.Width > ClientWidth) or (FDIB.Height > ClientHeight) then
1	daniel-mar	5425	begin
4	daniel-mar	5426	r := ClientWidth / FDIB.Width;
		5427	r2 := ClientHeight / FDIB.Height;
		5428	if r > r2 then
1	daniel-mar	5429	r := r2;
4	daniel-mar	5430	Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
		5431	end
		5432	else
1	daniel-mar	5433	Draw2(FDIB.Width, FDIB.Height);
4	daniel-mar	5434	end
		5435	else
		5436	if FStretch then
1	daniel-mar	5437	begin
4	daniel-mar	5438	if FKeepAspect then
		5439	begin
		5440	r := ClientWidth / FDIB.Width;
		5441	r2 := ClientHeight / FDIB.Height;
		5442	if r > r2 then
		5443	r := r2;
		5444	Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
		5445	end
		5446	else
		5447	Draw2(ClientWidth, ClientHeight);
		5448	end
		5449	else
		5450	Draw2(FDIB.Width, FDIB.Height);
1	daniel-mar	5451	end;
		5452	end;
		5453	end;
		5454
		5455	procedure TCustomDXPaintBox.SetAutoStretch(Value: Boolean);
		5456	begin
4	daniel-mar	5457	if FAutoStretch <> Value then
1	daniel-mar	5458	begin
		5459	FAutoStretch := Value;
		5460	Invalidate;
		5461	end;
		5462	end;
		5463
		5464	procedure TCustomDXPaintBox.SetCenter(Value: Boolean);
		5465	begin
4	daniel-mar	5466	if FCenter <> Value then
1	daniel-mar	5467	begin
		5468	FCenter := Value;
		5469	Invalidate;
		5470	end;
		5471	end;
		5472
		5473	procedure TCustomDXPaintBox.SetDIB(Value: TDIB);
		5474	begin
4	daniel-mar	5475	if FDIB <> Value then
1	daniel-mar	5476	begin
		5477	FDIB.Assign(Value);
		5478	Invalidate;
		5479	end;
		5480	end;
		5481
		5482	procedure TCustomDXPaintBox.SetKeepAspect(Value: Boolean);
		5483	begin
4	daniel-mar	5484	if Value <> FKeepAspect then
1	daniel-mar	5485	begin
		5486	FKeepAspect := Value;
		5487	Invalidate;
		5488	end;
		5489	end;
		5490
		5491	procedure TCustomDXPaintBox.SetStretch(Value: Boolean);
		5492	begin
4	daniel-mar	5493	if Value <> FStretch then
1	daniel-mar	5494	begin
		5495	FStretch := Value;
		5496	Invalidate;
		5497	end;
		5498	end;
		5499
		5500	procedure TCustomDXPaintBox.SetViewWidth(Value: Integer);
		5501	begin
4	daniel-mar	5502	if Value < 0 then Value := 0;
		5503	if Value <> FViewWidth then
1	daniel-mar	5504	begin
		5505	FViewWidth := Value;
		5506	Invalidate;
		5507	end;
		5508	end;
		5509
		5510	procedure TCustomDXPaintBox.SetViewHeight(Value: Integer);
		5511	begin
4	daniel-mar	5512	if Value < 0 then Value := 0;
		5513	if Value <> FViewHeight then
1	daniel-mar	5514	begin
		5515	FViewHeight := Value;
		5516	Invalidate;
		5517	end;
		5518	end;
		5519
4	daniel-mar	5520	{ DXFusion -> }
		5521
		5522	function PosValue(Value: Integer): Integer;
		5523	begin
		5524	if Value < 0 then result := 0 else result := Value;
		5525	end;
		5526
		5527	procedure TDIB.CreateDIBFromBitmap(const Bitmap: TBitmap);
		5528	var
		5529	pf: Integer;
		5530	begin
		5531	if Bitmap.PixelFormat = pf32bit then pf := 32 else pf := 24;
		5532	SetSize(Bitmap.Width, Bitmap.Height, pf); {always >=24}
		5533	Canvas.Draw(0, 0, Bitmap);
		5534	end;
		5535
		5536	function TDIB.CreateBitmapFromDIB: TBitmap;
		5537	//var
		5538	// X, Y: Integer;
		5539	begin
		5540	Result := TBitmap.Create;
		5541	if BitCount = 32 then
		5542	Result.PixelFormat := pf32bit
		5543	else if BitCount = 24 then
		5544	Result.PixelFormat := pf24bit
		5545	else if BitCount = 16 then
		5546	Result.PixelFormat := pf16bit
		5547	else if BitCount = 8 then
		5548	Result.PixelFormat := pf8bit
		5549	else Result.PixelFormat := pf24bit;
		5550	Result.Width := Width;
		5551	Result.Height := Height;
		5552	Result.Canvas.Draw(0, 0, Self);
		5553	// for Y := 0 to Height - 1 do
		5554	// for X := 0 to Width - 1 do
		5555	// Result.Canvas.Pixels[X, Y] := Canvas.Pixels[X, Y];
		5556	end;
		5557
		5558	procedure TDIB.DrawTo(SrcDIB: TDIB; X, Y, Width, Height,
		5559	SourceX, SourceY: Integer);
		5560	begin
		5561	SrcDIB.DrawOn(Rect(X, Y, Width, Height), Self.Canvas, SourceX, SourceY);
		5562	end;
		5563
		5564	procedure TDIB.DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
		5565	SourceX, SourceY: Integer; const Color: TColor);
		5566	var
		5567	i, j: Integer;
		5568	k1, k2: Integer;
		5569	n: Integer;
		5570	p1, p2: PByteArray;
		5571
		5572	Startk1, Startk2: Integer;
		5573
		5574	StartY: Integer;
		5575	EndY: Integer;
		5576
		5577	DestStartY: Integer;
		5578	begin
		5579	if Self.BitCount <> 24 then Exit;
		5580	if SrcDIB.BitCount <> 24 then Exit;
		5581	Startk1 := 3 * SourceX;
		5582	Startk2 := 3 * X;
		5583
		5584	DestStartY := Y - SourceY;
		5585
		5586	StartY := SourceY;
		5587	EndY := SourceY + Height;
		5588
		5589	if (StartY + DestStartY < 0) then
		5590	StartY := -DestStartY;
		5591	if (EndY + DestStartY > Self.Height) then
		5592	EndY := Self.Height - DestStartY;
		5593
		5594	if (StartY < 0) then
		5595	StartY := 0;
		5596	if (EndY > SrcDIB.Height) then
		5597	EndY := SrcDIB.Height;
		5598
		5599	for j := StartY to EndY - 1 do
		5600	begin
		5601	p1 := Self.Scanline[j + DestStartY];
		5602	p2 := SrcDIB.Scanline[j];
		5603
		5604	k1 := Startk1;
		5605	k2 := Startk2;
		5606
		5607	for i := SourceX to SourceX + Width - 1 do
		5608	begin
		5609	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		5610
		5611	if not (n = Color) then
		5612	begin
		5613	p1[k2] := p2[k1];
		5614	p1[k2 + 1] := p2[k1 + 1];
		5615	p1[k2 + 2] := p2[k1 + 2];
		5616	end;
		5617
		5618	k1 := k1 + 3;
		5619	k2 := k2 + 3;
		5620	end;
		5621	end;
		5622	end;
		5623
		5624	procedure TDIB.DrawShadow(SrcDIB: TDIB; X, Y, Width, Height,
		5625	Frame: Integer; FilterMode: TFilterMode);
		5626	var
		5627	i, j: Integer;
		5628	p1, p2: PByte;
		5629	FW: Integer;
		5630	begin
		5631	if Self.BitCount <> 24 then Exit;
		5632	if SrcDIB.BitCount <> 24 then Exit;
		5633
		5634	FW := Frame * Width;
		5635	for i := 1 to Height - 1 do
		5636	begin
		5637	p1 := Self.Scanline[i + Y];
		5638	p2 := SrcDIB.Scanline[i];
		5639	Inc(p1, 3 * (X + 1));
		5640	Inc(p2, 3 * (FW + 1));
		5641	for j := 1 to Width - 1 do
		5642	begin
		5643	if (p2^ = 0) then
		5644	begin
		5645	case FilterMode of
		5646	fmNormal, fmMix50:
		5647	begin
		5648	p1^ := p1^ shr 1; // Blue
		5649	Inc(p1);
		5650	p1^ := p1^ shr 1; // Green
		5651	Inc(p1);
		5652	p1^ := p1^ shr 1; // Red
		5653	Inc(p1);
		5654	end;
		5655	fmMix25:
		5656	begin
		5657	p1^ := p1^ - p1^ shr 2; // Blue
		5658	Inc(p1);
		5659	p1^ := p1^ - p1^ shr 2; // Green
		5660	Inc(p1);
		5661	p1^ := p1^ - p1^ shr 2; // Red
		5662	Inc(p1);
		5663	end;
		5664	fmMix75:
		5665	begin
		5666	p1^ := p1^ shr 2; // Blue
		5667	Inc(p1);
		5668	p1^ := p1^ shr 2; // Green
		5669	Inc(p1);
		5670	p1^ := p1^ shr 2; // Red
		5671	Inc(p1);
		5672	end;
		5673	end;
		5674	end
		5675	else
		5676	Inc(p1, 3); // Not in the loop...
		5677	Inc(p2, 3);
		5678	end;
		5679	end;
		5680	end;
		5681
		5682	procedure TDIB.DrawShadows(SrcDIB: TDIB; X, Y, Width, Height,
		5683	Frame: Integer; Alpha: Byte);
		5684	{plynule nastavovani stiny dle alpha}
		5685	type
		5686	P3ByteArray = ^T3ByteArray;
		5687	T3ByteArray = array[0..32767] of TBGR;
		5688	var
		5689	i, j, l1, l2: Integer;
		5690	p1, p2: P3ByteArray;
		5691	FW: Integer;
		5692	begin
		5693	if Self.BitCount <> 24 then Exit;
		5694	if SrcDIB.BitCount <> 24 then Exit;
		5695
		5696	FW := Frame * Width;
		5697	for i := 0 to Height - 1 do
		5698	begin
		5699	p1 := Self.Scanline[i + Y];
		5700	p2 := SrcDIB.Scanline[i];
		5701	l1 := X;
		5702	l2 := FW;
		5703	for j := 0 to Width - 1 do
		5704	begin
		5705	if (p2[j + l2].B = 0) and (p2[j + l2].G = 0) and (p2[j + l2].R = 0) then
		5706	begin
		5707	p1[J + l1].B := Round(p1[J + l1].B / $FF * Alpha);
		5708	p1[J + l1].G := Round(p1[J + l1].G / $FF * Alpha);
		5709	p1[J + l1].R := Round(p1[J + l1].R / $FF * Alpha);
		5710	end
		5711	end;
		5712	end;
		5713	end;
		5714
		5715	procedure TDIB.DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
		5716	Frame: Integer);
		5717	var
		5718	frameoffset, i, j: Integer;
		5719	p1, p2: pByte;
		5720	XOffset: Integer;
		5721	begin
		5722	if Self.BitCount <> 24 then Exit;
		5723	if SrcDIB.BitCount <> 24 then Exit;
		5724
		5725	frameoffset := 3 * (Frame * Width) + 3;
		5726	XOffset := 3 * X + 3;
		5727	for i := 1 to Height - 1 do
		5728	begin
		5729	p1 := Self.Scanline[i + Y];
		5730	p2 := SrcDIB.Scanline[i];
		5731	inc(p1, XOffset);
		5732	inc(p2, frameoffset);
		5733	for j := 1 to Width - 1 do
		5734	begin
		5735	p1^ := (p2^ * p1^) shr 8; // R
		5736	inc(p1);
		5737	inc(p2);
		5738	p1^ := (p2^ * p1^) shr 8; // G
		5739	inc(p1);
		5740	inc(p2);
		5741	p1^ := (p2^ * p1^) shr 8; // B
		5742	inc(p1);
		5743	inc(p2);
		5744	end;
		5745	end;
		5746	end;
		5747
		5748	procedure TDIB.DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
		5749	SourceX, SourceY: Integer; const Color: TColor; FilterMode: TFilterMode);
		5750	var
		5751	i, j: Integer;
		5752	k1, k2: Integer;
		5753	n: Integer;
		5754	p1, p2: PByteArray;
		5755	BitSwitch1, BitSwitch2: Boolean;
		5756
		5757	Startk1, Startk2: Integer;
		5758	StartY: Integer;
		5759	EndY: Integer;
		5760
		5761	DestStartY: Integer;
		5762	begin
		5763	if Self.BitCount <> 24 then Exit;
		5764	if SrcDIB.BitCount <> 24 then Exit;
		5765
		5766	Startk1 := 3 * SourceX;
		5767	Startk2 := 3 * X;
		5768
		5769	DestStartY := Y - SourceY;
		5770
		5771	StartY := SourceY;
		5772	EndY := SourceY + Height;
		5773
		5774	if (StartY + DestStartY < 0) then
		5775	StartY := -DestStartY;
		5776	if (EndY + DestStartY > Self.Height) then
		5777	EndY := Self.Height - DestStartY;
		5778
		5779	if (StartY < 0) then
		5780	StartY := 0;
		5781	if (EndY > SrcDIB.Height) then
		5782	EndY := SrcDIB.Height;
		5783
		5784	if Odd(Y) then BitSwitch1 := true else BitSwitch1 := false;
		5785	if Odd(X) then BitSwitch2 := true else BitSwitch2 := false;
		5786
		5787	for j := StartY to EndY - 1 do
		5788	begin
		5789	BitSwitch1 := not BitSwitch1;
		5790	p1 := Self.Scanline[j + DestStartY];
		5791	p2 := SrcDIB.Scanline[j];
		5792
		5793	k1 := Startk1;
		5794	k2 := Startk2;
		5795
		5796	for i := SourceX to SourceX + Width - 1 do
		5797	begin
		5798	BitSwitch2 := not BitSwitch2;
		5799
		5800	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		5801
		5802	case FilterMode of
		5803	fmNormal, fmMix50: if not (n = Color) and (BitSwitch1 xor BitSwitch2) then
		5804	begin
		5805	p1[k2] := p2[k1];
		5806	p1[k2 + 1] := p2[k1 + 1];
		5807	p1[k2 + 2] := p2[k1 + 2];
		5808	end;
		5809	fmMix25: if not (n = Color) and (BitSwitch1 and BitSwitch2) then
		5810	begin
		5811	p1[k2] := p2[k1];
		5812	p1[k2 + 1] := p2[k1 + 1];
		5813	p1[k2 + 2] := p2[k1 + 2];
		5814	end;
		5815	fmMix75: if not (n = Color) and (BitSwitch1 or BitSwitch2) then
		5816	begin
		5817	p1[k2] := p2[k1];
		5818	p1[k2 + 1] := p2[k1 + 1];
		5819	p1[k2 + 2] := p2[k1 + 2];
		5820	end;
		5821	end;
		5822
		5823	k1 := k1 + 3;
		5824	k2 := k2 + 3;
		5825	end;
		5826	end;
		5827	end;
		5828
		5829	procedure TDIB.DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height, Alpha, Frame:
		5830	Integer);
		5831	var
		5832	frameoffset, i, j, Wid: Integer;
		5833	p1, p2: pByte;
		5834	begin
		5835	if Self.BitCount <> 24 then Exit;
		5836	if SrcDIB.BitCount <> 24 then Exit;
		5837
		5838	if (Alpha < 1) or (Alpha > 256) then Exit;
		5839	Wid := Width shl 1 + Width;
		5840	frameoffset := Wid * Frame;
		5841	for i := 1 to Height - 1 do
		5842	begin
		5843	if (i + Y) > (Self.Height - 1) then Break; //add 25.5.2004 JB.
		5844	p1 := Self.Scanline[i + Y];
		5845	p2 := SrcDIB.Scanline[i];
		5846	inc(p1, X shl 1 + X + 3);
		5847	inc(p2, frameoffset + 3);
		5848	for j := 3 to Wid - 4 do
		5849	begin
		5850	inc(p1^, (Alpha - p1^) * p2^ shr 8);
		5851	inc(p1);
		5852	inc(p2);
		5853	end;
		5854	end;
		5855	end;
		5856
		5857	procedure TDIB.DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
		5858	SourceX, SourceY: Integer; const Color: TColor);
		5859	var
		5860	i, j: Integer;
		5861	k1, k2: Integer;
		5862	n: Integer;
		5863	p1, p2: PByteArray;
		5864
		5865	Startk1, Startk2: Integer;
		5866	StartY: Integer;
		5867	EndY: Integer;
		5868
		5869	DestStartY: Integer;
		5870	begin
		5871	if Self.BitCount <> 24 then Exit;
		5872	if SrcDIB.BitCount <> 24 then Exit;
		5873
		5874	Startk1 := 3 * SourceX;
		5875	Startk2 := 3 * X;
		5876
		5877	DestStartY := Y - SourceY;
		5878
		5879	StartY := SourceY;
		5880	EndY := SourceY + Height;
		5881
		5882	if (StartY + DestStartY < 0) then
		5883	StartY := -DestStartY;
		5884	if (EndY + DestStartY > Self.Height) then
		5885	EndY := Self.Height - DestStartY;
		5886
		5887	if (StartY < 0) then
		5888	StartY := 0;
		5889	if (EndY > SrcDIB.Height) then
		5890	EndY := SrcDIB.Height;
		5891
		5892	for j := StartY to EndY - 1 do
		5893	begin
		5894	p1 := Self.Scanline[j + DestStartY];
		5895	p2 := SrcDIB.Scanline[j];
		5896
		5897	k1 := Startk1;
		5898	k2 := Startk2;
		5899
		5900	for i := SourceX to SourceX + Width - 1 do
		5901	begin
		5902	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		5903
		5904	if not (n = Color) then
		5905	begin
		5906	p1[k2] := (p1[k2] + p2[k1]) shr 1;
		5907	p1[k2 + 1] := (p1[k2 + 1] + p2[k1 + 1]) shr 1;
		5908	p1[k2 + 2] := (p1[k2 + 2] + p2[k1 + 2]) shr 1;
		5909	end;
		5910
		5911	k1 := k1 + 3;
		5912	k2 := k2 + 3;
		5913	end;
		5914	end;
		5915	end;
		5916
		5917	procedure TDIB.DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
		5918	SourceX, SourceY, Alpha: Integer; const Color: TColor);
		5919	var
		5920	i, j: Integer;
		5921	k1, k2: Integer;
		5922	n: Integer;
		5923	p1, p2: PByteArray;
		5924
		5925	Startk1, Startk2: Integer;
		5926	StartY: Integer;
		5927	EndY: Integer;
		5928
		5929	DestStartY: Integer;
		5930	begin
		5931	if Self.BitCount <> 24 then Exit;
		5932	if SrcDIB.BitCount <> 24 then Exit;
		5933
		5934	Startk1 := 3 * SourceX;
		5935	Startk2 := 3 * x;
		5936
		5937	DestStartY := Y - SourceY;
		5938
		5939	StartY := SourceY;
		5940	EndY := SourceY + Height;
		5941
		5942	if (EndY + DestStartY > Self.Height) then
		5943	EndY := Self.Height - DestStartY;
		5944
		5945	if (EndY > SrcDIB.Height) then
		5946	EndY := SrcDIB.Height;
		5947
		5948	if (StartY < 0) then
		5949	StartY := 0;
		5950
		5951	if (StartY + DestStartY < 0) then
		5952	StartY := DestStartY;
		5953
		5954	for j := StartY to EndY - 1 do
		5955	begin
		5956	p1 := Self.Scanline[j + DestStartY];
		5957	p2 := SrcDIB.Scanline[j];
		5958
		5959	k1 := Startk1;
		5960	k2 := Startk2;
		5961
		5962	for i := SourceX to SourceX + Width - 1 do
		5963	begin
		5964	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		5965
		5966	if not (n = Color) then
		5967	begin
		5968	p1[k2] := (p1[k2] * (256 - Alpha) + p2[k1] * Alpha) shr 8;
		5969	p1[k2 + 1] := (p1[k2 + 1] * (256 - Alpha) + p2[k1 + 1] * Alpha) shr 8;
		5970	p1[k2 + 2] := (p1[k2 + 2] * (256 - Alpha) + p2[k1 + 2] * Alpha) shr 8;
		5971	end;
		5972
		5973	k1 := k1 + 3;
		5974	k2 := k2 + 3;
		5975	end;
		5976	end;
		5977	end;
		5978
		5979	procedure TDIB.DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y,
		5980	Width, Height, SourceX, SourceY: Integer);
		5981	var
		5982	i, j: Integer;
		5983	k1, k2, k3: Integer;
		5984	p1, p2, p3: PByteArray;
		5985
		5986	Startk1, Startk2: Integer;
		5987	StartY: Integer;
		5988	EndY: Integer;
		5989
		5990	DestStartY: Integer;
		5991	begin
		5992	if Self.BitCount <> 24 then Exit;
		5993	if SrcDIB.BitCount <> 24 then Exit;
		5994
		5995	Startk1 := 3 * SourceX;
		5996	Startk2 := 3 * x;
		5997
		5998	DestStartY := Y - SourceY;
		5999
		6000	StartY := SourceY;
		6001	EndY := SourceY + Height;
		6002
		6003	if (EndY + DestStartY > Self.Height) then
		6004	EndY := Self.Height - DestStartY;
		6005
		6006	if (EndY > SrcDIB.Height) then
		6007	EndY := SrcDIB.Height;
		6008
		6009	if (StartY < 0) then
		6010	StartY := 0;
		6011
		6012	if (StartY + DestStartY < 0) then
		6013	StartY := DestStartY;
		6014
		6015	for j := StartY to EndY - 1 do
		6016	begin
		6017	p1 := Self.Scanline[j + DestStartY];
		6018	p2 := SrcDIB.Scanline[j];
		6019	p3 := MaskDIB.Scanline[j];
		6020
		6021	k1 := Startk1;
		6022	k2 := Startk2;
		6023	k3 := 0;
		6024
		6025	for i := SourceX to SourceX + Width - 1 do
		6026	begin
		6027	p1[k2] := (p1[k2] * (256 - p3[k3]) + p2[k1] * p3[k3]) shr 8;
		6028	p1[k2 + 1] := (p1[k2 + 1] * (256 - p3[k3]) + p2[k1 + 1] * p3[k3]) shr 8;
		6029	p1[k2 + 2] := (p1[k2 + 2] * (256 - p3[k3]) + p2[k1 + 2] * p3[k3]) shr 8;
		6030
		6031	k1 := k1 + 3;
		6032	k2 := k2 + 3;
		6033	k3 := k3 + 3;
		6034	end;
		6035	end;
		6036	end;
		6037
		6038	procedure TDIB.DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height,
		6039	SourceX, SourceY: Integer; const Color: TColor);
		6040	var
		6041	i, j, r, g, b: Integer;
		6042	k1, k2: Integer;
		6043	n: Integer;
		6044	p1, p2: PByteArray;
		6045
		6046	Startk1, Startk2: Integer;
		6047	StartY: Integer;
		6048	EndY: Integer;
		6049
		6050	DestStartY: Integer;
		6051	begin
		6052	if Self.BitCount <> 24 then Exit;
		6053	if SrcDIB.BitCount <> 24 then Exit;
		6054
		6055	Startk1 := 3 * SourceX;
		6056	Startk2 := 3 * x;
		6057
		6058	DestStartY := Y - SourceY;
		6059
		6060	StartY := SourceY;
		6061	EndY := SourceY + Height;
		6062
		6063	if (EndY + DestStartY > Self.Height) then
		6064	EndY := Self.Height - DestStartY;
		6065
		6066	if (EndY > SrcDIB.Height) then
		6067	EndY := SrcDIB.Height;
		6068
		6069	if (StartY < 0) then
		6070	StartY := 0;
		6071
		6072	if (StartY + DestStartY < 0) then
		6073	StartY := DestStartY;
		6074
		6075	r := 0;
		6076	g := 0;
		6077	b := 0;
		6078
		6079	for j := StartY to EndY - 1 do
		6080	begin
		6081	p1 := Self.Scanline[j + DestStartY];
		6082	p2 := SrcDIB.Scanline[j];
		6083
		6084	k1 := Startk1;
		6085	k2 := Startk2;
		6086
		6087	for i := SourceX to SourceX + Width - 1 do
		6088	begin
		6089	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		6090
		6091	if Random(100) < 50 then
		6092	begin
		6093	b := p1[k2];
		6094	g := p1[k2 + 1];
		6095	r := p1[k2 + 2];
		6096	end;
		6097
		6098	if not (n = Color) then
		6099	begin
		6100	p1[k2] := b;
		6101	p1[k2 + 1] := g;
		6102	p1[k2 + 2] := r;
		6103	end;
		6104
		6105	k1 := k1 + 3;
		6106	k2 := k2 + 3;
		6107	end;
		6108	end;
		6109	end;
		6110
		6111	procedure TDIB.DrawMono(SrcDIB: TDIB; const X, Y, Width, Height,
		6112	SourceX, SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
		6113	var
		6114	i, j, r1, g1, b1, r2, g2, b2: Integer;
		6115	k1, k2: Integer;
		6116	n: Integer;
		6117	p1, p2: PByteArray;
		6118	Startk1, Startk2, StartY, EndY, DestStartY: Integer;
		6119	begin
		6120	if Self.BitCount <> 24 then Exit;
		6121	if SrcDIB.BitCount <> 24 then Exit;
		6122
		6123	Startk1 := 3 * SourceX;
		6124	Startk2 := 3 * x;
		6125
		6126	DestStartY := Y - SourceY;
		6127
		6128	StartY := SourceY;
		6129	EndY := SourceY + Height;
		6130
		6131	if (EndY + DestStartY > Self.Height) then
		6132	EndY := Self.Height - DestStartY;
		6133
		6134	if (EndY > SrcDIB.Height) then
		6135	EndY := SrcDIB.Height;
		6136
		6137	if (StartY < 0) then
		6138	StartY := 0;
		6139
		6140	if (StartY + DestStartY < 0) then
		6141	StartY := DestStartY;
		6142
		6143	r1 := GetRValue(BackColor);
		6144	g1 := GetGValue(BackColor);
		6145	b1 := GetBValue(BackColor);
		6146
		6147	r2 := GetRValue(ForeColor);
		6148	g2 := GetGValue(ForeColor);
		6149	b2 := GetBValue(ForeColor);
		6150
		6151
		6152	for j := StartY to EndY - 1 do
		6153	begin
		6154	p1 := Self.Scanline[j + DestStartY];
		6155	p2 := SrcDIB.Scanline[j];
		6156
		6157	k1 := Startk1;
		6158	k2 := Startk2;
		6159
		6160	for i := SourceX to SourceX + Width - 1 do
		6161	begin
		6162	n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
		6163
		6164	if (n = TransColor) then
		6165	begin
		6166	p1[k2] := b1;
		6167	p1[k2 + 1] := g1;
		6168	p1[k2 + 2] := r1;
		6169	end
		6170	else
		6171	begin
		6172	p1[k2] := b2;
		6173	p1[k2 + 1] := g2;
		6174	p1[k2 + 2] := r2;
		6175	end;
		6176
		6177	k1 := k1 + 3;
		6178	k2 := k2 + 3;
		6179	end;
		6180	end;
		6181	end;
		6182
		6183	procedure TDIB.Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
		6184	var i, j, k: Integer;
		6185	p1, p2, p3, p4: PByteArray;
		6186	begin
		6187	if Self.BitCount <> 24 then Exit;
		6188	if SrcDIB.BitCount <> 24 then Exit;
		6189
		6190	for i := 1 to SrcDIB.Height - 2 do
		6191	begin
		6192	p1 := SrcDIB.ScanLine[i - 1];
		6193	p2 := SrcDIB.ScanLine[i];
		6194	p3 := SrcDIB.ScanLine[i + 1];
		6195	p4 := Self.ScanLine[i];
		6196	for j := 3 to 3 * SrcDIB.Width - 4 do
		6197	begin
		6198	k := (p1[j - 3] * Setting[0] + p1[j] * Setting[1] + p1[j + 3] * Setting[2] +
		6199	p2[j - 3] * Setting[3] + p2[j] * Setting[4] + p2[j + 3] * Setting[5] +
		6200	p3[j - 3] * Setting[6] + p3[j] * Setting[7] + p3[j + 3] * Setting[8])
		6201	div Setting[9];
		6202	if k < 0 then k := 0;
		6203	if k > 255 then k := 255;
		6204	p4[j] := k;
		6205	end;
		6206	end;
		6207	end;
		6208
		6209	procedure TDIB.DrawAntialias(SrcDIB: TDIB);
		6210	var i, j, k, l, m: Integer;
		6211	p1, p2, p3: PByteArray;
		6212	begin
		6213	if Self.BitCount <> 24 then Exit;
		6214	if SrcDIB.BitCount <> 24 then Exit;
		6215
		6216	for i := 1 to Self.Height - 1 do
		6217	begin
		6218	k := i shl 1;
		6219	p1 := SrcDIB.Scanline[k];
		6220	p2 := SrcDIB.Scanline[k + 1];
		6221	p3 := Self.Scanline[i];
		6222	for j := 1 to Self.Width - 1 do
		6223	begin
		6224	m := 3 * j;
		6225	l := m shl 1;
		6226	p3[m] := (p1[l] + p1[l + 3] + p2[l] + p2[l + 3]) shr 2;
		6227	p3[m + 1] := (p1[l + 1] + p1[l + 4] + p2[l + 1] + p2[l + 4]) shr 2;
		6228	p3[m + 2] := (p1[l + 2] + p1[l + 5] + p2[l + 2] + p2[l + 5]) shr 2;
		6229	end;
		6230	end;
		6231	end;
		6232
		6233	procedure TDIB.FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
		6234	FilterMode: TFilterMode);
		6235	var
		6236	i, j: Integer;
		6237	t: TColor;
		6238	r1, g1, b1, r2, g2, b2: Integer;
		6239	begin
		6240	j := ROUND(Sqrt(Sqr(ABS(X2 - X1)) + Sqr(ABS(Y2 - Y1))));
		6241	if j < 1 then Exit;
		6242
		6243	r1 := GetRValue(Color);
		6244	g1 := GetGValue(Color);
		6245	b1 := GetBValue(Color);
		6246
		6247	for i := 0 to j do
		6248	begin
		6249	t := Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)];
		6250	r2 := GetRValue(t);
		6251	g2 := GetGValue(t);
		6252	b2 := GetBValue(t);
		6253	case FilterMode of
		6254	fmNormal: t := RGB(r1 + (((256 - r1) * r2) shr 8),
		6255	g1 + (((256 - g1) * g2) shr 8),
		6256	b1 + (((256 - b1) * b2) shr 8));
		6257	fmMix25: t := RGB((r1 + r2 * 3) shr 2, (g1 + g2 * 3) shr 2, (b1 + b2 * 3) shr 2);
		6258	fmMix50: t := RGB((r1 + r2) shr 1, (g1 + g2) shr 1, (b1 + b2) shr 1);
		6259	fmMix75: t := RGB((r1 * 3 + r2) shr 2, (g1 * 3 + g2) shr 2, (b1 * 3 + b2) shr 2);
		6260	end;
		6261	Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)] := t;
		6262	end;
		6263	end;
		6264
		6265	procedure TDIB.FilterRect(X, Y, Width, Height: Integer;
		6266	Color: TColor; FilterMode: TFilterMode);
		6267	var
		6268	i, j, r, g, b, C1: Integer;
		6269	p1, p2, p3: pByte;
		6270	begin
		6271	if Self.BitCount <> 24 then Exit;
		6272
		6273	r := GetRValue(Color);
		6274	g := GetGValue(Color);
		6275	b := GetBValue(Color);
		6276
		6277	for i := 0 to Height - 1 do
		6278	begin
		6279	p1 := Self.Scanline[i + Y];
		6280	Inc(p1, (3 * X));
		6281	for j := 0 to Width - 1 do
		6282	begin
		6283	case FilterMode of
		6284	fmNormal:
		6285	begin
		6286	p2 := p1;
		6287	Inc(p2);
		6288	p3 := p2;
		6289	Inc(p3);
		6290	C1 := (p1^ + p2^ + p3^) div 3;
		6291
		6292	p1^ := (C1 * b) shr 8;
		6293	Inc(p1);
		6294	p1^ := (C1 * g) shr 8;
		6295	Inc(p1);
		6296	p1^ := (C1 * r) shr 8;
		6297	Inc(p1);
		6298	end;
		6299	fmMix25:
		6300	begin
		6301	p1^ := (3 * p1^ + b) shr 2;
		6302	Inc(p1);
		6303	p1^ := (3 * p1^ + g) shr 2;
		6304	Inc(p1);
		6305	p1^ := (3 * p1^ + r) shr 2;
		6306	Inc(p1);
		6307	end;
		6308	fmMix50:
		6309	begin
		6310	p1^ := (p1^ + b) shr 1;
		6311	Inc(p1);
		6312	p1^ := (p1^ + g) shr 1;
		6313	Inc(p1);
		6314	p1^ := (p1^ + r) shr 1;
		6315	Inc(p1);
		6316	end;
		6317	fmMix75:
		6318	begin
		6319	p1^ := (p1^ + 3 * b) shr 2;
		6320	Inc(p1);
		6321	p1^ := (p1^ + 3 * g) shr 2;
		6322	Inc(p1);
		6323	p1^ := (p1^ + 3 * r) shr 2;
		6324	Inc(p1);
		6325	end;
		6326	end;
		6327	end;
		6328	end;
		6329	end;
		6330
		6331	procedure TDIB.InitLight(Count, Detail: Integer);
		6332	var
		6333	i, j: Integer;
		6334	begin
		6335	LG_COUNT := Count;
		6336	LG_DETAIL := Detail;
		6337
		6338	for i := 0 to 255 do // Build Lightning LUT
		6339	for j := 0 to 255 do
		6340	FLUTDist[i, j] := ROUND(Sqrt(Sqr(i * 10) + Sqr(j * 10)));
		6341	end;
		6342
		6343	procedure TDIB.DrawLights(FLight: TLightArray;
		6344	AmbientLight: TColor);
		6345	var
		6346	i, j, l, m, n, o, q, D1, D2, R, G, B, AR, AG, AB: Integer;
		6347	P: array{$IFNDEF VER4UP} [0..4096]{$ENDIF} of PByteArray;
		6348	begin
		6349	if Self.BitCount <> 24 then Exit;
		6350
		6351	{$IFDEF VER4UP}
		6352	SetLength(P, LG_DETAIL);
		6353	{$ENDIF}
		6354	AR := GetRValue(AmbientLight);
		6355	AG := GetGValue(AmbientLight);
		6356	AB := GetBValue(AmbientLight);
		6357
		6358	for i := (Self.Height div (LG_DETAIL + 1)) downto 1 do
		6359	begin
		6360	for o := 0 to LG_DETAIL do
		6361	P[o] := Self.Scanline[(LG_DETAIL + 1) * i - o];
		6362
		6363	for j := (Self.Width div (LG_DETAIL + 1)) downto 1 do
		6364	begin
		6365	R := AR;
		6366	G := AG;
		6367	B := AB;
		6368
		6369	for l := LG_COUNT - 1 downto 0 do // Check the lightsources
		6370	begin
		6371	D1 := ABS(j * (LG_DETAIL + 1) - FLight[l].X) div FLight[l].Size1;
		6372	D2 := ABS(i * (LG_DETAIL + 1) - FLight[l].Y) div FLight[l].Size2;
		6373	if D1 > 255 then D1 := 255;
		6374	if D2 > 255 then D2 := 255;
		6375
		6376	m := 255 - FLUTDist[D1, D2];
		6377	if m < 0 then m := 0;
		6378
		6379	Inc(R, (PosValue(GetRValue(FLight[l].Color) - R) * m shr 8));
		6380	Inc(G, (PosValue(GetGValue(FLight[l].Color) - G) * m shr 8));
		6381	Inc(B, (PosValue(GetBValue(FLight[l].Color) - B) * m shr 8));
		6382	end;
		6383
		6384	for q := LG_DETAIL downto 0 do
		6385	begin
		6386	n := 3 * (j * (LG_DETAIL + 1) - q);
		6387
		6388	for o := LG_DETAIL downto 0 do
		6389	begin
		6390	P[o][n] := (P[o][n] * B) shr 8;
		6391	P[o][n + 1] := (P[o][n + 1] * G) shr 8;
		6392	P[o][n + 2] := (P[o][n + 2] * R) shr 8;
		6393	end;
		6394	end;
		6395	end;
		6396	end;
		6397	{$IFDEF VER4UP}
		6398	SetLength(P, 0);
		6399	{$ENDIF}
		6400	end;
		6401
		6402	procedure TDIB.DrawOn(Dest: TRect; DestCanvas: TCanvas; Xsrc, Ysrc: Integer);
		6403	{procedure is supplement of original TDIBUltra function}
		6404	begin
		6405	//if not AsSigned(SrcCanvas) then Exit;
		6406	if (Xsrc < 0) then
		6407	begin
		6408	Dec(Dest.Left, Xsrc);
		6409	Inc(Dest.Right {Width }, Xsrc);
		6410	Xsrc := 0
		6411	end;
		6412	if (Ysrc < 0) then
		6413	begin
		6414	Dec(Dest.Top, Ysrc);
		6415	Inc(Dest.Bottom {Height}, Ysrc);
		6416	Ysrc := 0
		6417	end;
		6418	BitBlt(DestCanvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom, Self.Canvas.Handle, Xsrc, Ysrc, SRCCOPY);
		6419	end;
		6420
		6421	{ DXFusion <- }
		6422
		6423	{ added effect for DIB }
		6424
		6425	function IntToByte(i: Integer): Byte;
		6426	begin
		6427	if i > 255 then Result := 255
		6428	else if i < 0 then Result := 0
		6429	else Result := i;
		6430	end;
		6431
		6432	{standalone routine}
		6433
		6434	procedure TDIB.Darker(Percent: Integer);
		6435	{color to dark in percent}
		6436	var
		6437	p0: pbytearray;
		6438	r, g, b, x, y: Integer;
		6439	begin
		6440	if Self.BitCount <> 24 then Exit;
		6441	for y := 0 to Self.Height - 1 do
		6442	begin
		6443	p0 := Self.ScanLine[y];
		6444	for x := 0 to Self.Width - 1 do
		6445	begin
		6446	r := p0[x * 3];
		6447	g := p0[x * 3 + 1];
		6448	b := p0[x * 3 + 2];
		6449	p0[x * 3] := Round(R * Percent / 100);
		6450	p0[x * 3 + 1] := Round(G * Percent / 100);
		6451	p0[x * 3 + 2] := Round(B * Percent / 100);
		6452	end;
		6453	end;
		6454	end;
		6455
		6456	procedure TDIB.Lighter(Percent: Integer);
		6457	var
		6458	p0: pbytearray;
		6459	r, g, b, x, y: Integer;
		6460	begin
		6461	if Self.BitCount <> 24 then Exit;
		6462	for y := 0 to Self.Height - 1 do
		6463	begin
		6464	p0 := Self.ScanLine[y];
		6465	for x := 0 to Self.Width - 1 do
		6466	begin
		6467	r := p0[x * 3];
		6468	g := p0[x * 3 + 1];
		6469	b := p0[x * 3 + 2];
		6470	p0[x * 3] := Round(R * Percent / 100) + Round(255 - Percent / 100 * 255);
		6471	p0[x * 3 + 1] := Round(G * Percent / 100) + Round(255 - Percent / 100 * 255);
		6472	p0[x * 3 + 2] := Round(B * Percent / 100) + Round(255 - Percent / 100 * 255);
		6473	end;
		6474	end;
		6475	end;
		6476
		6477	procedure TDIB.Darkness(Amount: Integer);
		6478	var
		6479	p0: pbytearray;
		6480	r, g, b, x, y: Integer;
		6481	begin
		6482	if Self.BitCount <> 24 then Exit;
		6483	for y := 0 to Self.Height - 1 do
		6484	begin
		6485	p0 := Self.ScanLine[y];
		6486	for x := 0 to Self.Width - 1 do
		6487	begin
		6488	r := p0[x * 3];
		6489	g := p0[x * 3 + 1];
		6490	b := p0[x * 3 + 2];
		6491	p0[x * 3] := IntToByte(r - ((r) * Amount) div 255);
		6492	p0[x * 3 + 1] := IntToByte(g - ((g) * Amount) div 255);
		6493	p0[x * 3 + 2] := IntToByte(b - ((b) * Amount) div 255);
		6494	end;
		6495	end;
		6496	end;
		6497
		6498	function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		6499	begin
		6500	if i > Max then Result := Max
		6501	else if i < Min then Result := Min
		6502	else Result := i;
		6503	end;
		6504
		6505	procedure TDIB.DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
		6506	var
		6507	Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
		6508	cAngle, sAngle: Double;
		6509	xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
		6510	nw, ne, sw, se: TBGR;
		6511	P1, P2, P3: Pbytearray;
		6512	begin
		6513	Angle := angle;
		6514	Angle := -Angle * Pi / 180;
		6515	sAngle := Sin(Angle);
		6516	cAngle := Cos(Angle);
		6517	xDiff := (Self.Width - Src.Width) div 2;
		6518	yDiff := (Self.Height - Src.Height) div 2;
		6519	for y := 0 to Self.Height - 1 do
		6520	begin
		6521	P3 := Self.scanline[y];
		6522	py := 2 * (y - cy) + 1;
		6523	for x := 0 to Self.Width - 1 do
		6524	begin
		6525	px := 2 * (x - cx) + 1;
		6526	fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
		6527	fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
		6528	ifx := Round(fx);
		6529	ify := Round(fy);
		6530
		6531	if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then
		6532	begin
		6533	eww := fx - ifx;
		6534	nsw := fy - ify;
		6535	iy := TrimInt(ify + 1, 0, Src.Height - 1);
		6536	ix := TrimInt(ifx + 1, 0, Src.Width - 1);
		6537	P1 := Src.scanline[ify];
		6538	P2 := Src.scanline[iy];
		6539	nw.r := P1[ifx * 3];
		6540	nw.g := P1[ifx * 3 + 1];
		6541	nw.b := P1[ifx * 3 + 2];
		6542	ne.r := P1[ix * 3];
		6543	ne.g := P1[ix * 3 + 1];
		6544	ne.b := P1[ix * 3 + 2];
		6545	sw.r := P2[ifx * 3];
		6546	sw.g := P2[ifx * 3 + 1];
		6547	sw.b := P2[ifx * 3 + 2];
		6548	se.r := P2[ix * 3];
		6549	se.g := P2[ix * 3 + 1];
		6550	se.b := P2[ix * 3 + 2];
		6551
		6552	Top := nw.b + eww * (ne.b - nw.b);
		6553	Bottom := sw.b + eww * (se.b - sw.b);
		6554	P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
		6555
		6556	Top := nw.g + eww * (ne.g - nw.g);
		6557	Bottom := sw.g + eww * (se.g - sw.g);
		6558	P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
		6559
		6560	Top := nw.r + eww * (ne.r - nw.r);
		6561	Bottom := sw.r + eww * (se.r - sw.r);
		6562	P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
		6563	end;
		6564	end;
		6565	end;
		6566	end;
		6567
		6568	//----------------------
		6569	//--- 24 bit count routines ----------------------
		6570	//----------------------
		6571
		6572	procedure TDIB.DoInvert;
		6573	procedure PicInvert(src: TDIB);
		6574	var w, h, x, y: Integer;
		6575	p: pbytearray;
		6576	begin
		6577	w := src.width;
		6578	h := src.height;
		6579	src.BitCount := 24;
		6580	for y := 0 to h - 1 do
		6581	begin
		6582	p := src.scanline[y];
		6583	for x := 0 to w - 1 do
		6584	begin
		6585	p[x * 3] := not p[x * 3];
		6586	p[x * 3 + 1] := not p[x * 3 + 1];
		6587	p[x * 3 + 2] := not p[x * 3 + 2];
		6588	end;
		6589	end;
		6590	end;
		6591	begin
		6592	PicInvert(Self);
		6593	end;
		6594
		6595	procedure TDIB.DoAddColorNoise(Amount: Integer);
		6596	procedure AddColorNoise(var clip: TDIB; Amount: Integer);
		6597	var
		6598	p0: pbytearray;
		6599	x, y, r, g, b: Integer;
		6600	begin
		6601	for y := 0 to clip.Height - 1 do
		6602	begin
		6603	p0 := clip.ScanLine[y];
		6604	for x := 0 to clip.Width - 1 do
		6605	begin
		6606	r := p0[x * 3] + (Random(Amount) - (Amount shr 1));
		6607	g := p0[x * 3 + 1] + (Random(Amount) - (Amount shr 1));
		6608	b := p0[x * 3 + 2] + (Random(Amount) - (Amount shr 1));
		6609	p0[x * 3] := IntToByte(r);
		6610	p0[x * 3 + 1] := IntToByte(g);
		6611	p0[x * 3 + 2] := IntToByte(b);
		6612	end;
		6613	end;
		6614	end;
		6615	var BB: TDIB;
		6616	begin
		6617	BB := TDIB.Create;
		6618	BB.BitCount := 24;
		6619	BB.Assign(Self);
		6620	AddColorNoise(bb, Amount);
		6621	Self.Assign(BB);
		6622	BB.Free;
		6623	end;
		6624
		6625	procedure TDIB.DoAddMonoNoise(Amount: Integer);
		6626	procedure _AddMonoNoise(var clip: TDIB; Amount: Integer);
		6627	var
		6628	p0: pbytearray;
		6629	x, y, a, r, g, b: Integer;
		6630	begin
		6631	for y := 0 to clip.Height - 1 do
		6632	begin
		6633	p0 := clip.scanline[y];
		6634	for x := 0 to clip.Width - 1 do
		6635	begin
		6636	a := Random(Amount) - (Amount shr 1);
		6637	r := p0[x * 3] + a;
		6638	g := p0[x * 3 + 1] + a;
		6639	b := p0[x * 3 + 2] + a;
		6640	p0[x * 3] := IntToByte(r);
		6641	p0[x * 3 + 1] := IntToByte(g);
		6642	p0[x * 3 + 2] := IntToByte(b);
		6643	end;
		6644	end;
		6645	end;
		6646	var BB: TDIB;
		6647	begin
		6648	BB := TDIB.Create;
		6649	BB.BitCount := 24;
		6650	BB.Assign(Self);
		6651	_AddMonoNoise(bb, Amount);
		6652	Self.Assign(BB);
		6653	BB.Free;
		6654	end;
		6655
		6656	procedure TDIB.DoAntiAlias;
		6657	procedure AntiAlias(clip: TDIB);
		6658	procedure AntiAliasRect(clip: TDIB; XOrigin, YOrigin, XFinal, YFinal: Integer);
		6659	var Memo, x, y: Integer; (* Composantes primaires des points environnants *)
		6660	p0, p1, p2: pbytearray;
		6661	begin
		6662	if XFinal < XOrigin then begin Memo := XOrigin; XOrigin := XFinal; XFinal := Memo; end; (* Inversion des valeurs *)
		6663	if YFinal < YOrigin then begin Memo := YOrigin; YOrigin := YFinal; YFinal := Memo; end; (* si diff�rence n�gative*)
		6664	XOrigin := max(1, XOrigin);
		6665	YOrigin := max(1, YOrigin);
		6666	XFinal := min(clip.width - 2, XFinal);
		6667	YFinal := min(clip.height - 2, YFinal);
		6668	clip.BitCount := 24;
		6669	for y := YOrigin to YFinal do
		6670	begin
		6671	p0 := clip.ScanLine[y - 1];
		6672	p1 := clip.scanline[y];
		6673	p2 := clip.ScanLine[y + 1];
		6674	for x := XOrigin to XFinal do
		6675	begin
		6676	p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) div 4;
		6677	p1[x * 3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) div 4;
		6678	p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) div 4;
		6679	end;
		6680	end;
		6681	end;
		6682	begin
		6683	AntiAliasRect(clip, 0, 0, clip.width, clip.height);
		6684	end;
		6685	begin
		6686	AntiAlias(Self);
		6687	end;
		6688
		6689	procedure TDIB.DoContrast(Amount: Integer);
		6690	procedure _Contrast(var clip: TDIB; Amount: Integer);
		6691	var
		6692	p0: pbytearray;
		6693	rg, gg, bg, r, g, b, x, y: Integer;
		6694	begin
		6695	for y := 0 to clip.Height - 1 do
		6696	begin
		6697	p0 := clip.scanline[y];
		6698	for x := 0 to clip.Width - 1 do
		6699	begin
		6700	r := p0[x * 3];
		6701	g := p0[x * 3 + 1];
		6702	b := p0[x * 3 + 2];
		6703	rg := (Abs(127 - r) * Amount) div 255;
		6704	gg := (Abs(127 - g) * Amount) div 255;
		6705	bg := (Abs(127 - b) * Amount) div 255;
		6706	if r > 127 then r := r + rg else r := r - rg;
		6707	if g > 127 then g := g + gg else g := g - gg;
		6708	if b > 127 then b := b + bg else b := b - bg;
		6709	p0[x * 3] := IntToByte(r);
		6710	p0[x * 3 + 1] := IntToByte(g);
		6711	p0[x * 3 + 2] := IntToByte(b);
		6712	end;
		6713	end;
		6714	end;
		6715	var BB: TDIB;
		6716	begin
		6717	BB := TDIB.Create;
		6718	BB.BitCount := 24;
		6719	BB.Assign(Self);
		6720	_Contrast(bb, Amount);
		6721	Self.Assign(BB);
		6722	BB.Free;
		6723	end;
		6724
		6725	procedure TDIB.DoFishEye(Amount: Integer);
		6726	procedure _FishEye(var Bmp, Dst: TDIB; Amount: Extended);
		6727	var
		6728	xmid, ymid: Single;
		6729	fx, fy: Single;
		6730	r1, r2: Single;
		6731	ifx, ify: Integer;
		6732	dx, dy: Single;
		6733	rmax: Single;
		6734	ty, tx: Integer;
		6735	weight_x, weight_y: array[0..1] of Single;
		6736	weight: Single;
		6737	new_red, new_green: Integer;
		6738	new_blue: Integer;
		6739	total_red, total_green: Single;
		6740	total_blue: Single;
		6741	ix, iy: Integer;
		6742	sli, slo: PByteArray;
		6743	begin
		6744	xmid := Bmp.Width / 2;
		6745	ymid := Bmp.Height / 2;
		6746	rmax := Dst.Width * Amount;
		6747
		6748	for ty := 0 to Dst.Height - 1 do
		6749	begin
		6750	for tx := 0 to Dst.Width - 1 do
		6751	begin
		6752	dx := tx - xmid;
		6753	dy := ty - ymid;
		6754	r1 := Sqrt(dx * dx + dy * dy);
		6755	if r1 = 0 then
		6756	begin
		6757	fx := xmid;
		6758	fy := ymid;
		6759	end
		6760	else
		6761	begin
		6762	r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
		6763	fx := dx * r2 / r1 + xmid;
		6764	fy := dy * r2 / r1 + ymid;
		6765	end;
		6766	ify := Trunc(fy);
		6767	ifx := Trunc(fx);
		6768	// Calculate the weights.
		6769	if fy >= 0 then
		6770	begin
		6771	weight_y[1] := fy - ify;
		6772	weight_y[0] := 1 - weight_y[1];
		6773	end
		6774	else
		6775	begin
		6776	weight_y[0] := -(fy - ify);
		6777	weight_y[1] := 1 - weight_y[0];
		6778	end;
		6779	if fx >= 0 then
		6780	begin
		6781	weight_x[1] := fx - ifx;
		6782	weight_x[0] := 1 - weight_x[1];
		6783	end
		6784	else
		6785	begin
		6786	weight_x[0] := -(fx - ifx);
		6787	Weight_x[1] := 1 - weight_x[0];
		6788	end;
		6789
		6790	if ifx < 0 then
		6791	ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
		6792	else if ifx > Bmp.Width - 1 then
		6793	ifx := ifx mod Bmp.Width;
		6794	if ify < 0 then
		6795	ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
		6796	else if ify > Bmp.Height - 1 then
		6797	ify := ify mod Bmp.Height;
		6798
		6799	total_red := 0.0;
		6800	total_green := 0.0;
		6801	total_blue := 0.0;
		6802	for ix := 0 to 1 do
		6803	begin
		6804	for iy := 0 to 1 do
		6805	begin
		6806	if ify + iy < Bmp.Height then
		6807	sli := Bmp.scanline[ify + iy]
		6808	else
		6809	sli := Bmp.scanline[Bmp.Height - ify - iy];
		6810	if ifx + ix < Bmp.Width then
		6811	begin
		6812	new_red := sli[(ifx + ix) * 3];
		6813	new_green := sli[(ifx + ix) * 3 + 1];
		6814	new_blue := sli[(ifx + ix) * 3 + 2];
		6815	end
		6816	else
		6817	begin
		6818	new_red := sli[(Bmp.Width - ifx - ix) * 3];
		6819	new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
		6820	new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
		6821	end;
		6822	weight := weight_x[ix] * weight_y[iy];
		6823	total_red := total_red + new_red * weight;
		6824	total_green := total_green + new_green * weight;
		6825	total_blue := total_blue + new_blue * weight;
		6826	end;
		6827	end;
		6828	slo := Dst.scanline[ty];
		6829	slo[tx * 3] := Round(total_red);
		6830	slo[tx * 3 + 1] := Round(total_green);
		6831	slo[tx * 3 + 2] := Round(total_blue);
		6832
		6833	end;
		6834	end;
		6835	end;
		6836	var BB1, BB2: TDIB;
		6837	begin
		6838	BB1 := TDIB.Create;
		6839	BB1.BitCount := 24;
		6840	BB1.Assign(Self);
		6841	BB2 := TDIB.Create;
		6842	BB2.BitCount := 24;
		6843	BB2.Assign(BB1);
		6844	_FishEye(BB1, BB2, Amount);
		6845	Self.Assign(BB2);
		6846	BB1.Free;
		6847	BB2.Free;
		6848	end;
		6849
		6850	procedure TDIB.DoGrayScale;
		6851	procedure GrayScale(var clip: TDIB);
		6852	var
		6853	p0: pbytearray;
		6854	Gray, x, y: Integer;
		6855	begin
		6856	for y := 0 to clip.Height - 1 do
		6857	begin
		6858	p0 := clip.scanline[y];
		6859	for x := 0 to clip.Width - 1 do
		6860	begin
		6861	Gray := Round(p0[x * 3] * 0.3 + p0[x * 3 + 1] * 0.59 + p0[x * 3 + 2] * 0.11);
		6862	p0[x * 3] := Gray;
		6863	p0[x * 3 + 1] := Gray;
		6864	p0[x * 3 + 2] := Gray;
		6865	end;
		6866	end;
		6867	end;
		6868	var BB: TDIB;
		6869	begin
		6870	BB := TDIB.Create;
		6871	BB.BitCount := 24;
		6872	BB.Assign(Self);
		6873	GrayScale(BB);
		6874	Self.Assign(BB);
		6875	BB.Free;
		6876	end;
		6877
		6878	procedure TDIB.DoLightness(Amount: Integer);
		6879	procedure _Lightness(var clip: TDIB; Amount: Integer);
		6880	var
		6881	p0: pbytearray;
		6882	r, g, b, x, y: Integer;
		6883	begin
		6884	for y := 0 to clip.Height - 1 do
		6885	begin
		6886	p0 := clip.scanline[y];
		6887	for x := 0 to clip.Width - 1 do
		6888	begin
		6889	r := p0[x * 3];
		6890	g := p0[x * 3 + 1];
		6891	b := p0[x * 3 + 2];
		6892	p0[x * 3] := IntToByte(r + ((255 - r) * Amount) div 255);
		6893	p0[x * 3 + 1] := IntToByte(g + ((255 - g) * Amount) div 255);
		6894	p0[x * 3 + 2] := IntToByte(b + ((255 - b) * Amount) div 255);
		6895	end;
		6896	end;
		6897	end;
		6898	var BB: TDIB;
		6899	begin
		6900	BB := TDIB.Create;
		6901	BB.BitCount := 24;
		6902	BB.Assign(Self);
		6903	_Lightness(BB, Amount);
		6904	Self.Assign(BB);
		6905	BB.Free;
		6906	end;
		6907
		6908	procedure TDIB.DoDarkness(Amount: Integer);
		6909	var BB: TDIB;
		6910	begin
		6911	BB := TDIB.Create;
		6912	BB.BitCount := 24;
		6913	BB.Assign(Self);
		6914	BB.Darkness(Amount);
		6915	Self.Assign(BB);
		6916	BB.Free;
		6917	end;
		6918
		6919	procedure TDIB.DoSaturation(Amount: Integer);
		6920	procedure _Saturation(var clip: TDIB; Amount: Integer);
		6921	var
		6922	p0: pbytearray;
		6923	Gray, r, g, b, x, y: Integer;
		6924	begin
		6925	for y := 0 to clip.Height - 1 do
		6926	begin
		6927	p0 := clip.scanline[y];
		6928	for x := 0 to clip.Width - 1 do
		6929	begin
		6930	r := p0[x * 3];
		6931	g := p0[x * 3 + 1];
		6932	b := p0[x * 3 + 2];
		6933	Gray := (r + g + b) div 3;
		6934	p0[x * 3] := IntToByte(Gray + (((r - Gray) * Amount) div 255));
		6935	p0[x * 3 + 1] := IntToByte(Gray + (((g - Gray) * Amount) div 255));
		6936	p0[x * 3 + 2] := IntToByte(Gray + (((b - Gray) * Amount) div 255));
		6937	end;
		6938	end;
		6939	end;
		6940	var BB: TDIB;
		6941	begin
		6942	BB := TDIB.Create;
		6943	BB.BitCount := 24;
		6944	BB.Assign(Self);
		6945	_Saturation(BB, Amount);
		6946	Self.Assign(BB);
		6947	BB.Free;
		6948	end;
		6949
		6950	procedure TDIB.DoSplitBlur(Amount: Integer);
		6951	{NOTE: For a gaussian blur is amount 3}
		6952	procedure _SplitBlur(var clip: TDIB; Amount: Integer);
		6953	var
		6954	p0, p1, p2: pbytearray;
		6955	cx, x, y: Integer;
		6956	Buf: array[0..3, 0..2] of byte;
		6957	begin
		6958	if Amount = 0 then Exit;
		6959	for y := 0 to clip.Height - 1 do
		6960	begin
		6961	p0 := clip.scanline[y];
		6962	if y - Amount < 0 then p1 := clip.scanline[y]
		6963	else {y-Amount>0} p1 := clip.ScanLine[y - Amount];
		6964	if y + Amount < clip.Height then p2 := clip.ScanLine[y + Amount]
		6965	else {y+Amount>=Height} p2 := clip.ScanLine[clip.Height - y];
		6966
		6967	for x := 0 to clip.Width - 1 do
		6968	begin
		6969	if x - Amount < 0 then cx := x
		6970	else {x-Amount>0} cx := x - Amount;
		6971	Buf[0, 0] := p1[cx * 3];
		6972	Buf[0, 1] := p1[cx * 3 + 1];
		6973	Buf[0, 2] := p1[cx * 3 + 2];
		6974	Buf[1, 0] := p2[cx * 3];
		6975	Buf[1, 1] := p2[cx * 3 + 1];
		6976	Buf[1, 2] := p2[cx * 3 + 2];
		6977	if x + Amount < clip.Width then cx := x + Amount
		6978	else {x+Amount>=Width} cx := clip.Width - x;
		6979	Buf[2, 0] := p1[cx * 3];
		6980	Buf[2, 1] := p1[cx * 3 + 1];
		6981	Buf[2, 2] := p1[cx * 3 + 2];
		6982	Buf[3, 0] := p2[cx * 3];
		6983	Buf[3, 1] := p2[cx * 3 + 1];
		6984	Buf[3, 2] := p2[cx * 3 + 2];
		6985	p0[x * 3] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) shr 2;
		6986	p0[x * 3 + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) shr 2;
		6987	p0[x * 3 + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) shr 2;
		6988	end;
		6989	end;
		6990	end;
		6991	var BB: TDIB;
		6992	begin
		6993	BB := TDIB.Create;
		6994	BB.BitCount := 24;
		6995	BB.Assign(Self);
		6996	_SplitBlur(BB, Amount);
		6997	Self.Assign(BB);
		6998	BB.Free;
		6999	end;
		7000
		7001	procedure TDIB.DoGaussianBlur(Amount: Integer);
		7002	var BB: TDIB;
		7003	begin
		7004	BB := TDIB.Create;
		7005	BB.BitCount := 24;
		7006	BB.BitCount := 24;
		7007	BB.Assign(Self);
		7008	GaussianBlur(BB, Amount);
		7009	Self.Assign(BB);
		7010	BB.Free;
		7011	end;
		7012
		7013	procedure TDIB.DoMosaic(Size: Integer);
		7014	procedure Mosaic(var Bm: TDIB; size: Integer);
		7015	var
		7016	x, y, i, j: Integer;
		7017	p1, p2: pbytearray;
		7018	r, g, b: byte;
		7019	begin
		7020	y := 0;
		7021	repeat
		7022	p1 := bm.scanline[y];
		7023	repeat
		7024	j := 1;
		7025	repeat
		7026	p2 := bm.scanline[y];
		7027	x := 0;
		7028	repeat
		7029	r := p1[x * 3];
		7030	g := p1[x * 3 + 1];
		7031	b := p1[x * 3 + 2];
		7032	i := 1;
		7033	repeat
		7034	p2[x * 3] := r;
		7035	p2[x * 3 + 1] := g;
		7036	p2[x * 3 + 2] := b;
		7037	inc(x);
		7038	inc(i);
		7039	until (x >= bm.width) or (i > size);
		7040	until x >= bm.width;
		7041	inc(j);
		7042	inc(y);
		7043	until (y >= bm.height) or (j > size);
		7044	until (y >= bm.height) or (x >= bm.width);
		7045	until y >= bm.height;
		7046	end;
		7047	var BB: TDIB;
		7048	begin
		7049	BB := TDIB.Create;
		7050	BB.BitCount := 24;
		7051	BB.Assign(Self);
		7052	Mosaic(BB, Size);
		7053	Self.Assign(BB);
		7054	BB.Free;
		7055	end;
		7056
		7057	procedure TDIB.DoTwist(Amount: Integer);
		7058	procedure _Twist(var Bmp, Dst: TDIB; Amount: Integer);
		7059	var
		7060	fxmid, fymid: Single;
		7061	txmid, tymid: Single;
		7062	fx, fy: Single;
		7063	tx2, ty2: Single;
		7064	r: Single;
		7065	theta: Single;
		7066	ifx, ify: Integer;
		7067	dx, dy: Single;
		7068	OFFSET: Single;
		7069	ty, tx: Integer;
		7070	weight_x, weight_y: array[0..1] of Single;
		7071	weight: Single;
		7072	new_red, new_green: Integer;
		7073	new_blue: Integer;
		7074	total_red, total_green: Single;
		7075	total_blue: Single;
		7076	ix, iy: Integer;
		7077	sli, slo: PBytearray;
		7078
		7079	function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
		7080	begin
		7081	if xt = 0 then
		7082	if yt > 0 then
		7083	Result := Pi / 2
		7084	else
		7085	Result := -(Pi / 2)
		7086	else
		7087	begin
		7088	Result := ArcTan(yt / xt);
		7089	if xt < 0 then
		7090	Result := Pi + ArcTan(yt / xt);
		7091	end;
		7092	end;
		7093
		7094	begin
		7095	OFFSET := -(Pi / 2);
		7096	dx := Bmp.Width - 1;
		7097	dy := Bmp.Height - 1;
		7098	r := Sqrt(dx * dx + dy * dy);
		7099	tx2 := r;
		7100	ty2 := r;
		7101	txmid := (Bmp.Width - 1) / 2; //Adjust these to move center of rotation
		7102	tymid := (Bmp.Height - 1) / 2; //Adjust these to move ......
		7103	fxmid := (Bmp.Width - 1) / 2;
		7104	fymid := (Bmp.Height - 1) / 2;
		7105	if tx2 >= Bmp.Width then tx2 := Bmp.Width - 1;
		7106	if ty2 >= Bmp.Height then ty2 := Bmp.Height - 1;
		7107
		7108	for ty := 0 to Round(ty2) do
		7109	begin
		7110	for tx := 0 to Round(tx2) do
		7111	begin
		7112	dx := tx - txmid;
		7113	dy := ty - tymid;
		7114	r := Sqrt(dx * dx + dy * dy);
		7115	if r = 0 then
		7116	begin
		7117	fx := 0;
		7118	fy := 0;
		7119	end
		7120	else
		7121	begin
		7122	theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
		7123	fx := r * Cos(theta);
		7124	fy := r * Sin(theta);
		7125	end;
		7126	fx := fx + fxmid;
		7127	fy := fy + fymid;
		7128
		7129	ify := Trunc(fy);
		7130	ifx := Trunc(fx);
		7131	// Calculate the weights.
		7132	if fy >= 0 then
		7133	begin
		7134	weight_y[1] := fy - ify;
		7135	weight_y[0] := 1 - weight_y[1];
		7136	end
		7137	else
		7138	begin
		7139	weight_y[0] := -(fy - ify);
		7140	weight_y[1] := 1 - weight_y[0];
		7141	end;
		7142	if fx >= 0 then
		7143	begin
		7144	weight_x[1] := fx - ifx;
		7145	weight_x[0] := 1 - weight_x[1];
		7146	end
		7147	else
		7148	begin
		7149	weight_x[0] := -(fx - ifx);
		7150	Weight_x[1] := 1 - weight_x[0];
		7151	end;
		7152
		7153	if ifx < 0 then
		7154	ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
		7155	else if ifx > Bmp.Width - 1 then
		7156	ifx := ifx mod Bmp.Width;
		7157	if ify < 0 then
		7158	ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
		7159	else if ify > Bmp.Height - 1 then
		7160	ify := ify mod Bmp.Height;
		7161
		7162	total_red := 0.0;
		7163	total_green := 0.0;
		7164	total_blue := 0.0;
		7165	for ix := 0 to 1 do
		7166	begin
		7167	for iy := 0 to 1 do
		7168	begin
		7169	if ify + iy < Bmp.Height then
		7170	sli := Bmp.scanline[ify + iy]
		7171	else
		7172	sli := Bmp.scanline[Bmp.Height - ify - iy];
		7173	if ifx + ix < Bmp.Width then
		7174	begin
		7175	new_red := sli[(ifx + ix) * 3];
		7176	new_green := sli[(ifx + ix) * 3 + 1];
		7177	new_blue := sli[(ifx + ix) * 3 + 2];
		7178	end
		7179	else
		7180	begin
		7181	new_red := sli[(Bmp.Width - ifx - ix) * 3];
		7182	new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
		7183	new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
		7184	end;
		7185	weight := weight_x[ix] * weight_y[iy];
		7186	total_red := total_red + new_red * weight;
		7187	total_green := total_green + new_green * weight;
		7188	total_blue := total_blue + new_blue * weight;
		7189	end;
		7190	end;
		7191	slo := Dst.scanline[ty];
		7192	slo[tx * 3] := Round(total_red);
		7193	slo[tx * 3 + 1] := Round(total_green);
		7194	slo[tx * 3 + 2] := Round(total_blue);
		7195	end;
		7196	end;
		7197	end;
		7198	var BB1, BB2: TDIB;
		7199	begin
		7200	BB1 := TDIB.Create;
		7201	BB1.BitCount := 24;
		7202	BB1.Assign(Self);
		7203	BB2 := TDIB.Create;
		7204	BB2.BitCount := 24;
		7205	BB2.Assign(BB1);
		7206	_Twist(BB1, BB2, Amount);
		7207	Self.Assign(BB2);
		7208	BB1.Free;
		7209	BB2.Free;
		7210	end;
		7211
		7212	procedure TDIB.DoTrace(Amount: Integer);
		7213	procedure Trace(src: TDIB; intensity: Integer);
		7214	var
		7215	x, y, i: Integer;
		7216	P1, P2, P3, P4: PByteArray;
		7217	tb, TraceB: byte;
		7218	hasb: Boolean;
		7219	bitmap: TDIB;
		7220	begin
		7221	bitmap := TDIB.create;
		7222	bitmap.width := src.width;
		7223	bitmap.height := src.height;
		7224	bitmap.canvas.draw(0, 0, src);
		7225	bitmap.BitCount := 8;
		7226	src.BitCount := 24;
		7227	hasb := false;
		7228	TraceB := $00; tb := 0;
		7229	for i := 1 to Intensity do
		7230	begin
		7231	for y := 0 to BitMap.height - 2 do
		7232	begin
		7233	P1 := BitMap.ScanLine[y];
		7234	P2 := BitMap.scanline[y + 1];
		7235	P3 := src.scanline[y];
		7236	P4 := src.scanline[y + 1];
		7237	x := 0;
		7238	repeat
		7239	if p1[x] <> p1[x + 1] then
		7240	begin
		7241	if not hasb then
		7242	begin
		7243	tb := p1[x + 1];
		7244	hasb := true;
		7245	p3[x * 3] := TraceB;
		7246	p3[x * 3 + 1] := TraceB;
		7247	p3[x * 3 + 2] := TraceB;
		7248	end
		7249	else
		7250	begin
		7251	if p1[x] <> tb then
		7252	begin
		7253	p3[x * 3] := TraceB;
		7254	p3[x * 3 + 1] := TraceB;
		7255	p3[x * 3 + 2] := TraceB;
		7256	end
		7257	else
		7258	begin
		7259	p3[(x + 1) * 3] := TraceB;
		7260	p3[(x + 1) * 3 + 1] := TraceB;
		7261	p3[(x + 1) * 3 + 1] := TraceB;
		7262	end;
		7263	end;
		7264	end;
		7265	if p1[x] <> p2[x] then
		7266	begin
		7267	if not hasb then
		7268	begin
		7269	tb := p2[x];
		7270	hasb := true;
		7271	p3[x * 3] := TraceB;
		7272	p3[x * 3 + 1] := TraceB;
		7273	p3[x * 3 + 2] := TraceB;
		7274	end
		7275	else
		7276	begin
		7277	if p1[x] <> tb then
		7278	begin
		7279	p3[x * 3] := TraceB;
		7280	p3[x * 3 + 1] := TraceB;
		7281	p3[x * 3 + 2] := TraceB;
		7282	end
		7283	else
		7284	begin
		7285	p4[x * 3] := TraceB;
		7286	p4[x * 3 + 1] := TraceB;
		7287	p4[x * 3 + 2] := TraceB;
		7288	end;
		7289	end;
		7290	end;
		7291	inc(x);
		7292	until x >= (BitMap.width - 2);
		7293	end;
		7294	if i > 1 then
		7295	for y := BitMap.height - 1 downto 1 do
		7296	begin
		7297	P1 := BitMap.ScanLine[y];
		7298	P2 := BitMap.scanline[y - 1];
		7299	P3 := src.scanline[y];
		7300	P4 := src.scanline[y - 1];
		7301	x := Bitmap.width - 1;
		7302	repeat
		7303	if p1[x] <> p1[x - 1] then
		7304	begin
		7305	if not hasb then
		7306	begin
		7307	tb := p1[x - 1];
		7308	hasb := true;
		7309	p3[x * 3] := TraceB;
		7310	p3[x * 3 + 1] := TraceB;
		7311	p3[x * 3 + 2] := TraceB;
		7312	end
		7313	else
		7314	begin
		7315	if p1[x] <> tb then
		7316	begin
		7317	p3[x * 3] := TraceB;
		7318	p3[x * 3 + 1] := TraceB;
		7319	p3[x * 3 + 2] := TraceB;
		7320	end
		7321	else
		7322	begin
		7323	p3[(x - 1) * 3] := TraceB;
		7324	p3[(x - 1) * 3 + 1] := TraceB;
		7325	p3[(x - 1) * 3 + 2] := TraceB;
		7326	end;
		7327	end;
		7328	end;
		7329	if p1[x] <> p2[x] then
		7330	begin
		7331	if not hasb then
		7332	begin
		7333	tb := p2[x];
		7334	hasb := true;
		7335	p3[x * 3] := TraceB;
		7336	p3[x * 3 + 1] := TraceB;
		7337	p3[x * 3 + 2] := TraceB;
		7338	end
		7339	else
		7340	begin
		7341	if p1[x] <> tb then
		7342	begin
		7343	p3[x * 3] := TraceB;
		7344	p3[x * 3 + 1] := TraceB;
		7345	p3[x * 3 + 2] := TraceB;
		7346	end
		7347	else
		7348	begin
		7349	p4[x * 3] := TraceB;
		7350	p4[x * 3 + 1] := TraceB;
		7351	p4[x * 3 + 2] := TraceB;
		7352	end;
		7353	end;
		7354	end;
		7355	dec(x);
		7356	until x <= 1;
		7357	end;
		7358	end;
		7359	bitmap.free;
		7360	end;
		7361	var BB1, BB2: TDIB;
		7362	begin
		7363	BB1 := TDIB.Create;
		7364	BB1.BitCount := 24;
		7365	BB1.Assign(Self);
		7366	BB2 := TDIB.Create;
		7367	BB2.BitCount := 24;
		7368	BB2.Assign(BB1);
		7369	Trace(BB2, Amount);
		7370	Self.Assign(BB2);
		7371	BB1.Free;
		7372	BB2.Free;
		7373	end;
		7374
		7375	procedure TDIB.DoSplitlight(Amount: Integer);
		7376	procedure Splitlight(var clip: TDIB; amount: Integer);
		7377	var
		7378	x, y, i: Integer;
		7379	p1: pbytearray;
		7380
		7381	function sinpixs(a: Integer): Integer;
		7382	begin
		7383	result := variant(sin(a / 255 * pi / 2) * 255);
		7384	end;
		7385	begin
		7386	for i := 1 to amount do
		7387	for y := 0 to clip.height - 1 do
		7388	begin
		7389	p1 := clip.scanline[y];
		7390	for x := 0 to clip.width - 1 do
		7391	begin
		7392	p1[x * 3] := sinpixs(p1[x * 3]);
		7393	p1[x * 3 + 1] := sinpixs(p1[x * 3 + 1]);
		7394	p1[x * 3 + 2] := sinpixs(p1[x * 3 + 2]);
		7395	end;
		7396	end;
		7397	end;
		7398	var BB1 {,BB2}: TDIB;
		7399	begin
		7400	BB1 := TDIB.Create;
		7401	BB1.BitCount := 24;
		7402	BB1.Assign(Self);
		7403	// BB2 := TDIB.Create;
		7404	// BB2.BitCount := 24;
		7405	// BB2.Assign (BB1);
		7406	Splitlight(BB1, Amount);
		7407	Self.Assign(BB1);
		7408	BB1.Free;
		7409	// BB2.Free;
		7410	end;
		7411
		7412	procedure TDIB.DoTile(Amount: Integer);
		7413	procedure SmoothResize(var Src, Dst: TDIB);
		7414	var
		7415	x, y, xP, yP,
		7416	yP2, xP2: Integer;
		7417	Read, Read2: PByteArray;
		7418	t, z, z2, iz2: Integer;
		7419	pc: PBytearray;
		7420	w1, w2, w3, w4: Integer;
		7421	Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
		7422	begin
		7423	xP2 := ((src.Width - 1) shl 15) div Dst.Width;
		7424	yP2 := ((src.Height - 1) shl 15) div Dst.Height;
		7425	yP := 0;
		7426	for y := 0 to Dst.Height - 1 do
		7427	begin
		7428	xP := 0;
		7429	Read := src.ScanLine[yP shr 15];
		7430	if yP shr 16 < src.Height - 1 then
		7431	Read2 := src.ScanLine[yP shr 15 + 1]
		7432	else
		7433	Read2 := src.ScanLine[yP shr 15];
		7434	pc := Dst.scanline[y];
		7435	z2 := yP and $7FFF;
		7436	iz2 := $8000 - z2;
		7437	for x := 0 to Dst.Width - 1 do
		7438	begin
		7439	t := xP shr 15;
		7440	Col1r := Read[t * 3];
		7441	Col1g := Read[t * 3 + 1];
		7442	Col1b := Read[t * 3 + 2];
		7443	Col2r := Read2[t * 3];
		7444	Col2g := Read2[t * 3 + 1];
		7445	Col2b := Read2[t * 3 + 2];
		7446	z := xP and $7FFF;
		7447	w2 := (z * iz2) shr 15;
		7448	w1 := iz2 - w2;
		7449	w4 := (z * z2) shr 15;
		7450	w3 := z2 - w4;
		7451	pc[x * 3 + 2] :=
		7452	(Col1b * w1 + Read[(t + 1) * 3 + 2] * w2 +
		7453	Col2b * w3 + Read2[(t + 1) * 3 + 2] * w4) shr 15;
		7454	pc[x * 3 + 1] :=
		7455	(Col1g * w1 + Read[(t + 1) * 3 + 1] * w2 +
		7456	Col2g * w3 + Read2[(t + 1) * 3 + 1] * w4) shr 15;
		7457	pc[x * 3] :=
		7458	(Col1r * w1 + Read2[(t + 1) * 3] * w2 +
		7459	Col2r * w3 + Read2[(t + 1) * 3] * w4) shr 15;
		7460	Inc(xP, xP2);
		7461	end;
		7462	Inc(yP, yP2);
		7463	end;
		7464	end;
		7465	procedure Tile(src, dst: TDIB; amount: Integer);
		7466	var
		7467	w, h, w2, h2, i, j: Integer;
		7468	bm: TDIB;
		7469	begin
		7470	w := src.width;
		7471	h := src.height;
		7472	dst.width := w;
		7473	dst.height := h;
		7474	dst.Canvas.draw(0, 0, src);
		7475	if (amount <= 0) or ((w div amount) < 5) or ((h div amount) < 5) then exit;
		7476	h2 := h div amount;
		7477	w2 := w div amount;
		7478	bm := TDIB.create;
		7479	bm.width := w2;
		7480	bm.height := h2;
		7481	bm.BitCount := 24;
		7482	smoothresize(src, bm);
		7483	for j := 0 to amount - 1 do
		7484	for i := 0 to amount - 1 do
		7485	dst.canvas.Draw(i * w2, j * h2, bm);
		7486	bm.free;
		7487	end;
		7488	var BB1, BB2: TDIB;
		7489	begin
		7490	BB1 := TDIB.Create;
		7491	BB1.BitCount := 24;
		7492	BB1.Assign(Self);
		7493	BB2 := TDIB.Create;
		7494	BB2.BitCount := 24;
		7495	BB2.Assign(BB1);
		7496	Tile(BB1, BB2, Amount);
		7497	Self.Assign(BB2);
		7498	BB1.Free;
		7499	BB2.Free;
		7500	end;
		7501
		7502	procedure TDIB.DoSpotLight(Amount: Integer; Spot: TRect);
		7503	procedure SpotLight(var src: TDIB; Amount: Integer; Spot: TRect);
		7504	var
		7505	bm, z: TDIB;
		7506	w, h: Integer;
		7507	begin
		7508	z := TDIB.Create;
		7509	try
		7510	z.SetSize(src.Width, src.Height, 24);
		7511	z.DrawTo(src, 0, 0, src.Width, src.Height, 0, 0);
		7512	w := z.Width;
		7513	h := z.Height;
		7514	bm := TDIB.create;
		7515	try
		7516	bm.Width := w;
		7517	bm.Height := h;
		7518	bm.Canvas.Brush.color := clblack;
		7519	bm.Canvas.FillRect(rect(0, 0, w, h));
		7520	bm.Canvas.Brush.Color := clwhite;
		7521	bm.Canvas.Ellipse(Spot.left, spot.top, spot.right, spot.bottom);
		7522	bm.Transparent := true;
		7523	z.Canvas.CopyMode := cmSrcAnd; {as transparentcolor for white}
		7524	z.Canvas.Draw(0, 0, src);
		7525	z.Canvas.Draw(0, 0, bm);
		7526	src.Darkness(Amount);
		7527	src.Canvas.CopyMode := cmSrcPaint;
		7528	src.DrawTransparent(z, 0, 0, z.Width, z.Height, 0, 0, clBlack);
		7529	finally
		7530	bm.Free;
		7531	end;
		7532	finally
		7533	z.Free
		7534	end;
		7535	end;
		7536	var BB1, BB2: TDIB;
		7537	begin
		7538	BB1 := TDIB.Create;
		7539	BB1.BitCount := 24;
		7540	BB1.Assign(Self);
		7541	BB2 := TDIB.Create;
		7542	BB2.BitCount := 24;
		7543	BB2.Assign(BB1);
		7544	SpotLight(BB2, Amount, Spot);
		7545	Self.Assign(BB2);
		7546	BB1.Free;
		7547	BB2.Free;
		7548	end;
		7549
		7550	procedure TDIB.DoEmboss;
		7551	procedure Emboss(var Bmp: TDIB);
		7552	var
		7553	x, y: Integer;
		7554	p1, p2: Pbytearray;
		7555	begin
		7556	for y := 0 to Bmp.Height - 2 do
		7557	begin
		7558	p1 := bmp.scanline[y];
		7559	p2 := bmp.scanline[y + 1];
		7560	for x := 0 to Bmp.Width - 4 do
		7561	begin
		7562	p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] xor $FF)) shr 1;
		7563	p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
		7564	p1[x * 3 + 2] := (p1[x * 3 + 2] + (p2[(x + 3) * 3 + 2] xor $FF)) shr 1;
		7565	end;
		7566	end;
		7567	end;
		7568	var BB1, BB2: TDIB;
		7569	begin
		7570	BB1 := TDIB.Create;
		7571	BB1.BitCount := 24;
		7572	BB1.Assign(Self);
		7573	BB2 := TDIB.Create;
		7574	BB2.BitCount := 24;
		7575	BB2.Assign(BB1);
		7576	Emboss(BB2);
		7577	Self.Assign(BB2);
		7578	BB1.Free;
		7579	BB2.Free;
		7580	end;
		7581
		7582	procedure TDIB.DoSolorize(Amount: Integer);
		7583	procedure Solorize(src, dst: TDIB; amount: Integer);
		7584	var
		7585	w, h, x, y: Integer;
		7586	ps, pd: pbytearray;
		7587	c: Integer;
		7588	begin
		7589	w := src.width;
		7590	h := src.height;
		7591	src.BitCount := 24;
		7592	dst.BitCount := 24;
		7593	for y := 0 to h - 1 do
		7594	begin
		7595	ps := src.scanline[y];
		7596	pd := dst.scanline[y];
		7597	for x := 0 to w - 1 do
		7598	begin
		7599	c := (ps[x * 3] + ps[x * 3 + 1] + ps[x * 3 + 2]) div 3;
		7600	if c > amount then
		7601	begin
		7602	pd[x * 3] := 255 - ps[x * 3];
		7603	pd[x * 3 + 1] := 255 - ps[x * 3 + 1];
		7604	pd[x * 3 + 2] := 255 - ps[x * 3 + 2];
		7605	end
		7606	else
		7607	begin
		7608	pd[x * 3] := ps[x * 3];
		7609	pd[x * 3 + 1] := ps[x * 3 + 1];
		7610	pd[x * 3 + 2] := ps[x * 3 + 2];
		7611	end;
		7612	end;
		7613	end;
		7614	end;
		7615	var BB1, BB2: TDIB;
		7616	begin
		7617	BB1 := TDIB.Create;
		7618	BB1.BitCount := 24;
		7619	BB1.Assign(Self);
		7620	BB2 := TDIB.Create;
		7621	BB2.BitCount := 24;
		7622	BB2.Assign(BB1);
		7623	Solorize(BB1, BB2, Amount);
		7624	Self.Assign(BB2);
		7625	BB1.Free;
		7626	BB2.Free;
		7627	end;
		7628
		7629	procedure TDIB.DoPosterize(Amount: Integer);
		7630	procedure Posterize(src, dst: TDIB; amount: Integer);
		7631	var
		7632	w, h, x, y: Integer;
		7633	ps, pd: pbytearray;
		7634	begin
		7635	w := src.width;
		7636	h := src.height;
		7637	src.BitCount := 24;
		7638	dst.BitCount := 24;
		7639	for y := 0 to h - 1 do
		7640	begin
		7641	ps := src.scanline[y];
		7642	pd := dst.scanline[y];
		7643	for x := 0 to w - 1 do
		7644	begin
		7645	pd[x * 3] := round(ps[x * 3] / amount) * amount;
		7646	pd[x * 3 + 1] := round(ps[x * 3 + 1] / amount) * amount;
		7647	pd[x * 3 + 2] := round(ps[x * 3 + 2] / amount) * amount;
		7648	end;
		7649	end;
		7650	end;
		7651	var BB1, BB2: TDIB;
		7652	begin
		7653	BB1 := TDIB.Create;
		7654	BB1.BitCount := 24;
		7655	BB1.Assign(Self);
		7656	BB2 := TDIB.Create;
		7657	BB2.BitCount := 24;
		7658	BB2.Assign(BB1);
		7659	Posterize(BB1, BB2, Amount);
		7660	Self.Assign(BB2);
		7661	BB1.Free;
		7662	BB2.Free;
		7663	end;
		7664
		7665	procedure TDIB.DoBrightness(Amount: Integer);
		7666	procedure Brightness(src, dst: TDIB; level: Integer);
		7667	const
		7668	MaxPixelCount = 32768;
		7669	type
		7670	pRGBArray = ^TRGBArray;
		7671	TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
		7672	var
		7673	i, j, value: Integer;
		7674	OrigRow, DestRow: pRGBArray;
		7675	begin
		7676	// get brightness increment value
		7677	value := level;
		7678	src.BitCount := 24;
		7679	dst.BitCount := 24;
		7680	// for each row of pixels
		7681	for i := 0 to src.Height - 1 do
		7682	begin
		7683	OrigRow := src.ScanLine[i];
		7684	DestRow := dst.ScanLine[i];
		7685	// for each pixel in row
		7686	for j := 0 to src.Width - 1 do
		7687	begin
		7688	// add brightness value to pixel's RGB values
		7689	if value > 0 then
		7690	begin
		7691	// RGB values must be less than 256
		7692	DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
		7693	DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
		7694	DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
		7695	end
		7696	else
		7697	begin
		7698	// RGB values must be greater or equal than 0
		7699	DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
		7700	DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
		7701	DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
		7702	end;
		7703	end;
		7704	end;
		7705	end;
		7706	var BB1, BB2: TDIB;
		7707	begin
		7708	BB1 := TDIB.Create;
		7709	BB1.BitCount := 24;
		7710	BB1.Assign(Self);
		7711	BB2 := TDIB.Create;
		7712	BB2.BitCount := 24;
		7713	BB2.Assign(BB1);
		7714	Brightness(BB1, BB2, Amount);
		7715	Self.Assign(BB2);
		7716	BB1.Free;
		7717	BB2.Free;
		7718	end;
		7719
		7720	procedure TDIB.DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
		7721	procedure Resample(Src, Dst: TDIB; filtertype: TFilterTypeResample; fwidth: single);
		7722	// -----------------------------------------------------------------------------
		7723	//
		7724	// Filter functions
		7725	//
		7726	// -----------------------------------------------------------------------------
		7727
		7728	// Hermite filter
		7729	function HermiteFilter(Value: Single): Single;
		7730	begin
		7731	// f(t) = 2\|t\|^3 - 3\|t\|^2 + 1, -1 <= t <= 1
		7732	if (Value < 0.0) then
		7733	Value := -Value;
		7734	if (Value < 1.0) then
		7735	Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
		7736	else
		7737	Result := 0.0;
		7738	end;
		7739
		7740	// Box filter
		7741	// a.k.a. "Nearest Neighbour" filter
		7742	// anme: I have not been able to get acceptable
		7743	// results with this filter for subsampling.
		7744	function BoxFilter(Value: Single): Single;
		7745	begin
		7746	if (Value > -0.5) and (Value <= 0.5) then
		7747	Result := 1.0
		7748	else
		7749	Result := 0.0;
		7750	end;
		7751
		7752	// Triangle filter
		7753	// a.k.a. "Linear" or "Bilinear" filter
		7754	function TriangleFilter(Value: Single): Single;
		7755	begin
		7756	if (Value < 0.0) then
		7757	Value := -Value;
		7758	if (Value < 1.0) then
		7759	Result := 1.0 - Value
		7760	else
		7761	Result := 0.0;
		7762	end;
		7763
		7764	// Bell filter
		7765	function BellFilter(Value: Single): Single;
		7766	begin
		7767	if (Value < 0.0) then
		7768	Value := -Value;
		7769	if (Value < 0.5) then
		7770	Result := 0.75 - Sqr(Value)
		7771	else
		7772	if (Value < 1.5) then
		7773	begin
		7774	Value := Value - 1.5;
		7775	Result := 0.5 * Sqr(Value);
		7776	end
		7777	else
		7778	Result := 0.0;
		7779	end;
		7780
		7781	// B-spline filter
		7782	function SplineFilter(Value: Single): Single;
		7783	var
		7784	tt: single;
		7785	begin
		7786	if (Value < 0.0) then
		7787	Value := -Value;
		7788	if (Value < 1.0) then
		7789	begin
		7790	tt := Sqr(Value);
		7791	Result := 0.5 * tt * Value - tt + 2.0 / 3.0;
		7792	end
		7793	else
		7794	if (Value < 2.0) then
		7795	begin
		7796	Value := 2.0 - Value;
		7797	Result := 1.0 / 6.0 * Sqr(Value) * Value;
		7798	end
		7799	else
		7800	Result := 0.0;
		7801	end;
		7802
		7803	// Lanczos3 filter
		7804	function Lanczos3Filter(Value: Single): Single;
		7805	function SinC(Value: Single): Single;
		7806	begin
		7807	if (Value <> 0.0) then
		7808	begin
		7809	Value := Value * Pi;
		7810	Result := sin(Value) / Value
		7811	end
		7812	else
		7813	Result := 1.0;
		7814	end;
		7815	begin
		7816	if (Value < 0.0) then
		7817	Value := -Value;
		7818	if (Value < 3.0) then
		7819	Result := SinC(Value) * SinC(Value / 3.0)
		7820	else
		7821	Result := 0.0;
		7822	end;
		7823
		7824	function MitchellFilter(Value: Single): Single;
		7825	const
		7826	B = (1.0 / 3.0);
		7827	C = (1.0 / 3.0);
		7828	var
		7829	tt: single;
		7830	begin
		7831	if (Value < 0.0) then
		7832	Value := -Value;
		7833	tt := Sqr(Value);
		7834	if (Value < 1.0) then
		7835	begin
		7836	Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
		7837	+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
		7838	+ (6.0 - 2 * B));
		7839	Result := Value / 6.0;
		7840	end
		7841	else
		7842	if (Value < 2.0) then
		7843	begin
		7844	Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
		7845	+ ((6.0 * B + 30.0 * C) * tt)
		7846	+ ((-12.0 * B - 48.0 * C) * Value)
		7847	+ (8.0 * B + 24 * C));
		7848	Result := Value / 6.0;
		7849	end
		7850	else
		7851	Result := 0.0;
		7852	end;
		7853
		7854	// -----------------------------------------------------------------------------
		7855	//
		7856	// Interpolator
		7857	//
		7858	// -----------------------------------------------------------------------------
		7859	type
		7860	// Contributor for a pixel
		7861	TContributor = record
		7862	pixel: Integer; // Source pixel
		7863	weight: single; // Pixel weight
		7864	end;
		7865
		7866	TContributorList = array[0..0] of TContributor;
		7867	PContributorList = ^TContributorList;
		7868
		7869	// List of source pixels contributing to a destination pixel
		7870	TCList = record
		7871	n: Integer;
		7872	p: PContributorList;
		7873	end;
		7874
		7875	TCListList = array[0..0] of TCList;
		7876	PCListList = ^TCListList;
		7877
		7878	TRGB = packed record
		7879	r, g, b: single;
		7880	end;
		7881
		7882	// Physical bitmap pixel
		7883	TColorRGB = packed record
		7884	r, g, b: BYTE;
		7885	end;
		7886	PColorRGB = ^TColorRGB;
		7887
		7888	// Physical bitmap scanline (row)
		7889	TRGBList = packed array[0..0] of TColorRGB;
		7890	PRGBList = ^TRGBList;
		7891
		7892	var
		7893	xscale, yscale: single; // Zoom scale factors
		7894	i, j, k: Integer; // Loop variables
		7895	center: single; // Filter calculation variables
		7896	width, fscale, weight: single; // Filter calculation variables
		7897	left, right: Integer; // Filter calculation variables
		7898	n: Integer; // Pixel number
		7899	Work: TDIB;
		7900	contrib: PCListList;
		7901	rgb: TRGB;
		7902	color: TColorRGB;
		7903	{$IFDEF USE_SCANLINE}
		7904	SourceLine,
		7905	DestLine: PRGBList;
		7906	SourcePixel,
		7907	DestPixel: PColorRGB;
		7908	Delta,
		7909	DestDelta: Integer;
		7910	{$ENDIF}
		7911	SrcWidth,
		7912	SrcHeight,
		7913	DstWidth,
		7914	DstHeight: Integer;
		7915
		7916	function Color2RGB(Color: TColor): TColorRGB;
		7917	begin
		7918	Result.r := Color and $000000FF;
		7919	Result.g := (Color and $0000FF00) shr 8;
		7920	Result.b := (Color and $00FF0000) shr 16;
		7921	end;
		7922
		7923	function RGB2Color(Color: TColorRGB): TColor;
		7924	begin
		7925	Result := Color.r or (Color.g shl 8) or (Color.b shl 16);
		7926	end;
		7927
		7928	begin
		7929	DstWidth := Dst.Width;
		7930	DstHeight := Dst.Height;
		7931	SrcWidth := Src.Width;
		7932	SrcHeight := Src.Height;
		7933	if (SrcWidth < 1) or (SrcHeight < 1) then
		7934	raise Exception.Create('Source bitmap too small');
		7935
		7936	// Create intermediate image to hold horizontal zoom
		7937	Work := TDIB.Create;
		7938	try
		7939	Work.Height := SrcHeight;
		7940	Work.Width := DstWidth;
		7941	// xscale := DstWidth / SrcWidth;
		7942	// yscale := DstHeight / SrcHeight;
		7943	// Improvement suggested by David Ullrich:
		7944	if (SrcWidth = 1) then
		7945	xscale := DstWidth / SrcWidth
		7946	else
		7947	xscale := (DstWidth - 1) / (SrcWidth - 1);
		7948	if (SrcHeight = 1) then
		7949	yscale := DstHeight / SrcHeight
		7950	else
		7951	yscale := (DstHeight - 1) / (SrcHeight - 1);
		7952	// This implementation only works on 24-bit images because it uses
		7953	// TDIB.Scanline
		7954	{$IFDEF USE_SCANLINE}
		7955	//Src.PixelFormat := pf24bit;
		7956	Src.BitCount := 24;
		7957	//Dst.PixelFormat := Src.PixelFormat;
		7958	dst.BitCount := 24;
		7959	//Work.PixelFormat := Src.PixelFormat;
		7960	work.BitCount := 24;
		7961	{$ENDIF}
		7962
		7963	// --------------------------------------------
		7964	// Pre-calculate filter contributions for a row
		7965	// -----------------------------------------------
		7966	GetMem(contrib, DstWidth * sizeof(TCList));
		7967	// Horizontal sub-sampling
		7968	// Scales from bigger to smaller width
		7969	if (xscale < 1.0) then
		7970	begin
		7971	width := fwidth / xscale;
		7972	fscale := 1.0 / xscale;
		7973	for i := 0 to DstWidth - 1 do
		7974	begin
		7975	contrib^[i].n := 0;
		7976	GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
		7977	center := i / xscale;
		7978	// Original code:
		7979	// left := ceil(center - width);
		7980	// right := floor(center + width);
		7981	left := floor(center - width);
		7982	right := ceil(center + width);
		7983	for j := left to right do
		7984	begin
		7985	case filtertype of
		7986	ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
		7987	ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
		7988	ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
		7989	ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
		7990	ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
		7991	ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
		7992	ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
		7993	else
		7994	weight := 0
		7995	end;
		7996	if (weight = 0.0) then
		7997	continue;
		7998	if (j < 0) then
		7999	n := -j
		8000	else if (j >= SrcWidth) then
		8001	n := SrcWidth - j + SrcWidth - 1
		8002	else
		8003	n := j;
		8004	k := contrib^[i].n;
		8005	contrib^[i].n := contrib^[i].n + 1;
		8006	contrib^[i].p^[k].pixel := n;
		8007	contrib^[i].p^[k].weight := weight;
		8008	end;
		8009	end;
		8010	end
		8011	else
		8012	// Horizontal super-sampling
		8013	// Scales from smaller to bigger width
		8014	begin
		8015	for i := 0 to DstWidth - 1 do
		8016	begin
		8017	contrib^[i].n := 0;
		8018	GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
		8019	center := i / xscale;
		8020	// Original code:
		8021	// left := ceil(center - fwidth);
		8022	// right := floor(center + fwidth);
		8023	left := floor(center - fwidth);
		8024	right := ceil(center + fwidth);
		8025	for j := left to right do
		8026	begin
		8027	case filtertype of
		8028	ftrBox: weight := boxfilter(center - j);
		8029	ftrTriangle: weight := trianglefilter(center - j);
		8030	ftrHermite: weight := hermitefilter(center - j);
		8031	ftrBell: weight := bellfilter(center - j);
		8032	ftrBSpline: weight := splinefilter(center - j);
		8033	ftrLanczos3: weight := Lanczos3filter(center - j);
		8034	ftrMitchell: weight := Mitchellfilter(center - j);
		8035	else
		8036	weight := 0
		8037	end;
		8038	if (weight = 0.0) then
		8039	continue;
		8040	if (j < 0) then
		8041	n := -j
		8042	else if (j >= SrcWidth) then
		8043	n := SrcWidth - j + SrcWidth - 1
		8044	else
		8045	n := j;
		8046	k := contrib^[i].n;
		8047	contrib^[i].n := contrib^[i].n + 1;
		8048	contrib^[i].p^[k].pixel := n;
		8049	contrib^[i].p^[k].weight := weight;
		8050	end;
		8051	end;
		8052	end;
		8053
		8054	// ----------------------------------------------------
		8055	// Apply filter to sample horizontally from Src to Work
		8056	// ----------------------------------------------------
		8057	for k := 0 to SrcHeight - 1 do
		8058	begin
		8059	{$IFDEF USE_SCANLINE}
		8060	SourceLine := Src.ScanLine[k];
		8061	DestPixel := Work.ScanLine[k];
		8062	{$ENDIF}
		8063	for i := 0 to DstWidth - 1 do
		8064	begin
		8065	rgb.r := 0.0;
		8066	rgb.g := 0.0;
		8067	rgb.b := 0.0;
		8068	for j := 0 to contrib^[i].n - 1 do
		8069	begin
		8070	{$IFDEF USE_SCANLINE}
		8071	color := SourceLine^[contrib^[i].p^[j].pixel];
		8072	{$ELSE}
		8073	color := Color2RGB(Src.Canvas.Pixels[contrib^[i].p^[j].pixel, k]);
		8074	{$ENDIF}
		8075	weight := contrib^[i].p^[j].weight;
		8076	if (weight = 0.0) then
		8077	continue;
		8078	rgb.r := rgb.r + color.r * weight;
		8079	rgb.g := rgb.g + color.g * weight;
		8080	rgb.b := rgb.b + color.b * weight;
		8081	end;
		8082	if (rgb.r > 255.0) then
		8083	color.r := 255
		8084	else if (rgb.r < 0.0) then
		8085	color.r := 0
		8086	else
		8087	color.r := round(rgb.r);
		8088	if (rgb.g > 255.0) then
		8089	color.g := 255
		8090	else if (rgb.g < 0.0) then
		8091	color.g := 0
		8092	else
		8093	color.g := round(rgb.g);
		8094	if (rgb.b > 255.0) then
		8095	color.b := 255
		8096	else if (rgb.b < 0.0) then
		8097	color.b := 0
		8098	else
		8099	color.b := round(rgb.b);
		8100	{$IFDEF USE_SCANLINE}
		8101	// Set new pixel value
		8102	DestPixel^ := color;
		8103	// Move on to next column
		8104	inc(DestPixel);
		8105	{$ELSE}
		8106	Work.Canvas.Pixels[i, k] := RGB2Color(color);
		8107	{$ENDIF}
		8108	end;
		8109	end;
		8110
		8111	// Free the memory allocated for horizontal filter weights
		8112	for i := 0 to DstWidth - 1 do
		8113	FreeMem(contrib^[i].p);
		8114
		8115	FreeMem(contrib);
		8116
		8117	// -----------------------------------------------
		8118	// Pre-calculate filter contributions for a column
		8119	// -----------------------------------------------
		8120	GetMem(contrib, DstHeight * sizeof(TCList));
		8121	// Vertical sub-sampling
		8122	// Scales from bigger to smaller height
		8123	if (yscale < 1.0) then
		8124	begin
		8125	width := fwidth / yscale;
		8126	fscale := 1.0 / yscale;
		8127	for i := 0 to DstHeight - 1 do
		8128	begin
		8129	contrib^[i].n := 0;
		8130	GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
		8131	center := i / yscale;
		8132	// Original code:
		8133	// left := ceil(center - width);
		8134	// right := floor(center + width);
		8135	left := floor(center - width);
		8136	right := ceil(center + width);
		8137	for j := left to right do
		8138	begin
		8139	case filtertype of
		8140	ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
		8141	ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
		8142	ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
		8143	ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
		8144	ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
		8145	ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
		8146	ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
		8147	else
		8148	weight := 0
		8149	end;
		8150	if (weight = 0.0) then
		8151	continue;
		8152	if (j < 0) then
		8153	n := -j
		8154	else if (j >= SrcHeight) then
		8155	n := SrcHeight - j + SrcHeight - 1
		8156	else
		8157	n := j;
		8158	k := contrib^[i].n;
		8159	contrib^[i].n := contrib^[i].n + 1;
		8160	contrib^[i].p^[k].pixel := n;
		8161	contrib^[i].p^[k].weight := weight;
		8162	end;
		8163	end
		8164	end
		8165	else
		8166	// Vertical super-sampling
		8167	// Scales from smaller to bigger height
		8168	begin
		8169	for i := 0 to DstHeight - 1 do
		8170	begin
		8171	contrib^[i].n := 0;
		8172	GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
		8173	center := i / yscale;
		8174	// Original code:
		8175	// left := ceil(center - fwidth);
		8176	// right := floor(center + fwidth);
		8177	left := floor(center - fwidth);
		8178	right := ceil(center + fwidth);
		8179	for j := left to right do
		8180	begin
		8181	case filtertype of
		8182	ftrBox: weight := boxfilter(center - j);
		8183	ftrTriangle: weight := trianglefilter(center - j);
		8184	ftrHermite: weight := hermitefilter(center - j);
		8185	ftrBell: weight := bellfilter(center - j);
		8186	ftrBSpline: weight := splinefilter(center - j);
		8187	ftrLanczos3: weight := Lanczos3filter(center - j);
		8188	ftrMitchell: weight := Mitchellfilter(center - j);
		8189	else
		8190	weight := 0
		8191	end;
		8192	if (weight = 0.0) then
		8193	continue;
		8194	if (j < 0) then
		8195	n := -j
		8196	else if (j >= SrcHeight) then
		8197	n := SrcHeight - j + SrcHeight - 1
		8198	else
		8199	n := j;
		8200	k := contrib^[i].n;
		8201	contrib^[i].n := contrib^[i].n + 1;
		8202	contrib^[i].p^[k].pixel := n;
		8203	contrib^[i].p^[k].weight := weight;
		8204	end;
		8205	end;
		8206	end;
		8207
		8208	// --------------------------------------------------
		8209	// Apply filter to sample vertically from Work to Dst
		8210	// --------------------------------------------------
		8211	{$IFDEF USE_SCANLINE}
		8212	SourceLine := Work.ScanLine[0];
		8213	Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
		8214	DestLine := Dst.ScanLine[0];
		8215	DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
		8216	{$ENDIF}
		8217	for k := 0 to DstWidth - 1 do
		8218	begin
		8219	{$IFDEF USE_SCANLINE}
		8220	DestPixel := pointer(DestLine);
		8221	{$ENDIF}
		8222	for i := 0 to DstHeight - 1 do
		8223	begin
		8224	rgb.r := 0;
		8225	rgb.g := 0;
		8226	rgb.b := 0;
		8227	// weight := 0.0;
		8228	for j := 0 to contrib^[i].n - 1 do
		8229	begin
		8230	{$IFDEF USE_SCANLINE}
		8231	color := PColorRGB(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
		8232	{$ELSE}
		8233	color := Color2RGB(Work.Canvas.Pixels[k, contrib^[i].p^[j].pixel]);
		8234	{$ENDIF}
		8235	weight := contrib^[i].p^[j].weight;
		8236	if (weight = 0.0) then
		8237	continue;
		8238	rgb.r := rgb.r + color.r * weight;
		8239	rgb.g := rgb.g + color.g * weight;
		8240	rgb.b := rgb.b + color.b * weight;
		8241	end;
		8242	if (rgb.r > 255.0) then
		8243	color.r := 255
		8244	else if (rgb.r < 0.0) then
		8245	color.r := 0
		8246	else
		8247	color.r := round(rgb.r);
		8248	if (rgb.g > 255.0) then
		8249	color.g := 255
		8250	else if (rgb.g < 0.0) then
		8251	color.g := 0
		8252	else
		8253	color.g := round(rgb.g);
		8254	if (rgb.b > 255.0) then
		8255	color.b := 255
		8256	else if (rgb.b < 0.0) then
		8257	color.b := 0
		8258	else
		8259	color.b := round(rgb.b);
		8260	{$IFDEF USE_SCANLINE}
		8261	DestPixel^ := color;
		8262	inc(Integer(DestPixel), DestDelta);
		8263	{$ELSE}
		8264	Dst.Canvas.Pixels[k, i] := RGB2Color(color);
		8265	{$ENDIF}
		8266	end;
		8267	{$IFDEF USE_SCANLINE}
		8268	Inc(SourceLine, 1);
		8269	Inc(DestLine, 1);
		8270	{$ENDIF}
		8271	end;
		8272
		8273	// Free the memory allocated for vertical filter weights
		8274	for i := 0 to DstHeight - 1 do
		8275	FreeMem(contrib^[i].p);
		8276
		8277	FreeMem(contrib);
		8278
		8279	finally
		8280	Work.Free;
		8281	end;
		8282	end;
		8283	var BB1, BB2: TDIB;
		8284	begin
		8285	BB1 := TDIB.Create;
		8286	BB1.BitCount := 24;
		8287	BB1.Assign(Self);
		8288	BB2 := TDIB.Create;
		8289	BB2.SetSize(AmountX, AmountY, 24);
		8290	Resample(BB1, BB2, TypeResample, DefaultFilterRadius[TypeResample]);
		8291	Self.Assign(BB2);
		8292	BB1.Free;
		8293	BB2.Free;
		8294	end;
		8295
		8296	procedure TDIB.DoColorize(ForeColor, BackColor: TColor);
		8297	procedure Colorize(src, dst: TDIB; iForeColor, iBackColor: TColor; iDither: Boolean{$IFDEF VER4UP} = False{$ENDIF});
		8298	{for monochromatic picture change colors}
		8299	procedure InvertBitmap(Bmp: TDIB);
		8300	begin
		8301	Bmp.Canvas.CopyMode := cmDstInvert;
		8302	Bmp.Canvas.CopyRect(rect(0, 0, Bmp.Width, Bmp.Height),
		8303	Bmp.Canvas, rect(0, 0, Bmp.Width, Bmp.Height));
		8304	end;
		8305	var
		8306	fForeColor: TColor;
		8307	fForeDither: Boolean;
		8308	lTempBitmap: TDIB;
		8309	lTempBitmap2: TDIB;
		8310	lDitherBitmap: TDIB;
		8311	lCRect: TRect;
		8312	x, y, w, h: Integer;
		8313	begin
		8314	{--}
		8315	//fColor := iBackColor; ;
		8316	fForeColor := iForeColor;
		8317	fForeDither := iDither;
		8318	w := src.Width;
		8319	h := src.Height;
		8320	lDitherBitmap := nil;
		8321	lTempBitmap := TDIB.Create;
		8322	lTempBitmap.SetSize(w, h, 24);
		8323	lTempBitmap2 := TDIB.Create;
		8324	lTempBitmap2.SetSize(w, h, 24);
		8325	lCRect := rect(0, 0, w, h);
		8326	with lTempBitmap.Canvas do
		8327	begin
		8328	Brush.Style := bsSolid;
		8329	Brush.Color := iBackColor;
		8330	FillRect(lCRect);
		8331	CopyMode := cmSrcInvert;
		8332	CopyRect(lCRect, src.Canvas, lCRect);
		8333	InvertBitmap(src);
		8334	CopyMode := cmSrcPaint;
		8335	CopyRect(lCRect, src.Canvas, lCRect);
		8336	InvertBitmap(lTempBitmap);
		8337	CopyMode := cmSrcInvert;
		8338	CopyRect(lCRect, src.Canvas, lCRect);
		8339	InvertBitmap(src);
		8340	end;
		8341	with lTempBitmap2.Canvas do
		8342	begin
		8343	Brush.Style := bsSolid;
		8344	Brush.Color := clBlack;
		8345	FillRect(lCRect);
		8346	if fForeDither then
		8347	begin
		8348	InvertBitmap(src);
		8349	lDitherBitmap := TDIB.Create;
		8350	lDitherBitmap.SetSize(8, 8, 24);
		8351	with lDitherBitmap.Canvas do
		8352	begin
		8353	for x := 0 to 7 do
		8354	for y := 0 to 7 do
		8355	if ((x mod 2 = 0) and (y mod 2 > 0)) or ((x mod 2 > 0) and (y mod 2 = 0)) then
		8356	pixels[x, y] := fForeColor
		8357	else
		8358	pixels[x, y] := iBackColor;
		8359	end;
		8360	Brush.Bitmap.Assign(lDitherBitmap);
		8361	end
		8362	else
		8363	begin
		8364	Brush.Style := bsSolid;
		8365	Brush.Color := fForeColor;
		8366	end;
		8367	if not fForeDither then
		8368	InvertBitmap(src);
		8369	CopyMode := cmPatPaint;
		8370	CopyRect(lCRect, src.Canvas, lCRect);
		8371	if fForeDither then
		8372	if Assigned(lDitherBitmap) then
		8373	lDitherBitmap.Free;
		8374	CopyMode := cmSrcInvert;
		8375	CopyRect(lCRect, src.Canvas, lCRect);
		8376	end;
		8377	lTempBitmap.Canvas.CopyMode := cmSrcInvert;
		8378	lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
		8379	InvertBitmap(src);
		8380	lTempBitmap.Canvas.CopyMode := cmSrcErase;
		8381	lTempBitmap.Canvas.Copyrect(lCRect, src.Canvas, lCRect);
		8382	InvertBitmap(src);
		8383	lTempBitmap.Canvas.CopyMode := cmSrcInvert;
		8384	lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
		8385	InvertBitmap(lTempBitmap);
		8386	InvertBitmap(src);
		8387	dst.Assign(lTempBitmap);
		8388	lTempBitmap.Free;
		8389	end;
		8390	var BB1, BB2: TDIB;
		8391	begin
		8392	BB1 := TDIB.Create;
		8393	BB1.BitCount := 24;
		8394	BB1.Assign(Self);
		8395	BB2 := TDIB.Create;
		8396	Colorize(BB1, BB2, ForeColor, BackColor{$IFNDEF VER4UP}, False{$ENDIF});
		8397	Self.Assign(BB2);
		8398	BB1.Free;
		8399	BB2.Free;
		8400	end;
		8401
		8402	{ procedure for special purpose }
		8403
		8404	procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
		8405	var
		8406	P1, P2: PByteArray;
		8407	W, H: Integer;
		8408	begin
		8409	P1 := ScanLine[DIB2.Height - 1];
		8410	P2 := DIB2.ScanLine[DIB2.Height - 1];
		8411	W := WidthBytes;
		8412	H := Height;
		8413	asm
		8414	PUSH ESI
		8415	PUSH EDI
		8416	MOV ESI, P1
		8417	MOV EDI, P2
		8418	MOV EDX, W
		8419	MOV EAX, H
		8420	IMUL EDX
		8421	MOV ECX, EAX
		8422	@@1:
		8423	MOV AL, Step
		8424	MOV AH, [ESI]
		8425	CMP AL, AH
		8426	JA @@2
		8427	MOV AL, AH
		8428	@@2:
		8429	MOV [EDI], AL
		8430	INC ESI
		8431	INC EDI
		8432	DEC ECX
		8433	JNZ @@1
		8434	POP EDI
		8435	POP ESI
		8436	end;
		8437	end;
		8438
		8439	procedure TDIB.DoZoom(DIB2: TDIB; ZoomRatio: Real);
		8440	var
		8441	P1, P2: PByteArray;
		8442	W, H: Integer;
		8443	x, y: Integer;
		8444	xr, yr, xstep, ystep: real;
		8445	xstart: real;
		8446	begin
		8447	W := WidthBytes;
		8448	H := Height;
		8449	xstart := (W - (W * ZoomRatio)) / 2;
		8450
		8451	xr := xstart;
		8452	yr := (H - (H * ZoomRatio)) / 2;
		8453	xstep := ZoomRatio;
		8454	ystep := ZoomRatio;
		8455
		8456	for y := 1 to Height - 1 do
		8457	begin
		8458	P2 := DIB2.ScanLine[y];
		8459	if (yr >= 0) and (yr <= H) then
		8460	begin
		8461	P1 := ScanLine[Trunc(yr)];
		8462	for x := 1 to Width - 1 do
		8463	begin
		8464	if (xr >= 0) and (xr <= W) then
		8465	begin
		8466	P2[x] := P1[Trunc(xr)];
		8467	end
		8468	else
		8469	begin
		8470	P2[x] := 0;
		8471	end;
		8472	xr := xr + xstep;
		8473	end;
		8474	end
		8475	else
		8476	begin
		8477	for x := 1 to Width - 1 do
		8478	begin
		8479	P2[x] := 0;
		8480	end;
		8481	end;
		8482	xr := xstart;
		8483	yr := yr + ystep;
		8484	end;
		8485	end;
		8486
		8487	procedure TDIB.DoBlur(DIB2: TDIB);
		8488	var
		8489	P1, P2: PByteArray;
		8490	W: Integer;
		8491	x, y: Integer;
		8492	begin
		8493	W := WidthBytes;
		8494	for y := 1 to Height - 1 do
		8495	begin
		8496	P1 := ScanLine[y];
		8497	P2 := DIB2.ScanLine[y];
		8498	for x := 1 to Width - 1 do
		8499	begin
		8500	P2[x] := (P1[x] + P1[x - 1] + P1[x + 1] + P1[x + W] + P1[x - W]) div 5;
		8501	end;
		8502	end;
		8503	end;
		8504
		8505	procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
		8506	var
		8507	P1, P2: PByteArray;
		8508	W, H: Integer;
		8509	begin
		8510	P1 := ScanLine[DIB2.Height - 1];
		8511	P2 := DIB2.ScanLine[DIB2.Height - 1];
		8512	W := WidthBytes;
		8513	H := Height;
		8514	asm
		8515	PUSH ESI
		8516	PUSH EDI
		8517	MOV ESI, P1
		8518	MOV EDI, P2
		8519	MOV EDX, W
		8520	MOV EAX, H
		8521	IMUL EDX
		8522	MOV ECX, EAX
		8523	@@1:
		8524	MOV AL, Step
		8525	MOV AH, [ESI]
		8526	CMP AL, AH
		8527	JB @@2
		8528	MOV AL, AH
		8529	@@2:
		8530	MOV [EDI], AL
		8531	INC ESI
		8532	INC EDI
		8533	DEC ECX
		8534	JNZ @@1
		8535	POP EDI
		8536	POP ESI
		8537	end;
		8538	end;
		8539
		8540	procedure TDIB.FillDIB8(Color: Byte);
		8541	var
		8542	P: PByteArray;
		8543	W, H: Integer;
		8544	begin
		8545	P := ScanLine[Height - 1];
		8546	W := WidthBytes;
		8547	H := Height;
		8548	asm
		8549	PUSH ESI
		8550	MOV ESI, P
		8551	MOV EDX, W
		8552	MOV EAX, H
		8553	IMUL EDX
		8554	MOV ECX, EAX
		8555	MOV AL, Color
		8556	@@1:
		8557	MOV [ESI], AL
		8558	INC ESI
		8559	DEC ECX
		8560	JNZ @@1
		8561	POP ESI
		8562	end;
		8563	end;
		8564
		8565	procedure TDIB.DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
		8566	type
		8567	T3Byte = array[0..2] of Byte;
		8568	P3ByteArray = ^T3ByteArray;
		8569	T3ByteArray = array[0..32767] of T3Byte;
		8570	PLongArray = ^TLongArray;
		8571	TLongArray = array[0..32767] of LongInt;
		8572	var
		8573	p, p2: PByteArray;
		8574	x, y, x2, y2, angled: Integer;
		8575	cosy, siny: real;
		8576	begin
		8577	angled := 384 + Angle;
		8578	for y := 0 to Height - 1 do
		8579	begin
		8580	p := DIB1.ScanLine[y];
		8581	cosy := (y - cY) * dcos(angled and $1FF);
		8582	siny := (y - cY) * dsin(angled and $1FF);
		8583	for x := 0 to Width - 1 do
		8584	begin
		8585	x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
		8586	y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
		8587	case bitcount of
		8588	8:
		8589	begin
		8590	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		8591	begin
		8592	p2 := ScanLine[y2];
		8593	p[x] := p2[Width - x2];
		8594	end
		8595	else
		8596	begin
		8597	if p[x] > 4 then
		8598	p[x] := p[x] - 4
		8599	else
		8600	p[x] := 0;
		8601	end;
		8602	end;
		8603	16:
		8604	begin
		8605	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		8606	begin
		8607	PWordArray(p2) := ScanLine[y2];
		8608	PWordArray(p)[x] := PWordArray(p2)[Width - x2];
		8609	end
		8610	else
		8611	begin
		8612	if PWordArray(p)[x] > 4 then
		8613	PWordArray(p)[x] := PWordArray(p)[x] - 4
		8614	else
		8615	PWordArray(p)[x] := 0;
		8616	end;
		8617	end;
		8618	24:
		8619	begin
		8620	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		8621	begin
		8622	P3ByteArray(p2) := ScanLine[y2];
		8623	P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
		8624	end
		8625	else
		8626	begin
		8627	if P3ByteArray(p)[x][0] > 4 then
		8628	P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 4
		8629	else if P3ByteArray(p)[x][1] > 4 then
		8630	P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 4
		8631	else if P3ByteArray(p)[x][2] > 4 then
		8632	P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 4
		8633	else
		8634	begin
		8635	P3ByteArray(p)[x][0] := 0;
		8636	P3ByteArray(p)[x][1] := 0;
		8637	P3ByteArray(p)[x][2] := 0;
		8638	end;
		8639	end;
		8640	end;
		8641	32: begin
		8642	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		8643	begin
		8644	plongarray(p2) := ScanLine[y2];
		8645	plongarray(p)[x] := plongarray(p2)[Width - x2];
		8646	end
		8647	else
		8648	begin
		8649	if plongarray(p)[x] > 4 then
		8650	plongarray(p)[x] := plongarray(p)[x] - 4
		8651	else
		8652	plongarray(p)[x] := 0;
		8653	end;
		8654	end;
		8655	end
		8656	end;
		8657	end;
		8658	end;
		8659
		8660	function TDIB.Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
		8661	type
		8662	T3Byte = array[0..2] of Byte;
		8663	P3ByteArray = ^T3ByteArray;
		8664	T3ByteArray = array[0..32767] of T3Byte;
		8665	PLongArray = ^TLongArray;
		8666	TLongArray = array[0..32767] of LongInt;
		8667	function ColorToRGBTriple(const Color: TColor): TRGBTriple;
		8668	begin
		8669	with RESULT do
		8670	begin
		8671	rgbtRed := GetRValue(Color);
		8672	rgbtGreen := GetGValue(Color);
		8673	rgbtBlue := GetBValue(Color)
		8674	end
		8675	end {ColorToRGBTriple};
		8676
		8677	function TestQuad(T: T3Byte; Color: Integer): Boolean;
		8678	begin
		8679	Result := (T[0] > GetRValue(Color)) and
		8680	(T[1] > GetGValue(Color)) and
		8681	(T[2] > GetBValue(Color))
		8682	end;
		8683	var
		8684	p0, p, p2: PByteArray;
		8685	x, y, c: Integer;
		8686	z: Integer;
		8687	begin
		8688	if SprayInit then
		8689	begin
		8690	DIB.Assign(Self);
		8691	{ Spray seeds }
		8692	for c := 0 to AmountSpray do
		8693	begin
		8694	DIB.Pixels[Random(Width - 1), Random(Height - 1)] := 0;
		8695	end;
		8696	end;
		8697	Result := True; {all is black}
		8698	for y := 0 to DIB.Height - 1 do
		8699	begin
		8700	p := DIB.ScanLine[y];
		8701	for x := 0 to DIB.Width - 1 do
		8702	begin
		8703	case bitcount of
		8704	8:
		8705	begin
		8706	if p[x] < 16 then
		8707	begin
		8708	if p[x] > 0 then Result := False;
		8709	if y > 0 then
		8710	begin
		8711	p0 := DIB.ScanLine[y - 1];
		8712	if p0[x] > 4 then
		8713	p0[x] := p0[x] - 4
		8714	else
		8715	p0[x] := 0;
		8716	if x > 0 then
		8717	if p0[x - 1] > 2 then
		8718	p0[x - 1] := p0[x - 1] - 2
		8719	else
		8720	p0[x - 1] := 0;
		8721	if x < (DIB.Width - 1) then
		8722	if p0[x + 1] > 2 then
		8723	p0[x + 1] := p0[x + 1] - 2
		8724	else
		8725	p0[x + 1] := 0;
		8726	end;
		8727	if y < (DIB.Height - 1) then
		8728	begin
		8729	p2 := DIB.ScanLine[y + 1];
		8730	if p2[x] > 4 then
		8731	p2[x] := p2[x] - 4
		8732	else
		8733	p2[x] := 0;
		8734	if x > 0 then
		8735	if p2[x - 1] > 2 then
		8736	p2[x - 1] := p2[x - 1] - 2
		8737	else
		8738	p2[x - 1] := 0;
		8739	if x < (DIB.Width - 1) then
		8740	if p2[x + 1] > 2 then
		8741	p2[x + 1] := p2[x + 1] - 2
		8742	else
		8743	p2[x + 1] := 0;
		8744	end;
		8745	if p[x] > 8 then
		8746	p[x] := p[x] - 8
		8747	else
		8748	p[x] := 0;
		8749	if x > 0 then
		8750	if p[x - 1] > 4 then
		8751	p[x - 1] := p[x - 1] - 4
		8752	else
		8753	p[x - 1] := 0;
		8754	if x < (DIB.Width - 1) then
		8755	if p[x + 1] > 4 then
		8756	p[x + 1] := p[x + 1] - 4
		8757	else
		8758	p[x + 1] := 0;
		8759	end;
		8760	end;
		8761	16:
		8762	begin
		8763	if pwordarray(p)[x] < 16 then
		8764	begin
		8765	if pwordarray(p)[x] > 0 then Result := False;
		8766	if y > 0 then
		8767	begin
		8768	pwordarray(p0) := DIB.ScanLine[y - 1];
		8769	if pwordarray(p0)[x] > 4 then
		8770	pwordarray(p0)[x] := pwordarray(p0)[x] - 4
		8771	else
		8772	pwordarray(p0)[x] := 0;
		8773	if x > 0 then
		8774	if pwordarray(p0)[x - 1] > 2 then
		8775	pwordarray(p0)[x - 1] := pwordarray(p0)[x - 1] - 2
		8776	else
		8777	pwordarray(p0)[x - 1] := 0;
		8778	if x < (DIB.Width - 1) then
		8779	if pwordarray(p0)[x + 1] > 2 then
		8780	pwordarray(p0)[x + 1] := pwordarray(p0)[x + 1] - 2
		8781	else
		8782	pwordarray(p0)[x + 1] := 0;
		8783	end;
		8784	if y < (DIB.Height - 1) then
		8785	begin
		8786	pwordarray(p2) := DIB.ScanLine[y + 1];
		8787	if pwordarray(p2)[x] > 4 then
		8788	pwordarray(p2)[x] := pwordarray(p2)[x] - 4
		8789	else
		8790	pwordarray(p2)[x] := 0;
		8791	if x > 0 then
		8792	if pwordarray(p2)[x - 1] > 2 then
		8793	pwordarray(p2)[x - 1] := pwordarray(p2)[x - 1] - 2
		8794	else
		8795	pwordarray(p2)[x - 1] := 0;
		8796	if x < (DIB.Width - 1) then
		8797	if pwordarray(p2)[x + 1] > 2 then
		8798	pwordarray(p2)[x + 1] := pwordarray(p2)[x + 1] - 2
		8799	else
		8800	pwordarray(p2)[x + 1] := 0;
		8801	end;
		8802	if pwordarray(p)[x] > 8 then
		8803	pwordarray(p)[x] := pwordarray(p)[x] - 8
		8804	else
		8805	pwordarray(p)[x] := 0;
		8806	if x > 0 then
		8807	if pwordarray(p)[x - 1] > 4 then
		8808	pwordarray(p)[x - 1] := pwordarray(p)[x - 1] - 4
		8809	else
		8810	pwordarray(p)[x - 1] := 0;
		8811	if x < (DIB.Width - 1) then
		8812	if pwordarray(p)[x + 1] > 4 then
		8813	pwordarray(p)[x + 1] := pwordarray(p)[x + 1] - 4
		8814	else
		8815	pwordarray(p)[x + 1] := 0;
		8816	end;
		8817	end;
		8818	24:
		8819	begin
		8820	if not TestQuad(P3ByteArray(p)[x], 16) then
		8821	begin
		8822	if TestQuad(P3ByteArray(p)[x], 0) then Result := False;
		8823	if y > 0 then
		8824	begin
		8825	P3ByteArray(p0) := DIB.ScanLine[y - 1];
		8826	if TestQuad(P3ByteArray(p0)[x], 4) then
		8827	begin
		8828	for z := 0 to 2 do
		8829	if P3ByteArray(p0)[x][z] > 4 then
		8830	P3ByteArray(p0)[x][z] := P3ByteArray(p0)[x][z] - 4
		8831	end
		8832	else
		8833	for z := 0 to 2 do
		8834	P3ByteArray(p0)[x][z] := 0;
		8835	if x > 0 then
		8836	if TestQuad(P3ByteArray(p0)[x - 1], 2) then
		8837	begin
		8838	for z := 0 to 2 do
		8839	if P3ByteArray(p0)[x - 1][z] > 2 then
		8840	P3ByteArray(p0)[x - 1][z] := P3ByteArray(p0)[x - 1][z] - 2
		8841	end
		8842	else
		8843	for z := 0 to 2 do
		8844	P3ByteArray(p0)[x - 1][z] := 0;
		8845	if x < (DIB.Width - 1) then
		8846	if TestQuad(P3ByteArray(p0)[x + 1], 2) then
		8847	begin
		8848	for z := 0 to 2 do
		8849	if P3ByteArray(p0)[x + 1][z] > 2 then
		8850	P3ByteArray(p0)[x + 1][z] := P3ByteArray(p0)[x + 1][z] - 2
		8851	end
		8852	else
		8853	for z := 0 to 2 do
		8854	P3ByteArray(p0)[x + 1][z] := 0;
		8855	end;
		8856	if y < (DIB.Height - 1) then
		8857	begin
		8858	P3ByteArray(p2) := DIB.ScanLine[y + 1];
		8859	if TestQuad(P3ByteArray(p2)[x], 4) then
		8860	begin
		8861	for z := 0 to 2 do
		8862	if P3ByteArray(p2)[x][z] > 4 then
		8863	P3ByteArray(p2)[x][z] := P3ByteArray(p2)[x][z] - 4
		8864	end
		8865	else
		8866	for z := 0 to 2 do
		8867	P3ByteArray(p2)[x][z] := 0;
		8868	if x > 0 then
		8869	if TestQuad(P3ByteArray(p2)[x - 1], 2) then
		8870	begin
		8871	for z := 0 to 2 do
		8872	if P3ByteArray(p2)[x - 1][z] > 2 then
		8873	P3ByteArray(p2)[x - 1][z] := P3ByteArray(p2)[x - 1][z] - 2
		8874	end
		8875	else
		8876	for z := 0 to 2 do
		8877	P3ByteArray(p2)[x - 1][z] := 0;
		8878	if x < (DIB.Width - 1) then
		8879	if TestQuad(P3ByteArray(p2)[x + 1], 2) then
		8880	begin
		8881	for z := 0 to 2 do
		8882	if P3ByteArray(p2)[x + 1][z] > 2 then
		8883	P3ByteArray(p2)[x + 1][z] := P3ByteArray(p2)[x + 1][z] - 2
		8884	end
		8885	else
		8886	for z := 0 to 2 do
		8887	P3ByteArray(p2)[x + 1][z] := 0;
		8888	end;
		8889	if TestQuad(P3ByteArray(p)[x], 8) then
		8890	begin
		8891	for z := 0 to 2 do
		8892	if P3ByteArray(p)[x][z] > 8 then
		8893	P3ByteArray(p)[x][z] := P3ByteArray(p)[x][z] - 8
		8894	end
		8895	else
		8896	for z := 0 to 2 do
		8897	P3ByteArray(p)[x][z] := 0;
		8898	if x > 0 then
		8899	if TestQuad(P3ByteArray(p)[x - 1], 4) then
		8900	begin
		8901	for z := 0 to 2 do
		8902	if P3ByteArray(p)[x - 1][z] > 4 then
		8903	P3ByteArray(p)[x - 1][z] := P3ByteArray(p)[x - 1][z] - 4
		8904	end
		8905	else
		8906	for z := 0 to 2 do
		8907	P3ByteArray(p)[x - 1][z] := 0;
		8908	if x < (DIB.Width - 1) then
		8909	if TestQuad(P3ByteArray(p)[x + 1], 4) then
		8910	begin
		8911	for z := 0 to 2 do
		8912	if P3ByteArray(p)[x + 1][z] > 4 then
		8913	P3ByteArray(p)[x + 1][z] := P3ByteArray(p)[x + 1][z] - 4
		8914	end
		8915	else
		8916	for z := 0 to 2 do
		8917	P3ByteArray(p)[x + 1][z] := 0;
		8918	end;
		8919	end;
		8920	32:
		8921	begin
		8922	if plongarray(p)[x] < 16 then
		8923	begin
		8924	if plongarray(p)[x] > 0 then Result := False;
		8925	if y > 0 then
		8926	begin
		8927	plongarray(p0) := DIB.ScanLine[y - 1];
		8928	if plongarray(p0)[x] > 4 then
		8929	plongarray(p0)[x] := plongarray(p0)[x] - 4
		8930	else
		8931	plongarray(p0)[x] := 0;
		8932	if x > 0 then
		8933	if plongarray(p0)[x - 1] > 2 then
		8934	plongarray(p0)[x - 1] := plongarray(p0)[x - 1] - 2
		8935	else
		8936	plongarray(p0)[x - 1] := 0;
		8937	if x < (DIB.Width - 1) then
		8938	if plongarray(p0)[x + 1] > 2 then
		8939	plongarray(p0)[x + 1] := plongarray(p0)[x + 1] - 2
		8940	else
		8941	plongarray(p0)[x + 1] := 0;
		8942	end;
		8943	if y < (DIB.Height - 1) then
		8944	begin
		8945	plongarray(p2) := DIB.ScanLine[y + 1];
		8946	if plongarray(p2)[x] > 4 then
		8947	plongarray(p2)[x] := plongarray(p2)[x] - 4
		8948	else
		8949	plongarray(p2)[x] := 0;
		8950	if x > 0 then
		8951	if plongarray(p2)[x - 1] > 2 then
		8952	plongarray(p2)[x - 1] := plongarray(p2)[x - 1] - 2
		8953	else
		8954	plongarray(p2)[x - 1] := 0;
		8955	if x < (DIB.Width - 1) then
		8956	if plongarray(p2)[x + 1] > 2 then
		8957	plongarray(p2)[x + 1] := plongarray(p2)[x + 1] - 2
		8958	else
		8959	plongarray(p2)[x + 1] := 0;
		8960	end;
		8961	if plongarray(p)[x] > 8 then
		8962	plongarray(p)[x] := plongarray(p)[x] - 8
		8963	else
		8964	plongarray(p)[x] := 0;
		8965	if x > 0 then
		8966	if plongarray(p)[x - 1] > 4 then
		8967	plongarray(p)[x - 1] := plongarray(p)[x - 1] - 4
		8968	else
		8969	plongarray(p)[x - 1] := 0;
		8970	if x < (DIB.Width - 1) then
		8971	if plongarray(p)[x + 1] > 4 then
		8972	plongarray(p)[x + 1] := plongarray(p)[x + 1] - 4
		8973	else
		8974	plongarray(p)[x + 1] := 0;
		8975	end;
		8976	end;
		8977	end {case};
		8978	end;
		8979	end;
		8980	end;
		8981
		8982	procedure TDIB.Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
		8983	type
		8984	T3Byte = array[0..2] of Byte;
		8985	P3ByteArray = ^T3ByteArray;
		8986	T3ByteArray = array[0..32767] of T3Byte;
		8987	PLongArray = ^TLongArray;
		8988	TLongArray = array[0..32767] of LongInt;
		8989	var
		8990	p, p2: PByteArray;
		8991	x, y, x2, y2, angled, ysqr: Integer;
		8992	actdist, dist, cosy, siny: real;
		8993	begin
		8994	dist := Factor * sqrt(sqr(cX) + sqr(cY));
		8995	for y := 0 to DIB1.Height - 1 do
		8996	begin
		8997	p := DIB1.ScanLine[y];
		8998	ysqr := sqr(y - cY);
		8999	for x := 0 to (DIB1.Width) - 1 do
		9000	begin
		9001	actdist := (sqrt((sqr(x - cX) + ysqr)) / dist);
		9002	if dt = dtSlow then
		9003	actdist := dsin((Trunc(actdist * 1024)) and $1FF);
		9004	angled := 384 + Trunc((actdist) * Angle);
		9005
		9006	cosy := (y - cY) * dcos(angled and $1FF);
		9007	siny := (y - cY) * dsin(angled and $1FF);
		9008
		9009	x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
		9010	y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
		9011	case bitcount of
		9012	8:
		9013	begin
		9014	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		9015	begin
		9016	p2 := ScanLine[y2];
		9017	p[x] := p2[Width - x2];
		9018	end
		9019	else
		9020	begin
		9021	if p[x] > 2 then
		9022	p[x] := p[x] - 2
		9023	else
		9024	p[x] := 0;
		9025	end;
		9026	end;
		9027	16:
		9028	begin
		9029	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		9030	begin
		9031	pwordarray(p2) := ScanLine[y2];
		9032	pwordarray(p)[x] := pwordarray(p2)[Width - x2];
		9033	end
		9034	else
		9035	begin
		9036	if pwordarray(p)[x] > 2 then
		9037	pwordarray(p)[x] := pwordarray(p)[x] - 2
		9038	else
		9039	pwordarray(p)[x] := 0;
		9040	end;
		9041	end;
		9042	24:
		9043	begin
		9044	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		9045	begin
		9046	P3ByteArray(p2) := ScanLine[y2];
		9047	P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
		9048	end
		9049	else
		9050	begin
		9051	if P3ByteArray(p)[x][0] > 2 then
		9052	P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 2
		9053	else if P3ByteArray(p)[x][1] > 2 then
		9054	P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 2
		9055	else if P3ByteArray(p)[x][2] > 2 then
		9056	P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 2
		9057	else
		9058	begin
		9059	P3ByteArray(p)[x][0] := 0;
		9060	P3ByteArray(p)[x][1] := 0;
		9061	P3ByteArray(p)[x][2] := 0;
		9062	end;
		9063	end;
		9064	end;
		9065	32:
		9066	begin
		9067	if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
		9068	begin
		9069	plongarray(p2) := ScanLine[y2];
		9070	plongarray(p)[x] := plongarray(p2)[Width - x2];
		9071	end
		9072	else
		9073	begin
		9074	if p[x] > 2 then
		9075	plongarray(p)[x] := plongarray(p)[x] - 2
		9076	else
		9077	plongarray(p)[x] := 0;
		9078	end;
		9079	end;
		9080	end {case}
		9081	end;
		9082	end;
		9083	end;
		9084
		9085	procedure TDIB.AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor);
		9086	//anti-aliased line using the Wu algorithm by Peter Bone
		9087	var
		9088	dX, dY, X, Y, start, finish: Integer;
		9089	LM, LR: Integer;
		9090	dxi, dyi, dydxi: Integer;
		9091	P: PLines;
		9092	R, G, B: byte;
		9093	begin
		9094	R := GetRValue(Color);
		9095	G := GetGValue(Color);
		9096	B := GetBValue(Color);
		9097	dX := abs(x2 - x1); // Calculate deltax and deltay for initialisation
		9098	dY := abs(y2 - y1);
		9099	if (dX = 0) or (dY = 0) then
		9100	begin
		9101	Canvas.Pen.Color := (B shl 16) + (G shl 8) + R;
		9102	Canvas.MoveTo(x1, y1);
		9103	Canvas.LineTo(x2, y2);
		9104	exit;
		9105	end;
		9106	if dX > dY then
		9107	begin // horizontal or vertical
		9108	if y2 > y1 then // determine rise and run
		9109	dydxi := -dY shl 16 div dX
		9110	else
		9111	dydxi := dY shl 16 div dX;
		9112	if x2 < x1 then
		9113	begin
		9114	start := x2; // right to left
		9115	finish := x1;
		9116	dyi := y2 shl 16;
		9117	end
		9118	else
		9119	begin
		9120	start := x1; // left to right
		9121	finish := x2;
		9122	dyi := y1 shl 16;
		9123	dydxi := -dydxi; // inverse slope
		9124	end;
		9125	if finish >= Width then finish := Width - 1;
		9126	for X := start to finish do
		9127	begin
		9128	Y := dyi shr 16;
		9129	if (X < 0) or (Y < 0) or (Y > Height - 2) then
		9130	begin
		9131	Inc(dyi, dydxi);
		9132	Continue;
		9133	end;
		9134	LM := dyi - Y shl 16; // fractional part of dyi - in fixed-point
		9135	LR := 65536 - LM;
		9136	P := Scanline[Y];
		9137	P^[X].B := (B * LR + P^[X].B * LM) shr 16;
		9138	P^[X].G := (G * LR + P^[X].G * LM) shr 16;
		9139	P^[X].R := (R * LR + P^[X].R * LM) shr 16;
		9140	//Inc(Y);
		9141	P^[X].B := (B * LM + P^[X].B * LR) shr 16;
		9142	P^[X].G := (G * LM + P^[X].G * LR) shr 16;
		9143	P^[X].R := (R * LM + P^[X].R * LR) shr 16;
		9144	Inc(dyi, dydxi); // next point
		9145	end;
		9146	end
		9147	else
		9148	begin
		9149	if x2 > x1 then // determine rise and run
		9150	dydxi := -dX shl 16 div dY
		9151	else
		9152	dydxi := dX shl 16 div dY;
		9153	if y2 < y1 then
		9154	begin
		9155	start := y2; // right to left
		9156	finish := y1;
		9157	dxi := x2 shl 16;
		9158	end
		9159	else
		9160	begin
		9161	start := y1; // left to right
		9162	finish := y2;
		9163	dxi := x1 shl 16;
		9164	dydxi := -dydxi; // inverse slope
		9165	end;
		9166	if finish >= Height then finish := Height - 1;
		9167	for Y := start to finish do
		9168	begin
		9169	X := dxi shr 16;
		9170	if (Y < 0) or (X < 0) or (X > Width - 2) then
		9171	begin
		9172	Inc(dxi, dydxi);
		9173	Continue;
		9174	end;
		9175	LM := dxi - X shl 16;
		9176	LR := 65536 - LM;
		9177	P := Scanline[Y];
		9178	P^[X].B := (B * LR + P^[X].B * LM) shr 16;
		9179	P^[X].G := (G * LR + P^[X].G * LM) shr 16;
		9180	P^[X].R := (R * LR + P^[X].R * LM) shr 16;
		9181	Inc(X);
		9182	P^[X].B := (B * LM + P^[X].B * LR) shr 16;
		9183	P^[X].G := (G * LM + P^[X].G * LR) shr 16;
		9184	P^[X].R := (R * LM + P^[X].R * LR) shr 16;
		9185	Inc(dxi, dydxi); // next point
		9186	end;
		9187	end;
		9188	end;
		9189
		9190	function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
		9191	FromPoint, ToPoint: Extended): TColor;
		9192	var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
		9193	function CalcColorBytes(fb1, fb2: Byte): Byte;
		9194	begin
		9195	result := fb1;
		9196	if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1));
		9197	if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2));
		9198	end;
		9199	begin
		9200	if Pointvalue <= FromPoint then
		9201	begin
		9202	result := StartColor;
		9203	exit;
		9204	end;
		9205	if Pointvalue >= ToPoint then
		9206	begin
		9207	result := EndColor;
		9208	exit;
		9209	end;
		9210	F := (Pointvalue - FromPoint) / (ToPoint - FromPoint);
		9211	asm
		9212	mov EAX, Startcolor
		9213	cmp EAX, EndColor
		9214	je @@exit //when equal then exit
		9215	mov r1, AL
		9216	shr EAX,8
		9217	mov g1, AL
		9218	shr EAX,8
		9219	mov b1, AL
		9220	mov EAX, Endcolor
		9221	mov r2, AL
		9222	shr EAX,8
		9223	mov g2, AL
		9224	shr EAX,8
		9225	mov b2, AL
		9226	push ebp
		9227	mov AL, r1
		9228	mov DL, r2
		9229	call CalcColorBytes
		9230	pop ECX
		9231	push EBP
		9232	Mov r3, AL
		9233	mov DL, g2
		9234	mov AL, g1
		9235	call CalcColorBytes
		9236	pop ECX
		9237	push EBP
		9238	mov g3, Al
		9239	mov DL, B2
		9240	mov Al, B1
		9241	call CalcColorBytes
		9242	pop ECX
		9243	mov b3, AL
		9244	XOR EAX,EAX
		9245	mov AL, B3
		9246	shl EAX,8
		9247	mov AL, G3
		9248	shl EAX,8
		9249	mov AL, R3
		9250	@@Exit:
		9251	mov @result, EAX
		9252	end;
		9253	end;
		9254
		9255	procedure TDIB.ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
		9256	iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry; iRadius: Word);
		9257	var
		9258	tempColor: TColor;
		9259	const
		9260	WavelengthMinimum = 380;
		9261	WavelengthMaximum = 780;
		9262
		9263	procedure SetColor(Color: TColor);
		9264	begin
		9265	Canvas.Pen.Color := Color;
		9266	Canvas.Brush.Color := Color;
		9267	tempColor := Color
		9268	end {SetColor};
		9269
		9270	function WL2RGB(const Wavelength: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
		9271	const
		9272	Gamma = 0.80;
		9273	IntensityMax = 255;
		9274	var
		9275	Red, Blue, Green, Factor: Double;
		9276
		9277	function Adjust(const Color, Factor: Double): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		9278	begin
		9279	if Color = 0.0 then Result := 0
		9280	else Result := Round(IntensityMax * Power(Color * Factor, Gamma))
		9281	end {Adjust};
		9282	begin
		9283	case Trunc(Wavelength) of
		9284	380..439:
		9285	begin
		9286	Red := -(Wavelength - 440) / (440 - 380);
		9287	Green := 0.0;
		9288	Blue := 1.0
		9289	end;
		9290	440..489:
		9291	begin
		9292	Red := 0.0;
		9293	Green := (Wavelength - 440) / (490 - 440);
		9294	Blue := 1.0
		9295	end;
		9296	490..509:
		9297	begin
		9298	Red := 0.0;
		9299	Green := 1.0;
		9300	Blue := -(Wavelength - 510) / (510 - 490)
		9301	end;
		9302	510..579:
		9303	begin
		9304	Red := (Wavelength - 510) / (580 - 510);
		9305	Green := 1.0;
		9306	Blue := 0.0
		9307	end;
		9308	580..644:
		9309	begin
		9310	Red := 1.0;
		9311	Green := -(Wavelength - 645) / (645 - 580);
		9312	Blue := 0.0
		9313	end;
		9314	645..780:
		9315	begin
		9316	Red := 1.0;
		9317	Green := 0.0;
		9318	Blue := 0.0
		9319	end;
		9320	else
		9321	Red := 0.0;
		9322	Green := 0.0;
		9323	Blue := 0.0
		9324	end;
		9325	case Trunc(Wavelength) of
		9326	380..419: factor := 0.3 + 0.7 * (Wavelength - 380) / (420 - 380);
		9327	420..700: factor := 1.0;
		9328	701..780: factor := 0.3 + 0.7 * (780 - Wavelength) / (780 - 700)
		9329	else
		9330	factor := 0.0
		9331	end;
		9332	Result := RGB(Adjust(Red, Factor), Adjust(Green, Factor), Adjust(Blue, Factor));
		9333	end;
		9334
		9335	function Rainbow(const fraction: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
		9336	begin
		9337	if (fraction < 0.0) or (fraction > 1.0) then Result := clBlack
		9338	else
		9339	Result := WL2RGB(WavelengthMinimum + Fraction * (WavelengthMaximum - WavelengthMinimum))
		9340	end {Raindbow};
		9341
		9342	function ColorInterpolate(const fraction: Double; const Color1, Color2: TColor): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
		9343	var
		9344	complement: Double;
		9345	R1, R2, G1, G2, B1, B2: BYTE;
		9346	begin
		9347	if fraction <= 0 then Result := Color1
		9348	else
		9349	if fraction >= 1.0 then Result := Color2
		9350	else
		9351	begin
		9352	R1 := GetRValue(Color1);
		9353	G1 := GetGValue(Color1);
		9354	B1 := GetBValue(Color1);
		9355	R2 := GetRValue(Color2);
		9356	G2 := GetGValue(Color2);
		9357	B2 := GetBValue(Color2);
		9358	complement := 1.0 - fraction;
		9359	Result := RGB(Round(complement * R1 + fraction * R2),
		9360	Round(complement * G1 + fraction * G2),
		9361	Round(complement * B1 + fraction * B2))
		9362	end
		9363	end {ColorInterpolate};
		9364
		9365	// Conversion utility routines
		9366	function ColorToRGBTriple(const Color: TColor): TRGBTriple; {$IFDEF VER9UP}inline;{$ENDIF}
		9367	begin
		9368	with Result do
		9369	begin
		9370	rgbtRed := GetRValue(Color);
		9371	rgbtGreen := GetGValue(Color);
		9372	rgbtBlue := GetBValue(Color)
		9373	end
		9374	end {ColorToRGBTriple};
		9375
		9376	function RGBTripleToColor(const Triple: TRGBTriple): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
		9377	begin
		9378	Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)
		9379	end {RGBTripleToColor};
		9380	// Bresenham's Line Algorithm. Byte, March 1988, pp. 249-253.
		9381	var
		9382	a, b, d, diag_inc, dXdg, dXndg, dYdg, dYndg, i, nDginc, nDswap, x, y: Integer;
		9383	begin {DrawLine}
		9384	x := iStart.X;
		9385	y := iStart.Y;
		9386	a := iEnd.X - iStart.X;
		9387	b := iEnd.Y - iStart.Y;
		9388	if a < 0 then
		9389	begin
		9390	a := -a;
		9391	dXdg := -1
		9392	end
		9393	else dXdg := 1;
		9394	if b < 0 then
		9395	begin
		9396	b := -b;
		9397	dYdg := -1
		9398	end
		9399	else dYdg := 1;
		9400	if a < b then
		9401	begin
		9402	nDswap := a;
		9403	a := b;
		9404	b := nDswap;
		9405	dXndg := 0;
		9406	dYndg := dYdg
		9407	end
		9408	else
		9409	begin
		9410	dXndg := dXdg;
		9411	dYndg := 0
		9412	end;
		9413	d := b + b - a;
		9414	nDginc := b + b;
		9415	diag_inc := b + b - a - a;
		9416	for i := 0 to a do
		9417	begin
		9418	case iPixelGeometry of
		9419	pgPoint:
		9420	case iColorStyle of
		9421	csSolid:
		9422	Canvas.Pixels[x, y] := tempColor;
		9423	csGradient:
		9424	Canvas.Pixels[x, y] := ColorInterpolate(i / a, iGradientFrom, iGradientTo);
		9425	csRainbow:
		9426	Canvas.Pixels[x, y] := Rainbow(i / a)
		9427	end;
		9428	pgCircular:
		9429	begin
		9430	case iColorStyle of
		9431	csSolid: ;
		9432	csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
		9433	csRainbow: SetColor(Rainbow(i / a))
		9434	end;
		9435	Canvas.Ellipse(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
		9436	end;
		9437	pgRectangular:
		9438	begin
		9439	case iColorStyle of
		9440	csSolid: ;
		9441	csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
		9442	csRainbow: SetColor(Rainbow(i / a))
		9443	end;
		9444	Canvas.Rectangle(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
		9445	end
		9446	end;
		9447	if d < 0 then
		9448	begin
		9449	Inc(x, dXndg);
		9450	Inc(y, dYndg);
		9451	Inc(d, nDginc);
		9452	end
		9453	else
		9454	begin
		9455	Inc(x, dXdg);
		9456	Inc(y, dYdg);
		9457	Inc(d, diag_inc);
		9458	end
		9459	end
		9460	end {Line};
		9461
		9462	procedure TDIB.DoNovaEffect(sr, sg, sb, cx, cy, radius,
		9463	nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
		9464	// Copyright (c) 2000 by Keith Murray (kmurray@hotfreeware.com)
		9465	// All rights reserved.
		9466	// Adapted for DIB by JB.
		9467	type
		9468	PByteArray = ^TByteArray;
		9469	TByteArray = array[0..32767] of Byte;
		9470	PDoubleArray = ^TDoubleArray;
		9471	TDoubleArray = array[0..32767] of Double;
		9472	PIntegerArray = ^TIntegerArray;
		9473	TIntegerArray = array[0..32767] of Integer;
		9474	type
		9475	TProgressEvent = procedure(progress: Integer; message: string;
		9476	var cancel: Boolean) of object;
		9477	const
		9478	M_PI = 3.14159265358979323846;
		9479	RAND_MAX = 2147483647;
		9480
		9481	function Gauss: double;
		9482	const magnitude = 6;
		9483	var
		9484	sum: double;
		9485	i: Integer;
		9486	begin
		9487	sum := 0;
		9488	for i := 1 to magnitude do
		9489	sum := sum + (randgauss / 2147483647);
		9490	result := sum / magnitude;
		9491	end;
		9492
		9493	function Clamp(i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
		9494	begin
		9495	if i < l then
		9496	result := l
		9497	else
		9498	if i > h then
		9499	result := h
		9500	else
		9501	result := i;
		9502	end;
		9503
		9504	function IClamp(i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		9505	begin
		9506	if i < l then
		9507	result := l
		9508	else if i > h then
		9509	result := h
		9510	else result := i;
		9511	end;
		9512
		9513	procedure rgb_to_hsl(r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
		9514	{$IFNDEF VER4UP}
		9515	function Max(a, b: Double): Double;
		9516	begin
		9517	Result := a; if b > a then Result := b;
		9518	end;
		9519	function Min(a, b: Double): Double;
		9520	begin
		9521	Result := a; if b < a then Result := b;
		9522	end;
		9523	{$ENDIF}
		9524	var
		9525	v, m, vm: Double;
		9526	r2, g2, b2: Double;
		9527	begin
		9528	h := 0;
		9529	s := 0;
		9530	l := 0;
		9531	v := Max(r, g);
		9532	v := Max(v, b);
		9533	m := Min(r, g);
		9534	m := Min(m, b);
		9535	l := (m + v) / 2.0;
		9536	if l <= 0.0 then
		9537	exit;
		9538	vm := v - m;
		9539	s := vm;
		9540	if s > 0.0 then
		9541	begin
		9542	if l <= 0.5 then
		9543	s := s / (v + m)
		9544	else s := s / (2.0 - v - m);
		9545	end
		9546	else exit;
		9547	r2 := (v - 4) / vm;
		9548	g2 := (v - g) / vm;
		9549	b2 := (v - b) / vm;
		9550	if r = v then
		9551	begin
		9552	if g = m then
		9553	h := b2 + 5.0
		9554	else h := 1.0 - g2;
		9555	end
		9556	else if g = v then
		9557	begin
		9558	if b = m then
		9559	h := 1.0 + r2
		9560	else h := 3.0 - b2;
		9561	end
		9562	else
		9563	begin
		9564	if r = m then
		9565	h := 3.0 + g2
		9566	else h := 5.0 - r2;
		9567	end;
		9568	h := h / 6;
		9569	end;
		9570
		9571	procedure hsl_to_rgb(h, sl, l: Double; var r, g, b: Double); {$IFDEF VER9UP}inline;{$ENDIF}
		9572	var
		9573	v: Double;
		9574	m, sv: Double;
		9575	sextant: Integer;
		9576	fract, vsf, mid1, mid2: Double;
		9577	begin
		9578	if l <= 0.5 then
		9579	v := l * (1.0 + sl)
		9580	else v := l + sl - l * sl;
		9581	if v <= 0 then
		9582	begin
		9583	r := 0.0;
		9584	g := 0.0;
		9585	b := 0.0;
		9586	end
		9587	else
		9588	begin
		9589	m := l + l - v;
		9590	sv := (v - m) / v;
		9591	h := h * 6.0;
		9592	sextant := Trunc(h);
		9593	fract := h - sextant;
		9594	vsf := v * sv * fract;
		9595	mid1 := m + vsf;
		9596	mid2 := v - vsf;
		9597	case sextant of
		9598	0:
		9599	begin
		9600	r := v; g := mid1; b := m;
		9601	end;
		9602	1:
		9603	begin
		9604	r := mid2; g := v; b := m;
		9605	end;
		9606	2:
		9607	begin
		9608	r := m; g := v; b := mid1;
		9609	end;
		9610	3:
		9611	begin
		9612	r := m; g := mid2; b := v;
		9613	end;
		9614	4:
		9615	begin
		9616	r := mid1; g := m; b := v;
		9617	end;
		9618	5:
		9619	begin
		9620	r := v; g := m; b := mid2;
		9621	end;
		9622	end;
		9623	end;
		9624	end;
		9625
		9626	var
		9627	src_row, dest_row: PByte;
		9628	src, dest: PByteArray;
		9629	color, colors: array[0..3] of Integer;
		9630	SpokeColor: PIntegerArray;
		9631	spoke: PDoubleArray;
		9632	x1, y1, x2, y2, row, col, x, y, alpha, has_alpha, bpp, progress, max_progress, xc, yc, i, j: Integer;
		9633	u, v, l, l0, w, w1, c, nova_alpha, src_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
		9634	dstDIB: TDIB;
		9635	begin
		9636	colors[0] := sr;
		9637	colors[1] := sg;
		9638	colors[2] := sb;
		9639	new_alpha := 0;
		9640
		9641	GetMem(spoke, NSpokes * sizeof(Double));
		9642	GetMem(spokecolor, NSpokes * sizeof(Integer) * 3);
		9643	dstDIB := TDIB.Create;
		9644	dstDIB.Assign(Self);
		9645	dstDIB.Canvas.Brush.Color := clBlack;
		9646	dstDIB.Canvas.FillRect(dstDIB.Canvas.ClipRect);
		9647	try
		9648	rgb_to_hsl(colors[0] / 255.0, colors[1] / 255.0, colors[2] / 255.0, h, s, lu);
		9649
		9650	for i := 0 to NSpokes - 1 do
		9651	begin
		9652	spoke[i] := gauss;
		9653	h := h + randomhue / 360.0 * ({Random(RAND_MAX)}RandomSpok / RAND_MAX - 0.5);
		9654	if h < 0 then
		9655	h := h + 1.0
		9656	else if h > 1.0 then
		9657	h := h - 1.0;
		9658	hsl_to_rgb(h, s, lu, r, g, b);
		9659	spokecolor[3 * i + 0] := Trunc(255 * r);
		9660	spokecolor[3 * i + 1] := Trunc(255 * g);
		9661	spokecolor[3 * i + 2] := Trunc(255 * b);
		9662	end;
		9663
		9664	xc := cx;
		9665	yc := cy;
		9666	l0 := (x2 - xc) / 4 + 1;
		9667	bpp := Self.BitCount div 8;
		9668	has_alpha := 0;
		9669	alpha := bpp;
		9670	y := 0;
		9671	for row := 0 to Self.Height - 1 do begin
		9672	src_row := Self.ScanLine[row];
		9673	dest_row := dstDIB.ScanLine[row];
		9674	src := Pointer(src_row);
		9675	dest := Pointer(dest_row);
		9676	x := 0;
		9677	for col := 0 to Self.Width - 1 do begin
		9678	u := (x - xc) / radius;
		9679	v := (y - yc) / radius;
		9680	l := sqrt((u * u) + (v * v));
		9681	c := (arctan2(u, v) / (2 * M_PI) + 0.51) * NSpokes;
		9682	i := floor(c);
		9683	c := c - i;
		9684	i := i mod NSpokes;
		9685	w1 := spoke[i] * (1 - c) + spoke[(i + 1) mod NSpokes] * c;
		9686	w1 := w1 * w1;
		9687	w := 1 / (l + 0.001) * 0.9;
		9688	nova_alpha := Clamp(w, 0.0, 1.0);
		9689	ratio := nova_alpha;
		9690	compl_ratio := 1.0 - ratio;
		9691	for j := 0 to alpha - 1 do
		9692	begin
		9693	spokecol := spokecolor[3 * i + j] * (1.0 - c) + spokecolor[3 * ((i + 1) mod nspokes) + j] * c;
		9694	if w > 1.0 then
		9695	color[j] := IClamp(Trunc(spokecol * w), 0, 255)
		9696	else
		9697	color[j] := Trunc(src[j] * compl_ratio + spokecol * ratio);
		9698	color[j] := Trunc(color[j] + 255 * Clamp(w1 * w, 0.0, 1.0));
		9699	dest[j] := IClamp(color[j], 0, 255);
		9700	end;
		9701	inc(Integer(src), bpp);
		9702	inc(Integer(dest), bpp);
		9703	inc(x);
		9704	end;
		9705	inc(y);
		9706	end;
		9707	finally
		9708	Self.Assign(dstDIB);
		9709	dstDIB.Free;
		9710	FreeMem(Spoke);
		9711	FreeMem(SpokeColor);
		9712	end;
		9713	end;
		9714
		9715	procedure TDIB.DrawMandelbrot(ao, au: Integer; bo, bu: Double);
		9716	var
		9717	c1, c2, z1, z2, tmp: Double;
		9718	i, j, Count: Integer;
		9719	dstDIB: TDIB;
		9720	X, Y: Double;
		9721	X2, Y2: Integer;
		9722	begin
		9723	dstDIB := TDIB.Create;
		9724	dstDIB.Assign(Self);
		9725	X2 := dstDIB.FWidth;
		9726	Y2 := dstDIB.FHeight;
		9727	{as Example
		9728	ao := 1;
		9729	au := -2;
		9730	bo := 1.5;
		9731	bu := -1.5;
		9732	}
		9733	X := (ao - au) / dstDIB.FWidth;
		9734	Y := (bo - bu) / dstDIB.FHeight;
		9735	try
		9736	c2 := bu;
		9737	for i := 10 to X2 do
		9738	begin
		9739	c1 := au;
		9740	for j := 0 to Y2 do
		9741	begin
		9742	z1 := 0;
		9743	z2 := 0;
		9744	Count := 0;
		9745	{count is deep of iteration of the mandelbrot set
		9746	if \|z\| >=2 then z is not a member of a mandelset}
		9747	while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
		9748	begin
		9749	tmp := z1;
		9750	z1 := z1 * z1 - z2 * z2 + c1;
		9751	z2 := 2 * tmp * z2 + c2;
		9752	Inc(Count);
		9753	end;
		9754	//the color-palette depends on TColor(n*count mod t)
		9755	dstDIB.Canvas.Pixels[j, i] := (16 * Count mod 255);
		9756	c1 := c1 + X;
		9757	end;
		9758	c2 := c2 + Y;
		9759	end;
		9760	finally
		9761	Self.Assign(dstDIB);
		9762	dstDIB.Free;
		9763	end;
		9764	end;
		9765
		9766	procedure TDIB.SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
		9767	{Note: when depth parameter set to 0 will produce black and white picture only}
		9768	var
		9769	color, color2: longint;
		9770	r, g, b, rr, gg: byte;
		9771	h, w: Integer;
		9772	p0: pbytearray;
		9773	x, y: Integer;
		9774	begin
		9775	if Self.BitCount = 24 then
		9776	begin
		9777	Self.DoGrayScale;
		9778	for y := 0 to Self.Height - 1 do
		9779	begin
		9780	p0 := Self.ScanLine[y];
		9781	for x := 0 to Self.Width - 1 do
		9782	begin
		9783	r := p0[x * 3];
		9784	g := p0[x * 3 + 1];
		9785	b := p0[x * 3 + 2];
		9786	rr := r + (depth * 2);
		9787	gg := g + depth;
		9788	if rr <= ((depth * 2) - 1) then
		9789	rr := 255;
		9790	if gg <= (depth - 1) then
		9791	gg := 255;
		9792	p0[x * 3] := rr;
		9793	p0[x * 3 + 1] := gg;
		9794	p0[x * 3 + 2] := b;
		9795	end;
		9796	end;
		9797	Exit
		9798	end;
		9799	{this alogorithm is slower because does not use scanline property}
		9800	for h := 0 to Self.Height-1 do
		9801	begin
		9802	for w := 0 to Self.Width-1 do
		9803	begin
		9804	//first convert the bitmap to greyscale
		9805	color := ColorToRGB(Self.Canvas.Pixels[w, h]);
		9806	r := GetRValue(color);
		9807	g := GetGValue(color);
		9808	b := GetBValue(color);
		9809	color2 := (r + g + b) div 3;
		9810	Self.Canvas.Pixels[w, h] := RGB(color2, color2, color2);
		9811	//then convert it to sepia
		9812	color := ColorToRGB(Self.Canvas.Pixels[w, h]);
		9813	r := GetRValue(color);
		9814	g := GetGValue(color);
		9815	b := GetBValue(color);
		9816	rr := r + (depth * 2);
		9817	gg := g + depth;
		9818	if rr <= ((depth * 2) - 1) then
		9819	rr := 255;
		9820	if gg <= (depth - 1) then
		9821	gg := 255;
		9822	Self.Canvas.Pixels[w, h] := RGB(rr, gg, b);
		9823	end;
		9824	end;
		9825
		9826	end;
		9827
		9828	procedure TDIB.EncryptDecrypt(const Key: Integer);
		9829	{for decript call it again}
		9830	var
		9831	BytesPorScan: Integer;
		9832	w, h: Integer;
		9833	p: pByteArray;
		9834	begin
		9835	try
		9836	BytesPorScan := Abs(Integer(Self.ScanLine[1]) -
		9837	Integer(Self.ScanLine[0]));
		9838	except
		9839	raise Exception.Create('Error ');
		9840	end;
		9841	RandSeed := Key;
		9842	for h := 0 to Self.Height - 1 do
		9843	begin
		9844	P := Self.ScanLine[h];
		9845	for w := 0 to BytesPorScan - 1 do
		9846	P^[w] := P^[w] xor Random(256);
		9847	end;
		9848	end;
		9849
		9850	procedure TDIB.LinePolar(x, y: Integer; AngleInDegree, Length: extended; Color: cardinal);
		9851	var
		9852	xp, yp: Integer;
		9853	begin
		9854	xp := Round(Sin(AngleInDegree * Pi / 180) * Length) + x;
		9855	yp := Round(Cos(AngleInDegree * Pi / 180) * Length) + y;
		9856	AntialiasedLine(x, y, xp, yp, Color);
		9857	end;
		9858
		9859	//y = 0.299g + 0.587b + 0.114*r;
		9860
		9861	procedure TDIB.BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: byte);
		9862	var
		9863	cR, cG, cB: byte;
		9864	aR, aG, aB: byte;
		9865	dColor: Cardinal;
		9866	begin
		9867	aR := GetRValue(aColor);
		9868	aG := GetGValue(aColor);
		9869	aB := GetBValue(aColor);
		9870	dColor := Self.Canvas.Pixels[x, y];
		9871	cR := GetRValue(dColor);
		9872	cG := GetGValue(dColor);
		9873	cB := GetBValue(dColor);
		9874	Canvas.Pixels[x, y] := RGB((Alpha * (aR - cR) shr 8) + cR, // R alpha
		9875	(Alpha * (aG - cG) shr 8) + cG, // G alpha
		9876	(Alpha * (aB - cB) shr 8) + cB); // B alpha
		9877	end;
		9878
		9879
		9880	procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP} overload; {$ENDIF}
		9881	begin
		9882	DIB := TDIB.Create;
		9883	DIB.SetSize(iWidth, iHeight, iBitCount);
		9884	DIB.Fill(iFillColor);
		9885	end;
		9886
		9887	procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDib2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP} overload; {$ENDIF}
		9888	begin
		9889	DIB := TDIB.Create;
		9890	if Assigned(iBitmap) then
		9891	DIB.CreateDIBFromBitmap(iBitmap)
		9892	else
		9893	DIB.Fill(clBlack);
		9894	end;
		9895
1	daniel-mar	9896	initialization
		9897	TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
		9898	TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);
		9899	finalization
		9900	TPicture.UnRegisterGraphicClass(TDIB);
		9901
		9902	FEmptyDIBImage.Free;
		9903	FPaletteManager.Free;
4	daniel-mar	9904	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DIB.pas – Rev 4