Subversion Repositories spacemission

Compare Revisions

Regard whitespace Rev 3 → Rev 4

/VCL_DELPHIX_D6/DIB.pas
1,13 → 1,40
{*******************************************************}
{ }
{ DIB and PAINTBOX componets }
{ }
{ Copyright (C) 1997-2000 Hiroyuki Hori }
{ base components and effects }
{ Copyright (C) 2000 Keith Murray }
{ supernova effect }
{ Copyright (C) 2000 Michel Hibon }
{ new special effects added for DIB }
{ Copyright (C) 2001 Joakim Back }
{ conFusion effects (as DxFusion) }
{ Copyright (C) 2003 Babak Sateli }
{ 24-bit DIB effect as supplement ones }
{ Copyright (C) 2004-2012 Jaro Benes }
{ 32-bit DIB effect with alphachannel }
{ direct works with texture buffer }
{ modified and adapted all adopted functions }
{ }
{*******************************************************}
 
unit DIB;
 
interface
 
{$INCLUDE DelphiXcfg.inc}
{$DEFINE USE_SCANLINE}
 
uses
Windows, SysUtils, Classes, Graphics, Controls;
Windows, SysUtils, Classes, Graphics, Controls,
{$IFDEF VER17UP} Types, UITypes,{$ENDIF}
Math;
 
type
TColorLineStyle = (csSolid, csGradient, csRainbow);
TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
PRGBQuads = ^TRGBQuads;
TRGBQuads = array[0..255] of TRGBQuad;
 
TPaletteEntries = array[0..255] of TPaletteEntry;
17,6 → 44,16
B, G, R: Byte;
end;
 
{ Added this type for New SPecial Effect }
TFilter = array[0..2, 0..2] of SmallInt;
TLines = array[0..0] of TBGR;
PLines = ^TLines;
TBytes = array[0..0] of Byte;
PBytes = ^TBytes;
TPBytes = array[0..0] of PBytes;
PPBytes = ^TPBytes;
{ End of type's }
 
PArrayBGR = ^TArrayBGR;
TArrayBGR = array[0..10000] of TBGR;
 
29,7 → 66,7
PArrayDWord = ^TArrayDWord;
TArrayDWord = array[0..10000] of DWord;
 
{ TDIB }
{ TDIBPixelFormat }
 
TDIBPixelFormat = record
RBitMask, GBitMask, BBitMask: DWORD;
38,6 → 75,8
RBitCount2, GBitCount2, BBitCount2: DWORD;
end;
 
{ TDIBSharedImage }
 
TDIBSharedImage = class(TSharedImage)
private
FBitCount: Integer;
64,7 → 103,7
constructor Create;
procedure NewImage(AWidth, AHeight, ABitCount: Integer;
const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
procedure Compress(Source: TDIBSharedImage);
procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure ReadData(Stream: TStream; MemoryImage: Boolean);
76,6 → 115,33
destructor Destroy; override;
end;
 
{ TFilterTypeResample }
 
TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
ftrLanczos3, ftrMitchell);
 
TDistortType = (dtFast, dtSlow);
{DXFusion effect type}
TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);
 
{ TLightSource }
 
TLightSource = record
X, Y: Integer;
Size1, Size2: Integer;
Color: TColor;
end;
 
{ TLightArray }
 
TLightArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TLightsource;
 
{ TMatrixSetting }
 
TMatrixSetting = array[0..9] of Integer;
 
{ TDIB }
 
TDIB = class(TGraphic)
private
FCanvas: TCanvas;
96,6 → 162,10
FTopPBits: Pointer;
FWidth: Integer;
FWidthBytes: Integer;
FLUTDist: array[0..255, 0..255] of Integer;
LG_COUNT: Integer;
LG_DETAIL: Integer;
FFreeList: TList;
procedure AllocHandle;
procedure CanvasChanging(Sender: TObject);
procedure Changing(MemoryImage: Boolean);
113,15 → 183,28
function GetTopPBits: Pointer;
function GetTopPBitsReadOnly: Pointer;
procedure SetBitCount(Value: Integer);
procedure SetImage(Value: TDIBSharedImage);
procedure SetImage(Value: TDIBSharedImage); {$IFDEF VER9UP}inline;{$ENDIF}
procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
procedure SetPixel(X, Y: Integer; Value: DWORD);
procedure StartProgress(const Name: string);
procedure EndProgress;
procedure UpdateProgress(PercentY: Integer);
 
{ Added these 3 functions for New Specials Effects }
function Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function IntToByte(i: Integer): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
{ End of 3 functions for New Special Effect }
 
procedure Darkness(Amount: Integer);
function GetAlphaChannel: TDIB;
procedure SetAlphaChannel(const Value: TDIB);
function GetClientRect: TRect;
function GetRGBChannel: TDIB;
procedure SetRGBChannel(const Value: TDIB);
protected
procedure DefineProperties(Filer: TFiler); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetPalette: HPalette; override;
141,6 → 224,9
procedure Compress;
procedure Decompress;
procedure FreeHandle;
function HasAlphaChannel: Boolean;
function AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
procedure RetAlphaChannel(out oDIB: TDIB);
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure LoadFromStream(Stream: TStream); override;
147,7 → 233,7
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
procedure SaveToStream(Stream: TStream); override;
procedure SetSize(AWidth, AHeight, ABitCount: Integer);
procedure SetSize(AWidth, AHeight, ABitCount: Integer); {$IFDEF VER5UP}reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure UpdatePalette;
{ Special effect }
procedure Blur(ABitCount: Integer; Radius: Integer);
155,6 → 241,160
procedure Mirror(MirrorX, MirrorY: Boolean);
procedure Negative;
 
{ Added New Special Effect }
procedure Spray(Amount: Integer);
procedure Emboss;
procedure AddMonoNoise(Amount: Integer);
procedure AddGradiantNoise(Amount: byte);
function Twist(bmp: TDIB; Amount: byte): Boolean;
function FishEye(bmp: TDIB): Boolean;
function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
procedure Lightness(Amount: Integer);
procedure Saturation(Amount: Integer);
procedure Contrast(Amount: Integer);
procedure AddRGB(aR, aG, aB: Byte);
function Filter(Dest: TDIB; Filter: TFilter): Boolean;
procedure Sharpen(Amount: Integer);
function IntToColor(i: Integer): TBGR; {$IFDEF VER9UP}inline;{$ENDIF}
function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
procedure SplitBlur(Amount: Integer);
procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
{ End of New Special Effect }
{
New effect for TDIB
with Some Effects like AntiAlias, Contrast,
Lightness, Saturation, GaussianBlur, Mosaic,
Twist, Splitlight, Trace, Emboss, etc.
Works with 24bit color DIBs.
 
This component is based on TProEffectImage component version 1.0 by
Written By Babak Sateli (babak_sateli@yahoo.com, http://raveland.netfirms.com)
 
and modified by (c) 2004 Jaro Benes
for DelphiX use.
 
Demo was modified into DXForm with function like original
 
DISCLAIMER
This component is provided AS-IS without any warranty of any kind, either express or
implied. This component is freeware and can be used in any software product.
}
procedure DoInvert;
procedure DoAddColorNoise(Amount: Integer);
procedure DoAddMonoNoise(Amount: Integer);
procedure DoAntiAlias;
procedure DoContrast(Amount: Integer);
procedure DoFishEye(Amount: Integer);
procedure DoGrayScale;
procedure DoLightness(Amount: Integer);
procedure DoDarkness(Amount: Integer);
procedure DoSaturation(Amount: Integer);
procedure DoSplitBlur(Amount: Integer);
procedure DoGaussianBlur(Amount: Integer);
procedure DoMosaic(Size: Integer);
procedure DoTwist(Amount: Integer);
procedure DoSplitlight(Amount: Integer);
procedure DoTile(Amount: Integer);
procedure DoSpotLight(Amount: Integer; Spot: TRect);
procedure DoTrace(Amount: Integer);
procedure DoEmboss;
procedure DoSolorize(Amount: Integer);
procedure DoPosterize(Amount: Integer);
procedure DoBrightness(Amount: Integer);
procedure DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
{rotate}
procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
procedure DoColorize(ForeColor, BackColor: TColor);
{Simple explosion spoke effect}
procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
 
{Simple Mandelbrot-set drawing}
procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);
 
{Sephia effect}
procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
 
{Simple blend pixel}
procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
{Line in polar system}
procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
Color: cardinal);
 
{special version Dark/Light procedure in percent}
procedure Darker(Percent: Integer);
procedure Lighter(Percent: Integer);
 
{Simple graphical crypt}
procedure EncryptDecrypt(const Key: Integer);
 
{ Standalone DXFusion }
{--- c o n F u s i o n ---}
{By Joakim Back, www.back.mine.nu}
{Huge thanks to Ilkka Tuomioja for helping out with the project.}
 
{
modified by (c) 2005 Jaro Benes for DelphiX use.
}
 
procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
{Drawing Methods.}
procedure DrawOn(Dest: TRect; DestCanvas: TCanvas;
Xsrc, Ysrc: Integer);
procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
SourceY: Integer);
procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor); {$IFDEF VER5UP} reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
FilterMode: TFilterMode);
procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
Alpha: Byte);
procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor;
FilterMode: TFilterMode);
procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const Color: TColor);
procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY, Alpha: Integer; const Color: TColor);
procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
Height, SourceX, SourceY: Integer);
procedure DrawAntialias(SrcDIB: TDIB);
procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
{One-color Filters.}
procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
{ Lightsource. }
procedure InitLight(Count, Detail: Integer);
procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
//
// effect for special purpose
//
procedure FadeOut(DIB2: TDIB; Step: Byte);
procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
procedure DoBlur(DIB2: TDIB);
procedure FadeIn(DIB2: TDIB; Step: Byte);
procedure FillDIB8(Color: Byte);
procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
// lines
procedure AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor); {$IFDEF VER9UP} inline; {$ENDIF}
function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
iRadius: WORD);
// standard property
property BitCount: Integer read FBitCount write SetBitCount;
property BitmapInfo: PBitmapInfo read GetBitmapInfo;
property BitmapInfoSize: Integer read GetBitmapInfoSize;
174,8 → 414,15
property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
property Width: Integer read FWidth write SetWidth;
property WidthBytes: Integer read FWidthBytes;
property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
property RGBChannel: TDIB read GetRGBChannel write SetRGBChannel;
function CreateBitmapFromDIB: TBitmap;
procedure Fill(aColor: TColor);
property ClientRect: TRect read GetClientRect;
end;
 
{ TDIBitmap }
 
TDIBitmap = class(TDIB) end;
 
{ TCustomDXDIB }
235,10 → 482,10
 
