Subversion Repositories spacemission

Compare Revisions

Ignore 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,8 → 75,10
RBitCount2, GBitCount2, BBitCount2: DWORD;
end;
 
{ TDIBSharedImage }
 
TDIBSharedImage = class(TSharedImage)
private
private
FBitCount: Integer;
FBitmapInfo: PBitmapInfo;
FBitmapInfoSize: 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,10 → 115,37
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;
FImage: TDIBSharedImage;
FImage: TDIBSharedImage;
 
FProgressName: string;
FProgressOldY: DWORD;
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,67 → 508,137
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;
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);
Result.GBitMask := ((1 shl GBitCount)-1) shl (BBitCount);
Result.BBitMask := (1 shl BBitCount)-1;
Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
Result.BBitMask := (1 shl BBitCount) - 1;
Result.RBitCount := RBitCount;
Result.GBitCount := GBitCount;
Result.BBitCount := BBitCount;
Result.RBitCount2 := 8-RBitCount;
Result.GBitCount2 := 8-GBitCount;
Result.BBitCount2 := 8-BBitCount;
Result.RShift := (GBitCount+BBitCount)-(8-RBitCount);
Result.GShift := BBitCount-(8-GBitCount);
Result.BShift := 8-BBitCount;
Result.RBitCount2 := 8 - RBitCount;
Result.GBitCount2 := 8 - GBitCount;
Result.BBitCount2 := 8 - BBitCount;
Result.RShift := (GBitCount + BBitCount) - (8 - RBitCount);
Result.GShift := BBitCount - (8 - GBitCount);
Result.BShift := 8 - BBitCount;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
var
i: Integer;
begin
i := 0;
while (i < 31) and (((1 shl i) and b) = 0) do Inc(i);
 
function GetBitCount(b: Integer): Integer;
var
i: Integer;
Result := 0;
while ((1 shl i) and b) <> 0 do
begin
i := 0;
while (i<31) and (((1 shl i) and b)=0) do Inc(i);
 
Result := 0;
while ((1 shl i) and b)<>0 do
begin
Inc(i);
Inc(Result);
end;
Inc(i);
Inc(Result);
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;
 
378,7 → 695,7
var
i: Integer;
begin
for i:=0 to 255 do
for i := 0 to 255 do
with Result[i] do
begin
rgbRed := i;
415,7 → 732,7
var
i: Integer;
begin
for i:=0 to 255 do
for i := 0 to 255 do
Result[i] := PaletteEntryToRGBQuad(Entries[i]);
end;
 
435,7 → 752,7
var
i: Integer;
begin
for i:=0 to 255 do
for i := 0 to 255 do
Result[i] := RGBQuadToPaletteEntry(RGBQuads[i]);
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);
482,9 → 805,11
procedure TPaletteItem.Release;
begin
Dec(RefCount);
if RefCount<=0 then Free;
if RefCount <= 0 then Free;
end;
 
{ TPaletteManager }
 
constructor TPaletteManager.Create;
begin
inherited Create;
511,7 → 836,7
begin
{ Hash key making }
ID := ColorTableCount;
for i:=0 to ColorTableCount-1 do
for i := 0 to ColorTableCount - 1 do
with ColorTable[i] do
begin
Inc(ID, rgbRed);
520,11 → 845,11
end;
 
{ Does the same palette already exist? }
for i:=0 to FList.Count-1 do
for i := 0 to FList.Count - 1 do
begin
Item := TPaletteItem(FList.Items[i]);
if (Item.ID=ID) and (Item.ColorTableCount=ColorTableCount) and
CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount*SizeOf(TRGBQuad)) then
if (Item.ID = ID) and (Item.ColorTableCount = ColorTableCount) and
CompareMem(@Item.ColorTable, @ColorTable, ColorTableCount * SizeOf(TRGBQuad)) then
begin
Item.AddRef; Result := Item.Palette;
Exit;
534,7 → 859,7
{ New palette making }
Item := TPaletteItem.Create(FList);
Item.ID := ID;
Move(ColorTable, Item.ColorTable, ColorTableCount*SizeOf(TRGBQuad));
Move(ColorTable, Item.ColorTable, ColorTableCount * SizeOf(TRGBQuad));
Item.ColorTableCount := ColorTableCount;
 
with LogPalette do
553,12 → 878,12
i: Integer;
Item: TPaletteItem;
begin
if Palette=0 then Exit;
if Palette = 0 then Exit;
 
for i:=0 to FList.Count-1 do
for i := 0 to FList.Count - 1 do
begin
Item := TPaletteItem(FList.Items[i]);
if (Item.Palette=Palette) then
if (Item.Palette = Palette) then
begin
Palette := 0;
Item.Release;
572,11 → 897,13
 
function PaletteManager: TPaletteManager;
begin
if FPaletteManager=nil then
if FPaletteManager = nil then
FPaletteManager := TPaletteManager.Create;
Result := FPaletteManager;
end;
 
{ TDIBSharedImage }
 