TDXPaintBox = class(TCustomDXPaintBox)
published
{$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
{$IFDEF VER4UP}property Anchors; {$ENDIF}
property AutoStretch;
property Center;
{$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
{$IFDEF VER4UP}property Constraints; {$ENDIF}
property DIB;
property KeepAspect;
property Stretch;
261,34 → 508,105
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
{$IFDEF VER9UP}property OnResize; {$ENDIF}
{$IFDEF VER9UP}property OnCanResize; {$ENDIF}
{$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
property OnStartDrag;
end;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
const
DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
 
function GreyscaleColorTable: TRGBQuads;
 
function RGBQuad(R, G, B: Byte): TRGBQuad;
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
function RGBQuad(R, G, B: Byte): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; {$IFDEF VER9UP}inline;{$ENDIF}
 
function PosValue(Value: Integer): Integer;
 
type
TOC = 0..511;
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
 
{ Added Constants for TFilter Type }
const
EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
{ End of constants }
 
{ Added Constants for DXFusion Type }
const
{ 3x3 Matrix Presets. }
msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);
 
{Proportionaly scale of size, for recountin image sizes}
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single; {$IFDEF VER9UP}inline;{$ENDIF}
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
 
implementation
 
uses DXConsts;
uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
 
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
var
XScale, YScale: Single;
begin
XScale := 1;
YScale := 1;
if TargetWidth < SourceWidth then
XScale := TargetWidth / SourceWidth;
if TargetHeight < SourceHeight then
YScale := TargetHeight / SourceHeight;
Result := XScale;
if YScale < Result then
Result := YScale;
end;
 
{$IFNDEF VER4UP}
function Max(B1, B2: Integer): Integer;
begin
if B1>=B2 then Result := B1 else Result := B2;
end;
 
function Min(B1, B2: Integer): Integer;
begin
if B1 <= B2 then Result := B1 else Result := B2;
end;
{$ENDIF}
 
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := sin(((c * 360) / 511) * Pi / 180);
end;
 
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := cos(((c * 360) / 511) * Pi / 180);
end;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
begin
Result.RBitMask := ((1 shl RBitCount)-1) shl (GBitCount+BBitCount);
305,9 → 623,7
Result.BShift := 8-BBitCount;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
 
function GetBitCount(b: Integer): Integer;
function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
var
i: Integer;
begin
322,6 → 638,7
end;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
begin
Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
GetBitCount(BBitMask));
352,7 → 669,7
with PixelFormat do
begin
Result := (Color and RBitMask) shr RShift;
Result := Result or (Result shr RBitCount);
Result := Result or (Result shr RBitCount2);
end;
end;
 
361,7 → 678,7
with PixelFormat do
begin
Result := (Color and GBitMask) shr GShift;
Result := Result or (Result shr GBitCount);
Result := Result or (Result shr GBitCount2);
end;
end;
 
370,7 → 687,7
with PixelFormat do
begin
Result := (Color and BBitMask) shl BShift;
Result := Result or (Result shr BBitCount);
Result := Result or (Result shr BBitCount2);
end;
end;
 
447,6 → 764,8
RBitMask, GBitMask, BBitMask: DWORD;
end;
 
{ TPaletteItem }
 
TPaletteItem = class(TCollectionItem)
private
ID: Integer;
456,9 → 775,11
ColorTableCount: Integer;
destructor Destroy; override;
procedure AddRef;
procedure Release;
procedure Release; {$IFDEF VER17UP}reintroduce;{$ENDIF}
end;
 
{ TPaletteManager }
 
TPaletteManager = class
private
FList: TCollection;
468,6 → 789,8
procedure DeletePalette(var Palette: HPalette);
end;
 
{ TPaletteItem }
 
destructor TPaletteItem.Destroy;
begin
DeleteObject(Palette);
485,6 → 808,8
if RefCount<=0 then Free;
end;
 
{ TPaletteManager }
 
constructor TPaletteManager.Create;
begin
inherited Create;
577,6 → 902,8
Result := FPaletteManager;
end;
 
{ TDIBSharedImage }
 
constructor TDIBSharedImage.Create;
begin
inherited Create;
592,8 → 919,10
InfoOfs: Integer;
UsePixelFormat: Boolean;
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
 
{$ENDIF}
{ Pixel format check }
case ABitCount of
1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
602,16 → 931,19
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
16: begin
16:
begin
if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or
((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
24: begin
24:
begin
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
32: begin
32:
begin
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
696,7 → 1028,8
FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
if FPBits=nil then
OutOfMemoryError;
end else
end
else
begin
FDC := CreateCompatibleDC(0);
 
713,11 → 1046,17
 
procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
if Source = nil then Exit; //no source
if Source.FSize=0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
FMemoryImage := MemoryImage;
end else
end
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
726,7 → 1065,8
FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end else
end
else
begin
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end;
789,7 → 1129,8
 
AllocByte^ := B1;
AllocByte^ := B2;
end else
end
else
if (Source.FWidth-x>5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and
((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then
begin
797,7 → 1138,8
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
Inc(x, 2);
end else
end
else
begin
if (Source.FWidth-x<4) then
begin
815,7 → 1157,8
AllocByte^ := GetPixel(x) shl 4;
Inc(x);
end;
end else
end
else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
904,7 → 1247,8
 
AllocByte^ := B1;
AllocByte^ := B2;
end else
end
else
if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
begin
{ Encoding mode }
911,7 → 1255,8
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end else
end
else
begin
if (Source.FWidth-x<4) then
begin
924,13 → 1269,15
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x, 2);
end else
end
else
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end;
end else
end
else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
979,7 → 1326,8
begin
if Source.FCompressed then
Duplicate(Source, Source.FMemoryImage)
else begin
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, True, True);
case FBitmapInfo.bmiHeader.biCompression of
1030,7 → 1378,8
if i and 1=0 then
begin
C := Src^; Inc(Src);
end else
end
else
begin
C := C shl 4;
end;
1044,7 → 1393,8
Inc(X);
end;
end;
end else
end
else
begin
{ Encoding mode }
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
1101,7 → 1451,8
{ Absolute mode }
Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
end;
end else
end
else
begin
{ Encoding mode }
FillChar(Dest^, B1, B2); Inc(Dest, B1);
1115,7 → 1466,8
begin
if not Source.FCompressed then
Duplicate(Source, MemoryImage)
else begin
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
case Source.FBitmapInfo.bmiHeader.biCompression of
1136,6 → 1488,7
procedure LoadRLE4;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1144,6 → 1497,7
procedure LoadRLE8;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1157,7 → 1511,8
begin
for y:=0 to Abs(BI.biHeight)-1 do
Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
end else
end
else
begin
Stream.ReadBuffer(FPBits^, FSize);
end;
1170,12 → 1525,17
AColorTable: TRGBQuads;
APixelFormat: TDIBPixelFormat;
begin
if not Assigned(Stream) then Exit;
{ Header size reading }
i := Stream.Read(BI.biSize, 4);
 
if i=0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
Exit;
end;
if i<>4 then
1216,7 → 1576,8
Stream.ReadBuffer(Localpf, SizeOf(Localpf));
with Localpf do
APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
end else
end
else
begin
if BI.biBitCount=16 then
APixelFormat := MakeDIBPixelFormat(5, 5, 5)
1243,13 → 1604,14
with BCRGB[i] do
AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
end;
end else
end
else
begin
{ Windows type }
Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
end;
 
{ DIB ì¬ }
{ DIB compilation }
NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
 
1270,7 → 1632,9
begin
if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
DeleteObject(FHandle);
end else
end
else
// GlobalFree(THandle(FPBits));
begin
if FPBits<>nil then
GlobalFreePtr(FPBits);
1333,12 → 1697,26
begin
inherited Create;
SetImage(EmptyDIBImage);
 
FFreeList := TList.Create;
end;
 
destructor TDIB.Destroy;
var
D: TDIB;
begin
SetImage(EmptyDIBImage);
FCanvas.Free;
 
while FFreeList.Count > 0 do
try
D := TDIB(FFreeList[0]);
FFreeList.Remove(D);
D.Free;
except
end;
FFreeList.Free;
 
inherited Destroy;
end;
 
1372,12 → 1750,14
if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end else
end
else
if DIBSectionRec^.dsBm.bmBitsPixel>8 then
begin
PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
PixelFormat := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
end else
end
else
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;
1393,14 → 1773,64
end;
 
procedure AssignGraphic(Source: TGraphic);
{$IFDEF PNG_GRAPHICS}
var
alpha: TDIB;
png: {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF};
i, j: Integer;
q: pByteArray;
{$ENDIF}
begin
{$IFDEF PNG_GRAPHICS}
if Source is {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF} then
begin
alpha := TDIB.Create;
try
{png image}
png := {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF}.Create;
try
png.Assign(Source);
if png.TransparencyMode = ptmPartial then
begin
Alpha.SetSize(png.Width, png.Height, 8);
{separate alpha}
for i := 0 to png.Height - 1 do
begin
q := png.AlphaScanline[i];
for j := 0 to png.Width - 1 do
alpha.Pixels[j,i] := q[j];
end;
end;
SetSize(png.Width, png.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, png);
Transparent := png.Transparent;
finally
png.Free;
end;
if not alpha.Empty then
AssignAlphaChannel(alpha);
finally
alpha.Free;
end;
end
else
{$ENDIF}
if Source is TBitmap then
AssignBitmap(TBitmap(Source))
else
begin
SetSize(Source.Width, Source.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
if not HasAlphaChannel then
begin
SetSize(Source.Width, Source.Height, 24);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
end
end;
end;
 
1425,7 → 1855,7
inherited Assign(Source);
end;
 
procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
procedure TDIB.Draw(ACanvas: TCanvas; const ARect: TRect);
var
OldPalette: HPalette;
OldMode: Integer;
1436,7 → 1866,8
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
RealizePalette(ACanvas.Handle);
end else
end
else
OldPalette := 0;
try
OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
1444,14 → 1875,18
GdiFlush;
if FImage.FMemoryImage then
begin
with Rect do
StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
end else
with ARect do
begin
with Rect do
if StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Self.Width, Self.Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS, ACanvas.CopyMode) = 0 then
MessageBeep(1);
end;
end
else
begin
with ARect do
StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
FImage.FDC, 0, 0, Self.Width, Self.Height, ACanvas.CopyMode);
end;
finally
SetStretchBltMode(ACanvas.Handle, OldMode);
1557,6 → 1992,161
end;
end;
 
type
PRGBA = ^TRGBA;
TRGBA = array[0..0] of Windows.TRGBQuad;
 
function TDIB.HasAlphaChannel: Boolean;
{give that DIB contain the alphachannel}
var
p: PRGBA;
X, Y: Integer;
begin
Result := True;
if BitCount = 32 then
for Y := 0 to Height - 1 do
begin
p := ScanLine[Y];
for X := 0 to Width - 1 do
begin
if p[X].rgbReserved <> $0 then Exit;
end
end;
Result := False;
end;
 
function TDIB.AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
{copy alphachannel from other DIB or add from DIB8}
var
p32_0, p32_1: PRGBA;
p24: Pointer;
pB: PArrayByte;
X, Y: Integer;
tmpDIB, qAlpha: TDIB;
begin
Result := False;
if GetEmpty then Exit;
{Alphachannel can be copy into 32bit DIB only!}
if BitCount <> 32 then
begin
tmpDIB := TDIB.Create;
try
tmpDIB.Assign(Self);
Clear;
SetSize(tmpDIB.Width, tmpDIB.Height, 32);
Canvas.Draw(0, 0, tmpDIB);
finally
tmpDIB.Free;
end;
end;
qAlpha := TDIB.Create;
try
if not Assigned(Alpha) then Exit;
if ForceResize then
begin
{create temp}
tmpDIB := TDIB.Create;
try
{picture}
tmpDIB.Assign(ALPHA);
{resample size}
tmpDIB.DoResample(Width, Height, ftrBSpline);
{convert to greyscale}
tmpDIB.Greyscale(8);
{return picture to qAlpha}
qAlpha.Assign(tmpDIB);
finally
tmpDIB.Free;
end;
end
else
{Must be the same size!}
if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
else qAlpha.Assign(ALPHA);
{It works now with qAlpha only}
case qAlpha.BitCount of
24:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p24 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do with PBGR(p24)^ do
begin
p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
end
end;
end;
32:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p32_1 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := p32_1[X].rgbReserved;
end
end;
end;
8:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := pB[X];
end
end;
end;
1:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
if pB[X] = 0 then
p32_0[X].rgbReserved := $FF
else
p32_0[X].rgbReserved := 0
end
end;
end;
else
Exit;
end;
Result := True;
finally
qAlpha.Free;
end;
end;
 
procedure TDIB.RetAlphaChannel(out oDIB: TDIB);
{Store alphachannel information into DIB8}
var
p0: PRGBA;
pB: PArrayByte;
X, Y: Integer;
begin
oDIB := nil;
if not HasAlphaChannel then exit;
oDIB := TDIB.Create;
oDIB.SetSize(Width, Height, 8);
for Y := 0 to Height - 1 do
begin
p0 := ScanLine[Y];
pB := oDIB.ScanLine[Y];
for X := 0 to Width - 1 do
begin
pB[X] := p0[X].rgbReserved;
end
end;
end;
 
function TDIB.GetBitmapInfo: PBitmapInfo;
begin
Result := FImage.FBitmapInfo;
1683,7 → 2273,7
begin
case FBitCount of
1 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
4 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
8 : Result := PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X];
16: Result := PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X];
24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
1693,6 → 2283,17
end;
end;
 
function TDIB.GetRGBChannel: TDIB;
{Store RGB channel information into DIB24}
begin
Result := nil;
if Self.Empty then Exit;
Result := TDIB.Create;
Result.SetSize(Width, Height, 24);
Self.DrawOn(Bounds(0,0, Self.Width, Self.Height), Result.Canvas, 0, 0);
FFreeList.Add(Result);
end;
 
procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
var
P: PByte;
1707,8 → 2308,8
P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
end;
4 : begin
P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
P^ := (P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]);
P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
end;
8 : PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
16: PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
1723,6 → 2324,23
end;
end;
procedure TDIB.SetRGBChannel(const Value: TDIB);
var
alpha: TDIB;
begin
if Self.HasAlphaChannel then
try
RetAlphaChannel(alpha);
Self.SetSize(Value.Width, Value.Height, 32);
Value.DrawOn(Bounds(0,0,Value.Width, Value.Height), Self.Canvas, 0, 0);
Self.AssignAlphaChannel(alpha, True);
finally
alpha.Free;
end
else
Self.Assign(Value);
end;
 
procedure TDIB.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
1731,6 → 2349,8
end;
 
type
{ TGlobalMemoryStream }
 
TGlobalMemoryStream = class(TMemoryStream)
private
FHandle: THandle;
1773,6 → 2393,7
var
BF: TBitmapFileHeader;
i: Integer;
ImageJPEG: TJPEGImage;
begin
{ File header reading }
i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
1780,6 → 2401,30
if i<>SizeOf(TBitmapFileHeader) then
raise EInvalidGraphic.Create(SInvalidDIB);
 
{ Is the head jpeg ?}
 
if BF.bfType = $D8FF then
begin
ImageJPEG := TJPEGImage.Create;
try
try
Stream.Position := 0;
ImageJPEG.LoadFromStream(Stream);
except
on EInvalidGraphic do ImageJPEG := nil;
end;
if ImageJPEG <> nil then
begin
{set size and bitcount in natural units of jpeg}
SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
Canvas.Draw(0, 0, ImageJPEG);
Exit
end;
finally
ImageJPEG.Free;
end;
end
else
{ Is the head 'BM'? }
if BF.bfType<>BitmapFileType then
raise EInvalidGraphic.Create(SInvalidDIB);
1864,7 → 2509,8
if Empty then
begin
SetSize(Max(Width, 1), Max(Height, 1), Value)
end else
end
else
begin
ConvertBitCount(Value);
end;
2031,13 → 2677,16
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
end;
4 : begin
4:
begin
i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
end;
8 : begin
8:
begin
i := PByte(SrcP)^;
Inc(PByte(SrcP));
end;
2044,15 → 2693,18
end;
 
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
end;
8 : begin
8:
begin
PByte(DestP)^ := i;
Inc(PByte(DestP));
end;
2079,7 → 2731,8
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
begin
cR := rgbRed;
2087,7 → 2740,8
cB := rgbBlue;
end;
end;
4 : begin
4:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
begin
cR := rgbRed;
2095,7 → 2749,8
cB := rgbBlue;
end;
end;
8 : begin
8:
begin
with Temp.ColorTable[PByte(SrcP)^] do
begin
cR := rgbRed;
2104,11 → 2759,13
end;
Inc(PByte(SrcP));
end;
16: begin
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
Inc(PWord(SrcP));
end;
24: begin
24:
begin
with PBGR(SrcP)^ do
begin
cR := R;
2118,7 → 2775,8
 
Inc(PBGR(SrcP));
end;
32: begin
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
Inc(PDWORD(SrcP));
end;
2125,11 → 2783,13
end;
 
case BitCount of
16: begin
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PWord(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^ do
begin
R := cR;
2138,7 → 2798,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PDWORD(DestP));
end;
2163,7 → 2824,8
if Temp.BitCount<=BitCount then
begin
PaletteToPalette_Inc;
end else
end
else
begin
case BitCount of
1: begin
2177,12 → 2839,14
 
Canvas.Draw(0, 0, Temp);
end;
end else
end
else
if (Temp.BitCount<=8) and (BitCount>8) then
begin
{ The image is converted from the palette color image into the rgb color image. }
PaletteToRGB_or_RGBToRGB;
end else
end
else
if (Temp.BitCount>8) and (BitCount<=8) then
begin
{ The image is converted from the rgb color image into the palette color image. }
2197,7 → 2861,8
UpdatePalette;
 
Canvas.Draw(0, 0, Temp);
end else
end
else
if (Temp.BitCount>8) and (BitCount>8) then
begin
{ The image is converted from the rgb color image into the rgb color image. }
2251,6 → 2916,211
Inc(FProgressY);
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
begin
if Empty then Exit;
if (not MirrorX) and (not MirrorY) then Exit;
 
if (not MirrorX) and (MirrorY) then
begin
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
finally
FreeMem(TempBuf, WidthBytes);
end;
end
else
if (MirrorX) and (not MirrorY) then
begin
Width2 := Width shr 1;
 
StartProgress('Mirror');
try
for y := 0 to Height - 1 do
begin
P1 := ScanLine[y];
 
case BitCount of
1:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
4:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P1) + Width - 1);
for x := 0 to Width2 - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 2);
for x := 0 to Width2 - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 3);
for x := 0 to Width2 - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 4);
for x := 0 to Width2 - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y);
end;
finally
EndProgress;
end;
end
else
if (MirrorX) and (MirrorY) then
begin
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
case BitCount of
1:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
4:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P2) + Width - 1);
for x := 0 to Width - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 2);
for x := 0 to Width - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 3);
for x := 0 to Width - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 4);
for x := 0 to Width - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
end;
end;
 
procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
type
TAve = record
2270,7 → 3140,8
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2285,7 → 3156,8
Inc(AveP);
end;
end;
4 : begin
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2300,7 → 3172,8
Inc(AveP);
end;
end;
8 : begin
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2316,7 → 3189,8
Inc(AveP);
end;
end;
16: begin
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2333,7 → 3207,8
Inc(AveP);
end;
end;
24: begin
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2349,7 → 3224,8
Inc(AveP);
end;
end;
32: begin
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2377,7 → 3253,8
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2392,7 → 3269,8
Inc(AveP);
end;
end;
4 : begin
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2407,7 → 3285,8
Inc(AveP);
end;
end;
8 : begin
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2423,7 → 3302,8
Inc(AveP);
end;
end;
16: begin
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2440,7 → 3320,8
Inc(AveP);
end;
end;
24: begin
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2456,7 → 3337,8
Inc(AveP);
end;
end;
32: begin
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2579,27 → 3461,32
 
{ The average is written. }
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
with Ave do
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR+cG+cB) div c) div 3>127)) shl Shift1[X and 7]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
with Ave do
P^ := (P^ and Mask4n[X and 1]) or (((((cR+cG+cB) div c) div 3) shr 4) shl Shift4[X and 1]);
end;
8 : begin
8:
begin
with Ave do
PByte(DestP)^ := ((cR+cG+cB) div c) div 3;
Inc(PByte(DestP));
end;
16: begin
16:
begin
with Ave do
PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PWORD(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^, Ave do
begin
R := cR div c;
2608,7 → 3495,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
with Ave do
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PDWORD(DestP));
2658,6 → 3546,64
end;
end;
 
procedure TDIB.Negative;
var
i, i2: Integer;
P: Pointer;
begin
if Empty then exit;
 
if BitCount <= 8 then
begin
for i := 0 to 255 do
with ColorTable[i] do
begin
rgbRed := 255 - rgbRed;
rgbGreen := 255 - rgbGreen;
rgbBlue := 255 - rgbBlue;
end;
UpdatePalette;
end else
begin
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
 
@@byte_skip:
end;
end;
end;
 
procedure TDIB.Greyscale(ABitCount: Integer);
var
YTblR, YTblG, YTblB: array[0..255] of Byte;
2668,7 → 3614,7
DestP, SrcP: Pointer;
P: PByte;
begin
if Empty then exit;
if Empty then Exit;
 