constructor TDIBSharedImage.Create;
begin
inherited Create;
592,29 → 919,34
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
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
4 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
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
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
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
32: begin
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
1: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
4: if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
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
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
if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
32:
begin
if not ((PixelFormat.RBitMask = $FF0000) and (PixelFormat.GBitMask = $00FF00) and (PixelFormat.BBitMask = $0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
else
raise EInvalidGraphicOperation.CreateFmt(SInvalidDIBBitCount, [ABitCount]);
end;
622,21 → 954,21
FBitCount := ABitCount;
FHeight := AHeight;
FWidth := AWidth;
FWidthBytes := (((AWidth*ABitCount)+31) shr 5) * 4;
FWidthBytes := (((AWidth * ABitCount) + 31) shr 5) * 4;
FNextLine := -FWidthBytes;
FSize := FWidthBytes*FHeight;
FSize := FWidthBytes * FHeight;
UsePixelFormat := ABitCount in [16, 32];
 
FPixelFormat := PixelFormat;
 
FPaletteCount := 0;
if FBitCount<=8 then
if FBitCount <= 8 then
FPaletteCount := 1 shl FBitCount;
 
FBitmapInfoSize := SizeOf(TBitmapInfoHeader);
if UsePixelFormat then
Inc(FBitmapInfoSize, SizeOf(TLocalDIBPixelFormat));
Inc(FBitmapInfoSize, SizeOf(TRGBQuad)*FPaletteCount);
Inc(FBitmapInfoSize, SizeOf(TRGBQuad) * FPaletteCount);
 
GetMem(FBitmapInfo, FBitmapInfoSize);
FillChar(FBitmapInfo^, FBitmapInfoSize, 0);
653,9 → 985,9
biCompression := BI_BITFIELDS
else
begin
if (FBitCount=4) and (Compressed) then
if (FBitCount = 4) and (Compressed) then
biCompression := BI_RLE4
else if (FBitCount=8) and (Compressed) then
else if (FBitCount = 8) and (Compressed) then
biCompression := BI_RLE8
else
biCompression := BI_RGB;
670,7 → 1002,7
 
if UsePixelFormat then
begin
with PLocalDIBPixelFormat(Integer(FBitmapInfo)+InfoOfs)^ do
with PLocalDIBPixelFormat(Integer(FBitmapInfo) + InfoOfs)^ do
begin
RBitMask := PixelFormat.RBitMask;
GBitMask := PixelFormat.GBitMask;
683,7 → 1015,7
FColorTablePos := InfoOfs;
 
FColorTable := ColorTable;
Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
 
FCompressed := FBitmapInfo^.bmiHeader.biCompression in [BI_RLE4, BI_RLE8];
FMemoryImage := MemoryImage or FCompressed;
694,14 → 1026,15
if MemoryImage then
begin
FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
if FPBits=nil then
if FPBits = nil then
OutOfMemoryError;
end else
end
else
begin
FDC := CreateCompatibleDC(0);
 
FHandle := CreateDIBSection(FDC, FBitmapInfo^, DIB_RGB_COLORS, FPBits, 0, 0);
if FHandle=0 then
if FHandle = 0 then
raise EOutOfResources.CreateFmt(SCannotMade, ['DIB']);
 
FOldHandle := SelectObject(FDC, FHandle);
708,16 → 1041,22
end;
end;
 
FTopPBits := Pointer(Integer(FPBits)+(FHeight-1)*FWidthBytes);
FTopPBits := Pointer(Integer(FPBits) + (FHeight - 1) * FWidthBytes);
end;
 
procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
if Source.FSize=0 then
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;
741,9 → 1081,9
 
function AllocByte: PByte;
begin
if Size mod 4096=0 then
ReAllocMem(FPBits, Size+4095);
Result := Pointer(Integer(FPBits)+Size);
if Size mod 4096 = 0 then
ReAllocMem(FPBits, Size + 4095);
Result := Pointer(Integer(FPBits) + Size);
Inc(Size);
end;
 
755,7 → 1095,7
 
function GetPixel(x: Integer): Integer;
begin
if X and 1=0 then
if X and 1 = 0 then
Result := PArrayByte(Src)[X shr 1] shr 4
else
Result := PArrayByte(Src)[X shr 1] and $0F;
764,23 → 1104,23
begin
Size := 0;
 
for y:=0 to Source.FHeight-1 do
for y := 0 to Source.FHeight - 1 do
begin
x := 0;
Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
while x<Source.FWidth do
Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
while x < Source.FWidth do
begin
if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) then
if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) then
begin
{ Encoding mode }
B1 := 2;
B2 := (GetPixel(x) shl 4) or GetPixel(x+1);
B2 := (GetPixel(x) shl 4) or GetPixel(x + 1);
 
Inc(x, 2);
 
C := B2;
 
while (x<Source.FWidth) and (C and $F=GetPixel(x)) and (B1<255) do
while (x < Source.FWidth) and (C and $F = GetPixel(x)) and (B1 < 255) do
begin
Inc(B1);
Inc(x);
789,62 → 1129,65
 
AllocByte^ := B1;
AllocByte^ := B2;
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
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
{ Encoding mode }
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
Inc(x, 2);
end else
begin
if (Source.FWidth-x<4) then
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
Inc(x, 2);
end
else
begin
if (Source.FWidth - x < 4) then
begin
{ Encoding mode }
while Source.FWidth-x>=2 do
begin
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
Inc(x, 2);
end;
while Source.FWidth - x >= 2 do
begin
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
Inc(x, 2);
end;
 
if Source.FWidth-x=1 then
if Source.FWidth - x = 1 then
begin
AllocByte^ := 1;
AllocByte^ := GetPixel(x) shl 4;
Inc(x);
end;
end
else
begin
AllocByte^ := 1;
AllocByte^ := GetPixel(x) shl 4;
Inc(x);
end;
end else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
PB2 := Size; AllocByte;
PB1 := Size; AllocByte;
PB2 := Size; AllocByte;
 
B1 := 0;
B2 := 4;
B1 := 0;
B2 := 4;
 
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
AllocByte^ := (GetPixel(x+2) shl 4) or GetPixel(x+3);
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
AllocByte^ := (GetPixel(x + 2) shl 4) or GetPixel(x + 3);
 
Inc(x, 4);
Inc(x, 4);
 
while (x+1<Source.FWidth) and (B2<254) do
begin
if (Source.FWidth-x>3) and (GetPixel(x)=GetPixel(x+2)) and (GetPixel(x+1)=GetPixel(x+3)) then
Break;
while (x + 1 < Source.FWidth) and (B2 < 254) do
begin
if (Source.FWidth - x > 3) and (GetPixel(x) = GetPixel(x + 2)) and (GetPixel(x + 1) = GetPixel(x + 3)) then
Break;
 
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
Inc(B2, 2);
Inc(x, 2);
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x + 1);
Inc(B2, 2);
Inc(x, 2);
end;
 
PByte(Integer(FPBits) + PB1)^ := B1;
PByte(Integer(FPBits) + PB2)^ := B2;
end;
 
PByte(Integer(FPBits)+PB1)^ := B1;
PByte(Integer(FPBits)+PB2)^ := B2;
end;
end;
 
if Size and 1=1 then AllocByte;
if Size and 1 = 1 then AllocByte;
end;
 
{ End of line }
866,9 → 1209,9
 
function AllocByte: PByte;
begin
if Size mod 4096=0 then
ReAllocMem(FPBits, Size+4095);
Result := Pointer(Integer(FPBits)+Size);
if Size mod 4096 = 0 then
ReAllocMem(FPBits, Size + 4095);
Result := Pointer(Integer(FPBits) + Size);
Inc(Size);
end;
 
880,13 → 1223,13
begin
Size := 0;
 
for y:=0 to Source.FHeight-1 do
for y := 0 to Source.FHeight - 1 do
begin
x := 0;
Src := Pointer(Integer(Source.FPBits)+y*FWidthBytes);
while x<Source.FWidth do
Src := Pointer(Integer(Source.FPBits) + y * FWidthBytes);
while x < Source.FWidth do
begin
if (Source.FWidth-x>2) and (Src^=PByte(Integer(Src)+1)^) then
if (Source.FWidth - x > 2) and (Src^ = PByte(Integer(Src) + 1)^) then
begin
{ Encoding mode }
B1 := 2;
895,7 → 1238,7
Inc(x, 2);
Inc(Src, 2);
 
while (x<Source.FWidth) and (Src^=B2) and (B1<255) do
while (x < Source.FWidth) and (Src^ = B2) and (B1 < 255) do
begin
Inc(B1);
Inc(x);
904,63 → 1247,67
 
AllocByte^ := B1;
AllocByte^ := B2;
end else
if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
begin
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 }
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end else
begin
if (Source.FWidth-x<4) then
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end
else
begin
if (Source.FWidth - x < 4) then
begin
{ Encoding mode }
if Source.FWidth-x=2 then
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
if Source.FWidth - x = 2 then
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
 
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x, 2);
end else
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x, 2);
end
else
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end;
end
else
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end;
end else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
PB2 := Size; AllocByte;
PB1 := Size; AllocByte;
PB2 := Size; AllocByte;
 
B1 := 0;
B2 := 3;
B1 := 0;
B2 := 3;
 
Inc(x, 3);
Inc(x, 3);
 
AllocByte^ := Src^; Inc(Src);
AllocByte^ := Src^; Inc(Src);
AllocByte^ := Src^; Inc(Src);
AllocByte^ := Src^; Inc(Src);
AllocByte^ := Src^; Inc(Src);
AllocByte^ := Src^; Inc(Src);
 
while (x<Source.FWidth) and (B2<255) do
begin
if (Source.FWidth-x>3) and (Src^=PByte(Integer(Src)+1)^) and (Src^=PByte(Integer(Src)+2)^) and (Src^=PByte(Integer(Src)+3)^) then
Break;
while (x < Source.FWidth) and (B2 < 255) do
begin
if (Source.FWidth - x > 3) and (Src^ = PByte(Integer(Src) + 1)^) and (Src^ = PByte(Integer(Src) + 2)^) and (Src^ = PByte(Integer(Src) + 3)^) then
Break;
 
AllocByte^ := Src^; Inc(Src);
Inc(B2);
Inc(x);
AllocByte^ := Src^; Inc(Src);
Inc(B2);
Inc(x);
end;
 
PByte(Integer(FPBits) + PB1)^ := B1;
PByte(Integer(FPBits) + PB2)^ := B2;
end;
 
PByte(Integer(FPBits)+PB1)^ := B1;
PByte(Integer(FPBits)+PB2)^ := B2;
end;
end;
 
if Size and 1=1 then AllocByte;
if Size and 1 = 1 then AllocByte;
end;
 
{ End of line }
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
1008,35 → 1356,36
B1 := Src^; Inc(Src);
B2 := Src^; Inc(Src);
 
if B1=0 then
if B1 = 0 then
begin
case B2 of
0: begin { End of line }
X := 0;
Inc(Y);
end;
0: begin { End of line }
X := 0;
Inc(Y);
end;
1: Break; { End of bitmap }
2: begin { Difference of coordinates }
Inc(X, B1);
Inc(Y, B2); Inc(Src, 2);
end;
2: begin { Difference of coordinates }
Inc(X, B1);
Inc(Y, B2); Inc(Src, 2);
end;
else
{ Absolute mode }
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
 
C := 0;
for i:=0 to B2-1 do
for i := 0 to B2 - 1 do
begin
if i and 1=0 then
if i and 1 = 0 then
begin
C := Src^; Inc(Src);
end else
end
else
begin
C := C shl 4;
end;
 
P := Pointer(Integer(Dest)+X shr 1);
if X and 1=0 then
P := Pointer(Integer(Dest) + X shr 1);
if X and 1 = 0 then
P^ := (P^ and $0F) or (C and $F0)
else
P^ := (P^ and $F0) or ((C and $F0) shr 4);
1044,15 → 1393,16
Inc(X);
end;
end;
end else
end
else
begin
{ Encoding mode }
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
Dest := Pointer(Longint(FPBits) + Y * FWidthBytes);
 
for i:=0 to B1-1 do
for i := 0 to B1 - 1 do
begin
P := Pointer(Integer(Dest)+X shr 1);
if X and 1=0 then
P := Pointer(Integer(Dest) + X shr 1);
if X and 1 = 0 then
P^ := (P^ and $0F) or (B2 and $F0)
else
P^ := (P^ and $F0) or ((B2 and $F0) shr 4);
1085,23 → 1435,24
B1 := Src^; Inc(Src);
B2 := Src^; Inc(Src);
 
if B1=0 then
if B1 = 0 then
begin
case B2 of
0: begin { End of line }
X := 0; Inc(Y);
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
end;
0: begin { End of line }
X := 0; Inc(Y);
Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
end;
1: Break; { End of bitmap }
2: begin { Difference of coordinates }
Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes+X);
end;
2: begin { Difference of coordinates }
Inc(X, B1); Inc(Y, B2); Inc(Src, 2);
Dest := Pointer(Longint(FPBits) + Y * FWidthBytes + X);
end;
else
{ 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
1123,7 → 1475,7
BI_RLE8: DecodeRLE8;
else
Duplicate(Source, MemoryImage);
end;
end;
end;
end;
 
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);
1153,11 → 1507,12
var
y: Integer;
begin
if BI.biHeight<0 then
if BI.biHeight < 0 then
begin
for y:=0 to Abs(BI.biHeight)-1 do
Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
end else
for y := 0 to Abs(BI.biHeight) - 1 do
Stream.ReadBuffer(Pointer(Integer(FTopPBits) + y * FNextLine)^, FWidthBytes);
end
else
begin
Stream.ReadBuffer(FPBits^, FSize);
end;
1170,15 → 1525,20
AColorTable: TRGBQuads;
APixelFormat: TDIBPixelFormat;
begin
if not Assigned(Stream) then Exit;
{ Header size reading }
i := Stream.Read(BI.biSize, 4);
 
if i=0 then
if i = 0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
Exit;
end;
if i<>4 then
if i <> 4 then
raise EInvalidGraphic.Create(SInvalidDIB);
 
{ Kind check of DIB }
1188,7 → 1548,7
SizeOf(TBitmapCoreHeader):
begin
{ OS/2 type }
Stream.ReadBuffer(Pointer(Integer(@BC)+4)^, SizeOf(TBitmapCoreHeader)-4);
Stream.ReadBuffer(Pointer(Integer(@BC) + 4)^, SizeOf(TBitmapCoreHeader) - 4);
 
with BI do
begin
1204,7 → 1564,7
SizeOf(TBitmapInfoHeader):
begin
{ Windows type }
Stream.ReadBuffer(Pointer(Integer(@BI)+4)^, SizeOf(TBitmapInfoHeader)-4);
Stream.ReadBuffer(Pointer(Integer(@BI) + 4)^, SizeOf(TBitmapInfoHeader) - 4);
end;
else
raise EInvalidGraphic.Create(SInvalidDIB);
1216,11 → 1576,12
Stream.ReadBuffer(Localpf, SizeOf(Localpf));
with Localpf do
APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
end else
end
else
begin
if BI.biBitCount=16 then
if BI.biBitCount = 16 then
APixelFormat := MakeDIBPixelFormat(5, 5, 5)
else if BI.biBitCount=32 then
else if BI.biBitCount = 32 then
APixelFormat := MakeDIBPixelFormat(8, 8, 8)
else
APixelFormat := MakeDIBPixelFormat(8, 8, 8);
1228,9 → 1589,9
 
{ Palette reading }
PalCount := BI.biClrUsed;
if (PalCount=0) and (BI.biBitCount<=8) then
if (PalCount = 0) and (BI.biBitCount <= 8) then
PalCount := 1 shl BI.biBitCount;
if PalCount>256 then PalCount := 256;
if PalCount > 256 then PalCount := 256;
 
FillChar(AColorTable, SizeOf(AColorTable), 0);
 
1237,27 → 1598,28
if OS2 then
begin
{ OS/2 type }
Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple)*PalCount);
for i:=0 to PalCount-1 do
Stream.ReadBuffer(BCRGB, SizeOf(TRGBTriple) * PalCount);
for i := 0 to PalCount - 1 do
begin
with BCRGB[i] do
AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
end;
end else
end
else
begin
{ Windows type }
Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
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]);
 
{ Pixel data reading }
case BI.biCompression of
BI_RGB : LoadRGB;
BI_RLE4 : LoadRLE4;
BI_RLE8 : LoadRLE8;
BI_RGB: LoadRGB;
BI_RLE4: LoadRLE4;
BI_RLE8: LoadRLE8;
BI_BITFIELDS: LoadRGB;
else
raise EInvalidGraphic.Create(SInvalidDIB);
1266,18 → 1628,20
 