Temp := TDIB.Create;
try
2706,30 → 3652,36
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
end;
4 : begin
4:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
end;
8 : begin
8:
begin
with Temp.ColorTable[PByte(SrcP)^] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
Inc(PByte(SrcP));
end;
16: begin
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PWord(SrcP));
end;
24: begin
24:
begin
with PBGR(SrcP)^ do
c := YTblR[R]+YTblG[G]+YTblB[B];
Inc(PBGR(SrcP));
end;
32: begin
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PDWORD(SrcP));
2737,23 → 3689,28
end;
 
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c>127)) shl Shift1[X and 7]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
end;
8 : begin
8:
begin
PByte(DestP)^ := c;
Inc(PByte(DestP));
end;
16: begin
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PWord(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^ do
begin
R := c;
2762,7 → 3719,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PDWORD(DestP));
end;
2779,253 → 3737,1574
end;
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
//--------------------------------------------------------------------------------------------------
// Version : 0.1 - 26/06/2000 //
// Version : 0.2 - 04/07/2000 //
// At someone's request, i have added 3 news effects : //
// 1 - Rotate //
// 2 - SplitBlur //
// 3 - GaussianBlur //
//--------------------------------------------------------------------------------------------------
// - NEW SPECIAL EFFECT - (English) //
//--------------------------------------------------------------------------------------------------
// At the start, my idea was to create a component derived from TCustomDXDraw. Unfortunately, //
// it's impossible to run a graphic component (derived from TCustomDXDraw) in a conception's //
// mode (i don't success, but perhaps, somebody know how doing ! In that case, please help me !!!)//
// Then, i'm used the DIB's unit for my work, but this unit is poor in special effect. Knowing a //
// library with more effect, i'm undertaked to import this library in DIB's unit. You can see the //
// FastLib library at : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// It was very difficult, because implementation's graphic was very different that DIB's unit. //
// Sometimes, i'm deserted the possibility of original effect, particularly in conversion of DIB //
// whith 256, 16 and 2 colors. If someone can implement this fonctionnality, thanks to tell me //
// how this miracle is possible !!! //
// All these procedures are translated and adapted by : //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : These procedures don't modify the DIB's unit structure //
// Nota Bene : I don't implement these type of graphics (32 and 16 bit per pixels), //
// for one reason : I haven't bitmaps of this type !!! //
//--------------------------------------------------------------------------------------------------
//--------------------------------------------------------------------------------------------------
// - NOUVEAUX EFFETS SPECIAUX - (Français) //
//--------------------------------------------------------------------------------------------------
// Au commencement, mon idée était de dériver un composant de TCustomDXDraw. Malheureusement, //
// c'est impossible de faire fonctionner un composant graphique (derivé de TCustomDXDraw) en mode //
// conception (je n'y suis pas parvenu, mais peut-être, que quelqu'un sait comment faire ! Dans //
// ce cas, vous seriez aimable de m'aider !!!) //
// Alors, j'ai utilisé l'unité DIB pour mon travail,mais celle-ci est pauvre en effet spéciaux. //
// Connaissant une librairie avec beaucoup plus d'effets spéciaux, j'ai entrepris d'importer //
// cette librairie dans l'unité DIB. Vous pouvez voir la librairie FastLib à : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// C'était très difficile car l'implémentation graphique est très différente de l'unité DIB. //
// Parfois, j'ai abandonné les possibilités de l'effet original, particulièrement dans la //
// conversion des DIB avec 256, 16 et 2 couleurs. Si quelqu'un arrive à implémenter ces //
// fonctionnalités, merci de me dire comment ce miracle est possible !!! //
// Toutes ces procédures ont été traduites et adaptées par: //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : Ces procédures ne modifient pas la structure de l'unité DIB //
// Nota Bene : Je n'ai pas implémenté ces types de graphiques (32 et 16 bit par pixels), //
// pour une raison : je n'ai pas de bitmap de ce type !!! //
//--------------------------------------------------------------------------------------------------
 
function TDIB.IntToColor(i: Integer): TBGR;
begin
if Empty then exit;
if (not MirrorX) and (not MirrorY) then Exit;
Result.b := i shr 16;
Result.g := i shr 8;
Result.r := i;
end;
 