destructor TDIBSharedImage.Destroy;
begin
if FHandle<>0 then
if FHandle <> 0 then
begin
if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
if FOldHandle <> 0 then SelectObject(FDC, FOldHandle);
DeleteObject(FHandle);
end else
end
else
// GlobalFree(THandle(FPBits));
begin
if FPBits<>nil then
if FPBits <> nil then
GlobalFreePtr(FPBits);
end;
 
PaletteManager.DeletePalette(FPalette);
if FDC<>0 then DeleteDC(FDC);
if FDC <> 0 then DeleteDC(FDC);
 
FreeMem(FBitmapInfo);
inherited Destroy;
1289,7 → 1653,7
 
function TDIBSharedImage.GetPalette: THandle;
begin
if FPaletteCount>0 then
if FPaletteCount > 0 then
begin
if FChangePalette then
begin
1307,10 → 1671,10
FColorTable := Value;
FChangePalette := True;
 
if (FSize>0) and (FPaletteCount>0) then
if (FSize > 0) and (FPaletteCount > 0) then
begin
SetDIBColorTable(FDC, 0, 256, FColorTable);
Move(FColorTable, Pointer(Integer(FBitmapInfo)+FColorTablePos)^, SizeOf(TRGBQuad)*FPaletteCount);
Move(FColorTable, Pointer(Integer(FBitmapInfo) + FColorTablePos)^, SizeOf(TRGBQuad) * FPaletteCount);
end;
end;
 
1321,7 → 1685,7
 
function EmptyDIBImage: TDIBSharedImage;
begin
if FEmptyDIBImage=nil then
if FEmptyDIBImage = nil then
begin
FEmptyDIBImage := TDIBSharedImage.Create;
FEmptyDIBImage.Reference;
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;
 
1357,33 → 1735,35
 
case GetObject(Source.Handle, SizeOf(Data), @Data) of
SizeOf(Windows.TBitmap):
begin
BitmapRec := @Data;
case BitmapRec^.bmBitsPixel of
16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
else
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;
SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
begin
BitmapRec := @Data;
case BitmapRec^.bmBitsPixel of
16: PixelFormat := MakeDIBPixelFormat(5, 5, 5);
else
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;
SetSize(BitmapRec^.bmWidth, BitmapRec^.bmHeight, BitmapRec^.bmBitsPixel);
end;
SizeOf(TDIBSection):
begin
DIBSectionRec := @Data;
if DIBSectionRec^.dsBm.bmBitsPixel >= 24 then
begin
DIBSectionRec := @Data;
if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end
else
if DIBSectionRec^.dsBm.bmBitsPixel > 8 then
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
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;
SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
DIBSectionRec^.dsBm.bmBitsPixel);
end;
SetSize(DIBSectionRec^.dsBm.bmWidth, DIBSectionRec^.dsBm.bmHeight,
DIBSectionRec^.dsBm.bmBitsPixel);
end;
else
Exit;
end;
1393,24 → 1773,74
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, 24);
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;
 
begin
if Source=nil then
if Source = nil then
begin
Clear;
end else if Source is TDIB then
begin
if Source<>Self then
if Source <> Self then
SetImage(TDIB(Source).FImage);
end else if Source is TGraphic then
begin
1417,26 → 1847,27
AssignGraphic(TGraphic(Source));
end else if Source is TPicture then
begin
if TPicture(Source).Graphic<>nil then
if TPicture(Source).Graphic <> nil then
AssignGraphic(TPicture(Source).Graphic)
else
Clear;
end else
end else
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;
begin
if Size>0 then
if Size > 0 then
begin
if PaletteCount>0 then
if PaletteCount > 0 then
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
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 Rect do
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);
1476,7 → 1911,7
var
TempImage: TDIBSharedImage;
begin
if (FImage.RefCount>1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
if (FImage.RefCount > 1) or (FImage.FCompressed) or ((not MemoryImage) and (FImage.FMemoryImage)) then
begin
TempImage := TDIBSharedImage.Create;
try
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;
1569,7 → 2159,7
 
function TDIB.GetCanvas: TCanvas;
begin
if (FCanvas=nil) or (FCanvas.Handle=0) then
if (FCanvas = nil) or (FCanvas.Handle = 0) then
begin
AllocHandle;
 
1582,7 → 2172,7
 
function TDIB.GetEmpty: Boolean;
begin
Result := Size=0;
Result := Size = 0;
end;
 
function TDIB.GetHandle: THandle;
1625,22 → 2215,22
function TDIB.GetScanLine(Y: Integer): Pointer;
begin
Changing(True);
if (Y<0) or (Y>=FHeight) then
if (Y < 0) or (Y >= FHeight) then
raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
 
if not FImage.FMemoryImage then
GDIFlush;
Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
end;
 
function TDIB.GetScanLineReadOnly(Y: Integer): Pointer;
begin
if (Y<0) or (Y>=FHeight) then
if (Y < 0) or (Y >= FHeight) then
raise EInvalidGraphicOperation.CreateFmt(SScanline, [Y]);
 
if not FImage.FMemoryImage then
GDIFlush;
Result := Pointer(Integer(FTopPBits)+Y*FNextLine);
Result := Pointer(Integer(FTopPBits) + Y * FNextLine);
end;
 
function TDIB.GetTopPBits: Pointer;
1657,7 → 2247,7
if not FImage.FMemoryImage then
GDIFlush;
Result := FTopPBits;
end;
end;
 
function TDIB.GetWidth: Integer;
begin
1679,20 → 2269,31
Decompress;
 
Result := 0;
if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
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];
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
Result := R or (G shl 8) or (B shl 16);
32: Result := PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X];
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]);
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
Result := R or (G shl 8) or (B shl 16);
32: Result := PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X];
end;
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;
1699,30 → 2300,47
begin
Changing(True);
 
if (X>=0) and (X<FWidth) and (Y>=0) and (Y<FHeight) then
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
begin
case FBitCount of
1 : begin
P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
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]);
end;
8 : PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
16: PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
begin
B := Byte(Value shr 16);
G := Byte(Value shr 8);
R := Byte(Value);
end;
32: PArrayDWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
1: begin
P := @PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3];
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]));
end;
8: PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
16: PArrayWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
24: with PArrayBGR(Integer(FTopPBits) + Y * FNextLine)[X] do
begin
B := Byte(Value shr 16);
G := Byte(Value shr 8);
R := Byte(Value);
end;
32: PArrayDWord(Integer(FTopPBits) + Y * FNextLine)[X] := Value;
end;
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;
1767,22 → 2387,47
end;
 
const
BitmapFileType = Ord('B') + Ord('M')*$100;
BitmapFileType = Ord('B') + Ord('M') * $100;
 
procedure TDIB.LoadFromStream(Stream: TStream);
var
BF: TBitmapFileHeader;
i: Integer;
ImageJPEG: TJPEGImage;
begin
{ File header reading }
i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
if i=0 then Exit;
if i<>SizeOf(TBitmapFileHeader) then
if i = 0 then Exit;
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);
if BF.bfType <> BitmapFileType then
raise EInvalidGraphic.Create(SInvalidDIB);
 