if (not MirrorX) and (MirrorY) then
function TDIB.Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer;
begin
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
if iMark then
begin
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMax
else
Result := iValue;
end
else
begin
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMin
else
Result := iValue;
end;
end;
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
procedure TDIB.Contrast(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 126 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i - y);
end;
for i := 127 to 255 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i + y);
end;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
UpdateProgress(y*2);
procedure TDIB.Saturation(Amount: Integer);
var
Grays: array[0..767] of Integer;
Alpha: array[0..255] of Word;
Gray, x, y: Integer;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 255 do
Alpha[i] := (i * Amount) shr 8;
x := 0;
for i := 0 to 255 do
begin
Gray := i - Alpha[i];
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
end;
finally
EndProgress;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
Gray := Grays[rgbRed + rgbGreen + rgbBlue];
rgbRed := IntToByte(Gray + Alpha[rgbRed]);
rgbGreen := IntToByte(Gray + Alpha[rgbGreen]);
rgbBlue := IntToByte(Gray + Alpha[rgbBlue]);
end;
finally
FreeMem(TempBuf, WidthBytes);
end;
end else if (MirrorX) and (not MirrorY) then
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
Width2 := Width shr 1;
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
Gray := Grays[PBGR(D)^.R + PBGR(D)^.G + PBGR(D)^.B];
PBGR(D)^.B := IntToByte(Gray + Alpha[PBGR(D)^.B]);
PBGR(D)^.G := IntToByte(Gray + Alpha[PBGR(D)^.G]);
PBGR(D)^.R := IntToByte(Gray + Alpha[PBGR(D)^.R]);
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := IntToByte(Gray + Alpha[B]) + IntToByte(Gray + Alpha[G]) +
IntToByte(Gray + Alpha[R]);
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
StartProgress('Mirror');
try
for y:=0 to Height-1 do
procedure TDIB.Lightness(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
P1 := ScanLine[y];
 
D := nil;
S := nil;
Temp1 := nil;
if Amount < 0 then
begin
Amount := -Amount;
for i := 0 to 255 do
Table1[i] := IntToByte(i - ((Amount * i) shr 8));
end
else
for i := 0 to 255 do
Table1[i] := IntToByte(i + ((Amount * (i xor 255)) shr 8));
case BitCount of
1 : begin
for x:=0 to Width2-1 do
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
end;
end;
4 : begin
for x:=0 to Width2-1 do
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
8 : begin
P2 := Pointer(Integer(P1)+Width-1);
for x:=0 to Width2-1 do
for x := 0 to Pred(Width) do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
16: begin
P2 := Pointer(Integer(P1)+(Width-1)*2);
for x:=0 to Width2-1 do
8:
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
24: begin
P2 := Pointer(Integer(P1)+(Width-1)*3);
for x:=0 to Width2-1 do
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
procedure TDIB.AddRGB(aR, aG, aB: Byte);
var
Table: array[0..255] of TBGR;
x, y: Integer;
i: Byte;
D: pointer;
P: PByte;
color: DWORD;
Temp1: TDIB;
R, G, B: Byte;
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
color := 0;
D := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24, 16:
begin
for i := 0 to 255 do
begin
Table[i].b := IntToByte(i + aB);
Table[i].g := IntToByte(i + aG);
Table[i].r := IntToByte(i + aR);
end;
end;
32: begin
P2 := Pointer(Integer(P1)+(Width-1)*4);
for x:=0 to Width2-1 do
8, 4:
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(rgbRed + aR);
rgbGreen := IntToByte(rgbGreen + aG);
rgbBlue := IntToByte(rgbBlue + aB);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table[R].r + Table[G].g + Table[B].b;
Inc(PWord(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
UpdateProgress(y);
function TDIB.Filter(Dest: TDIB; Filter: TFilter): Boolean;
var
Sum, r, g, b, x, y: Integer;
a, i, j: byte;
tmp: TBGR;
Col: PBGR;
D: Pointer;
begin
Result := True;
Sum := Filter[0, 0] + Filter[1, 0] + Filter[2, 0] +
Filter[0, 1] + Filter[1, 1] + Filter[2, 1] +
Filter[0, 2] + Filter[1, 2] + Filter[2, 2];
if Sum = 0 then
Sum := 1;
Col := PBits;
for y := 0 to Pred(Height) do
begin
D := Dest.ScanLine[y];
for x := 0 to Pred(Width) do
begin
r := 0; g := 0; b := 0;
case BitCount of
32, 16, 4, 1:
begin
Result := False;
Exit;
end;
finally
EndProgress;
24:
begin
for i := 0 to 2 do
begin
for j := 0 to 2 do
begin
Tmp := IntToColor(Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
end;
end else if (MirrorX) and (MirrorY) then
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
Dest.Pixels[x, y] := rgb(Col.r, Col.g, Col.b);
end;
8:
begin
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
for i := 0 to 2 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
for j := 0 to 2 do
begin
a := (Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
tmp.r := ColorTable[a].rgbRed;
tmp.g := ColorTable[a].rgbGreen;
tmp.b := ColorTable[a].rgbBlue;
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
end;
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
PByte(D)^ := rgb(Col.r, Col.g, Col.b);
Inc(PByte(D));
end;
end;
end;
end;
end;
 
procedure TDIB.Spray(Amount: Integer);
var
value, x, y: Integer;
D: Pointer;
color: DWORD;
P: PByte;
begin
for y := Pred(Height) downto 0 do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
value := Random(Amount);
color := Pixels[Interval(0, Pred(Width), x + (value - Random(value * 2)), True),
Interval(0, Pred(Height), y + (value - Random(value * 2)), True)];
case BitCount of
1 : begin
for x:=0 to Width-1 do
32:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
PDWord(D)^ := color;
Inc(PDWord(D));
end;
24:
begin
PBGR(D)^ := IntToColor(color);
Inc(PBGR(D));
end;
4 : begin
for x:=0 to Width-1 do
16:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
PWord(D)^ := color;
Inc(PWord(D));
end;
8:
begin
PByte(D)^ := color;
Inc(PByte(D));
end;
8 : begin
P2 := Pointer(Integer(P2)+Width-1);
for x:=0 to Width-1 do
4:
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
1:
begin
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
16: begin
P2 := Pointer(Integer(P2)+(Width-1)*2);
for x:=0 to Width-1 do
else
end;
end;
end;
end;
 
procedure TDIB.Sharpen(Amount: Integer);
var
Lin0, Lin1, Lin2: PLines;
pc: PBGR;
cx, x, y: Integer;
Buf: array[0..8] of TBGR;
D: pointer;
c: DWORD;
i: byte;
P1: PByte;
Temp1: TDIB;
 
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
D := nil;
GetMem(pc, SizeOf(TBGR));
c := 0;
Temp1 := nil;
case Bitcount of
32, 16, 1: Exit;
24:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
end;
8:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
Temp1.colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
Temp1.colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
Temp1.colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
 
end;
24: begin
P2 := Pointer(Integer(P2)+(Width-1)*3);
for x:=0 to Width-1 do
end;
Temp1.UpdatePalette;
end;
4:
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
end;
end;
32: begin
P2 := Pointer(Integer(P2)+(Width-1)*4);
for x:=0 to Width-1 do
UpdatePalette;
end;
end;
for y := 0 to Pred(Height) do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
Lin0 := ScanLine[Interval(0, Pred(Height), y - Amount, True)];
Lin1 := ScanLine[y];
Lin2 := ScanLine[Interval(0, Pred(Height), y + Amount, True)];
case Bitcount of
24, 8, 4: D := Temp1.ScanLine[y];
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
cx := Interval(0, Pred(Width), x - Amount, True);
Buf[0] := Lin0[cx];
Buf[1] := Lin1[cx];
Buf[2] := Lin2[cx];
Buf[3] := Lin0[x];
Buf[4] := Lin1[x];
Buf[5] := Lin2[x];
cx := Interval(0, Pred(Width), x + Amount, true);
Buf[6] := Lin0[cx];
Buf[7] := Lin1[cx];
Buf[8] := Lin0[cx];
pc.b := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
pc.g := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
pc.r := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
PBGR(D)^.B := pc.b;
PBGR(D)^.G := pc.g;
PBGR(D)^.R := pc.r;
Inc(PBGR(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P1 := @PArrayByte(D)[X shr 1];
P1^ := ((P1^ and Mask4n[X and 1]) or ((c shl Shift4[X and 1])));
end;
end;
end;
end;
case BitCount of
24, 8:
begin
Assign(Temp1);
Temp1.Free;
end;
4: Temp1.Free;
end;
FreeMem(pc, SizeOf(TBGR));
end;
 
UpdateProgress(y*2);
procedure TDIB.Emboss;
var
x, y: longint;
D, D1, P: pointer;
color: TBGR;
c: DWORD;
P1: PByte;
 
begin
D := nil;
D1 := nil;
P := nil;
case BitCount of
32, 16, 1: Exit;
24:
begin
D := PBits;
D1 := Ptr(Integer(D) + 3);
end;
finally
EndProgress;
else
end;
for y := 0 to Pred(Height) do
begin
case Bitcount of
8, 4:
begin
P := ScanLine[y];
end;
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
PBGR(D)^.B := ((PBGR(D)^.B + (PBGR(D1)^.B xor $FF)) shr 1);
PBGR(D)^.G := ((PBGR(D)^.G + (PBGR(D1)^.G xor $FF)) shr 1);
PBGR(D)^.R := ((PBGR(D)^.R + (PBGR(D1)^.R xor $FF)) shr 1);
Inc(PBGR(D));
if (y < Height - 2) and (x < Width - 2) then
Inc(PBGR(D1));
end;
8:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
PByte(P)^ := c;
Inc(PByte(P));
end;
4:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) - 1) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
if c > 64 then
c := c - 8;
P1 := @PArrayByte(P)[X shr 1];
P1^ := (P1^ and Mask4n[X and 1]) or ((c) shl Shift4[X and 1]);
end;
else
end;
end;
case BitCount of
24:
begin
D := Ptr(Integer(D1));
if y < Height - 2 then
D1 := Ptr(Integer(D1) + 6)
else
D1 := Ptr(Integer(ScanLine[Pred(Height)]) + 3);
end;
else
end;
end;
end;
 
procedure TDIB.Negative;
procedure TDIB.AddMonoNoise(Amount: Integer);
var
i, i2: Integer;
P: Pointer;
value: cardinal;
x, y: longint;
a: byte;
D: pointer;
color: DWORD;
P: PByte;
begin
if Empty then exit;
for y := 0 to Pred(Height) do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
value := Random(Amount) - (Amount shr 1);
PBGR(D)^.B := IntToByte(PBGR(D)^.B + value);
PBGR(D)^.G := IntToByte(PBGR(D)^.G + value);
PBGR(D)^.R := IntToByte(PBGR(D)^.R + value);
Inc(PBGR(D));
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 8;
color := Interval(0, 255, (pixels[x, y] - a), True);
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 16;
color := Interval(0, 15, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 1];
P^ := ((P^ and Mask4n[X and 1]) or ((color shl Shift4[X and 1])));
end;
1:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 32;
color := Interval(0, 1, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
else
end;
end;
end;
end;
 
if BitCount<=8 then
procedure TDIB.AddGradiantNoise(Amount: byte);
var
a, i: byte;
x, y: Integer;
Table: array[0..255] of TBGR;
S, D: pointer;
color: DWORD;
Temp1: TDIB;
P: PByte;
 
begin
D := nil;
S := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
for i:=0 to 255 do
begin
a := Random(Amount);
Table[i].b := IntToByte(i + a);
Table[i].g := IntToByte(i + a);
Table[i].r := IntToByte(i + a);
end;
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := 255-rgbRed;
rgbGreen := 255-rgbGreen;
rgbBlue := 255-rgbBlue;
a := Random(Amount);
rgbRed := IntToByte(rgbRed + a);
rgbGreen := IntToByte(rgbGreen + a);
rgbBlue := IntToByte(rgbBlue + a);
end;
end;
UpdatePalette;
end else
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
case BitCount of
24: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16: ; // I haven't bitmap of this type ! Sorry
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
function TDIB.FishEye(bmp: TDIB): Boolean;
var
weight, xmid, ymid, fx, fy, r1, r2, dx, dy, rmax: Double;
Amount, ifx, ify, ty, tx, new_red, new_green, new_blue, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Double;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
D: Pointer;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Amount := 1;
xmid := Width / 2;
ymid := Height / 2;
rmax := Max(Bmp.Width, Bmp.Height) * Amount;
for ty := 0 to Pred(Height) do
begin
for tx := 0 to Pred(Width) do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(Sqr(dx) + Sqr(dy));
if r1 <> 0 then
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end
else
begin
fx := xmid;
fy := ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
function TDIB.SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
var
weight, Theta, cosTheta, sinTheta, sfrom_y, sfrom_x: Double;
ifrom_y, ifrom_x, xDiff, yDiff, to_y, to_x: Integer;
weight_x, weight_y: array[0..1] of Double;
ix, iy, new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Theta := -Degree * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Bmp.Width - Width) div 2;
yDiff := (Bmp.Height - Height) div 2;
for to_y := 0 to Pred(Bmp.Height) do
begin
for to_x := 0 to Pred(Bmp.Width) do
begin
sfrom_x := (cx + (to_x - cx) * cosTheta - (to_y - cy) * sinTheta) - xDiff;
ifrom_x := Trunc(sfrom_x);
sfrom_y := (cy + (to_x - cx) * sinTheta + (to_y - cy) * cosTheta) - yDiff;
ifrom_y := Trunc(sfrom_y);
if sfrom_y >= 0 then
begin
weight_y[1] := sfrom_y - ifrom_y;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(sfrom_y - ifrom_y);
weight_y[1] := 1 - weight_y[0];
end;
if sfrom_x >= 0 then
begin
weight_x[1] := sfrom_x - ifrom_x;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(sfrom_x - ifrom_x);
Weight_x[1] := 1 - weight_x[0];
end;
if ifrom_x < 0 then
ifrom_x := Pred(Width) - (-ifrom_x mod Width)
else
if ifrom_x > Pred(Width) then
ifrom_x := ifrom_x mod Width;
if ifrom_y < 0 then
ifrom_y := Pred(Height) - (-ifrom_y mod Height)
else
if ifrom_y > Pred(Height) then
ifrom_y := ifrom_y mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ifrom_y + iy < Height then
sli := ScanLine[ifrom_y + iy]
else
sli := ScanLine[Height - ifrom_y - iy];
if ifrom_x + ix < Width then
begin
new_red := sli^[ifrom_x + ix].r;
new_green := sli^[ifrom_x + ix].g;
new_blue := sli^[ifrom_x + ix].b;
end
else
begin
new_red := sli^[Width - ifrom_x - ix].r;
new_green := sli^[Width - ifrom_x - ix].g;
new_blue := sli^[Width - ifrom_x - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[to_y];
slo^[to_x].r := Round(total_red);
slo^[to_x].g := Round(total_green);
slo^[to_x].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
function TDIB.Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
var
x, y, dx, dy, sdx, sdy, xDiff, yDiff, isinTheta, icosTheta: Integer;
D, S: Pointer;
sinTheta, cosTheta, Theta: Double;
Col: TBGR;
i: byte;
color: DWORD;
P: PByte;
begin
D := nil;
S := nil;
Result := True;
dst.SetSize(Width, Height, Bitcount);
dst.Canvas.Brush.Color := clBlack;
Dst.Canvas.FillRect(Bounds(0, 0, Width, Height));
case BitCount of
32, 16:
begin
Result := False;
Exit;
end;
8, 4, 1:
begin
for i := 0 to 255 do
Dst.ColorTable[i] := ColorTable[i];
Dst.UpdatePalette;
end;
end;
Theta := -Angle * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Dst.Width - Width) div 2;
yDiff := (Dst.Height - Height) div 2;
isinTheta := Round(sinTheta * $10000);
icosTheta := Round(cosTheta * $10000);
for y := 0 to Pred(Dst.Height) do
begin
case BitCount of
4, 1:
begin
D := Dst.ScanLine[y];
S := ScanLine[y];
end;
else
end;
sdx := Round(((cx + (-cx) * cosTheta - (y - cy) * sinTheta) - xDiff) * $10000);
sdy := Round(((cy + (-cy) * sinTheta + (y - cy) * cosTheta) - yDiff) * $10000);
for x := 0 to Pred(Dst.Width) do
begin
dx := (sdx shr 16);
dy := (sdy shr 16);
if (dx > -1) and (dx < Width) and (dy > -1) and (dy < Height) then
begin
case bitcount of
8, 24: Dst.pixels[x, y] := Pixels[dx, dy];
4:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[x shr 1];
P^ := (P^ and Mask4n[x and 1]) or (color shl Shift4[x and 1]);
end;
1:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
end;
end;
Inc(sdx, icosTheta);
Inc(sdy, isinTheta);
end;
end;
end;
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
procedure TDIB.GaussianBlur(Bmp: TDIB; Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do
Bmp.SplitBlur(i);
end;
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
procedure TDIB.SplitBlur(Amount: Integer);
var
Lin1, Lin2: PLines;
cx, x, y: Integer;
Buf: array[0..3] of TBGR;
D: Pointer;
 
@@byte_skip:
begin
case Bitcount of
32, 16, 8, 4, 1: Exit;
end;
for y := 0 to Pred(Height) do
begin
Lin1 := ScanLine[TrimInt(y + Amount, 0, Pred(Height))];
Lin2 := ScanLine[TrimInt(y - Amount, 0, Pred(Height))];
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
cx := TrimInt(x + Amount, 0, Pred(Width));
Buf[0] := Lin1[cx];
Buf[1] := Lin2[cx];
cx := TrimInt(x - Amount, 0, Pred(Width));
Buf[2] := Lin1[cx];
Buf[3] := Lin2[cx];
PBGR(D)^.b := (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b) shr 2;
PBGR(D)^.g := (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g) shr 2;
PBGR(D)^.r := (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r) shr 2;
Inc(PBGR(D));
end;
end;
end;
 
function TDIB.Twist(bmp: TDIB; Amount: byte): Boolean;
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Single;
sli, slo: PLines;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
if Amount = 0 then
Amount := 1;
OFFSET := -(Pi / 2);
dx := Pred(Width);
dy := Pred(Height);
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Pred(Width)) / 2;
tymid := (Pred(Height)) / 2;
fxmid := (Pred(Width)) / 2;
fymid := (Pred(Height)) / 2;
if tx2 >= Width then
tx2 := Pred(Width);
if ty2 >= Height then
ty2 := Pred(Height);
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
function TDIB.TrimInt(i, Min, Max: Integer): Integer;
begin
if i > Max then
Result := Max
else
if i < Min then
Result := Min
else
Result := i;
end;
 
function TDIB.IntToByte(i: Integer): Byte;
begin
if i > 255 then
Result := 255
else
if i < 0 then
Result := 0
else
Result := i;
end;
 
//--------------------------------------------------------------------------------------------------
// End of these New Special Effect //
// Please contributes to add effects and filters to this collection //
// Please, work to implement 32,16,8,4,2 BitCount's DIB //
// Have fun - Mickey - Good job //
//--------------------------------------------------------------------------------------------------
 
function TDIB.GetAlphaChannel: TDIB;
begin
RetAlphaChannel(Result);
 
FFreeList.Add(Result);
end;
 
procedure TDIB.SetAlphaChannel(const Value: TDIB);
begin
if not AssignAlphaChannel(Value{$IFNDEF VER4UP}, False{$ENDIF}) then
Exception.Create('Cannot set alphachannel from DIB.');
end;
 
procedure TDIB.Fill(aColor: TColor);
begin
Canvas.Brush.Color := aColor;
Canvas.FillRect(ClientRect);
end;
 
function TDIB.GetClientRect: TRect;
begin
Result := Bounds(0, 0, Width, Height);
end;
 
{ TCustomDXDIB }
 
constructor TCustomDXDIB.Create(AOnwer: TComponent);
3078,17 → 5357,20
begin
inherited Canvas.StretchDraw(Bounds(-(Width-ClientWidth) div 2,
-(Height-ClientHeight) div 2, Width, Height), FDIB);
end else
end
else
begin
inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
end;
end else
end
else
begin
if FCenter then
begin
inherited Canvas.Draw(-(Width-ClientWidth) div 2, -(Height-ClientHeight) div 2,
FDIB);
end else
end
else
begin
inherited Canvas.Draw(0, 0, FDIB);
end;
3128,11 → 5410,14
if r>r2 then
r := r2;
Draw2(Round(r*ClientWidth), Round(r*ClientHeight));
end else
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
begin
if FAutoStretch then
begin
3143,9 → 5428,11
if r>r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
end
else
Draw2(FDIB.Width, FDIB.Height);
end else
end
else
if FStretch then
begin
if FKeepAspect then
3155,9 → 5442,11
if r>r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
end
else
Draw2(ClientWidth, ClientHeight);
end else
end
else
Draw2(FDIB.Width, FDIB.Height);
end;
end;
3228,6 → 5517,4382
end;
end;
 
{ DXFusion -> }
 
function PosValue(Value: Integer): Integer;
begin
if Value < 0 then result := 0 else result := Value;
end;
 
procedure TDIB.CreateDIBFromBitmap(const Bitmap: TBitmap);
var
pf: Integer;
begin
if Bitmap.PixelFormat = pf32bit then pf := 32 else pf := 24;
SetSize(Bitmap.Width, Bitmap.Height, pf); {always >=24}
Canvas.Draw(0, 0, Bitmap);
end;
 
function TDIB.CreateBitmapFromDIB: TBitmap;
//var
// X, Y: Integer;
begin
Result := TBitmap.Create;
if BitCount = 32 then
Result.PixelFormat := pf32bit
else if BitCount = 24 then
Result.PixelFormat := pf24bit
else if BitCount = 16 then
Result.PixelFormat := pf16bit
else if BitCount = 8 then
Result.PixelFormat := pf8bit
else Result.PixelFormat := pf24bit;
Result.Width := Width;
Result.Height := Height;
Result.Canvas.Draw(0, 0, Self);
// for Y := 0 to Height - 1 do
// for X := 0 to Width - 1 do
// Result.Canvas.Pixels[X, Y] := Canvas.Pixels[X, Y];
end;
 
procedure TDIB.DrawTo(SrcDIB: TDIB; X, Y, Width, Height,
SourceX, SourceY: Integer);
begin
SrcDIB.DrawOn(Rect(X, Y, Width, Height), Self.Canvas, SourceX, SourceY);
end;
 
procedure TDIB.DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
 
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawShadow(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; FilterMode: TFilterMode);
var
i, j: Integer;
p1, p2: PByte;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
Inc(p1, 3 * (X + 1));
Inc(p2, 3 * (FW + 1));
for j := 1 to Width - 1 do
begin
if (p2^ = 0) then
begin
case FilterMode of
fmNormal, fmMix50:
begin
p1^ := p1^ shr 1; // Blue
Inc(p1);
p1^ := p1^ shr 1; // Green
Inc(p1);
p1^ := p1^ shr 1; // Red
Inc(p1);
end;
fmMix25:
begin
p1^ := p1^ - p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Red
Inc(p1);
end;
fmMix75:
begin
p1^ := p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ shr 2; // Red
Inc(p1);
end;
end;
end
else
Inc(p1, 3); // Not in the loop...
Inc(p2, 3);
end;
end;
end;
 
procedure TDIB.DrawShadows(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; Alpha: Byte);
{plynule nastavovani stiny dle alpha}
type
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of TBGR;
var
i, j, l1, l2: Integer;
p1, p2: P3ByteArray;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
l1 := X;
l2 := FW;
for j := 0 to Width - 1 do
begin
if (p2[j + l2].B = 0) and (p2[j + l2].G = 0) and (p2[j + l2].R = 0) then
begin
p1[J + l1].B := Round(p1[J + l1].B / $FF * Alpha);
p1[J + l1].G := Round(p1[J + l1].G / $FF * Alpha);
p1[J + l1].R := Round(p1[J + l1].R / $FF * Alpha);
end
end;
end;
end;
 
procedure TDIB.DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
var
frameoffset, i, j: Integer;
p1, p2: pByte;
XOffset: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
frameoffset := 3 * (Frame * Width) + 3;
XOffset := 3 * X + 3;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, XOffset);
inc(p2, frameoffset);
for j := 1 to Width - 1 do
begin
p1^ := (p2^ * p1^) shr 8; // R
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // G
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // B
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor; FilterMode: TFilterMode);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
BitSwitch1, BitSwitch2: Boolean;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if Odd(Y) then BitSwitch1 := true else BitSwitch1 := false;
if Odd(X) then BitSwitch2 := true else BitSwitch2 := false;
 
for j := StartY to EndY - 1 do
begin
BitSwitch1 := not BitSwitch1;
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
BitSwitch2 := not BitSwitch2;
 
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
case FilterMode of
fmNormal, fmMix50: if not (n = Color) and (BitSwitch1 xor BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix25: if not (n = Color) and (BitSwitch1 and BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix75: if not (n = Color) and (BitSwitch1 or BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height, Alpha, Frame:
Integer);
var
frameoffset, i, j, Wid: Integer;
p1, p2: pByte;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
if (Alpha < 1) or (Alpha > 256) then Exit;
Wid := Width shl 1 + Width;
frameoffset := Wid * Frame;
for i := 1 to Height - 1 do
begin
if (i + Y) > (Self.Height - 1) then Break; //add 25.5.2004 JB.
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, X shl 1 + X + 3);
inc(p2, frameoffset + 3);
for j := 3 to Wid - 4 do
begin
inc(p1^, (Alpha - p1^) * p2^ shr 8);
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] + p2[k1]) shr 1;
p1[k2 + 1] := (p1[k2 + 1] + p2[k1 + 1]) shr 1;
p1[k2 + 2] := (p1[k2 + 2] + p2[k1 + 2]) shr 1;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY, Alpha: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] * (256 - Alpha) + p2[k1] * Alpha) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - Alpha) + p2[k1 + 1] * Alpha) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - Alpha) + p2[k1 + 2] * Alpha) shr 8;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y,
Width, Height, SourceX, SourceY: Integer);
var
i, j: Integer;
k1, k2, k3: Integer;
p1, p2, p3: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
p3 := MaskDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
k3 := 0;
 
for i := SourceX to SourceX + Width - 1 do
begin
p1[k2] := (p1[k2] * (256 - p3[k3]) + p2[k1] * p3[k3]) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - p3[k3]) + p2[k1 + 1] * p3[k3]) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - p3[k3]) + p2[k1 + 2] * p3[k3]) shr 8;
 
k1 := k1 + 3;
k2 := k2 + 3;
k3 := k3 + 3;
end;
end;
end;
 
procedure TDIB.DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j, r, g, b: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r := 0;
g := 0;
b := 0;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if Random(100) < 50 then
begin
b := p1[k2];
g := p1[k2 + 1];
r := p1[k2 + 2];
end;
 
if not (n = Color) then
begin
p1[k2] := b;
p1[k2 + 1] := g;
p1[k2 + 2] := r;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawMono(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
var
i, j, r1, g1, b1, r2, g2, b2: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
Startk1, Startk2, StartY, EndY, DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r1 := GetRValue(BackColor);
g1 := GetGValue(BackColor);
b1 := GetBValue(BackColor);
 
r2 := GetRValue(ForeColor);
g2 := GetGValue(ForeColor);
b2 := GetBValue(ForeColor);
 
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if (n = TransColor) then
begin
p1[k2] := b1;
p1[k2 + 1] := g1;
p1[k2 + 2] := r1;
end
else
begin
p1[k2] := b2;
p1[k2 + 1] := g2;
p1[k2 + 2] := r2;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
var i, j, k: Integer;
p1, p2, p3, p4: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to SrcDIB.Height - 2 do
begin
p1 := SrcDIB.ScanLine[i - 1];
p2 := SrcDIB.ScanLine[i];
p3 := SrcDIB.ScanLine[i + 1];
p4 := Self.ScanLine[i];
for j := 3 to 3 * SrcDIB.Width - 4 do
begin
k := (p1[j - 3] * Setting[0] + p1[j] * Setting[1] + p1[j + 3] * Setting[2] +
p2[j - 3] * Setting[3] + p2[j] * Setting[4] + p2[j + 3] * Setting[5] +
p3[j - 3] * Setting[6] + p3[j] * Setting[7] + p3[j + 3] * Setting[8])
div Setting[9];
if k < 0 then k := 0;
if k > 255 then k := 255;
p4[j] := k;
end;
end;
end;
 
procedure TDIB.DrawAntialias(SrcDIB: TDIB);
var i, j, k, l, m: Integer;
p1, p2, p3: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to Self.Height - 1 do
begin
k := i shl 1;
p1 := SrcDIB.Scanline[k];
p2 := SrcDIB.Scanline[k + 1];
p3 := Self.Scanline[i];
for j := 1 to Self.Width - 1 do
begin
m := 3 * j;
l := m shl 1;
p3[m] := (p1[l] + p1[l + 3] + p2[l] + p2[l + 3]) shr 2;
p3[m + 1] := (p1[l + 1] + p1[l + 4] + p2[l + 1] + p2[l + 4]) shr 2;
p3[m + 2] := (p1[l + 2] + p1[l + 5] + p2[l + 2] + p2[l + 5]) shr 2;
end;
end;
end;
 
procedure TDIB.FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode);
var
i, j: Integer;
t: TColor;
r1, g1, b1, r2, g2, b2: Integer;
begin
j := ROUND(Sqrt(Sqr(ABS(X2 - X1)) + Sqr(ABS(Y2 - Y1))));
if j < 1 then Exit;
 