ReadData(Stream);
end;
1815,7 → 2460,7
WriteData(Stream);
 
AData := GlobalAlloc(GHND, Stream.Size);
if AData=0 then OutOfMemoryError;
if AData = 0 then OutOfMemoryError;
 
P := GlobalLock(AData);
Move(Stream.Memory^, P^, Stream.Size);
1833,9 → 2478,9
 
with BF do
begin
bfType := BitmapFileType;
bfOffBits := SizeOf(TBitmapFileHeader)+BitmapInfoSize;
bfSize := bfOffBits+FImage.FBitmapInfo^.bmiHeader.biSizeImage;
bfType := BitmapFileType;
bfOffBits := SizeOf(TBitmapFileHeader) + BitmapInfoSize;
bfSize := bfOffBits + FImage.FBitmapInfo^.bmiHeader.biSizeImage;
bfReserved1 := 0;
bfReserved2 := 0;
end;
1857,7 → 2502,7
 
procedure TDIB.SetBitCount(Value: Integer);
begin
if Value<=0 then
if Value <= 0 then
Clear
else
begin
1864,7 → 2509,8
if Empty then
begin
SetSize(Max(Width, 1), Max(Height, 1), Value)
end else
end
else
begin
ConvertBitCount(Value);
end;
1873,7 → 2519,7
 
procedure TDIB.SetHeight(Value: Integer);
begin
if Value<=0 then
if Value <= 0 then
Clear
else
begin
1886,7 → 2532,7
 
procedure TDIB.SetWidth(Value: Integer);
begin
if Value<=0 then
if Value <= 0 then
Clear
else
begin
1899,16 → 2545,16
 
procedure TDIB.SetImage(Value: TDIBSharedImage);
begin
if FImage<>Value then
if FImage <> Value then
begin
if FCanvas<>nil then
if FCanvas <> nil then
FCanvas.Handle := 0;
 
FImage.Release;
FImage := Value;
FImage.Reference;
 
if FCanvas<>nil then
if FCanvas <> nil then
FCanvas.Handle := FImage.FDC;
 
ColorTable := FImage.FColorTable;
1959,12 → 2605,12
var
TempImage: TDIBSharedImage;
begin
if (AWidth=Width) and (AHeight=Height) and (ABitCount=BitCount) and
(NowPixelFormat.RBitMask=PixelFormat.RBitMask) and
(NowPixelFormat.GBitMask=PixelFormat.GBitMask) and
(NowPixelFormat.BBitMask=PixelFormat.BBitMask) then Exit;
if (AWidth = Width) and (AHeight = Height) and (ABitCount = BitCount) and
(NowPixelFormat.RBitMask = PixelFormat.RBitMask) and
(NowPixelFormat.GBitMask = PixelFormat.GBitMask) and
(NowPixelFormat.BBitMask = PixelFormat.BBitMask) then Exit;
 
if (AWidth<=0) or (AHeight<=0) then
if (AWidth <= 0) or (AHeight <= 0) then
begin
Clear;
Exit;
2005,12 → 2651,12
var
i: Integer;
begin
for i:=0 to 255 do
for i := 0 to 255 do
with ColorTable[i] do
begin
rgbRed := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1);
rgbGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1);
rgbBlue := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1);
rgbRed := ((i shr (G + B - 1)) and (1 shl R - 1)) * 255 div (1 shl R - 1);
rgbGreen := ((i shr (B - 1)) and (1 shl G - 1)) * 255 div (1 shl G - 1);
rgbBlue := ((i shr 0) and (1 shl B - 1)) * 255 div (1 shl B - 1);
end;
end;
 
2023,39 → 2669,45
begin
i := 0;
 
for y:=0 to Height-1 do
for y := 0 to Height - 1 do
begin
SrcP := Temp.ScanLine[y];
DestP := ScanLine[y];
 
for x:=0 to Width-1 do
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
1 : begin
i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
end;
4 : begin
i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
end;
8 : begin
i := PByte(SrcP)^;
Inc(PByte(SrcP));
end;
1:
begin
i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
end;
4:
begin
i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
end;
8:
begin
i := PByte(SrcP)^;
Inc(PByte(SrcP));
end;
end;
 
case BitCount of
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
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
end;
8 : begin
PByte(DestP)^ := i;
Inc(PByte(DestP));
end;
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
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
end;
8:
begin
PByte(DestP)^ := i;
Inc(PByte(DestP));
end;
end;
end;
end;
2071,77 → 2723,86
cG := 0;
cB := 0;
 
for y:=0 to Height-1 do
for y := 0 to Height - 1 do
begin
SrcP := Temp.ScanLine[y];
DestP := ScanLine[y];
 
for x:=0 to Width-1 do
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
1 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
1:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
4 : begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
end;
4:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
8 : begin
with Temp.ColorTable[PByte(SrcP)^] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
Inc(PByte(SrcP));
end;
8:
begin
with Temp.ColorTable[PByte(SrcP)^] do
begin
cR := rgbRed;
cG := rgbGreen;
cB := rgbBlue;
end;
16: begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
Inc(PWord(SrcP));
Inc(PByte(SrcP));
end;
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
Inc(PWord(SrcP));
end;
24:
begin
with PBGR(SrcP)^ do
begin
cR := R;
cG := G;
cB := B;
end;
24: begin
with PBGR(SrcP)^ do
begin
cR := R;
cG := G;
cB := B;
end;
 
Inc(PBGR(SrcP));
end;
32: begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
Inc(PDWORD(SrcP));
end;
Inc(PBGR(SrcP));
end;
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
Inc(PDWORD(SrcP));
end;
end;
 
case BitCount of
16: begin
PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PWord(DestP));
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PWord(DestP));
end;
24:
begin
with PBGR(DestP)^ do
begin
R := cR;
G := cG;
B := cB;
end;
24: begin
with PBGR(DestP)^ do
begin
R := cR;
G := cG;
B := cB;
end;
Inc(PBGR(DestP));
end;
32: begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PDWORD(DestP));
end;
Inc(PBGR(DestP));
end;
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PDWORD(DestP));
end;
end;
end;
end;
2148,7 → 2809,7
end;
 
begin
if Size=0 then exit;
if Size = 0 then exit;
 
Temp := TDIB.Create;
try
2155,21 → 2816,22
Temp.Assign(Self);
SetSize(Temp.Width, Temp.Height, ABitCount);
 
if FImage=Temp.FImage then Exit;
if FImage = Temp.FImage then Exit;
 
if (Temp.BitCount<=8) and (BitCount<=8) then
if (Temp.BitCount <= 8) and (BitCount <= 8) then
begin
{ The image is converted from the palette color image into the palette color image. }
if Temp.BitCount<=BitCount then
if Temp.BitCount <= BitCount then
begin
PaletteToPalette_Inc;
end else
end
else
begin
case BitCount of
1: begin
ColorTable[0] := RGBQuad(0, 0, 0);
ColorTable[1] := RGBQuad(255, 255, 255);
end;
ColorTable[0] := RGBQuad(0, 0, 0);
ColorTable[1] := RGBQuad(255, 255, 255);
end;
4: CreateHalftonePalette(1, 2, 1);
8: CreateHalftonePalette(3, 3, 2);
end;
2177,32 → 2839,35
 
Canvas.Draw(0, 0, Temp);
end;
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
if (Temp.BitCount>8) and (BitCount<=8) then
begin
{ The image is converted from the rgb color image into the palette color image. }
case BitCount of
1: begin
ColorTable[0] := RGBQuad(0, 0, 0);
ColorTable[1] := RGBQuad(255, 255, 255);
end;
4: CreateHalftonePalette(1, 2, 1);
8: CreateHalftonePalette(3, 3, 2);
end;
UpdatePalette;
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
if (Temp.BitCount > 8) and (BitCount <= 8) then
begin
{ The image is converted from the rgb color image into the palette color image. }
case BitCount of
1: begin
ColorTable[0] := RGBQuad(0, 0, 0);
ColorTable[1] := RGBQuad(255, 255, 255);
end;
4: CreateHalftonePalette(1, 2, 1);
8: CreateHalftonePalette(3, 3, 2);
end;
UpdatePalette;
 
Canvas.Draw(0, 0, Temp);
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. }
PaletteToRGB_or_RGBToRGB;
end;
Canvas.Draw(0, 0, Temp);
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. }
PaletteToRGB_or_RGBToRGB;
end;
finally
Temp.Free;
end;
2230,12 → 2895,12
Redraw: Boolean;
Percent: DWORD;
begin
Redraw := (GetTickCount-FProgressOldTime>200) and (FProgressY-FProgressOldY>32) and
(((Height div 3>Integer(FProgressY)) and (FProgressOldY=0)) or (FProgressOldY<>0));
Redraw := (GetTickCount - FProgressOldTime > 200) and (FProgressY - FProgressOldY > 32) and
(((Height div 3 > Integer(FProgressY)) and (FProgressOldY = 0)) or (FProgressOldY <> 0));
 
Percent := PercentY*100 div Height;
Percent := PercentY * 100 div Height;
 
if (Percent<>FProgressOld) or (Redraw) then
if (Percent <> FProgressOld) or (Redraw) then
begin
Progress(Self, psRunning, Percent, Redraw,
Rect(0, FProgressOldY, Width, FProgressY), FProgressName);
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,102 → 3140,108
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
begin
with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
begin
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(AveP);
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(AveP);
end;
4 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
begin
with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
begin
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(AveP);
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(AveP);
end;
8 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[PByte(SrcP)^], AveP^ do
begin
with Temp.ColorTable[PByte(SrcP)^], AveP^ do
begin
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(PByte(SrcP));
Inc(AveP);
Inc(cR, rgbRed);
Inc(cG, rgbGreen);
Inc(cB, rgbBlue);
Inc(c);
end;
Inc(PByte(SrcP));
Inc(AveP);
end;
16: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
with AveP^ do
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
with AveP^ do
begin
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PWord(SrcP));
Inc(AveP);
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PWord(SrcP));
Inc(AveP);
end;
24: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with PBGR(SrcP)^, AveP^ do
begin
with PBGR(SrcP)^, AveP^ do
begin
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PBGR(SrcP));
Inc(AveP);
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PBGR(SrcP));
Inc(AveP);
end;
32: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
with AveP^ do
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
with AveP^ do
begin
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PDWORD(SrcP));
Inc(AveP);
Inc(cR, R);
Inc(cG, G);
Inc(cB, B);
Inc(c);
end;
Inc(PDWORD(SrcP));
Inc(AveP);
end;
end;
end;
end;
 
2377,102 → 3253,108
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
begin
with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 3)^ and Mask1[x and 7]) shr Shift1[x and 7]], AveP^ do
begin
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(AveP);
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(AveP);
end;
4 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[(PByte(Integer(SrcP) + X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
begin
with Temp.ColorTable[(PByte(Integer(SrcP)+X shr 1)^ and Mask4[x and 1]) shr Shift4[x and 1]], AveP^ do
begin
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(AveP);
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(AveP);
end;
8 : begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with Temp.ColorTable[PByte(SrcP)^], AveP^ do
begin
with Temp.ColorTable[PByte(SrcP)^], AveP^ do
begin
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(PByte(SrcP));
Inc(AveP);
Dec(cR, rgbRed);
Dec(cG, rgbGreen);
Dec(cB, rgbBlue);
Dec(c);
end;
Inc(PByte(SrcP));
Inc(AveP);
end;
16: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
with AveP^ do
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
with AveP^ do
begin
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PWord(SrcP));
Inc(AveP);
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PWord(SrcP));
Inc(AveP);
end;
24: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
with PBGR(SrcP)^, AveP^ do
begin
with PBGR(SrcP)^, AveP^ do
begin
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PBGR(SrcP));
Inc(AveP);
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PBGR(SrcP));
Inc(AveP);
end;
32: begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
end;
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits) + Y * Temp.NextLine);
AveP := @Ave;
for x := 0 to XCount - 1 do
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
with AveP^ do
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
with AveP^ do
begin
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PDWORD(SrcP));
Inc(AveP);
Dec(cR, R);
Dec(cG, G);
Dec(cB, B);
Dec(c);
end;
Inc(PDWORD(SrcP));
Inc(AveP);
end;
end;
end;
end;
 
2485,9 → 3367,9
DestP: Pointer;
P: PByte;
begin
GetMem(AveX, Width*SizeOf(TAve));
GetMem(AveX, Width * SizeOf(TAve));
try
FillChar(AveX^, Width*SizeOf(TAve), 0);
FillChar(AveX^, Width * SizeOf(TAve), 0);
 
FirstX2 := -1;
LastX2 := -1;
2495,44 → 3377,44
LastY := -1;
 
x := 0;
for x2:=-Radius to Radius do
for x2 := -Radius to Radius do
begin
jx := x+x2;
if (jx>=0) and (jx<Width) then
jx := x + x2;
if (jx >= 0) and (jx < Width) then
begin
if FirstX2=-1 then FirstX2 := jx;
if LastX2<jx then LastX2 := jx;
if FirstX2 = -1 then FirstX2 := jx;
if LastX2 < jx then LastX2 := jx;
end;
end;
 
y := 0;
for y2:=-Radius to Radius do
for y2 := -Radius to Radius do
begin
jy := y+y2;
if (jy>=0) and (jy<Height) then
jy := y + y2;
if (jy >= 0) and (jy < Height) then
begin
if FirstY=-1 then FirstY := jy;
if LastY<jy then LastY := jy;
if FirstY = -1 then FirstY := jy;
if LastY < jy then LastY := jy;
end;
end;
 
for y:=FirstY to LastY do
for y := FirstY to LastY do
AddAverage(y, Temp.Width, AveX^);
 
for y:=0 to Height-1 do
for y := 0 to Height - 1 do
begin
DestP := ScanLine[y];
 
{ The average is updated. }
if y-FirstY=Radius+1 then
if y - FirstY = Radius + 1 then
begin
DeleteAverage(FirstY, Temp.Width, AveX^);
Inc(FirstY);
end;
 
if LastY-y=Radius-1 then
if LastY - y = Radius - 1 then
begin
Inc(LastY); if LastY>=Height then LastY := Height-1;
Inc(LastY); if LastY >= Height then LastY := Height - 1;
AddAverage(LastY, Temp.Width, AveX^);
end;
 