r1 := GetRValue(Color);
g1 := GetGValue(Color);
b1 := GetBValue(Color);
 
for i := 0 to j do
begin
t := Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)];
r2 := GetRValue(t);
g2 := GetGValue(t);
b2 := GetBValue(t);
case FilterMode of
fmNormal: t := RGB(r1 + (((256 - r1) * r2) shr 8),
g1 + (((256 - g1) * g2) shr 8),
b1 + (((256 - b1) * b2) shr 8));
fmMix25: t := RGB((r1 + r2 * 3) shr 2, (g1 + g2 * 3) shr 2, (b1 + b2 * 3) shr 2);
fmMix50: t := RGB((r1 + r2) shr 1, (g1 + g2) shr 1, (b1 + b2) shr 1);
fmMix75: t := RGB((r1 * 3 + r2) shr 2, (g1 * 3 + g2) shr 2, (b1 * 3 + b2) shr 2);
end;
Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)] := t;
end;
end;
 
procedure TDIB.FilterRect(X, Y, Width, Height: Integer;
Color: TColor; FilterMode: TFilterMode);
var
i, j, r, g, b, C1: Integer;
p1, p2, p3: pByte;
begin
if Self.BitCount <> 24 then Exit;
 
r := GetRValue(Color);
g := GetGValue(Color);
b := GetBValue(Color);
 
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
Inc(p1, (3 * X));
for j := 0 to Width - 1 do
begin
case FilterMode of
fmNormal:
begin
p2 := p1;
Inc(p2);
p3 := p2;
Inc(p3);
C1 := (p1^ + p2^ + p3^) div 3;
 
p1^ := (C1 * b) shr 8;
Inc(p1);
p1^ := (C1 * g) shr 8;
Inc(p1);
p1^ := (C1 * r) shr 8;
Inc(p1);
end;
fmMix25:
begin
p1^ := (3 * p1^ + b) shr 2;
Inc(p1);
p1^ := (3 * p1^ + g) shr 2;
Inc(p1);
p1^ := (3 * p1^ + r) shr 2;
Inc(p1);
end;
fmMix50:
begin
p1^ := (p1^ + b) shr 1;
Inc(p1);
p1^ := (p1^ + g) shr 1;
Inc(p1);
p1^ := (p1^ + r) shr 1;
Inc(p1);
end;
fmMix75:
begin
p1^ := (p1^ + 3 * b) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * g) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * r) shr 2;
Inc(p1);
end;
end;
end;
end;
end;
 
procedure TDIB.InitLight(Count, Detail: Integer);
var
i, j: Integer;
begin
LG_COUNT := Count;
LG_DETAIL := Detail;
 
for i := 0 to 255 do // Build Lightning LUT
for j := 0 to 255 do
FLUTDist[i, j] := ROUND(Sqrt(Sqr(i * 10) + Sqr(j * 10)));
end;
 
procedure TDIB.DrawLights(FLight: TLightArray;
AmbientLight: TColor);
var
i, j, l, m, n, o, q, D1, D2, R, G, B, AR, AG, AB: Integer;
P: array{$IFNDEF VER4UP} [0..4096]{$ENDIF} of PByteArray;
begin
if Self.BitCount <> 24 then Exit;
 
{$IFDEF VER4UP}
SetLength(P, LG_DETAIL);
{$ENDIF}
AR := GetRValue(AmbientLight);
AG := GetGValue(AmbientLight);
AB := GetBValue(AmbientLight);
 
for i := (Self.Height div (LG_DETAIL + 1)) downto 1 do
begin
for o := 0 to LG_DETAIL do
P[o] := Self.Scanline[(LG_DETAIL + 1) * i - o];
 
for j := (Self.Width div (LG_DETAIL + 1)) downto 1 do
begin
R := AR;
G := AG;
B := AB;
 
for l := LG_COUNT - 1 downto 0 do // Check the lightsources
begin
D1 := ABS(j * (LG_DETAIL + 1) - FLight[l].X) div FLight[l].Size1;
D2 := ABS(i * (LG_DETAIL + 1) - FLight[l].Y) div FLight[l].Size2;
if D1 > 255 then D1 := 255;
if D2 > 255 then D2 := 255;
 
m := 255 - FLUTDist[D1, D2];
if m < 0 then m := 0;
 
Inc(R, (PosValue(GetRValue(FLight[l].Color) - R) * m shr 8));
Inc(G, (PosValue(GetGValue(FLight[l].Color) - G) * m shr 8));
Inc(B, (PosValue(GetBValue(FLight[l].Color) - B) * m shr 8));
end;
 
for q := LG_DETAIL downto 0 do
begin
n := 3 * (j * (LG_DETAIL + 1) - q);
 
for o := LG_DETAIL downto 0 do
begin
P[o][n] := (P[o][n] * B) shr 8;
P[o][n + 1] := (P[o][n + 1] * G) shr 8;
P[o][n + 2] := (P[o][n + 2] * R) shr 8;
end;
end;
end;
end;
{$IFDEF VER4UP}
SetLength(P, 0);
{$ENDIF}
end;
 
procedure TDIB.DrawOn(Dest: TRect; DestCanvas: TCanvas; Xsrc, Ysrc: Integer);
{procedure is supplement of original TDIBUltra function}
begin
//if not AsSigned(SrcCanvas) then Exit;
if (Xsrc < 0) then
begin
Dec(Dest.Left, Xsrc);
Inc(Dest.Right {Width }, Xsrc);
Xsrc := 0
end;
if (Ysrc < 0) then
begin
Dec(Dest.Top, Ysrc);
Inc(Dest.Bottom {Height}, Ysrc);
Ysrc := 0
end;
BitBlt(DestCanvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom, Self.Canvas.Handle, Xsrc, Ysrc, SRCCOPY);
end;
 
{ DXFusion <- }
 
{ added effect for DIB }
 
function IntToByte(i: Integer): Byte;
begin
if i > 255 then Result := 255
else if i < 0 then Result := 0
else Result := i;
end;
 
{standalone routine}
 
procedure TDIB.Darker(Percent: Integer);
{color to dark in percent}
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100);
p0[x * 3 + 1] := Round(G * Percent / 100);
p0[x * 3 + 2] := Round(B * Percent / 100);
end;
end;
end;
 
procedure TDIB.Lighter(Percent: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 1] := Round(G * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 2] := Round(B * Percent / 100) + Round(255 - Percent / 100 * 255);
end;
end;
end;
 
procedure TDIB.Darkness(Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r - ((r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g - ((g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b - ((b) * Amount) div 255);
end;
end;
end;
 
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i > Max then Result := Max
else if i < Min then Result := Min
else Result := i;
end;
 
procedure TDIB.DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
var
Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
cAngle, sAngle: Double;
xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
nw, ne, sw, se: TBGR;
P1, P2, P3: Pbytearray;
begin
Angle := angle;
Angle := -Angle * Pi / 180;
sAngle := Sin(Angle);
cAngle := Cos(Angle);
xDiff := (Self.Width - Src.Width) div 2;
yDiff := (Self.Height - Src.Height) div 2;
for y := 0 to Self.Height - 1 do
begin
P3 := Self.scanline[y];
py := 2 * (y - cy) + 1;
for x := 0 to Self.Width - 1 do
begin
px := 2 * (x - cx) + 1;
fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
ifx := Round(fx);
ify := Round(fy);
 
if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then
begin
eww := fx - ifx;
nsw := fy - ify;
iy := TrimInt(ify + 1, 0, Src.Height - 1);
ix := TrimInt(ifx + 1, 0, Src.Width - 1);
P1 := Src.scanline[ify];
P2 := Src.scanline[iy];
nw.r := P1[ifx * 3];
nw.g := P1[ifx * 3 + 1];
nw.b := P1[ifx * 3 + 2];
ne.r := P1[ix * 3];
ne.g := P1[ix * 3 + 1];
ne.b := P1[ix * 3 + 2];
sw.r := P2[ifx * 3];
sw.g := P2[ifx * 3 + 1];
sw.b := P2[ifx * 3 + 2];
se.r := P2[ix * 3];
se.g := P2[ix * 3 + 1];
se.b := P2[ix * 3 + 2];
 
Top := nw.b + eww * (ne.b - nw.b);
Bottom := sw.b + eww * (se.b - sw.b);
P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.g + eww * (ne.g - nw.g);
Bottom := sw.g + eww * (se.g - sw.g);
P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.r + eww * (ne.r - nw.r);
Bottom := sw.r + eww * (se.r - sw.r);
P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
end;
end;
end;
end;
 
//----------------------
//--- 24 bit count routines ----------------------
//----------------------
 
procedure TDIB.DoInvert;
procedure PicInvert(src: TDIB);
var w, h, x, y: Integer;
p: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
for y := 0 to h - 1 do
begin
p := src.scanline[y];
for x := 0 to w - 1 do
begin
p[x * 3] := not p[x * 3];
p[x * 3 + 1] := not p[x * 3 + 1];
p[x * 3 + 2] := not p[x * 3 + 2];
end;
end;
end;
begin
PicInvert(Self);
end;
 
procedure TDIB.DoAddColorNoise(Amount: Integer);
procedure AddColorNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.ScanLine[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3] + (Random(Amount) - (Amount shr 1));
g := p0[x * 3 + 1] + (Random(Amount) - (Amount shr 1));
b := p0[x * 3 + 2] + (Random(Amount) - (Amount shr 1));
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
AddColorNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAddMonoNoise(Amount: Integer);
procedure _AddMonoNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, a, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
a := Random(Amount) - (Amount shr 1);
r := p0[x * 3] + a;
g := p0[x * 3 + 1] + a;
b := p0[x * 3 + 2] + a;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_AddMonoNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAntiAlias;
procedure AntiAlias(clip: TDIB);
procedure AntiAliasRect(clip: TDIB; XOrigin, YOrigin, XFinal, YFinal: Integer);
var Memo, x, y: Integer; (* Composantes primaires des points environnants *)
p0, p1, p2: pbytearray;
begin
if XFinal < XOrigin then begin Memo := XOrigin; XOrigin := XFinal; XFinal := Memo; end; (* Inversion des valeurs *)
if YFinal < YOrigin then begin Memo := YOrigin; YOrigin := YFinal; YFinal := Memo; end; (* si diff‚rence n‚gative*)
XOrigin := max(1, XOrigin);
YOrigin := max(1, YOrigin);
XFinal := min(clip.width - 2, XFinal);
YFinal := min(clip.height - 2, YFinal);
clip.BitCount := 24;
for y := YOrigin to YFinal do
begin
p0 := clip.ScanLine[y - 1];
p1 := clip.scanline[y];
p2 := clip.ScanLine[y + 1];
for x := XOrigin to XFinal do
begin
p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) div 4;
p1[x * 3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) div 4;
p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) div 4;
end;
end;
end;
begin
AntiAliasRect(clip, 0, 0, clip.width, clip.height);
end;
begin
AntiAlias(Self);
end;
 
procedure TDIB.DoContrast(Amount: Integer);
procedure _Contrast(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
rg, gg, bg, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rg := (Abs(127 - r) * Amount) div 255;
gg := (Abs(127 - g) * Amount) div 255;
bg := (Abs(127 - b) * Amount) div 255;
if r > 127 then r := r + rg else r := r - rg;
if g > 127 then g := g + gg else g := g - gg;
if b > 127 then b := b + bg else b := b - bg;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Contrast(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoFishEye(Amount: Integer);
procedure _FishEye(var Bmp, Dst: TDIB; Amount: Extended);
var
xmid, ymid: Single;
fx, fy: Single;
r1, r2: Single;
ifx, ify: Integer;
dx, dy: Single;
rmax: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PByteArray;
begin
xmid := Bmp.Width / 2;
ymid := Bmp.Height / 2;
rmax := Dst.Width * Amount;
 
for ty := 0 to Dst.Height - 1 do
begin
for tx := 0 to Dst.Width - 1 do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(dx * dx + dy * dy);
if r1 = 0 then
begin
fx := xmid;
fy := ymid;
end
else
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
 
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_FishEye(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoGrayScale;
procedure GrayScale(var clip: TDIB);
var
p0: pbytearray;
Gray, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
Gray := Round(p0[x * 3] * 0.3 + p0[x * 3 + 1] * 0.59 + p0[x * 3 + 2] * 0.11);
p0[x * 3] := Gray;
p0[x * 3 + 1] := Gray;
p0[x * 3 + 2] := Gray;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
GrayScale(BB);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoLightness(Amount: Integer);
procedure _Lightness(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r + ((255 - r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g + ((255 - g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b + ((255 - b) * Amount) div 255);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Lightness(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoDarkness(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
BB.Darkness(Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSaturation(Amount: Integer);
procedure _Saturation(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
Gray, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
Gray := (r + g + b) div 3;
p0[x * 3] := IntToByte(Gray + (((r - Gray) * Amount) div 255));
p0[x * 3 + 1] := IntToByte(Gray + (((g - Gray) * Amount) div 255));
p0[x * 3 + 2] := IntToByte(Gray + (((b - Gray) * Amount) div 255));
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Saturation(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSplitBlur(Amount: Integer);
{NOTE: For a gaussian blur is amount 3}
procedure _SplitBlur(var clip: TDIB; Amount: Integer);
var
p0, p1, p2: pbytearray;
cx, x, y: Integer;
Buf: array[0..3, 0..2] of byte;
begin
if Amount = 0 then Exit;
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
if y - Amount < 0 then p1 := clip.scanline[y]
else {y-Amount>0} p1 := clip.ScanLine[y - Amount];
if y + Amount < clip.Height then p2 := clip.ScanLine[y + Amount]
else {y+Amount>=Height} p2 := clip.ScanLine[clip.Height - y];
 
for x := 0 to clip.Width - 1 do
begin
if x - Amount < 0 then cx := x
else {x-Amount>0} cx := x - Amount;
Buf[0, 0] := p1[cx * 3];
Buf[0, 1] := p1[cx * 3 + 1];
Buf[0, 2] := p1[cx * 3 + 2];
Buf[1, 0] := p2[cx * 3];
Buf[1, 1] := p2[cx * 3 + 1];
Buf[1, 2] := p2[cx * 3 + 2];
if x + Amount < clip.Width then cx := x + Amount
else {x+Amount>=Width} cx := clip.Width - x;
Buf[2, 0] := p1[cx * 3];
Buf[2, 1] := p1[cx * 3 + 1];
Buf[2, 2] := p1[cx * 3 + 2];
Buf[3, 0] := p2[cx * 3];
Buf[3, 1] := p2[cx * 3 + 1];
Buf[3, 2] := p2[cx * 3 + 2];
p0[x * 3] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) shr 2;
p0[x * 3 + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) shr 2;
p0[x * 3 + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) shr 2;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_SplitBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoGaussianBlur(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.BitCount := 24;
BB.Assign(Self);
GaussianBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoMosaic(Size: Integer);
procedure Mosaic(var Bm: TDIB; size: Integer);
var
x, y, i, j: Integer;
p1, p2: pbytearray;
r, g, b: byte;
begin
y := 0;
repeat
p1 := bm.scanline[y];
repeat
j := 1;
repeat
p2 := bm.scanline[y];
x := 0;
repeat
r := p1[x * 3];
g := p1[x * 3 + 1];
b := p1[x * 3 + 2];
i := 1;
repeat
p2[x * 3] := r;
p2[x * 3 + 1] := g;
p2[x * 3 + 2] := b;
inc(x);
inc(i);
until (x >= bm.width) or (i > size);
until x >= bm.width;
inc(j);
inc(y);
until (y >= bm.height) or (j > size);
until (y >= bm.height) or (x >= bm.width);
until y >= bm.height;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
Mosaic(BB, Size);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoTwist(Amount: Integer);
procedure _Twist(var Bmp, Dst: TDIB; Amount: Integer);
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PBytearray;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
OFFSET := -(Pi / 2);
dx := Bmp.Width - 1;
dy := Bmp.Height - 1;
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Bmp.Width - 1) / 2; //Adjust these to move center of rotation
tymid := (Bmp.Height - 1) / 2; //Adjust these to move ......
fxmid := (Bmp.Width - 1) / 2;
fymid := (Bmp.Height - 1) / 2;
if tx2 >= Bmp.Width then tx2 := Bmp.Width - 1;
if ty2 >= Bmp.Height then ty2 := Bmp.Height - 1;
 
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
 
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_Twist(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoTrace(Amount: Integer);
procedure Trace(src: TDIB; intensity: Integer);
var
x, y, i: Integer;
P1, P2, P3, P4: PByteArray;
tb, TraceB: byte;
hasb: Boolean;
bitmap: TDIB;
begin
bitmap := TDIB.create;
bitmap.width := src.width;
bitmap.height := src.height;
bitmap.canvas.draw(0, 0, src);
bitmap.BitCount := 8;
src.BitCount := 24;
hasb := false;
TraceB := $00; tb := 0;
for i := 1 to Intensity do
begin
for y := 0 to BitMap.height - 2 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 1];
P3 := src.scanline[y];
P4 := src.scanline[y + 1];
x := 0;
repeat
if p1[x] <> p1[x + 1] then
begin
if not hasb then
begin
tb := p1[x + 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x + 1) * 3] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
inc(x);
until x >= (BitMap.width - 2);
end;
if i > 1 then
for y := BitMap.height - 1 downto 1 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 1];
P3 := src.scanline[y];
P4 := src.scanline[y - 1];
x := Bitmap.width - 1;
repeat
if p1[x] <> p1[x - 1] then
begin
if not hasb then
begin
tb := p1[x - 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x - 1) * 3] := TraceB;
p3[(x - 1) * 3 + 1] := TraceB;
p3[(x - 1) * 3 + 2] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
dec(x);
until x <= 1;
end;
end;
bitmap.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Trace(BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSplitlight(Amount: Integer);
procedure Splitlight(var clip: TDIB; amount: Integer);
var
x, y, i: Integer;
p1: pbytearray;
 
function sinpixs(a: Integer): Integer;
begin
result := variant(sin(a / 255 * pi / 2) * 255);
end;
begin
for i := 1 to amount do
for y := 0 to clip.height - 1 do
begin
p1 := clip.scanline[y];
for x := 0 to clip.width - 1 do
begin
p1[x * 3] := sinpixs(p1[x * 3]);
p1[x * 3 + 1] := sinpixs(p1[x * 3 + 1]);
p1[x * 3 + 2] := sinpixs(p1[x * 3 + 2]);
end;
end;
end;
var BB1 {,BB2}: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
// BB2 := TDIB.Create;
// BB2.BitCount := 24;
// BB2.Assign (BB1);
Splitlight(BB1, Amount);
Self.Assign(BB1);
BB1.Free;
// BB2.Free;
end;
 
procedure TDIB.DoTile(Amount: Integer);
procedure SmoothResize(var Src, Dst: TDIB);
var
x, y, xP, yP,
yP2, xP2: Integer;
Read, Read2: PByteArray;
t, z, z2, iz2: Integer;
pc: PBytearray;
w1, w2, w3, w4: Integer;
Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
begin
xP2 := ((src.Width - 1) shl 15) div Dst.Width;
yP2 := ((src.Height - 1) shl 15) div Dst.Height;
yP := 0;
for y := 0 to Dst.Height - 1 do
begin
xP := 0;
Read := src.ScanLine[yP shr 15];
if yP shr 16 < src.Height - 1 then
Read2 := src.ScanLine[yP shr 15 + 1]
else
Read2 := src.ScanLine[yP shr 15];
pc := Dst.scanline[y];
z2 := yP and $7FFF;
iz2 := $8000 - z2;
for x := 0 to Dst.Width - 1 do
begin
t := xP shr 15;
Col1r := Read[t * 3];
Col1g := Read[t * 3 + 1];
Col1b := Read[t * 3 + 2];
Col2r := Read2[t * 3];
Col2g := Read2[t * 3 + 1];
Col2b := Read2[t * 3 + 2];
z := xP and $7FFF;
w2 := (z * iz2) shr 15;
w1 := iz2 - w2;
w4 := (z * z2) shr 15;
w3 := z2 - w4;
pc[x * 3 + 2] :=
(Col1b * w1 + Read[(t + 1) * 3 + 2] * w2 +
Col2b * w3 + Read2[(t + 1) * 3 + 2] * w4) shr 15;
pc[x * 3 + 1] :=
(Col1g * w1 + Read[(t + 1) * 3 + 1] * w2 +
Col2g * w3 + Read2[(t + 1) * 3 + 1] * w4) shr 15;
pc[x * 3] :=
(Col1r * w1 + Read2[(t + 1) * 3] * w2 +
Col2r * w3 + Read2[(t + 1) * 3] * w4) shr 15;
Inc(xP, xP2);
end;
Inc(yP, yP2);
end;
end;
procedure Tile(src, dst: TDIB; amount: Integer);
var
w, h, w2, h2, i, j: Integer;
bm: TDIB;
begin
w := src.width;
h := src.height;
dst.width := w;
dst.height := h;
dst.Canvas.draw(0, 0, src);
if (amount <= 0) or ((w div amount) < 5) or ((h div amount) < 5) then exit;
h2 := h div amount;
w2 := w div amount;
bm := TDIB.create;
bm.width := w2;
bm.height := h2;
bm.BitCount := 24;
smoothresize(src, bm);
for j := 0 to amount - 1 do
for i := 0 to amount - 1 do
dst.canvas.Draw(i * w2, j * h2, bm);
bm.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Tile(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSpotLight(Amount: Integer; Spot: TRect);
procedure SpotLight(var src: TDIB; Amount: Integer; Spot: TRect);
var
bm, z: TDIB;
w, h: Integer;
begin
z := TDIB.Create;
try
z.SetSize(src.Width, src.Height, 24);
z.DrawTo(src, 0, 0, src.Width, src.Height, 0, 0);
w := z.Width;
h := z.Height;
bm := TDIB.create;
try
bm.Width := w;
bm.Height := h;
bm.Canvas.Brush.color := clblack;
bm.Canvas.FillRect(rect(0, 0, w, h));
bm.Canvas.Brush.Color := clwhite;
bm.Canvas.Ellipse(Spot.left, spot.top, spot.right, spot.bottom);
bm.Transparent := true;
z.Canvas.CopyMode := cmSrcAnd; {as transparentcolor for white}
z.Canvas.Draw(0, 0, src);
z.Canvas.Draw(0, 0, bm);
src.Darkness(Amount);
src.Canvas.CopyMode := cmSrcPaint;
src.DrawTransparent(z, 0, 0, z.Width, z.Height, 0, 0, clBlack);
finally
bm.Free;
end;
finally
z.Free
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
SpotLight(BB2, Amount, Spot);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoEmboss;
procedure Emboss(var Bmp: TDIB);
var
x, y: Integer;
p1, p2: Pbytearray;
begin
for y := 0 to Bmp.Height - 2 do
begin
p1 := bmp.scanline[y];
p2 := bmp.scanline[y + 1];
for x := 0 to Bmp.Width - 4 do
begin
p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] xor $FF)) shr 1;
p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
p1[x * 3 + 2] := (p1[x * 3 + 2] + (p2[(x + 3) * 3 + 2] xor $FF)) shr 1;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Emboss(BB2);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSolorize(Amount: Integer);
procedure Solorize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
c: Integer;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
c := (ps[x * 3] + ps[x * 3 + 1] + ps[x * 3 + 2]) div 3;
if c > amount then
begin
pd[x * 3] := 255 - ps[x * 3];
pd[x * 3 + 1] := 255 - ps[x * 3 + 1];
pd[x * 3 + 2] := 255 - ps[x * 3 + 2];
end
else
begin
pd[x * 3] := ps[x * 3];
pd[x * 3 + 1] := ps[x * 3 + 1];
pd[x * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Solorize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoPosterize(Amount: Integer);
procedure Posterize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
pd[x * 3] := round(ps[x * 3] / amount) * amount;
pd[x * 3 + 1] := round(ps[x * 3 + 1] / amount) * amount;
pd[x * 3 + 2] := round(ps[x * 3 + 2] / amount) * amount;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Posterize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoBrightness(Amount: Integer);
procedure Brightness(src, dst: TDIB; level: Integer);
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
var
i, j, value: Integer;
OrigRow, DestRow: pRGBArray;
begin
// get brightness increment value
value := level;
src.BitCount := 24;
dst.BitCount := 24;
// for each row of pixels
for i := 0 to src.Height - 1 do
begin
OrigRow := src.ScanLine[i];
DestRow := dst.ScanLine[i];
// for each pixel in row
for j := 0 to src.Width - 1 do
begin
// add brightness value to pixel's RGB values
if value > 0 then
begin
// RGB values must be less than 256
DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
end
else
begin
// RGB values must be greater or equal than 0
DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Brightness(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
procedure Resample(Src, Dst: TDIB; filtertype: TFilterTypeResample; fwidth: single);
// -----------------------------------------------------------------------------
//
// Filter functions
//
// -----------------------------------------------------------------------------
 
// Hermite filter
function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;
 
// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;
 
// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := 1.0 - Value
else
Result := 0.0;
end;
 
// Bell filter
function BellFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 0.5) then
Result := 0.75 - Sqr(Value)
else
if (Value < 1.5) then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end
else
Result := 0.0;
end;
 
// B-spline filter
function SplineFilter(Value: Single): Single;
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
begin
tt := Sqr(Value);
Result := 0.5 * tt * Value - tt + 2.0 / 3.0;
end
else
if (Value < 2.0) then
begin
Value := 2.0 - Value;
Result := 1.0 / 6.0 * Sqr(Value) * Value;
end
else
Result := 0.0;
end;
 
// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if (Value <> 0.0) then
begin
Value := Value * Pi;
Result := sin(Value) / Value
end
else
Result := 1.0;
end;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 3.0) then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;
 
function MitchellFilter(Value: Single): Single;
const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
tt := Sqr(Value);
if (Value < 1.0) then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
+ (6.0 - 2 * B));
Result := Value / 6.0;
end
else
if (Value < 2.0) then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
+ ((6.0 * B + 30.0 * C) * tt)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24 * C));
Result := Value / 6.0;
end
else
Result := 0.0;
end;
 
// -----------------------------------------------------------------------------
//
// Interpolator
//
// -----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
pixel: Integer; // Source pixel
weight: single; // Pixel weight
end;
 
TContributorList = array[0..0] of TContributor;
PContributorList = ^TContributorList;
 
// List of source pixels contributing to a destination pixel
TCList = record
n: Integer;
p: PContributorList;
end;
 
TCListList = array[0..0] of TCList;
PCListList = ^TCListList;
 
TRGB = packed record
r, g, b: single;
end;
 
// Physical bitmap pixel
TColorRGB = packed record
r, g, b: BYTE;
end;
PColorRGB = ^TColorRGB;
 
// Physical bitmap scanline (row)
TRGBList = packed array[0..0] of TColorRGB;
PRGBList = ^TRGBList;
 
var
xscale, yscale: single; // Zoom scale factors
i, j, k: Integer; // Loop variables
center: single; // Filter calculation variables
width, fscale, weight: single; // Filter calculation variables
left, right: Integer; // Filter calculation variables
n: Integer; // Pixel number
Work: TDIB;
contrib: PCListList;
rgb: TRGB;
color: TColorRGB;
{$IFDEF USE_SCANLINE}
SourceLine,
DestLine: PRGBList;
SourcePixel,
DestPixel: PColorRGB;
Delta,
DestDelta: Integer;
{$ENDIF}
SrcWidth,
SrcHeight,
DstWidth,
DstHeight: Integer;
 
function Color2RGB(Color: TColor): TColorRGB;
begin
Result.r := Color and $000000FF;
Result.g := (Color and $0000FF00) shr 8;
Result.b := (Color and $00FF0000) shr 16;
end;
 
function RGB2Color(Color: TColorRGB): TColor;
begin
Result := Color.r or (Color.g shl 8) or (Color.b shl 16);
end;
 
begin
DstWidth := Dst.Width;
DstHeight := Dst.Height;
SrcWidth := Src.Width;
SrcHeight := Src.Height;
if (SrcWidth < 1) or (SrcHeight < 1) then
raise Exception.Create('Source bitmap too small');
 
// Create intermediate image to hold horizontal zoom
Work := TDIB.Create;
try
Work.Height := SrcHeight;
Work.Width := DstWidth;
// xscale := DstWidth / SrcWidth;
// yscale := DstHeight / SrcHeight;
// Improvement suggested by David Ullrich:
if (SrcWidth = 1) then
xscale := DstWidth / SrcWidth
else
xscale := (DstWidth - 1) / (SrcWidth - 1);
if (SrcHeight = 1) then
yscale := DstHeight / SrcHeight
else
yscale := (DstHeight - 1) / (SrcHeight - 1);
// This implementation only works on 24-bit images because it uses
// TDIB.Scanline
{$IFDEF USE_SCANLINE}
//Src.PixelFormat := pf24bit;
Src.BitCount := 24;
//Dst.PixelFormat := Src.PixelFormat;
dst.BitCount := 24;
//Work.PixelFormat := Src.PixelFormat;
work.BitCount := 24;
{$ENDIF}
 
// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(contrib, DstWidth * sizeof(TCList));
// Horizontal sub-sampling
// Scales from bigger to smaller width
if (xscale < 1.0) then
begin
width := fwidth / xscale;
fscale := 1.0 / xscale;
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end
else
// Horizontal super-sampling
// Scales from smaller to bigger width
begin
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
for k := 0 to SrcHeight - 1 do
begin
{$IFDEF USE_SCANLINE}
SourceLine := Src.ScanLine[k];
DestPixel := Work.ScanLine[k];
{$ENDIF}
for i := 0 to DstWidth - 1 do
begin
rgb.r := 0.0;
rgb.g := 0.0;
rgb.b := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := SourceLine^[contrib^[i].p^[j].pixel];
{$ELSE}
color := Color2RGB(Src.Canvas.Pixels[contrib^[i].p^[j].pixel, k]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
// Set new pixel value
DestPixel^ := color;
// Move on to next column
inc(DestPixel);
{$ELSE}
Work.Canvas.Pixels[i, k] := RGB2Color(color);
{$ENDIF}
end;
end;
 
// Free the memory allocated for horizontal filter weights
for i := 0 to DstWidth - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(contrib, DstHeight * sizeof(TCList));
// Vertical sub-sampling
// Scales from bigger to smaller height
if (yscale < 1.0) then
begin
width := fwidth / yscale;
fscale := 1.0 / yscale;
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end
end
else
// Vertical super-sampling
// Scales from smaller to bigger height
begin
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
{$IFDEF USE_SCANLINE}
SourceLine := Work.ScanLine[0];
Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
DestLine := Dst.ScanLine[0];
DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
{$ENDIF}
for k := 0 to DstWidth - 1 do
begin
{$IFDEF USE_SCANLINE}
DestPixel := pointer(DestLine);
{$ENDIF}
for i := 0 to DstHeight - 1 do
begin
rgb.r := 0;
rgb.g := 0;
rgb.b := 0;
// weight := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := PColorRGB(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
{$ELSE}
color := Color2RGB(Work.Canvas.Pixels[k, contrib^[i].p^[j].pixel]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
DestPixel^ := color;
inc(Integer(DestPixel), DestDelta);
{$ELSE}
Dst.Canvas.Pixels[k, i] := RGB2Color(color);
{$ENDIF}
end;
{$IFDEF USE_SCANLINE}
Inc(SourceLine, 1);
Inc(DestLine, 1);
{$ENDIF}
end;
 
// Free the memory allocated for vertical filter weights
for i := 0 to DstHeight - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
finally
Work.Free;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.SetSize(AmountX, AmountY, 24);
Resample(BB1, BB2, TypeResample, DefaultFilterRadius[TypeResample]);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoColorize(ForeColor, BackColor: TColor);
procedure Colorize(src, dst: TDIB; iForeColor, iBackColor: TColor; iDither: Boolean{$IFDEF VER4UP} = False{$ENDIF});
{for monochromatic picture change colors}
procedure InvertBitmap(Bmp: TDIB);
begin
Bmp.Canvas.CopyMode := cmDstInvert;
Bmp.Canvas.CopyRect(rect(0, 0, Bmp.Width, Bmp.Height),
Bmp.Canvas, rect(0, 0, Bmp.Width, Bmp.Height));
end;
var
fForeColor: TColor;
fForeDither: Boolean;
lTempBitmap: TDIB;
lTempBitmap2: TDIB;
lDitherBitmap: TDIB;
lCRect: TRect;
x, y, w, h: Integer;
begin
{--}
//fColor := iBackColor; ;
fForeColor := iForeColor;
fForeDither := iDither;
w := src.Width;
h := src.Height;
lDitherBitmap := nil;
lTempBitmap := TDIB.Create;
lTempBitmap.SetSize(w, h, 24);
lTempBitmap2 := TDIB.Create;
lTempBitmap2.SetSize(w, h, 24);
lCRect := rect(0, 0, w, h);
with lTempBitmap.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := iBackColor;
FillRect(lCRect);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
CopyMode := cmSrcPaint;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(lTempBitmap);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
end;
with lTempBitmap2.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clBlack;
FillRect(lCRect);
if fForeDither then
begin
InvertBitmap(src);
lDitherBitmap := TDIB.Create;
lDitherBitmap.SetSize(8, 8, 24);
with lDitherBitmap.Canvas do
begin
for x := 0 to 7 do
for y := 0 to 7 do
if ((x mod 2 = 0) and (y mod 2 > 0)) or ((x mod 2 > 0) and (y mod 2 = 0)) then
pixels[x, y] := fForeColor
else
pixels[x, y] := iBackColor;
end;
Brush.Bitmap.Assign(lDitherBitmap);
end
else
begin
Brush.Style := bsSolid;
Brush.Color := fForeColor;
end;
if not fForeDither then
InvertBitmap(src);
CopyMode := cmPatPaint;
CopyRect(lCRect, src.Canvas, lCRect);
if fForeDither then
if Assigned(lDitherBitmap) then
lDitherBitmap.Free;
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
end;
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcErase;
lTempBitmap.Canvas.Copyrect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(lTempBitmap);
InvertBitmap(src);
dst.Assign(lTempBitmap);
lTempBitmap.Free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
Colorize(BB1, BB2, ForeColor, BackColor{$IFNDEF VER4UP}, False{$ENDIF});
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
{ procedure for special purpose }
 
procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JA @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.DoZoom(DIB2: TDIB; ZoomRatio: Real);
var
P1, P2: PByteArray;
W, H: Integer;
x, y: Integer;
xr, yr, xstep, ystep: real;
xstart: real;
begin
W := WidthBytes;
H := Height;
xstart := (W - (W * ZoomRatio)) / 2;
 
xr := xstart;
yr := (H - (H * ZoomRatio)) / 2;
xstep := ZoomRatio;
ystep := ZoomRatio;
 
for y := 1 to Height - 1 do
begin
P2 := DIB2.ScanLine[y];
if (yr >= 0) and (yr <= H) then
begin
P1 := ScanLine[Trunc(yr)];
for x := 1 to Width - 1 do
begin
if (xr >= 0) and (xr <= W) then
begin
P2[x] := P1[Trunc(xr)];
end
else
begin
P2[x] := 0;
end;
xr := xr + xstep;
end;
end
else
begin
for x := 1 to Width - 1 do
begin
P2[x] := 0;
end;
end;
xr := xstart;
yr := yr + ystep;
end;
end;
 
procedure TDIB.DoBlur(DIB2: TDIB);
var
P1, P2: PByteArray;
W: Integer;
x, y: Integer;
begin
W := WidthBytes;
for y := 1 to Height - 1 do
begin
P1 := ScanLine[y];
P2 := DIB2.ScanLine[y];
for x := 1 to Width - 1 do
begin
P2[x] := (P1[x] + P1[x - 1] + P1[x + 1] + P1[x + W] + P1[x - W]) div 5;
end;
end;
end;
 
procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JB @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.FillDIB8(Color: Byte);
var
P: PByteArray;
W, H: Integer;
begin
P := ScanLine[Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
MOV ESI, P
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
MOV AL, Color
@@1:
MOV [ESI], AL
INC ESI
DEC ECX
JNZ @@1
POP ESI
end;
end;
 
procedure TDIB.DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled: Integer;
cosy, siny: real;
begin
angled := 384 + Angle;
for y := 0 to Height - 1 do
begin
p := DIB1.ScanLine[y];
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
for x := 0 to Width - 1 do
begin
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 4 then
p[x] := p[x] - 4
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
PWordArray(p2) := ScanLine[y2];
PWordArray(p)[x] := PWordArray(p2)[Width - x2];
end
else
begin
if PWordArray(p)[x] > 4 then
PWordArray(p)[x] := PWordArray(p)[x] - 4
else
PWordArray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 4 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 4
else if P3ByteArray(p)[x][1] > 4 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 4
else if P3ByteArray(p)[x][2] > 4 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 4
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32: begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if plongarray(p)[x] > 4 then
plongarray(p)[x] := plongarray(p)[x] - 4
else
plongarray(p)[x] := 0;
end;
end;
end
end;
end;
end;
 
function TDIB.Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
function ColorToRGBTriple(const Color: TColor): TRGBTriple;
begin
with RESULT do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function TestQuad(T: T3Byte; Color: Integer): Boolean;
begin
Result := (T[0] > GetRValue(Color)) and
(T[1] > GetGValue(Color)) and
(T[2] > GetBValue(Color))
end;
var
p0, p, p2: PByteArray;
x, y, c: Integer;
z: Integer;
begin
if SprayInit then
begin
DIB.Assign(Self);
{ Spray seeds }
for c := 0 to AmountSpray do
begin
DIB.Pixels[Random(Width - 1), Random(Height - 1)] := 0;
end;
end;
Result := True; {all is black}
for y := 0 to DIB.Height - 1 do
begin
p := DIB.ScanLine[y];
for x := 0 to DIB.Width - 1 do
begin
case bitcount of
8:
begin
if p[x] < 16 then
begin
if p[x] > 0 then Result := False;
if y > 0 then
begin
p0 := DIB.ScanLine[y - 1];
if p0[x] > 4 then
p0[x] := p0[x] - 4
else
p0[x] := 0;
if x > 0 then
if p0[x - 1] > 2 then
p0[x - 1] := p0[x - 1] - 2
else
p0[x - 1] := 0;
if x < (DIB.Width - 1) then
if p0[x + 1] > 2 then
p0[x + 1] := p0[x + 1] - 2
else
p0[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
p2 := DIB.ScanLine[y + 1];
if p2[x] > 4 then
p2[x] := p2[x] - 4
else
p2[x] := 0;
if x > 0 then
if p2[x - 1] > 2 then
p2[x - 1] := p2[x - 1] - 2
else
p2[x - 1] := 0;
if x < (DIB.Width - 1) then
if p2[x + 1] > 2 then
p2[x + 1] := p2[x + 1] - 2
else
p2[x + 1] := 0;
end;
if p[x] > 8 then
p[x] := p[x] - 8
else
p[x] := 0;
if x > 0 then
if p[x - 1] > 4 then
p[x - 1] := p[x - 1] - 4
else
p[x - 1] := 0;
if x < (DIB.Width - 1) then
if p[x + 1] > 4 then
p[x + 1] := p[x + 1] - 4
else
p[x + 1] := 0;
end;
end;
16:
begin
if pwordarray(p)[x] < 16 then
begin
if pwordarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
pwordarray(p0) := DIB.ScanLine[y - 1];
if pwordarray(p0)[x] > 4 then
pwordarray(p0)[x] := pwordarray(p0)[x] - 4
else
pwordarray(p0)[x] := 0;
if x > 0 then
if pwordarray(p0)[x - 1] > 2 then
pwordarray(p0)[x - 1] := pwordarray(p0)[x - 1] - 2
else
pwordarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p0)[x + 1] > 2 then
pwordarray(p0)[x + 1] := pwordarray(p0)[x + 1] - 2
else
pwordarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
pwordarray(p2) := DIB.ScanLine[y + 1];
if pwordarray(p2)[x] > 4 then
pwordarray(p2)[x] := pwordarray(p2)[x] - 4
else
pwordarray(p2)[x] := 0;
if x > 0 then
if pwordarray(p2)[x - 1] > 2 then
pwordarray(p2)[x - 1] := pwordarray(p2)[x - 1] - 2
else
pwordarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p2)[x + 1] > 2 then
pwordarray(p2)[x + 1] := pwordarray(p2)[x + 1] - 2
else
pwordarray(p2)[x + 1] := 0;
end;
if pwordarray(p)[x] > 8 then
pwordarray(p)[x] := pwordarray(p)[x] - 8
else
pwordarray(p)[x] := 0;
if x > 0 then
if pwordarray(p)[x - 1] > 4 then
pwordarray(p)[x - 1] := pwordarray(p)[x - 1] - 4
else
pwordarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p)[x + 1] > 4 then
pwordarray(p)[x + 1] := pwordarray(p)[x + 1] - 4
else
pwordarray(p)[x + 1] := 0;
end;
end;
24:
begin
if not TestQuad(P3ByteArray(p)[x], 16) then
begin
if TestQuad(P3ByteArray(p)[x], 0) then Result := False;
if y > 0 then
begin
P3ByteArray(p0) := DIB.ScanLine[y - 1];
if TestQuad(P3ByteArray(p0)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x][z] > 4 then
P3ByteArray(p0)[x][z] := P3ByteArray(p0)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p0)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x - 1][z] > 2 then
P3ByteArray(p0)[x - 1][z] := P3ByteArray(p0)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p0)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x + 1][z] > 2 then
P3ByteArray(p0)[x + 1][z] := P3ByteArray(p0)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x + 1][z] := 0;
end;
if y < (DIB.Height - 1) then
begin
P3ByteArray(p2) := DIB.ScanLine[y + 1];
if TestQuad(P3ByteArray(p2)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x][z] > 4 then
P3ByteArray(p2)[x][z] := P3ByteArray(p2)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p2)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x - 1][z] > 2 then
P3ByteArray(p2)[x - 1][z] := P3ByteArray(p2)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p2)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x + 1][z] > 2 then
P3ByteArray(p2)[x + 1][z] := P3ByteArray(p2)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x + 1][z] := 0;
end;
if TestQuad(P3ByteArray(p)[x], 8) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x][z] > 8 then
P3ByteArray(p)[x][z] := P3ByteArray(p)[x][z] - 8
end
else
for z := 0 to 2 do
P3ByteArray(p)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p)[x - 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x - 1][z] > 4 then
P3ByteArray(p)[x - 1][z] := P3ByteArray(p)[x - 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p)[x + 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x + 1][z] > 4 then
P3ByteArray(p)[x + 1][z] := P3ByteArray(p)[x + 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x + 1][z] := 0;
end;
end;
32:
begin
if plongarray(p)[x] < 16 then
begin
if plongarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
plongarray(p0) := DIB.ScanLine[y - 1];
if plongarray(p0)[x] > 4 then
plongarray(p0)[x] := plongarray(p0)[x] - 4
else
plongarray(p0)[x] := 0;
if x > 0 then
if plongarray(p0)[x - 1] > 2 then
plongarray(p0)[x - 1] := plongarray(p0)[x - 1] - 2
else
plongarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p0)[x + 1] > 2 then
plongarray(p0)[x + 1] := plongarray(p0)[x + 1] - 2
else
plongarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
plongarray(p2) := DIB.ScanLine[y + 1];
if plongarray(p2)[x] > 4 then
plongarray(p2)[x] := plongarray(p2)[x] - 4
else
plongarray(p2)[x] := 0;
if x > 0 then
if plongarray(p2)[x - 1] > 2 then
plongarray(p2)[x - 1] := plongarray(p2)[x - 1] - 2
else
plongarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p2)[x + 1] > 2 then
plongarray(p2)[x + 1] := plongarray(p2)[x + 1] - 2
else
plongarray(p2)[x + 1] := 0;
end;
if plongarray(p)[x] > 8 then
plongarray(p)[x] := plongarray(p)[x] - 8
else
plongarray(p)[x] := 0;
if x > 0 then
if plongarray(p)[x - 1] > 4 then
plongarray(p)[x - 1] := plongarray(p)[x - 1] - 4
else
plongarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p)[x + 1] > 4 then
plongarray(p)[x + 1] := plongarray(p)[x + 1] - 4
else
plongarray(p)[x + 1] := 0;
end;
end;
end {case};
end;
end;
end;
 