2541,7 → 3423,7
LastX := LastX2;
 
FillChar(Ave, SizeOf(Ave), 0);
for x:=FirstX to LastX do
for x := FirstX to LastX do
with AveX[x] do
begin
Inc(Ave.cR, cR);
2550,10 → 3432,10
Inc(Ave.c, c);
end;
 
for x:=0 to Width-1 do
for x := 0 to Width - 1 do
begin
{ The average is updated. }
if x-FirstX=Radius+1 then
if x - FirstX = Radius + 1 then
begin
with AveX[FirstX] do
begin
2565,9 → 3447,9
Inc(FirstX);
end;
 
if LastX-x=Radius-1 then
if LastX - x = Radius - 1 then
begin
Inc(LastX); if LastX>=Width then LastX := Width-1;
Inc(LastX); if LastX >= Width then LastX := Width - 1;
with AveX[LastX] do
begin
Inc(Ave.cR, cR);
2579,40 → 3461,46
 
{ The average is written. }
case BitCount of
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]);
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
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
with Ave do
PByte(DestP)^ := ((cR + cG + cB) div c) div 3;
Inc(PByte(DestP));
end;
16:
begin
with Ave do
PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PWORD(DestP));
end;
24:
begin
with PBGR(DestP)^, Ave do
begin
R := cR div c;
G := cG div c;
B := cB div c;
end;
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
with Ave do
PByte(DestP)^ := ((cR+cG+cB) div c) div 3;
Inc(PByte(DestP));
end;
16: begin
with Ave do
PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PWORD(DestP));
end;
24: begin
with PBGR(DestP)^, Ave do
begin
R := cR div c;
G := cG div c;
B := cB div c;
end;
Inc(PBGR(DestP));
end;
32: begin
with Ave do
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PDWORD(DestP));
end;
Inc(PBGR(DestP));
end;
32:
begin
with Ave do
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PDWORD(DestP));
end;
end;
end;
 
2626,7 → 3514,7
var
i, j: Integer;
begin
if Empty or (Radius=0) then Exit;
if Empty or (Radius = 0) then Exit;
 
Radius := Abs(Radius);
 
2637,12 → 3525,12
Temp.Assign(Self);
SetSize(Width, Height, ABitCount);
 
if ABitCount<=8 then
if ABitCount <= 8 then
begin
FillChar(ColorTable, SizeOf(ColorTable), 0);
for i:=0 to (1 shl ABitCount)-1 do
for i := 0 to (1 shl ABitCount) - 1 do
begin
j := i * (1 shl (8-ABitCount));
j := i * (1 shl (8 - ABitCount));
j := j or (j shr ABitCount);
ColorTable[i] := RGBQuad(j, j, j);
end;
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
2675,12 → 3621,12
Temp.Assign(Self);
SetSize(Width, Height, ABitCount);
 
if ABitCount<=8 then
if ABitCount <= 8 then
begin
FillChar(ColorTable, SizeOf(ColorTable), 0);
for i:=0 to (1 shl ABitCount)-1 do
for i := 0 to (1 shl ABitCount) - 1 do
begin
j := i * (1 shl (8-ABitCount));
j := i * (1 shl (8 - ABitCount));
j := j or (j shr ABitCount);
ColorTable[i] := RGBQuad(j, j, j);
end;
2687,11 → 3633,11
UpdatePalette;
end;
 
for i:=0 to 255 do
for i := 0 to 255 do
begin
YTblR[i] := Trunc(0.3588*i);
YTblG[i] := Trunc(0.4020*i);
YTblB[i] := Trunc(0.2392*i);
YTblR[i] := Trunc(0.3588 * i);
YTblG[i] := Trunc(0.4020 * i);
YTblB[i] := Trunc(0.2392 * i);
end;
 
c := 0;
2698,74 → 3644,86
 
StartProgress('Greyscale');
try
for y:=0 to Height-1 do
for y := 0 to Height - 1 do
begin
DestP := ScanLine[y];
SrcP := Temp.ScanLine[y];
 
for x:=0 to Width-1 do
for x := 0 to Width - 1 do
begin
case Temp.BitCount of
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
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
with Temp.ColorTable[PByte(SrcP)^] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
Inc(PByte(SrcP));
end;
16: begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PWord(SrcP));
end;
24: begin
with PBGR(SrcP)^ do
c := YTblR[R]+YTblG[G]+YTblB[B];
Inc(PBGR(SrcP));
end;
32: begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PDWORD(SrcP));
end;
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
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
with Temp.ColorTable[PByte(SrcP)^] do
c := YTblR[rgbRed] + YTblG[rgbGreen] + YTblB[rgbBlue];
Inc(PByte(SrcP));
end;
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
c := YTblR[R] + YTblR[G] + YTblR[B];
Inc(PWord(SrcP));
end;
24:
begin
with PBGR(SrcP)^ do
c := YTblR[R] + YTblG[G] + YTblB[B];
Inc(PBGR(SrcP));
end;
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
c := YTblR[R] + YTblR[G] + YTblR[B];
Inc(PDWORD(SrcP));
end;
end;
 
case BitCount of
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]);
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
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
PByte(DestP)^ := c;
Inc(PByte(DestP));
end;
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PWord(DestP));
end;
24:
begin
with PBGR(DestP)^ do
begin
R := c;
G := c;
B := c;
end;
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
PByte(DestP)^ := c;
Inc(PByte(DestP));
end;
16: begin
PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PWord(DestP));
end;
24: begin
with PBGR(DestP)^ do
begin
R := c;
G := c;
B := c;
end;
Inc(PBGR(DestP));
end;
32: begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PDWORD(DestP));
end;
Inc(PBGR(DestP));
end;
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PDWORD(DestP));
end;
end;
end;
 
2779,253 → 3737,1574
end;
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
//--------------------------------------------------------------------------------------------------
// 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
Result.b := i shr 16;
Result.g := i shr 8;
Result.r := i;
end;
 
function TDIB.Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer;
begin
if iMark then
begin
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;
 
procedure TDIB.Contrast(Amount: Integer);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
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
if Empty then exit;
if (not MirrorX) and (not MirrorY) then Exit;
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;
 
if (not MirrorX) and (MirrorY) then
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
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
Gray := i - Alpha[i];
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
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
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
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;
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
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;
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
 
UpdateProgress(y*2);
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
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
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;
finally
EndProgress;
UpdatePalette;
end;
finally
FreeMem(TempBuf, WidthBytes);
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;
end else if (MirrorX) and (not MirrorY) then
begin
Width2 := Width shr 1;
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;
 
StartProgress('Mirror');
try
for y:=0 to Height-1 do
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
color := 0;
D := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24, 16:
begin
P1 := ScanLine[y];
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;
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(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;
 
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;
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;
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;
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;
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
for i := 0 to 2 do
begin
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;
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;
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;
 
UpdateProgress(y);
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
32:
begin
PDWord(D)^ := color;
Inc(PDWord(D));
end;
24:
begin
PBGR(D)^ := IntToColor(color);
Inc(PBGR(D));
end;
16:
begin
PWord(D)^ := color;
Inc(PWord(D));
end;
8:
begin
PByte(D)^ := color;
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;
1:
begin
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
else
end;
finally
EndProgress;
end;
end else if (MirrorX) and (MirrorY) then
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
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;
end;
Temp1.UpdatePalette;
end;
4:
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;
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;
UpdatePalette;
end;
end;
for y := 0 to Pred(Height) do
begin
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
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
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
Assign(Temp1);
Temp1.Free;
end;
4: Temp1.Free;
end;
FreeMem(pc, SizeOf(TBGR));
end;
 
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;
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;
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;
 
UpdateProgress(y*2);
procedure TDIB.AddMonoNoise(Amount: Integer);
var
value: cardinal;
x, y: longint;
a: byte;
D: pointer;
color: DWORD;
P: PByte;
begin
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;
finally
EndProgress;
end;
end;
end;
 
procedure TDIB.Negative;
procedure TDIB.AddGradiantNoise(Amount: byte);
var
i, i2: Integer;
P: Pointer;
a, i: byte;
x, y: Integer;
Table: array[0..255] of TBGR;
S, D: pointer;
color: DWORD;
Temp1: TDIB;
P: PByte;
 
begin
if Empty then exit;
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
a := Random(Amount);
rgbRed := IntToByte(rgbRed + a);
rgbGreen := IntToByte(rgbGreen + a);
rgbBlue := IntToByte(rgbBlue + a);
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: 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;
 
if BitCount<=8 then
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 i:=0 to 255 do
with ColorTable[i] do
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
rgbRed := 255-rgbRed;
rgbGreen := 255-rgbGreen;
rgbBlue := 255-rgbBlue;
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;
UpdatePalette;
end else
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.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
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
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;
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
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;
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
procedure TDIB.GaussianBlur(Bmp: TDIB; Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do
Bmp.SplitBlur(i);
end;
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
procedure TDIB.SplitBlur(Amount: Integer);
var
Lin1, Lin2: PLines;
cx, x, y: Integer;
Buf: array[0..3] of TBGR;
D: Pointer;
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@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;
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
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;
 
@@byte_skip:
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);
3072,23 → 5351,26
 
procedure Draw2(Width, Height: Integer);
begin
if (Width<>FDIB.Width) or (Height<>FDIB.Height) then
if (Width <> FDIB.Width) or (Height <> FDIB.Height) then
begin
if FCenter then
begin
inherited Canvas.StretchDraw(Bounds(-(Width-ClientWidth) div 2,
-(Height-ClientHeight) div 2, Width, Height), FDIB);
end else
inherited Canvas.StretchDraw(Bounds(-(Width - ClientWidth) div 2,
-(Height - ClientHeight) div 2, Width, Height), FDIB);
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,
inherited Canvas.Draw(-(Width - ClientWidth) div 2, -(Height - ClientHeight) div 2,
FDIB);
end else
end
else
begin
inherited Canvas.Draw(0, 0, FDIB);
end;
3112,53 → 5394,60
 
if FDIB.Empty then Exit;
 
if (FViewWidth>0) or (FViewHeight>0) then
if (FViewWidth > 0) or (FViewHeight > 0) then
begin
ViewWidth2 := FViewWidth;
if ViewWidth2=0 then ViewWidth2 := FDIB.Width;
if ViewWidth2 = 0 then ViewWidth2 := FDIB.Width;
ViewHeight2 := FViewHeight;
if ViewHeight2=0 then ViewHeight2 := FDIB.Height;
if ViewHeight2 = 0 then ViewHeight2 := FDIB.Height;
 
if FAutoStretch then
begin
if (ClientWidth<ViewWidth2) or (ClientHeight<ViewHeight2) then
if (ClientWidth < ViewWidth2) or (ClientHeight < ViewHeight2) then
begin
r := ViewWidth2/ClientWidth;
r2 := ViewHeight2/ClientHeight;
if r>r2 then
r := ViewWidth2 / ClientWidth;
r2 := ViewHeight2 / ClientHeight;
if r > r2 then
r := r2;
Draw2(Round(r*ClientWidth), Round(r*ClientHeight));
end else
Draw2(Round(r * ClientWidth), Round(r * ClientHeight));
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
begin
if FAutoStretch then
begin
if (FDIB.Width>ClientWidth) or (FDIB.Height>ClientHeight) then
if (FDIB.Width > ClientWidth) or (FDIB.Height > ClientHeight) then
begin
r := ClientWidth/FDIB.Width;
r2 := ClientHeight/FDIB.Height;
if r>r2 then
r := ClientWidth / FDIB.Width;
r2 := ClientHeight / FDIB.Height;
if r > r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
end
else
Draw2(FDIB.Width, FDIB.Height);
end else
if FStretch then
begin
if FKeepAspect then
end
else
if FStretch then
begin
r := ClientWidth/FDIB.Width;
r2 := ClientHeight/FDIB.Height;
if r>r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
Draw2(ClientWidth, ClientHeight);
end else
Draw2(FDIB.Width, FDIB.Height);
if FKeepAspect then
begin
r := ClientWidth / FDIB.Width;
r2 := ClientHeight / FDIB.Height;
if r > r2 then
r := r2;
Draw2(Round(r * FDIB.Width), Round(r * FDIB.Height));
end
else
Draw2(ClientWidth, ClientHeight);
end
else
Draw2(FDIB.Width, FDIB.Height);
end;
end;
end;
3165,7 → 5454,7
 
procedure TCustomDXPaintBox.SetAutoStretch(Value: Boolean);
begin
if FAutoStretch<>Value then
if FAutoStretch <> Value then
begin
FAutoStretch := Value;
Invalidate;
3174,7 → 5463,7
 
procedure TCustomDXPaintBox.SetCenter(Value: Boolean);
begin
if FCenter<>Value then
if FCenter <> Value then
begin
FCenter := Value;
Invalidate;
3183,7 → 5472,7
 
procedure TCustomDXPaintBox.SetDIB(Value: TDIB);
begin
if FDIB<>Value then
if FDIB <> Value then
begin
FDIB.Assign(Value);
Invalidate;
3192,7 → 5481,7
 
procedure TCustomDXPaintBox.SetKeepAspect(Value: Boolean);
begin
if Value<>FKeepAspect then
if Value <> FKeepAspect then
begin
FKeepAspect := Value;
Invalidate;
3201,7 → 5490,7
 
procedure TCustomDXPaintBox.SetStretch(Value: Boolean);
begin
if Value<>FStretch then
if Value <> FStretch then
begin
FStretch := Value;
Invalidate;
3210,8 → 5499,8
 
procedure TCustomDXPaintBox.SetViewWidth(Value: Integer);
begin
if Value<0 then Value := 0;
if Value<>FViewWidth then
if Value < 0 then Value := 0;
if Value <> FViewWidth then
begin
FViewWidth := Value;
Invalidate;
3220,8 → 5509,8
 
procedure TCustomDXPaintBox.SetViewHeight(Value: Integer);
begin
if Value<0 then Value := 0;
if Value<>FViewHeight then
if Value < 0 then Value := 0;
if Value <> FViewHeight then
begin
FViewHeight := Value;
Invalidate;
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);
3236,4 → 9901,4
 
FEmptyDIBImage.Free;
FPaletteManager.Free;
end.
end.