procedure TDIB.Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled, ysqr: Integer;
actdist, dist, cosy, siny: real;
begin
dist := Factor * sqrt(sqr(cX) + sqr(cY));
for y := 0 to DIB1.Height - 1 do
begin
p := DIB1.ScanLine[y];
ysqr := sqr(y - cY);
for x := 0 to (DIB1.Width) - 1 do
begin
actdist := (sqrt((sqr(x - cX) + ysqr)) / dist);
if dt = dtSlow then
actdist := dsin((Trunc(actdist * 1024)) and $1FF);
angled := 384 + Trunc((actdist) * Angle);
 
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
 
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 2 then
p[x] := p[x] - 2
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
pwordarray(p2) := ScanLine[y2];
pwordarray(p)[x] := pwordarray(p2)[Width - x2];
end
else
begin
if pwordarray(p)[x] > 2 then
pwordarray(p)[x] := pwordarray(p)[x] - 2
else
pwordarray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 2 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 2
else if P3ByteArray(p)[x][1] > 2 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 2
else if P3ByteArray(p)[x][2] > 2 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 2
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if p[x] > 2 then
plongarray(p)[x] := plongarray(p)[x] - 2
else
plongarray(p)[x] := 0;
end;
end;
end {case}
end;
end;
end;
 
procedure TDIB.AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor);
//anti-aliased line using the Wu algorithm by Peter Bone
var
dX, dY, X, Y, start, finish: Integer;
LM, LR: Integer;
dxi, dyi, dydxi: Integer;
P: PLines;
R, G, B: byte;
begin
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
dX := abs(x2 - x1); // Calculate deltax and deltay for initialisation
dY := abs(y2 - y1);
if (dX = 0) or (dY = 0) then
begin
Canvas.Pen.Color := (B shl 16) + (G shl 8) + R;
Canvas.MoveTo(x1, y1);
Canvas.LineTo(x2, y2);
exit;
end;
if dX > dY then
begin // horizontal or vertical
if y2 > y1 then // determine rise and run
dydxi := -dY shl 16 div dX
else
dydxi := dY shl 16 div dX;
if x2 < x1 then
begin
start := x2; // right to left
finish := x1;
dyi := y2 shl 16;
end
else
begin
start := x1; // left to right
finish := x2;
dyi := y1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Width then finish := Width - 1;
for X := start to finish do
begin
Y := dyi shr 16;
if (X < 0) or (Y < 0) or (Y > Height - 2) then
begin
Inc(dyi, dydxi);
Continue;
end;
LM := dyi - Y shl 16; // fractional part of dyi - in fixed-point
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
//Inc(Y);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dyi, dydxi); // next point
end;
end
else
begin
if x2 > x1 then // determine rise and run
dydxi := -dX shl 16 div dY
else
dydxi := dX shl 16 div dY;
if y2 < y1 then
begin
start := y2; // right to left
finish := y1;
dxi := x2 shl 16;
end
else
begin
start := y1; // left to right
finish := y2;
dxi := x1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Height then finish := Height - 1;
for Y := start to finish do
begin
X := dxi shr 16;
if (Y < 0) or (X < 0) or (X > Width - 2) then
begin
Inc(dxi, dydxi);
Continue;
end;
LM := dxi - X shl 16;
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
Inc(X);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dxi, dydxi); // next point
end;
end;
end;
 
function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
function CalcColorBytes(fb1, fb2: Byte): Byte;
begin
result := fb1;
if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1));
if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2));
end;
begin
if Pointvalue <= FromPoint then
begin
result := StartColor;
exit;
end;
if Pointvalue >= ToPoint then
begin
result := EndColor;
exit;
end;
F := (Pointvalue - FromPoint) / (ToPoint - FromPoint);
asm
mov EAX, Startcolor
cmp EAX, EndColor
je @@exit //when equal then exit
mov r1, AL
shr EAX,8
mov g1, AL
shr EAX,8
mov b1, AL
mov EAX, Endcolor
mov r2, AL
shr EAX,8
mov g2, AL
shr EAX,8
mov b2, AL
push ebp
mov AL, r1
mov DL, r2
call CalcColorBytes
pop ECX
push EBP
Mov r3, AL
mov DL, g2
mov AL, g1
call CalcColorBytes
pop ECX
push EBP
mov g3, Al
mov DL, B2
mov Al, B1
call CalcColorBytes
pop ECX
mov b3, AL
XOR EAX,EAX
mov AL, B3
shl EAX,8
mov AL, G3
shl EAX,8
mov AL, R3
@@Exit:
mov @result, EAX
end;
end;
 
procedure TDIB.ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry; iRadius: Word);
var
tempColor: TColor;
const
WavelengthMinimum = 380;
WavelengthMaximum = 780;
 
procedure SetColor(Color: TColor);
begin
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
tempColor := Color
end {SetColor};
 
function WL2RGB(const Wavelength: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
const
Gamma = 0.80;
IntensityMax = 255;
var
Red, Blue, Green, Factor: Double;
 
function Adjust(const Color, Factor: Double): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if Color = 0.0 then Result := 0
else Result := Round(IntensityMax * Power(Color * Factor, Gamma))
end {Adjust};
begin
case Trunc(Wavelength) of
380..439:
begin
Red := -(Wavelength - 440) / (440 - 380);
Green := 0.0;
Blue := 1.0
end;
440..489:
begin
Red := 0.0;
Green := (Wavelength - 440) / (490 - 440);
Blue := 1.0
end;
490..509:
begin
Red := 0.0;
Green := 1.0;
Blue := -(Wavelength - 510) / (510 - 490)
end;
510..579:
begin
Red := (Wavelength - 510) / (580 - 510);
Green := 1.0;
Blue := 0.0
end;
580..644:
begin
Red := 1.0;
Green := -(Wavelength - 645) / (645 - 580);
Blue := 0.0
end;
645..780:
begin
Red := 1.0;
Green := 0.0;
Blue := 0.0
end;
else
Red := 0.0;
Green := 0.0;
Blue := 0.0
end;
case Trunc(Wavelength) of
380..419: factor := 0.3 + 0.7 * (Wavelength - 380) / (420 - 380);
420..700: factor := 1.0;
701..780: factor := 0.3 + 0.7 * (780 - Wavelength) / (780 - 700)
else
factor := 0.0
end;
Result := RGB(Adjust(Red, Factor), Adjust(Green, Factor), Adjust(Blue, Factor));
end;
 
function Rainbow(const fraction: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (fraction < 0.0) or (fraction > 1.0) then Result := clBlack
else
Result := WL2RGB(WavelengthMinimum + Fraction * (WavelengthMaximum - WavelengthMinimum))
end {Raindbow};
 
function ColorInterpolate(const fraction: Double; const Color1, Color2: TColor): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
var
complement: Double;
R1, R2, G1, G2, B1, B2: BYTE;
begin
if fraction <= 0 then Result := Color1
else
if fraction >= 1.0 then Result := Color2
else
begin
R1 := GetRValue(Color1);
G1 := GetGValue(Color1);
B1 := GetBValue(Color1);
R2 := GetRValue(Color2);
G2 := GetGValue(Color2);
B2 := GetBValue(Color2);
complement := 1.0 - fraction;
Result := RGB(Round(complement * R1 + fraction * R2),
Round(complement * G1 + fraction * G2),
Round(complement * B1 + fraction * B2))
end
end {ColorInterpolate};
 
// Conversion utility routines
function ColorToRGBTriple(const Color: TColor): TRGBTriple; {$IFDEF VER9UP}inline;{$ENDIF}
begin
with Result do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function RGBTripleToColor(const Triple: TRGBTriple): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)
end {RGBTripleToColor};
// Bresenham's Line Algorithm. Byte, March 1988, pp. 249-253.
var
a, b, d, diag_inc, dXdg, dXndg, dYdg, dYndg, i, nDginc, nDswap, x, y: Integer;
begin {DrawLine}
x := iStart.X;
y := iStart.Y;
a := iEnd.X - iStart.X;
b := iEnd.Y - iStart.Y;
if a < 0 then
begin
a := -a;
dXdg := -1
end
else dXdg := 1;
if b < 0 then
begin
b := -b;
dYdg := -1
end
else dYdg := 1;
if a < b then
begin
nDswap := a;
a := b;
b := nDswap;
dXndg := 0;
dYndg := dYdg
end
else
begin
dXndg := dXdg;
dYndg := 0
end;
d := b + b - a;
nDginc := b + b;
diag_inc := b + b - a - a;
for i := 0 to a do
begin
case iPixelGeometry of
pgPoint:
case iColorStyle of
csSolid:
Canvas.Pixels[x, y] := tempColor;
csGradient:
Canvas.Pixels[x, y] := ColorInterpolate(i / a, iGradientFrom, iGradientTo);
csRainbow:
Canvas.Pixels[x, y] := Rainbow(i / a)
end;
pgCircular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Ellipse(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end;
pgRectangular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Rectangle(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end
end;
if d < 0 then
begin
Inc(x, dXndg);
Inc(y, dYndg);
Inc(d, nDginc);
end
else
begin
Inc(x, dXdg);
Inc(y, dYdg);
Inc(d, diag_inc);
end
end
end {Line};
 
procedure TDIB.DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
// Copyright (c) 2000 by Keith Murray (kmurray@hotfreeware.com)
// All rights reserved.
// Adapted for DIB by JB.
type
PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
PDoubleArray = ^TDoubleArray;
TDoubleArray = array[0..32767] of Double;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array[0..32767] of Integer;
type
TProgressEvent = procedure(progress: Integer; message: string;
var cancel: Boolean) of object;
const
M_PI = 3.14159265358979323846;
RAND_MAX = 2147483647;
 
function Gauss: double;
const magnitude = 6;
var
sum: double;
i: Integer;
begin
sum := 0;
for i := 1 to magnitude do
sum := sum + (randgauss / 2147483647);
result := sum / magnitude;
end;
 
function Clamp(i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else
if i > h then
result := h
else
result := i;
end;
 
function IClamp(i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else if i > h then
result := h
else result := i;
end;
 
procedure rgb_to_hsl(r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
{$IFNDEF VER4UP}
function Max(a, b: Double): Double;
begin
Result := a; if b > a then Result := b;
end;
function Min(a, b: Double): Double;
begin
Result := a; if b < a then Result := b;
end;
{$ENDIF}
var
v, m, vm: Double;
r2, g2, b2: Double;
begin
h := 0;
s := 0;
l := 0;
v := Max(r, g);
v := Max(v, b);
m := Min(r, g);
m := Min(m, b);
l := (m + v) / 2.0;
if l <= 0.0 then
exit;
vm := v - m;
s := vm;
if s > 0.0 then
begin
if l <= 0.5 then
s := s / (v + m)
else s := s / (2.0 - v - m);
end
else exit;
r2 := (v - 4) / vm;
g2 := (v - g) / vm;
b2 := (v - b) / vm;
if r = v then
begin
if g = m then
h := b2 + 5.0
else h := 1.0 - g2;
end
else if g = v then
begin
if b = m then
h := 1.0 + r2
else h := 3.0 - b2;
end
else
begin
if r = m then
h := 3.0 + g2
else h := 5.0 - r2;
end;
h := h / 6;
end;
 
procedure hsl_to_rgb(h, sl, l: Double; var r, g, b: Double); {$IFDEF VER9UP}inline;{$ENDIF}
var
v: Double;
m, sv: Double;
sextant: Integer;
fract, vsf, mid1, mid2: Double;
begin
if l <= 0.5 then
v := l * (1.0 + sl)
else v := l + sl - l * sl;
if v <= 0 then
begin
r := 0.0;
g := 0.0;
b := 0.0;
end
else
begin
m := l + l - v;
sv := (v - m) / v;
h := h * 6.0;
sextant := Trunc(h);
fract := h - sextant;
vsf := v * sv * fract;
mid1 := m + vsf;
mid2 := v - vsf;
case sextant of
0:
begin
r := v; g := mid1; b := m;
end;
1:
begin
r := mid2; g := v; b := m;
end;
2:
begin
r := m; g := v; b := mid1;
end;
3:
begin
r := m; g := mid2; b := v;
end;
4:
begin
r := mid1; g := m; b := v;
end;
5:
begin
r := v; g := m; b := mid2;
end;
end;
end;
end;
 
var
src_row, dest_row: PByte;
src, dest: PByteArray;
color, colors: array[0..3] of Integer;
SpokeColor: PIntegerArray;
spoke: PDoubleArray;
x1, y1, x2, y2, row, col, x, y, alpha, has_alpha, bpp, progress, max_progress, xc, yc, i, j: Integer;
u, v, l, l0, w, w1, c, nova_alpha, src_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
dstDIB: TDIB;
begin
colors[0] := sr;
colors[1] := sg;
colors[2] := sb;
new_alpha := 0;
 
GetMem(spoke, NSpokes * sizeof(Double));
GetMem(spokecolor, NSpokes * sizeof(Integer) * 3);
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
dstDIB.Canvas.Brush.Color := clBlack;
dstDIB.Canvas.FillRect(dstDIB.Canvas.ClipRect);
try
rgb_to_hsl(colors[0] / 255.0, colors[1] / 255.0, colors[2] / 255.0, h, s, lu);
 
for i := 0 to NSpokes - 1 do
begin
spoke[i] := gauss;
h := h + randomhue / 360.0 * ({Random(RAND_MAX)}RandomSpok / RAND_MAX - 0.5);
if h < 0 then
h := h + 1.0
else if h > 1.0 then
h := h - 1.0;
hsl_to_rgb(h, s, lu, r, g, b);
spokecolor[3 * i + 0] := Trunc(255 * r);
spokecolor[3 * i + 1] := Trunc(255 * g);
spokecolor[3 * i + 2] := Trunc(255 * b);
end;
 
xc := cx;
yc := cy;
l0 := (x2 - xc) / 4 + 1;
bpp := Self.BitCount div 8;
has_alpha := 0;
alpha := bpp;
y := 0;
for row := 0 to Self.Height - 1 do begin
src_row := Self.ScanLine[row];
dest_row := dstDIB.ScanLine[row];
src := Pointer(src_row);
dest := Pointer(dest_row);
x := 0;
for col := 0 to Self.Width - 1 do begin
u := (x - xc) / radius;
v := (y - yc) / radius;
l := sqrt((u * u) + (v * v));
c := (arctan2(u, v) / (2 * M_PI) + 0.51) * NSpokes;
i := floor(c);
c := c - i;
i := i mod NSpokes;
w1 := spoke[i] * (1 - c) + spoke[(i + 1) mod NSpokes] * c;
w1 := w1 * w1;
w := 1 / (l + 0.001) * 0.9;
nova_alpha := Clamp(w, 0.0, 1.0);
ratio := nova_alpha;
compl_ratio := 1.0 - ratio;
for j := 0 to alpha - 1 do
begin
spokecol := spokecolor[3 * i + j] * (1.0 - c) + spokecolor[3 * ((i + 1) mod nspokes) + j] * c;
if w > 1.0 then
color[j] := IClamp(Trunc(spokecol * w), 0, 255)
else
color[j] := Trunc(src[j] * compl_ratio + spokecol * ratio);
color[j] := Trunc(color[j] + 255 * Clamp(w1 * w, 0.0, 1.0));
dest[j] := IClamp(color[j], 0, 255);
end;
inc(Integer(src), bpp);
inc(Integer(dest), bpp);
inc(x);
end;
inc(y);
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
FreeMem(Spoke);
FreeMem(SpokeColor);
end;
end;
 
procedure TDIB.DrawMandelbrot(ao, au: Integer; bo, bu: Double);
var
c1, c2, z1, z2, tmp: Double;
i, j, Count: Integer;
dstDIB: TDIB;
X, Y: Double;
X2, Y2: Integer;
begin
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
X2 := dstDIB.FWidth;
Y2 := dstDIB.FHeight;
{as Example
ao := 1;
au := -2;
bo := 1.5;
bu := -1.5;
}
X := (ao - au) / dstDIB.FWidth;
Y := (bo - bu) / dstDIB.FHeight;
try
c2 := bu;
for i := 10 to X2 do
begin
c1 := au;
for j := 0 to Y2 do
begin
z1 := 0;
z2 := 0;
Count := 0;
{count is deep of iteration of the mandelbrot set
if |z| >=2 then z is not a member of a mandelset}
while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
begin
tmp := z1;
z1 := z1 * z1 - z2 * z2 + c1;
z2 := 2 * tmp * z2 + c2;
Inc(Count);
end;
//the color-palette depends on TColor(n*count mod t)
dstDIB.Canvas.Pixels[j, i] := (16 * Count mod 255);
c1 := c1 + X;
end;
c2 := c2 + Y;
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
end;
end;
 
procedure TDIB.SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
{Note: when depth parameter set to 0 will produce black and white picture only}
var
color, color2: longint;
r, g, b, rr, gg: byte;
h, w: Integer;
p0: pbytearray;
x, y: Integer;
begin
if Self.BitCount = 24 then
begin
Self.DoGrayScale;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
p0[x * 3] := rr;
p0[x * 3 + 1] := gg;
p0[x * 3 + 2] := b;
end;
end;
Exit
end;
{this alogorithm is slower because does not use scanline property}
for h := 0 to Self.Height-1 do
begin
for w := 0 to Self.Width-1 do
begin
//first convert the bitmap to greyscale
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
color2 := (r + g + b) div 3;
Self.Canvas.Pixels[w, h] := RGB(color2, color2, color2);
//then convert it to sepia
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
Self.Canvas.Pixels[w, h] := RGB(rr, gg, b);
end;
end;
 
end;
 
procedure TDIB.EncryptDecrypt(const Key: Integer);
{for decript call it again}
var
BytesPorScan: Integer;
w, h: Integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(Self.ScanLine[1]) -
Integer(Self.ScanLine[0]));
except
raise Exception.Create('Error ');
end;
RandSeed := Key;
for h := 0 to Self.Height - 1 do
begin
P := Self.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;
 
procedure TDIB.LinePolar(x, y: Integer; AngleInDegree, Length: extended; Color: cardinal);
var
xp, yp: Integer;
begin
xp := Round(Sin(AngleInDegree * Pi / 180) * Length) + x;
yp := Round(Cos(AngleInDegree * Pi / 180) * Length) + y;
AntialiasedLine(x, y, xp, yp, Color);
end;
 
//y = 0.299*g + 0.587*b + 0.114*r;
 
procedure TDIB.BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: byte);
var
cR, cG, cB: byte;
aR, aG, aB: byte;
dColor: Cardinal;
begin
aR := GetRValue(aColor);
aG := GetGValue(aColor);
aB := GetBValue(aColor);
dColor := Self.Canvas.Pixels[x, y];
cR := GetRValue(dColor);
cG := GetGValue(dColor);
cB := GetBValue(dColor);
Canvas.Pixels[x, y] := RGB((Alpha * (aR - cR) shr 8) + cR, // R alpha
(Alpha * (aG - cG) shr 8) + cG, // G alpha
(Alpha * (aB - cB) shr 8) + cB); // B alpha
end;
 
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
DIB.SetSize(iWidth, iHeight, iBitCount);
DIB.Fill(iFillColor);
end;
 
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDib2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
if Assigned(iBitmap) then
DIB.CreateDIBFromBitmap(iBitmap)
else
DIB.Fill(clBlack);
end;
 
initialization
TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);