{ +-------------------------------------------------------------+ } { | | } { | GM-Software | } { | =========== | } { | | } { | Project: All PRojects | } { | | } { | Description: Fast bitmap processing. | } { | | } { | | } { | Copyright (C) - 2005 - Gerrit Moeller. | } { | | } { | Source code distributed under MIT license. | } { | | } { | Web: https://www.gm-software.de | } { | | } { +-------------------------------------------------------------+ } {$INCLUDE GMCompilerSettings.inc} unit GMFastBMP; interface uses {$IFNDEF JEDIAPI}Windows{$ELSE}{$ENDIF}, GMActiveX, GMIntf; type TRGBColor = packed record b,g,r: Byte end; PRGBColor =^TRGBColor; const cRGBsz = SizeOf(TRGBColor); cMaxRGBLines = High(LongInt) div SizeOf(Pointer); cMaxRGBQuad = High(LongInt) div SizeOf(TRGBQuad); cDfltTopDown = False; cDfltFillWhite = False; type PRGBMaxQuadArray = ^TRGBMaxQuadArray; TRGBMaxQuadArray = array [0..cMaxRGBQuad-11] of TRGBQuad; PBitmapHeaderMax = ^TBitmapHeaderMax; TBitmapHeaderMax = packed record bmiHeader: TBitmapInfoHeader; bmiColors: TRGBMaxQuadArray; end; TBmpLines = array [0..cMaxRGBLines-1] of Pointer; PBmpLines = ^TBmpLines; TGMFastBMPBase = class(TGMRefCountedObj, IGMGetHandle) protected FHandle: LongWord; FDC: LongWord; FBmpSize: TPoint; FBits: Pointer; FBitsMemSize: LongInt; FTopDown: Boolean; FRowSize: LongInt; FRowGap: LongInt; FLines: PBmpLines; FBmpInfo: PBitmapInfoHeader; procedure SetupPixelsMember(const PixelsPtr: Pointer); virtual; abstract; function BmpInfoHdrSize: LongInt; virtual; public // Interfaces function GetHandle: THandle; stdcall; public constructor Create(const ARefLifeTime: Boolean = True); overload; override; constructor Create(const AWidth: LongInt = 0; const AHeight: LongInt = 0; const AFillWhite: Boolean = cDfltFillWhite; const ATopDown: Boolean = cDfltTopDown; const ARefLifeTime: Boolean = True); reintroduce; overload; constructor Create(const ASize: TPoint; const AFillWhite: Boolean = cDfltFillWhite; const ATopDown: Boolean = cDfltTopDown; const ARefLifeTime: Boolean = True); reintroduce; overload; destructor Destroy; override; procedure FillWhite; procedure SetBmpInfoHdrColors(const ColorCount: LongWord; const PColors: PRGBMaxQuadArray); procedure SetSize(const AWidth, AHeight: LongInt; const AFillWhite: Boolean = cDfltFillWhite; const ATopDown: Boolean = cDfltTopDown); virtual; function BitsPerPixel: LongInt; virtual; abstract; procedure Draw(const DestDC: HDC; const DstOrgn: TPoint; const ROP: DWORD = SRCCOPY); procedure StretchDraw(const DestDC: HDC; const DstOrgn, DestSz: TPoint; const ROP: DWORD = SRCCOPY); overload; procedure StretchDraw(const DestDC: HDC; const DstRect: TRect; const ROP: DWORD = SRCCOPY); overload; procedure StretchRect(const DestDC: HDC; const DstOrgn, DestSz, SrcOrgn, SrcSz: TPoint; const ROP: DWORD = SRCCOPY); overload; procedure StretchRect(const DestDC: HDC; const DstRect, SrcRect: TRect; const ROP: DWORD = SRCCOPY); overload; //procedure TileDraw(fdc,x,y,w,h:LongInt); virtual; abstract; //procedure Resize(Dst:TGMFastBMPBase); virtual; abstract; //procedure SmoothResize(Dst:TGMFastBMPBase); virtual; abstract; //procedure CopyRect(Dst:TGMFastBMPBase;x,y,w,h,sx,sy:LongInt); virtual; abstract; //procedure Tile(Dst:TGMFastBMPBase); virtual; abstract; //function Size: TPoint; function Bounds: TRect; function DC: HDC; procedure DestroyDC; property Size: TPoint read FBmpSize; //property DC: LongWord read FDC; property Handle: LongWord read FHandle; property Width: LongInt read FBmpSize.x; property Height: LongInt read FBmpSize.y; property TopDown: Boolean read FTopDown; property Bits: Pointer read FBits; property BitsMemSize: LongInt read FBitsMemSize; property RowSize: LongInt read FRowSize; property RowGap: LongInt read FRowGap; property Lines: PBmpLines read FLines; end; TGMFastMonoBmp = class; IGMFastMonoBmp = interface(IUnknown) ['{67DDD64D-6B3D-473b-85A4-E3646ED51B07}'] function Obj: TGMFastMonoBmp; end; TMonoLine = array [0..High(LongInt)-1] of Byte; PMonoLine = ^TMonoLine; TMonoLines = array [0..cMaxRGBLines-1] of PMonoLine; PMonoLines = ^TMonoLines; TGMFastMonoBmp = class(TGMFastBMPBase, IGMFastMonoBmp) protected FPixels: PMonoLines; procedure SetupPixelsMember(const PixelsPtr: Pointer); override; function BmpInfoHdrSize: LongInt; override; public constructor Create(const AWidth: LongInt = 0; const AHeight: LongInt = 0; const AFillWhite: Boolean = cDfltFillWhite; const ATopDown: Boolean = cDfltTopDown; const ARefLifeTime: Boolean = True); //destructor Destroy; override; function Obj: TGMFastMonoBmp; function BitsPerPixel: LongInt; override; procedure SetInvertedPixel(const x, y: LongInt; const r, g, b: Word); procedure SetPixel(const x, y: LongInt; const r, g, b: Word); property Pixels: PMonoLines read FPixels; // <- just a typecast to inherited FLines member! end; T256Line = array [0..High(LongInt)-1] of Byte; P256Line = ^T256Line; T256Lines = array [0..cMaxRGBLines-1] of P256Line; P256Lines = ^T256Lines; TGMFast256Bmp = class; IGMFast256Bmp = interface(IUnknown) ['{67DDD64D-6B3D-473b-85A4-E3646ED51B07}'] function Obj: TGMFast256Bmp; end; TGMFast256Bmp = class(TGMFastBMPBase, IGMFast256Bmp) protected FPixels: P256Lines; procedure SetupPixelsMember(const PixelsPtr: Pointer); override; public function Obj: TGMFast256Bmp; function BitsPerPixel: LongInt; override; property Pixels: P256Lines read FPixels; // <- just a typecast to inherited FLines member! end; TRGBLine = array [0..High(LongInt) div SizeOf(TRGBColor)-1] of TRGBColor; PRGBLine = ^TRGBLine; TRGBLines = array [0..cMaxRGBLines-1] of PRGBLine; PRGBLines = ^TRGBLines; TGMFastRGBBmp = class; IGMFastRGBBmp = interface(IUnknown) ['{D2AFE8F2-FEFC-4652-B5D0-9D239950DFA8}'] function Obj: TGMFastRGBBmp; end; TGMFastRGBBmp = class(TGMFastBMPBase, IGMFastRGBBmp) protected FPixels: PRGBLines; procedure SetupPixelsMember(const PixelsPtr: Pointer); override; public constructor Create(const ASource: IGMFastRGBBmp; const ARect: PRect = nil; const ARefLifeTime: Boolean = True); reintroduce; overload; //destructor Destroy; override; function Obj: TGMFastRGBBmp; function BitsPerPixel: LongInt; override; procedure CopyContents(const ASource: TGMFastRGBBmp; const ARect: PRect = nil); procedure CopyRect(const ASource: TGMFastRGBBmp; const ARect: TRect); //procedure SetSize(const AWidth, AHeight: LongInt; const AFillWhite: Boolean = cDfltFillWhite); override; procedure LoadFromStream(const AStream: IStream; const AOnProgress: IUnknown = nil); procedure LoadFromFile(const AFileName: TGMString; const AOnProgress: IUnknown = nil); procedure SaveToFile(const AFileName: TGMString); //procedure SaveToFile(const AFileName: TGMString); //procedure LoadFromhBmp(hBmp:LongInt); //procedure LoadFromRes(hInst:LongInt;sName:TGMString); property Pixels: PRGBLines read FPixels; // <- just a typecast to inherited FLines member! //procedure SetInterface(fWidth,fHeight:LongInt;pBits:Pointer); //procedure Copy(FB:TGMFastRGBBmp); // GDI drawing methods //procedure Draw(fdc: LongWord; x,y:LongInt); override; //procedure Stretch(fdc,x,y,w,h:LongInt); override; //procedure DrawRect(fdc,x,y,w,h,sx,sy:LongInt); override; //procedure StretchRect(fdc,x,y,w,h,sx,sy,sw,sh:LongInt); override; //procedure TileDraw(fdc,x,y,w,h:LongInt); override; // native conversions //procedure Resize(Dst:TGMFastBMPBase); override; //procedure SmoothResize(Dst:TGMFastBMPBase); override; //procedure CopyRect(Dst:TGMFastBMPBase;x,y,w,h,sx,sy:LongInt); override; //procedure Tile(Dst:TGMFastBMPBase); override; //function CountColors:LongInt; end; {const //colors dur tfBlack : TRGBColor=(b:0;g:0;r:0); tfMaroon : TRGBColor=(b:0;g:0;r:128); tfGreen : TRGBColor=(b:0;g:128;r:0); tfOlive : TRGBColor=(b:0;g:128;r:128); tfNavy : TRGBColor=(b:128;g:0;r:0); tfPurple : TRGBColor=(b:128;g:0;r:128); tfTeal : TRGBColor=(b:128;g:128;r:0); tfGray : TRGBColor=(b:128;g:128;r:128); tfSilver : TRGBColor=(b:192;g:192;r:192); tfRed : TRGBColor=(b:0;g:0;r:255); tfLime : TRGBColor=(b:0;g:255;r:0); tfYellow : TRGBColor=(b:0;g:255;r:255); tfBlue : TRGBColor=(b:255;g:0;r:0); tfFuchsia : TRGBColor=(b:255;g:0;r:255); tfAqua : TRGBColor=(b:255;g:255;r:0); tfLtGray : TRGBColor=(b:192;g:192;r:192); tfDkGray : TRGBColor=(b:128;g:128;r:128); tfWhite : TRGBColor=(b:255;g:255;r:255); } procedure FxRGB(const Bmp: TGMFastRGBBmp; const ra, ga, ba: LongInt; const Bounds: TRect); procedure FxLightness(const Bmp: TGMFastRGBBmp; Amount: LongInt; const Bounds: TRect); procedure FxContrast(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxSaturation(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxHFlip(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxVFlip(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxEmboss(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxSpray(const Bmp, Dst: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxInvert(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxGrayscale(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxRedEyeFilter(const Bmp: TGMFastRGBBmp; const ThresHold: LongInt; const Bounds: TRect); procedure FxSharpen(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxGaussianSharpen(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxSplitBlur(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxGaussianBlur(const Bmp: TGMFastRGBBmp; const Distance: LongInt; const Bounds: TRect); procedure FxSoftenEdges(const Bmp: TGMFastRGBBmp; const Bounds: TRect); procedure FxMosaic(const Bmp: TGMFastRGBBmp; const xAmount, yAmount: LongInt; const Bounds: TRect); procedure FxFishEye(const Bmp, Dst: TGMFastRGBBmp; const Amount: Extended; const Bounds: TRect); procedure FxTwist(const Bmp, Dst: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); procedure FxAlphaBlend(const Dst, Src1, Src2: TGMFastRGBBmp; const Alpha: LongInt; const Bounds: TRect); // 0..255 {function FRGB(r,g,b:Byte): TRGBColor; function IntToColor(i:LongInt): TRGBColor; function TrimInt(i,Min,Max:LongInt): LongInt;} implementation uses GMCommon; resourcestring RStrNoBmpStream = 'Stream does not contain a Bitmap'; { ------------------------- } { ---- Global Routines ---- } { ------------------------- } {function FRGB(r,g,b:Byte):TRGBColor; begin Result.b:=b; Result.g:=g; Result.r:=r; end; function IntToColor(i:LongInt):TRGBColor; begin Result.b:=i shr 16; Result.g:=i shr 8; Result.r:=i; end;} function TrimInt(const Value, Min, Max: LongInt): LongInt; begin if Value > Max then Result := Max else if Value < Min then Result := Min else Result := Value; end; function IntToByte(const Value: LongInt): Byte; begin if Value > 255 then Result := 255 else if Value < 0 then Result := 0 else Result := Value; end; procedure LimitBounds(const Bmp: TGMFastRGBBmp; PBounds: PRect); begin if (Bmp = nil) or (PBounds = nil) then Exit; if PBounds.Left > PBounds.Right then GMExchangeLongInt(PBounds.Left, PBounds.Right); if PBounds.Top > PBounds.Bottom then GMExchangeLongInt(PBounds.Top, PBounds.Bottom); IntersectRect(PBounds^, PBounds^, Bmp.Bounds); {PBounds.Left := Max(0, PBounds.Left); PBounds.Top := Max(0, PBounds.Top); PBounds.Right := Min(Bmp.Width, PBounds.Right); PBounds.Bottom := Min(0, PBounds.Bottom);} end; {procedure DecodeRLE4(Bmp:TFastDIB;Data:Pointer); procedure OddMove(Src,Dst:PByte;Size:Integer); begin if Size=0 then Exit; repeat Dst^:=(Dst^ and $F0)or(Src^ shr 4); Inc(Dst); Dst^:=(Dst^ and $0F)or(Src^ shl 4); Inc(Src); Dec(Size); until Size=0; end; procedure OddFill(Mem:PByte;Size,Value:Integer); begin Value:=(Value shr 4)or(Value shl 4); Mem^:=(Mem^ and $F0)or(Value and $0F); Inc(Mem); if Size>1 then FillByte(Mem^,Size,Value); Mem^:=(Mem^ and $0F)or(Value and $F0); end; var pb: PByte; x,y,z,i: Integer; begin pb:=Data; x:=0; y:=0; while y<Bmp.AbsHeight do begin if pb^=0 then begin Inc(pb); z:=pb^; case pb^ of 0: begin Inc(y); x:=0; end; 1: Break; 2: begin Inc(pb); Inc(x,pb^); Inc(pb); Inc(y,pb^); end; else begin Inc(pb); i:=(z+1)shr 1; if(z and 2)=2 then Inc(i); if((x and 1)=1)and(x+i<Bmp.Width)then OddMove(pb,@Bmp.Pixels8[y,x shr 1],i) else Move(pb^,Bmp.Pixels8[y,x shr 1],i); Inc(pb,i-1); Inc(x,z); end; end; end else begin z:=pb^; Inc(pb); if((x and 1)=1)and(x+z<Bmp.Width)then OddFill(@Bmp.Pixels8[y,x shr 1],z shr 1,pb^) else FillByte(Bmp.Pixels8[y,x shr 1],z shr 1,pb^); Inc(x,z); end; Inc(pb); end; end;} function CompareRGBColors(const Color1, Color2: TRGBColor; const Delta: Byte = 0): Boolean; begin Result := (Abs(Color1.r - Color2.r) <= Delta) and (Abs(Color1.g - Color2.g) <= Delta) and (Abs(Color1.b - Color2.b) <= Delta); end; procedure DecodeRLE8(const Width, Height: LongInt; const RLEBits, RGBBits: Pointer); var pb: PByte; x, y, z, i, s, RowSize: LongInt; begin RowSize := GMAlignedValue(Width, 4); pb := RLEBits; y:=0; x:=0; while y < Height do begin if pb^ = 0 then begin Inc(pb); case pb^ of 0: begin Inc(y); x:=0; end; 1: Break; 2: begin Inc(pb); Inc(x,pb^); Inc(pb); Inc(y,pb^); end; else begin i := pb^; s := (i + 1) and (not 1); z := s - 1; Inc(pb); if x + s > Width then s := Width - x; Move(pb^, GMAddPtr(RGBBits, (y * RowSize) + x)^, s); Inc(pb, z); Inc(x, i); end; end; end else begin i:=pb^; Inc(pb); if i+x > Width then i := Width-x; FillByte(GMAddPtr(RGBBits, (y*RowSize) + x)^, i, pb^); Inc(x,i); end; Inc(pb); end; end; { ------------------------ } { ---- TGMFastBMPBase ---- } { ------------------------ } constructor TGMFastBMPBase.Create(const ARefLifeTime: Boolean); begin inherited Create(ARefLifeTime); //FDC := CreateCompatibleDC(0); //GMApiCheckObj(DC <> 0, Self, 'CreateCompatibleDC'); FTopDown := cDfltTopDown; GetMem(FBmpInfo, BmpInfoHdrSize); FillByte(FBmpInfo^, BmpInfoHdrSize, 0); FBmpInfo.biSize := SizeOf(TBitmapInfoHeader); // <- always use SizeOf(TBitmapInfoHeader) here! FBmpInfo.biPlanes := 1; FBmpInfo.biBitCount := BitsPerPixel; FBmpInfo.biCompression := BI_RGB; end; constructor TGMFastBMPBase.Create(const AWidth: LongInt; const AHeight: LongInt; const AFillWhite: Boolean; const ATopDown: Boolean; const ARefLifeTime: Boolean); begin Create(ARefLifeTime); FTopDown := ATopDown; if (AWidth > 0) and (AHeight > 0) then SetSize(AWidth, AHeight, AFillWhite, ATopDown); end; constructor TGMFastBMPBase.Create(const ASize: TPoint; const AFillWhite, ATopDown, ARefLifeTime: Boolean); begin Create(Asize.x, Asize.y, AFillWhite, ATopDown, ARefLifeTime); end; destructor TGMFastBMPBase.Destroy; begin //if FDC <> 0 then begin DeleteDC(FDC); FDC := 0; end; DestroyDC; if FHandle <> 0 then begin DeleteObject(FHandle); FHandle := 0; end; FreeMem(FBmpInfo); FreeMem(FLines); inherited Destroy; end; function TGMFastBMPBase.BmpInfoHdrSize: LongInt; begin Result := SizeOf(TBitmapInfoHeader); end; function TGMFastBMPBase.DC: HDC; begin if FDC = 0 then begin FDC := CreateCompatibleDC(0); GMApiCheckObj(FDC <> 0, Self, 'CreateCompatibleDC'); if FHandle <> 0 then DeleteObject(SelectObject(FDC, FHandle)); end; Result := FDC; end; procedure TGMFastBMPBase.DestroyDC; begin if FDC <> 0 then begin DeleteDC(FDC); FDC := 0; end; end; procedure TGMFastBMPBase.SetBmpInfoHdrColors(const ColorCount: LongWord; const PColors: PRGBMaxQuadArray); begin ReallocMem(FBmpInfo, SizeOf(TBitmapInfoHeader) + ColorCount * SizeOf(TRGBQuad)); Move(PColors^, PBitmapHeaderMax(FBmpInfo).bmiColors[0], ColorCount * SizeOf(TRGBQuad)); FBmpInfo.biClrUsed := ColorCount; FBmpInfo.biClrImportant := ColorCount; end; function TGMFastBMPBase.GetHandle: Longword; begin Result := FHandle; end; procedure TGMFastBMPBase.SetSize(const AWidth, AHeight: LongInt; const AFillWhite, ATopDown: Boolean); var x, i: LongInt; begin if (Width = AWidth) and (Height = AHeight) then Exit; if FHandle <> 0 then DeleteObject(FHandle); FTopDown := ATopDown; FBmpSize.x := AWidth; FBmpSize.y := AHeight; FBmpInfo.biWidth := Width; if TopDown then FBmpInfo.biHeight := -Height else FBmpInfo.biHeight := Height; FHandle := CreateDIBSection(0, PBitmapInfo(FBmpInfo)^, DIB_RGB_COLORS, FBits, 0, 0); GMApiCheckObj(FHandle <> 0, Self, 'CreateDIBSection'); if FDC <> 0 then DeleteObject(SelectObject(FDC, FHandle)); FRowSize := ((Width * BitsPerPixel + 31) shr 5) shl 2; FRowGap := Width mod 4; FBitsMemSize := RowSize * Height; FreeMem(FLines); GetMem(FLines, Height * SizeOf(Pointer)); x := LongInt(Bits); for i:=0 to Height-1 do begin FLines[i] := Pointer(x); Inc(x, RowSize); end; SetupPixelsMember(FLines); if AFillWhite then FillWhite; end; procedure TGMFastBMPBase.FillWhite; begin if (Bits <> nil) and (BitsMemSize > 0) then FillByte(Bits^, BitsMemSize, $FF); end; procedure TGMFastBMPBase.StretchDraw(const DestDC: HDC; const DstOrgn, DestSz: TPoint; const ROP: DWORD); var ScanLines: LongInt; begin ScanLines := StretchDIBits(DestDC, DstOrgn.x, DstOrgn.y, DestSz.x, DestSz.y, 0, 0, Width, Height, Bits, PBitmapInfo(FBmpInfo)^, DIB_RGB_COLORS, ROP); GMAPICheckObj(LongWord(ScanLines) <> GDI_ERROR, Self, 'StretchDraw: StretchDIBits'); end; procedure TGMFastBMPBase.StretchDraw(const DestDC: HDC; const DstRect: TRect; const ROP: DWORD); begin StretchDraw(DestDC, DstRect.TopLeft, GMRectSize(DstRect), ROP); end; procedure TGMFastBMPBase.Draw(const DestDC: HDC; const DstOrgn: TPoint; const ROP: DWORD); begin StretchDraw(DestDC, DstOrgn, Size, ROP); //StretchDIBits(DestDC, DstOrgn.x, DstOrgn.y, Width, Height, 0, 0, Width, Height, Bits, PBitmapInfo(FBmpInfo)^, DIB_RGB_COLORS, ROP); end; procedure TGMFastBMPBase.StretchRect(const DestDC: HDC; const DstOrgn, DestSz, SrcOrgn, SrcSz: TPoint; const ROP: DWORD); var ScanLines: LongInt; begin ScanLines := StretchDIBits(DestDC, DstOrgn.x, DstOrgn.y, DestSz.x, DestSz.y, SrcOrgn.x, SrcOrgn.y, SrcSz.x, SrcSz.y, Bits, PBitmapInfo(FBmpInfo)^, DIB_RGB_COLORS, ROP); GMAPICheckObj(LongWord(ScanLines) <> GDI_ERROR, Self, 'StretchRect: StretchDIBits'); end; procedure TGMFastBMPBase.StretchRect(const DestDC: HDC; const DstRect, SrcRect: TRect; const ROP: DWORD); begin StretchRect(DestDC, DstRect.TopLeft, GMRectSize(DstRect), SrcRect.TopLeft, GMRectSize(SrcRect), ROP); end; function TGMFastBMPBase.Bounds: TRect; begin Result := GMRect(0, 0, Width, Height); end; { ------------------------ } { ---- TGMFastMonoBmp ---- } { ------------------------ } constructor TGMFastMonoBmp.Create(const AWidth: LongInt; const AHeight: LongInt; const AFillWhite: Boolean; const ATopDown: Boolean; const ARefLifeTime: Boolean); begin inherited Create(AWidth, AHeight, AFillWhite, ATopDown, ARefLifeTime); {if Inverted then begin FBmpInfo.bmiColors[0].rgbBlue := $FF; FBmpInfo.bmiColors[0].rgbGreen := $FF; FBmpInfo.bmiColors[0].rgbRed := $FF; end else begin} with PBitmapHeaderMax(FBmpInfo).bmiColors[1] do begin rgbBlue := $FF; rgbGreen := $FF; rgbRed := $FF; end; //end; end; {destructor TGMFastMonoBmp.Destroy; begin FreeMem(FPixels); inherited Destroy; end;} function TGMFastMonoBmp.BmpInfoHdrSize: LongInt; begin Result := inherited BmpInfoHdrSize + 2 * SizeOf(TRGBQuad); end; function TGMFastMonoBmp.Obj: TGMFastMonoBmp; begin Result := Self; end; function TGMFastMonoBmp.BitsPerPixel: LongInt; begin Result := 1; end; procedure TGMFastMonoBmp.SetupPixelsMember(const PixelsPtr: Pointer); begin FPixels := PixelsPtr; end; {procedure TGMFastMonoBmp.SetSize(const AWidth, AHeight: LongInt; const AFillWhite: Boolean); var x: LongInt; i: LongInt; begin if (AWidth = Width) and (AHeight = Height) then Exit; inherited SetSize(AWidth, AHeight, AFillWhite); GetMem(FPixels, Height * SizeOf(Pointer)); x := LongInt(Bits); for i:=0 to Height-1 do begin Pixels[i] := Pointer(x); Inc(x, RowSize); end; end;} procedure TGMFastMonoBmp.SetInvertedPixel(const x, y: LongInt; const r, g, b: Word); var PLine: PMonoLine; Mask: Byte; bx: LongInt; begin if (x >= Width) or (y >= Height) then Exit; //Assert((x < Width) and (y < Height)); PLine := Pixels[y]; Mask := $80 shr (x mod 8); bx := x div 8; if (r<>0) or (g<>0) or (b<>0) then //if (r=$FF) or (g=$FF) or (b=$FF) then PLine[bx] := PLine[bx] and not Mask else PLine[bx] := PLine[bx] or Mask; end; procedure TGMFastMonoBmp.SetPixel(const x, y: LongInt; const r, g, b: Word); var PLine: PMonoLine; Mask: Byte; bx: LongInt; begin if (x >= Width) or (y >= Height) then Exit; //Assert((x < Width) and (y < Height)); PLine := Pixels[y]; Mask := $80 shr (x mod 8); bx := x div 8; if (r=0) and (g=0) and (b=0) then PLine[bx] := PLine[bx] and not Mask else PLine[bx] := PLine[bx] or Mask; end; { ----------------------- } { ---- TGMFast256Bmp ---- } { ----------------------- } function TGMFast256Bmp.Obj: TGMFast256Bmp; begin Result := Self; end; function TGMFast256Bmp.BitsPerPixel: LongInt; begin Result := 8; end; procedure TGMFast256Bmp.SetupPixelsMember(const PixelsPtr: Pointer); begin FPixels := PixelsPtr; end; { ----------------------- } { ---- TGMFastRGBBmp ---- } { ----------------------- } constructor TGMFastRGBBmp.Create(const ASource: IGMFastRGBBmp; const ARect: PRect; const ARefLifeTime: Boolean); begin inherited Create(0, 0, False, ASource.Obj.TopDown, ARefLifeTime); CopyContents(ASource.Obj, ARect); end; {destructor TGMFastRGBBmp.Destroy; begin FreeMem(FPixels); inherited Destroy; end;} function TGMFastRGBBmp.Obj: TGMFastRGBBmp; begin Result := Self; end; function TGMFastRGBBmp.BitsPerPixel: LongInt; begin Result := SizeOf(TRGBColor) * 8; end; procedure TGMFastRGBBmp.SetupPixelsMember(const PixelsPtr: Pointer); begin FPixels := PixelsPtr; end; procedure TGMFastRGBBmp.CopyContents(const ASource: TGMFastRGBBmp; const ARect: PRect); //var R: TRect; begin if ASource = nil then Exit; // Alternative: Immer via CopyRect: //if ARect <> nil then R := ARect^ else R := ASource.Bounds; //CopyRect(ASource, R); if ARect <> nil then CopyRect(ASource, ARect^) else begin SetSize(ASource.Width, ASource.Height, False, ASource.TopDown); CopyMemory(Bits, ASource.Bits, BitsMemSize); end; end; procedure TGMFastRGBBmp.CopyRect(const ASource: TGMFastRGBBmp; const ARect: TRect); var i, w: LongInt; begin if ASource = nil then Exit; LimitBounds(ASource, @ARect); SetSize(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, False, ASource.TopDown); w := Width * cRGBsz; for i:=0 to Height-1 do CopyMemory(Pixels[i], @ASource.Pixels[ARect.Top+i, ARect.Left], w); end; {procedure TGMFastRGBBmp.SetSize(const AWidth, AHeight: LongInt; const AFillWhite: Boolean); var x: LongInt; i: LongInt; begin if (AWidth = Width) and (AHeight = Height) then Exit; inherited SetSize(AWidth, AHeight, AFillWhite); GetMem(FPixels, Height * SizeOf(Pointer)); x:=LongInt(Bits); for i:=0 to Height-1 do begin Pixels[i] := Pointer(x); Inc(x, RowSize); end; end;} procedure TGMFastRGBBmp.LoadFromFile(const AFileName: TGMString; const AOnProgress: IUnknown); var FileStrm: IStream; begin FileStrm := TGMFileIStream.CreateRead(AFileName); LoadFromStream(FileStrm, AOnProgress); end; procedure TGMFastRGBBmp.LoadFromStream(const AStream: IStream; const AOnProgress: IUnknown); var FileBits: Pointer; HBmp: THandle; cmpr: DWORD; HdrBuf, BitBuf: AnsiString; BmpHdr: TBitmapFileHeader; PBmpInfoHdr: PBitmapInfo; begin if AStream = nil then Exit; GMSafeIStreamRead(AStream, @BmpHdr, SizeOf(BmpHdr), {$I %CurrentRoutine%}); if BmpHdr.bfType <> cBmpSig then raise EGMException.ObjError(RStrNoBmpStream, Self, {$I %CurrentRoutine%}); SetLength(HdrBuf, BmpHdr.bfOffBits - GMIStreamPos(AStream)); GMSafeIStreamRead(AStream, PAnsiChar(HdrBuf), Length(HdrBuf), {$I %CurrentRoutine%}); PBmpInfoHdr := Pointer(PAnsiChar(HdrBuf)); SetSize(PBmpInfoHdr.bmiHeader.biWidth, Abs(PBmpInfoHdr.bmiHeader.biHeight), False, False); cmpr := PBmpInfoHdr.bmiHeader.biCompression; PBmpInfoHdr.bmiHeader.biCompression := BI_RGB; FileBits := nil; HBmp := CreateDIBSection(0, PBmpInfoHdr^, DIB_RGB_COLORS, FileBits, 0, 0); GMApiCheckObj(HBmp <> 0, Self, 'CreateDIBSection'); try Setlength(BitBuf, BmpHdr.bfSize - GMIStreamPos(AStream)); GMSafeIStreamRead(AStream, PAnsiChar(BitBuf), Length(BitBuf), {$I %CurrentRoutine%}); case cmpr of BI_RLE8: DecodeRLE8(Width, Height, PAnsiChar(BitBuf), FileBits); //else GMSafeIStreamRead(AStream, FileBits, BmpHdr.bfSize - GMIStreamPos(AStream), {$I %CurrentRoutine%}); else GMApiCheckObj(SetDIBits(0, HBmp, 0, Height, PAnsiChar(BitBuf), PBmpInfoHdr^, DIB_RGB_COLORS) > 0, Self, {$I %CurrentRoutine%}); end; StretchDIBits(DC, 0, 0, Width, Height, 0, 0, Width, Height, FileBits, PBmpInfoHdr^, DIB_RGB_COLORS, SRCCOPY); finally DeleteObject(HBmp); end; end; procedure TGMFastRGBBmp.SaveToFile(const AFileName: TGMString); var hFile: LongInt; iWrote: Cardinal; fHead: TBitmapFileHeader; WasNeg: Boolean; begin // saves upside down.. just Flop from FastFX if you want hFile:=CreateFile(PGMChar(AFileName), GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, 0, 0); fHead.bfType := 19778; // "BM" fHead.bfSize := SizeOf(fHead) + BmpInfoHdrSize + BitsMemSize; fHead.bfOffBits := SizeOf(fHead) + BmpInfoHdrSize; WriteFile(hFile, fHead, SizeOf(fHead), iWrote, nil); WasNeg := FBmpInfo.biHeight < 0; //FBmpInfo.biHeight := Abs(FBmpInfo.biHeight); if WasNeg then FBmpInfo.biHeight := -FBmpInfo.biHeight; WriteFile(hFile, FBmpInfo^, BmpInfoHdrSize, iWrote, nil); if WasNeg then FBmpInfo.biHeight := -FBmpInfo.biHeight; WriteFile(hFile, Bits^, BitsMemSize, iWrote, nil); CloseHandle(hFile); end; {procedure TGMFastRGBBmp.LoadFromFile(FileName:TGMString); var hFile, bSize: LongInt; iRead: Cardinal; fHead: TBitmapFileHeader; fSize: DWORD; begin hFile:=CreateFile(PGMChar(FileName),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0); //hFile:=OpenFile(PGMChar(FileName),fData,OF_READ); ReadFile(hFile,fHead,SizeOf(fHead),iRead,nil); ReadFile(hFile,FBmpInfo,SizeOf(FBmpInfo),iRead,nil); SetSize(FBmpInfo.bmiHeader.biWidth,Abs(FBmpInfo.bmiHeader.biHeight)); //bSize:=(((fInfo.bmiHeader.biWidth*fInfo.bmiHeader.biBitCount+31)shr 5)shl 2)*fInfo.bmiHeader.biHeight; //GetMem(fBits,bSize); fSize:=GetFileSize(hFile,nil); SetFilePointer(hFile,fHead.bfOffBits,nil,FILE_BEGIN); ReadFile(hFile,Bits^,fSize-fHead.bfOffBits,iRead,nil); StretchDIBits(hDC,0,0,Width,Height,0,0,Width,Height,Bits,FBmpInfo,DIB_RGB_COLORS,SRCCOPY); //FreeMem(fBits); CloseHandle(hFile); end;} {procedure TFastDIB.LoadFromFile(FileName:TGMString); var i: DWord; Buffer: Pointer; FBmpInfo: TBMInfo; hFile: Windows.HFILE; fBits,xSize,fSize: DWord; begin hFile:=CreateFile(PGMChar(FileName),GENERIC_READ,FILE_SHARE_READ,nil,OPEN_EXISTING,0,0); fSize:=GetFileSize(hFile,nil); xSize:=fSize; if xSize>1078 then xSize:=1078; GetMem(Buffer,1078); ReadFile(hFile,Buffer^,xSize,i,nil); fBits:=LoadHeader(Buffer,FBmpInfo); SetSizeIndirect(FBmpInfo); SetFilePointer(hFile,fBits-xSize,nil,FILE_CURRENT); if(FBmpInfo.Header.Compression=1)or(FBmpInfo.Header.Compression=2)then xSize:=PDWord(Integer(Buffer)+2)^-fBits else if fSize-fBits > Size then xSize:=Size else xSize:=fSize-fBits; if(FBmpInfo.Header.Compression=0)or(FBmpInfo.Header.Compression=3)then ReadFile(hFile,Bits^,xSize,i,nil)else begin ReAllocMem(Buffer,xSize); ReadFile(hFile,Buffer^,xSize,i,nil); if FBmpInfo.Header.Compression=1 then DecodeRLE8(Self,Buffer) else DecodeRLE4(Self,Buffer); end; CloseHandle(hFile); FreeMem(Buffer); end;} {procedure TGMFastRGBBmp.SaveToFile(const AFileName: TGMString); type TByteArray = array [0..0] of Byte; PByteArray =^TByteArray; var hFile: LongInt; iWrote: Cardinal; //fData: TofStruct; fHead: TBitmapFileHeader; begin // saves upside down.. just Flop from FastFX if you want hFile:=CreateFile(PGMChar(AFileName),GENERIC_WRITE,FILE_SHARE_READ,nil,CREATE_ALWAYS,0,0); //hFile:=OpenFile(PGMChar(FileName),fData,OF_CREATE or OF_WRITE); fHead.bfType := 19778; // "BM" fHead.bfSize := SizeOf(fHead) + SizeOf(FBmpInfo) + BitsMemSize; fHead.bfOffBits := SizeOf(fHead)+SizeOf(FBmpInfo); WriteFile(hFile, fHead, SizeOf(fHead), iWrote, nil); FBmpInfo.biHeight := Abs(FBmpInfo.biHeight); WriteFile(hFile, FBmpInfo, SizeOf(FBmpInfo), iWrote, nil); FBmpInfo.biHeight := -FBmpInfo.biHeight; WriteFile(hFile, PByteArray(Bits)^, BitsMemSize, iWrote, nil); CloseHandle(hFile); end;} {procedure TGMFastRGBBmp.LoadFromhBmp(hBmp:LongInt); var Bmp: TBitmap; memDC: LongInt; begin GetObject(hBmp,SizeOf(Bmp),@Bmp); SetSize(Bmp.bmWidth,Bmp.bmHeight); memDC:=CreateCompatibleDC(0); GMApiCheckObj(memDC <> 0, Self, 'CreateCompatibleDC'); SelectObject(memDC,hBmp); GMApiCheckObj(GetDIBits(memDC, hBmp, 0, Height, Bits, FBmpInfo, DIB_RGB_COLORS) <> 0, Self, 'GetDIBits'); DeleteDC(memDC); end;} {procedure TGMFastRGBBmp.LoadFromRes(hInst:LongInt;sName:TGMString); var hBmp: LongInt; begin hBmp:=LoadImage(hInst,PGMChar(sName),IMAGE_BITMAP,0,0,0); LoadFromhBmp(hBmp); DeleteObject(hBmp); end;} { SrcLn := @ASource.Pixels[ARect.Top, ARect.Left]; DstLn := @Pixels[0, 0]; for i:=0 to Height-1 do begin CopyMemory(DstLn, SrcLn, w); SrcLn := GMAddPtr(SrcLn, ASource.RowSize); // Ptr(LongInt(n1)+Dst.RowSize); DstLn := GMAddPtr(DstLn, RowSize); // Ptr(LongInt(n2)+RowSize); end; } {for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Tmp.b:=Tmp.b xor 255; Tmp.g:=Tmp.g xor 255; Tmp.r:=Tmp.r xor 255; Inc(Tmp); end; end; procedure TGMFastRGBBmp.CopyRect(Dst:TGMFastBMPBase;x,y,w,h,sx,sy:LongInt); var n1,n2: Pointer; i: LongInt; begin if x<0 then begin Dec(sx,x); Inc(w,x); x:=0; end; if y<0 then begin Dec(sy,y); Inc(h,y); y:=0; end; if sx<0 then begin Dec(x,sx); Inc(w,sx); sx:=0; end; if sy<0 then begin Dec(y,sy); Inc(h,sy); sy:=0; end; if(sx>Width-1)or(sy>Height-1)then Exit; if sx+w>Width then Dec(w,(sx+w)-(Width)); if sy+h>Height then Dec(h,(sy+h)-(Height)); if x+w>Dst.Width then Dec(w,(x+w)-(Dst.Width)); if y+h>Dst.Height then Dec(h,(y+h)-(Dst.Height)); n1:=@Dst.Pixels[y,x]; n2:=@Pixels[sy,sx]; for i:=0 to h-1 do begin CopyMemory(n1,n2,w*3); n1:=Ptr(LongInt(n1)+Dst.RowSize); n2:=Ptr(LongInt(n2)+RowSize); end; end;} {procedure TGMFastRGBBmp.SetInterface(fWidth,fHeight:LongInt;pBits:Pointer); var x: LongInt; i: LongInt; begin Width:=fWidth; Height:=Abs(fHeight); FBmpInfo.bmiHeader.biWidth:=fWidth; FBmpInfo.bmiHeader.biHeight:=fHeight; RowSize:=((Width*24+31)shr 5)shl 2; Gap:=Width mod 4; MemSize:=RowSize*Height; ReallocMem(Pixels,Height*4); Bits:=pBits; x:=LongInt(Bits); for i:=0 to fHeight-1 do begin Pixels[i]:=Pointer(x); Inc(x,RowSize); end; end;} {procedure TGMFastRGBBmp.TileDraw(fdc,x,y,w,h:LongInt); var wd,hd, hBmp, memDC: LongInt; begin if(Width=0)or(Height=0)then Exit; memDC:=CreateCompatibleDC(fdc); hBmp:=CreateCompatibleBitmap(fdc,w,h); SelectObject(memDC,hBmp); Draw(memDC,0,0); wd:=Width; hd:=Height; while wd<w do begin BitBlt(memDC,wd,0,wd*2,h,memDC,0,0,SRCCOPY); Inc(wd,wd); end; while hd<h do begin BitBlt(memDC,0,hd,w,hd*2,memDC,0,0,SRCCOPY); Inc(hd,hd); end; BitBlt(fdc,x,y,w,h,memDC,0,0,SRCCOPY); DeleteDC(memDC); DeleteObject(hBmp); end;} {procedure TGMFastRGBBmp.Resize(Dst:TGMFastBMPBase); var xCount, yCount, x,y,xP,yP, xD,yD, yiScale, xiScale: LongInt; xScale, yScale: Single; Read, Line: PRGBLine; Tmp: TRGBColor; pc: PRGBColor; begin if(Dst.Width=0)or(Dst.Height=0)then Exit; if(Dst.Width=Width)and(Dst.Height=Height)then begin CopyMemory(Dst.Bits,Bits,MemSize); Exit; end; xScale:=Dst.Width/Width; yScale:=Dst.Height/Height; if(xScale<1)or(yScale<1)then begin // shrinking xiScale:=(Width shl 16) div Dst.Width; yiScale:=(Height shl 16) div Dst.Height; yP:=0; for y:=0 to Dst.Height-1 do begin xP:=0; read:=Pixels[yP shr 16]; pc:=@Dst.Pixels[y,0]; for x:=0 to Dst.Width-1 do begin pc^:=Read[xP shr 16]; Inc(pc); Inc(xP,xiScale); end; Inc(yP,yiScale); end; end else // zooming begin yiScale:=Round(yScale+0.5); xiScale:=Round(xScale+0.5); GetMem(Line,Dst.Width*3); for y:=0 to Height-1 do begin yP:=Trunc(yScale*y); Read:=Pixels[y]; for x:=0 to Width-1 do begin xP:=Trunc(xScale*x); Tmp:=Read[x]; for xCount:=0 to xiScale-1 do begin xD:=xCount+xP; if xD>=Dst.Width then Break; Line[xD]:=Tmp; end; end; for yCount:=0 to yiScale-1 do begin yD:=yCount+yP; if yD>=Dst.Height then Break; CopyMemory(Dst.Pixels[yD],Line,Dst.Width*3); end; end; FreeMem(Line); end; end;} // huge thanks to Vit Kovalcik for this awesome function! // performs a fast bilinear interpolation <vkovalcik@iname.com> {procedure TGMFastRGBBmp.SmoothResize(Dst:TGMFastBMPBase); var x,y,xP,yP, yP2,xP2: LongInt; Read,Read2: PRGBLine; t,z,z2,iz2: LongInt; pc:PRGBColor; w1,w2,w3,w4: LongInt; Col1,Col2: PRGBColor; begin if(Dst.Width<1)or(Dst.Height<1)then Exit; if Width=1 then begin Resize(Dst); Exit; end; if(Dst.Width=Width)and(Dst.Height=Height)then begin CopyMemory(Dst.Bits,Bits,MemSize); Exit; end; xP2:=((Width-1)shl 15)div Dst.Width; yP2:=((Height-1)shl 15)div Dst.Height; yP:=0; for y:=0 to Dst.Height-1 do begin xP:=0; Read:=Pixels[yP shr 15]; if yP shr 16<Height-1 then Read2:=Pixels[yP shr 15+1] else Read2:=Pixels[yP shr 15]; pc:=@Dst.Pixels[y,0]; z2:=yP and $7FFF; iz2:=$8000-z2; for x:=0 to Dst.Width-1 do begin t:=xP shr 15; Col1:=@Read[t]; Col2:=@Read2[t]; z:=xP and $7FFF; w2:=(z*iz2)shr 15; w1:=iz2-w2; w4:=(z*z2)shr 15; w3:=z2-w4; pc.b:= (Col1.b*w1+PRGBColor(LongInt(Col1)+3).b*w2+ Col2.b*w3+PRGBColor(LongInt(Col2)+3).b*w4)shr 15; pc.g:= (Col1.g*w1+PRGBColor(LongInt(Col1)+3).g*w2+ Col2.g*w3+PRGBColor(LongInt(Col2)+3).g*w4)shr 15; pc.r:= (Col1.r*w1+PRGBColor(LongInt(Col1)+3).r*w2+ Col2.r*w3+PRGBColor(LongInt(Col2)+3).r*w4)shr 15; Inc(pc); Inc(xP,xP2); end; Inc(yP,yP2); end; end;} {procedure TGMFastRGBBmp.CopyRect(Dst:TGMFastBMPBase;x,y,w,h,sx,sy:LongInt); var n1,n2: Pointer; i: LongInt; begin if x<0 then begin Dec(sx,x); Inc(w,x); x:=0; end; if y<0 then begin Dec(sy,y); Inc(h,y); y:=0; end; if sx<0 then begin Dec(x,sx); Inc(w,sx); sx:=0; end; if sy<0 then begin Dec(y,sy); Inc(h,sy); sy:=0; end; if(sx>Width-1)or(sy>Height-1)then Exit; if sx+w>Width then Dec(w,(sx+w)-(Width)); if sy+h>Height then Dec(h,(sy+h)-(Height)); if x+w>Dst.Width then Dec(w,(x+w)-(Dst.Width)); if y+h>Dst.Height then Dec(h,(y+h)-(Dst.Height)); n1:=@Dst.Pixels[y,x]; n2:=@Pixels[sy,sx]; for i:=0 to h-1 do begin CopyMemory(n1,n2,w*3); n1:=Ptr(LongInt(n1)+Dst.RowSize); n2:=Ptr(LongInt(n2)+RowSize); end; end;} {procedure TGMFastRGBBmp.Tile(Dst:TGMFastBMPBase); var w,h,cy,cx: LongInt; begin if(Dst.Width=0)or(Dst.Height=0)or (Width=0)or(Height=0)then Exit; CopyRect(Dst,0,0,Width,Height,0,0); w:=Width; h:=Height; cx:=Dst.Width; cy:=Dst.Height; while w<cx do begin Dst.CopyRect(Dst,w,0,w*2,h,0,0); Inc(w,w); end; while h<cy do begin Dst.CopyRect(Dst,0,h,w,h*2,0,0); Inc(h,h); end; end;} // Vit's function, accurate to 256^3! {function TGMFastRGBBmp.CountColors:LongInt; type TSpace = array[0..255,0..255,0..31]of Byte; PSpace =^TSpace; var x,y: LongInt; Tmp: PRGBColor; Count: LongInt; Buff: PByte; Test: Byte; Space: PSpace; begin New(Space); FillByte(Space^,SizeOf(TSpace),0); Tmp:=Bits; Count:=0; for y:=0 to Height-1 do begin for x:=0 to Width-1 do begin Buff:=@Space^[Tmp.r,Tmp.g,Tmp.b shr 3]; Test:=(1 shl(Tmp.b and 7)); if(Buff^ and Test)=0 then begin Inc(Count); Buff^:=Buff^ or Test; end; Inc(Tmp); end; Tmp:=Ptr(LongInt(Tmp)+Gap); end; Result:=Count; Dispose(Space); end;} { -------------------------- } { ---- Image Operations ---- } { -------------------------- } procedure FxRGB(const Bmp: TGMFastRGBBmp; const ra, ga, ba: LongInt; const Bounds: TRect); var Table: array [0..255] of TRGBColor; x, y: LongInt; Tmp: PRGBColor; i: Byte; begin LimitBounds(Bmp, @Bounds); for i:=0 to 255 do begin Table[i].b:=IntToByte(i+ba); Table[i].g:=IntToByte(i+ga); Table[i].r:=IntToByte(i+ra); end; for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Tmp.b:=Table[Tmp.b].b; Tmp.g:=Table[Tmp.g].g; Tmp.r:=Table[Tmp.r].r; Inc(Tmp); end; end; end; procedure FxContrast(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var x, y: LongInt; Table: array [0..255] of Byte; Tmp: PRGBColor; i: Byte; begin LimitBounds(Bmp, @Bounds); for i:=0 to 126 do begin y:=(Abs(128-i)*Amount) div 256; Table[i]:=IntToByte(i-y); end; for i:=127 to 255 do begin y:=(Abs(128-i)*Amount) div 256; Table[i]:=IntToByte(i+y); end; for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Tmp.b:=Table[Tmp.b]; Tmp.g:=Table[Tmp.g]; Tmp.r:=Table[Tmp.r]; Inc(Tmp); end; end; end; procedure FxSaturation(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var Grays: array[0..767]of LongInt; Alpha: array[0..255]of Word; Gray, x, y: LongInt; pc: PRGBColor; i: Byte; begin LimitBounds(Bmp, @Bounds); for i:=0 to 255 do Alpha[i]:=(i*Amount)shr 8; x:=0; for i:=0 to 255 do begin Gray:=i-Alpha[i]; Grays[x]:=Gray; Inc(x); Grays[x]:=Gray; Inc(x); Grays[x]:=Gray; Inc(x); end; for y:=Bounds.Top to Bounds.Bottom-1 do begin pc := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Gray:=Grays[pc.r+pc.g+pc.b]; pc.b:=IntToByte(Gray+Alpha[pc.b]); pc.g:=IntToByte(Gray+Alpha[pc.g]); pc.r:=IntToByte(Gray+Alpha[pc.r]); Inc(pc); end; end; end; procedure FxLightness(const Bmp: TGMFastRGBBmp; Amount: LongInt; const Bounds: TRect); var x, y: LongInt; Table: array [0..255] of Byte; Tmp: PRGBColor; i: Byte; begin LimitBounds(Bmp, @Bounds); if Amount<0 then begin Amount:=-Amount; for i:=0 to 255 do Table[i]:=IntToByte(i-((Amount*i)shr 8)); end else for i:=0 to 255 do Table[i]:=IntToByte(i+((Amount*(i xor 255))shr 8)); for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Tmp.b:=Table[Tmp.b]; Tmp.g:=Table[Tmp.g]; Tmp.r:=Table[Tmp.r]; Inc(Tmp); end; end; end; procedure FxHFlip(const Bmp: TGMFastRGBBmp; const Bounds: TRect); var w, x, y: LongInt; Tmp: TRGBColor; Line: PRGBLine; begin LimitBounds(Bmp, @Bounds); w:=GMRectSize(Bounds).x-1; Line:=Bmp.Pixels[Bounds.Top]; for y:=Bounds.Top to Bounds.Bottom-1 do begin for x:=0 to w div 2 do begin Tmp:=Line[Bounds.Left+x]; Line[Bounds.Left+x] := Line[Bounds.Right-x-1]; Line[Bounds.Right-x-1] := Tmp; end; //Line := Ptr(PtrInt(Line)+Bmp.RowSize); Line := Pointer(PtrInt(Line)+Bmp.RowSize); end; end; procedure FxVFlip(const Bmp: TGMFastRGBBmp; const Bounds: TRect); var y, h, w: LongInt; p1, p2, Line: PRGBColor; begin LimitBounds(Bmp, @Bounds); w := (Bounds.Right - Bounds.Left) * cRGBsz; GetMem(Line, w); try h:=Bounds.Bottom - Bounds.Top-1; for y:=0 to h div 2 do begin p1 := @Bmp.Pixels[Bounds.Top+y, Bounds.Left]; p2 := @Bmp.Pixels[Bounds.Bottom-y-1, Bounds.Left]; CopyMemory(Line, p1 , w); CopyMemory(p1, p2, w); CopyMemory(p2, Line, w); end; finally FreeMem(Line); end; end; procedure FxEmboss(const Bmp: TGMFastRGBBmp; const Bounds: TRect); //const c2szRGB = 2 * cRGBsz; var x, y, w: LongInt; p1, p2: PRGBColor; Line: PRGBLine; begin LimitBounds(Bmp, @Bounds); w := Bounds.Right - Bounds.Left; GetMem(Line, w * cRGBsz); try CopyMemory(Line, @Bmp.Pixels[Bounds.Bottom-1, Bounds.Left], w * cRGBsz); for y:=Bounds.Top to Bounds.Bottom-1 do begin p1 := @Bmp.Pixels[y, Bounds.Left]; if y < Bounds.Bottom-2 then p2 := @Bmp.Pixels[y+1, Bounds.Left+1] else p2 := GMAddPtr(Line, cRGBsz); for x:=Bounds.Left to Bounds.Right-1 do begin p1.b:=(p1.b+(p2.b xor $FF))shr 1; p1.g:=(p1.g+(p2.g xor $FF))shr 1; p1.r:=(p1.r+(p2.r xor $FF))shr 1; Inc(p1); if (y < Bounds.Bottom-2) and (x < Bounds.Right-2) then Inc(p2); end; end; finally FreeMem(Line); end; end; procedure FxSpray(const Bmp, Dst: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var r, x, y: LongInt; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do for x:=Bounds.Left to Bounds.Right-1 do begin r:=Random(Amount); Dst.Pixels[y,x]:= Bmp.Pixels[TrimInt(y+(r-Random(r*2)),Bounds.Top,Bounds.Bottom-1), TrimInt(x+(r-Random(r*2)),Bounds.Left,Bounds.Right-1)]; end; end; procedure FxInvert(const Bmp: TGMFastRGBBmp; const Bounds: TRect); var x, y: LongInt; Tmp: PRGBColor; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin Tmp.b:=Tmp.b xor 255; Tmp.g:=Tmp.g xor 255; Tmp.r:=Tmp.r xor 255; Inc(Tmp); end; end; end; procedure FxGrayscale(const Bmp: TGMFastRGBBmp; const Bounds: TRect); var x, y: LongInt; g, i: Byte; Tmp: PRGBColor; // Div3: array [0..767] of Byte; begin LimitBounds(Bmp, @Bounds); //x:=0; //for i:=0 to 255 do // begin // Div3[x]:=i; Inc(x); // Div3[x]:=i; Inc(x); // Div3[x]:=i; Inc(x); // end; for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin g := Round(Tmp.r * 0.3 + Tmp.g * 0.59 + Tmp.b * 0.11); // g:=Div3[Tmp.b+Tmp.g+Tmp.r]; Tmp.b:=g; Tmp.g:=g; Tmp.r:=g; Inc(Tmp); end; end; end; procedure FxRedEyeFilter(const Bmp: TGMFastRGBBmp; const ThresHold: LongInt; const Bounds: TRect); const rf = 0.5133333; gf = 1; bf = 0.1933333; // Ammount = 12; var x, y, r, g, b: LongInt; Tmp: PRGBColor; //Col: TRGBColor; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do begin Tmp := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin r := Round(Tmp.r * rf); g := Round(Tmp.g * gf); b := Round(Tmp.b * bf); if (r >= g - ThresHold) and (r >= b -ThresHold) then Tmp.r := IntToByte(Round((g + b) / (2 * rf))); Inc(Tmp); end; end; end; procedure FxSharpen(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var Lin0, Lin1, Lin2: PRGBLine; pc: PRGBColor; cx, x, y: LongInt; Buf: array [0..8] of TRGBColor; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do begin Lin0 := Bmp.Pixels[TrimInt(y-Amount, 0, Bounds.Bottom-1)]; Lin1 := Bmp.Pixels[y]; Lin2 := Bmp.Pixels[TrimInt(y+Amount, 0, Bounds.Bottom-1)]; pc := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin cx:=TrimInt(x-Amount, 0, Bounds.Right-1); 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:=TrimInt(x+Amount, 0, Bounds.Right-1); Buf[6]:=Lin0[cx]; Buf[7]:=Lin1[cx]; Buf[8]:=Lin2[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); Inc(pc); end; end; end; procedure FxGaussianSharpen(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var i: LongInt; begin for i:=Amount downto 1 do FxSharpen(Bmp, i, Bounds); end; procedure FxSplitBlur(const Bmp: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var Lin1, Lin2: PRGBLine; pc: PRGBColor; cx, x, y: LongInt; Buf: array [0..3] of TRGBColor; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do begin Lin1:=Bmp.Pixels[TrimInt(y+Amount, 0, Bounds.Bottom-1)]; Lin2:=Bmp.Pixels[TrimInt(y-Amount, 0, Bounds.Bottom-1)]; pc := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin cx:=TrimInt(x+Amount, 0, Bounds.Right-1); Buf[0]:=Lin1[cx]; Buf[1]:=Lin2[cx]; cx:=TrimInt(x-Amount, 0, Bounds.Right-1); Buf[2]:=Lin1[cx]; Buf[3]:=Lin2[cx]; pc.b:=(Buf[0].b+Buf[1].b+Buf[2].b+Buf[3].b)shr 2; pc.g:=(Buf[0].g+Buf[1].g+Buf[2].g+Buf[3].g)shr 2; pc.r:=(Buf[0].r+Buf[1].r+Buf[2].r+Buf[3].r)shr 2; Inc(pc); end; end; end; procedure FxGaussianBlur(const Bmp: TGMFastRGBBmp; const Distance: LongInt; const Bounds: TRect); var i: LongInt; begin for i:=1 to Distance do FxSplitBlur(Bmp, i, Bounds); end; procedure FxSoftenEdges(const Bmp: TGMFastRGBBmp; const Bounds: TRect); var pc: PRGBColor; x, y: LongInt; Clr1, Clr2: TRGBColor; procedure AssignColor; begin if CompareRGBColors(Clr1, Clr2) and not CompareRGBColors(Clr1, pc^, 50) then begin // pc.r := ((Clr1.r + Clr2.r + pc.r) div 3); // pc.g := ((Clr1.g + Clr2.g + pc.g) div 3); // pc.b := ((Clr1.b + Clr2.b + pc.b) div 3); pc.r := ((Clr2.r + pc.r) shr 1); pc.g := ((Clr2.g + pc.g) shr 1); pc.b := ((Clr2.b + pc.b) shr 1); end; end; begin LimitBounds(Bmp, @Bounds); for y:=Bounds.Top to Bounds.Bottom-1 do begin pc := @Bmp.Pixels[y, Bounds.Left]; for x:=Bounds.Left to Bounds.Right-1 do begin if (y > Bounds.Top) and (x > Bounds.Left) then begin Clr1 := Bmp.Pixels[y-1, x]; Clr2 := Bmp.Pixels[y, x-1]; AssignColor; end; if (y > Bounds.Top) and (x < Bounds.Right-1) then begin Clr1 := Bmp.Pixels[y-1, x]; Clr2 := Bmp.Pixels[y, x+1]; AssignColor; end; if (y < Bounds.Bottom-1) and (x > Bounds.Left) then begin Clr1 := Bmp.Pixels[y+1, x]; Clr2 := Bmp.Pixels[y, x-1]; AssignColor; end; if (y < Bounds.Bottom-1) and (x < Bounds.Right-1) then begin Clr1 := Bmp.Pixels[y+1, x]; Clr2 := Bmp.Pixels[y, x+1]; AssignColor; end; Inc(pc); end; end; end; procedure FxMosaic(const Bmp: TGMFastRGBBmp; const xAmount, yAmount: LongInt; const Bounds: TRect); var Delta, tx, ty, cx, cy, ix, iy, x, y: LongInt; Col: TRGBColor; Pix: PRGBColor; Line: PRGBLine; begin if(xAmount<1)or(yAmount<1)then Exit; ix:=(xAmount shr 1)+(xAmount and 1); iy:=(yAmount shr 1)+(yAmount and 1); y:=Bounds.Top; while y < Bounds.Bottom do begin x:=Bounds.Left; cy:=y+iy; if cy>=Bounds.Bottom then Line:=Bmp.Pixels[Bounds.Bottom-1] else Line:=Bmp.Pixels[cy]; if y+yAmount-1>=Bounds.Bottom then ty:=Bounds.Bottom-1-y else ty:=yAmount; while x < Bounds.Right do begin cx:=x+ix; if cx>=Bounds.Right then Col:=Line[Bounds.Right-1] else Col:=Line[cx]; if x+xAmount-1>=Bounds.Right then tx:=Bounds.Right-1-x else tx:=xAmount; Delta:=Bmp.RowSize-tx*3; //Pix:=Ptr(PtrInt(Bmp.Pixels[y])+x*3); Pix:=Pointer(PtrInt(Bmp.Pixels[y])+x*3); for cy:=1 to ty do begin for cx:=1 to tx do begin Pix^:=Col; Inc(Pix); end; //Pix:=Ptr(PtrInt(Pix)+Delta); Pix:=Pointer(PtrInt(Pix)+Delta); end; Inc(x,xAmount); end; Inc(y,yAmount); end; end; procedure FxFishEye(const Bmp, Dst: TGMFastRGBBmp; const Amount: Extended; const Bounds: TRect); var xmid,ymid : Single; fx,fy : Single; r1, r2 : Single; ifx, ify : LongInt; dx, dy : Single; rmax : Single; ty, tx : LongInt; weight_x, weight_y : array[0..1] of Single; weight : Single; new_red, new_green : LongInt; new_blue : LongInt; total_red, total_green : Single; total_blue : Single; ix, iy : LongInt; sli, slo : PRGBLine; begin LimitBounds(Bmp, @Bounds); IntersectRect((@Bounds)^, Bounds, Dst.Bounds); xmid := (Bounds.Left + Bounds.Right) /2; ymid := (Bounds.Top + Bounds.Bottom) /2; rmax := (Bounds.Right - Bounds.Left) * Amount; for ty := Bounds.Top to Bounds.Bottom-1 do begin for tx := Bounds.Left to Bounds.Right - 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 := Bounds.Right-1-(-ifx mod Bounds.Right) else if ifx > Bounds.Right-1 then ifx := ifx mod Bounds.Right; if ify < 0 then ify := Bounds.Bottom-1-(-ify mod Bounds.Bottom) else if ify > Bounds.Bottom-1 then ify := ify mod Bounds.Bottom; 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 < Bounds.Bottom then sli := Bmp.Pixels[ify + iy] else sli := Bmp.Pixels[Bounds.Bottom - ify - iy]; if ifx + ix < Bounds.Right 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^[Bounds.Right - ifx - ix].r; new_green := sli^[Bounds.Right - ifx - ix].g; new_blue := sli^[Bounds.Right - 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; slo := Dst.Pixels[ty]; slo^[tx].r := Round(total_red); slo^[tx].g := Round(total_green); slo^[tx].b := Round(total_blue); end; end; end; procedure FxTwist(const Bmp, Dst: TGMFastRGBBmp; const Amount: LongInt; const Bounds: TRect); var fxmid, fymid : Single; txmid, tymid : Single; fx,fy : Single; tx2, ty2 : Single; r : Single; theta : Single; ifx, ify : LongInt; dx, dy : Single; OFFSET : Single; ty, tx : LongInt; weight_x, weight_y : array[0..1] of Single; weight : Single; new_red, new_green : LongInt; new_blue : LongInt; total_red, total_green : Single; total_blue : Single; ix, iy : LongInt; sli, slo : PRGBLine; function ArcTan2(xt,yt : Single): Single; 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 LimitBounds(Bmp, @Bounds); IntersectRect((@Bounds)^, Bounds, Dst.Bounds); OFFSET := -(Pi/2); dx := Bounds.Right - Bounds.Left - 1; dy := Bounds.Bottom - Bounds.Top - 1; r := Sqrt(dx * dx + dy * dy); tx2 := Bounds.Left + r; ty2 := Bounds.Top + r; txmid := (Bounds.Left + Bounds.Right -1) / 2; //Adjust these to move center of rotation tymid := (Bounds.Top + Bounds.Bottom -1) / 2; //Adjust these to move ...... fxmid := txmid; fymid := tymid; if tx2 >= Bounds.Right then tx2 := Bounds.Right-1; if ty2 >= Bounds.Bottom then ty2 := Bounds.Bottom-1; for ty := Bounds.Top to Round(ty2) do begin for tx := Bounds.Left 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 := Bounds.Right-1-(-ifx mod Bounds.Right) else if ifx > Bounds.Right-1 then ifx := ifx mod Bounds.Right; if ify < 0 then ify := Bounds.Bottom-1-(-ify mod Bounds.Bottom) else if ify > Bounds.Bottom-1 then ify := ify mod Bounds.Bottom; 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 < Bounds.Bottom then sli := Bmp.Pixels[ify + iy] else sli := Bmp.Pixels[Bounds.Bottom - ify - iy]; if ifx + ix < Bounds.Right 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^[Bounds.Right - ifx - ix].r; new_green := sli^[Bounds.Right - ifx - ix].g; new_blue := sli^[Bounds.Right - 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; slo := Dst.Pixels[ty]; slo^[tx].r := Round(total_red); slo^[tx].g := Round(total_green); slo^[tx].b := Round(total_blue); end; end; end; {$R-} procedure FxAlphaBlend(const Dst, Src1, Src2: TGMFastRGBBmp; const Alpha: LongInt; const Bounds: TRect); var x, y, i: LongInt; c1, c2, c3: PRGBColor; Table: array [-255..255] of LongInt; begin {ToDo: FxAlphaBlend mit Bounds} //LimitBounds(Bmp, @Bounds); for i:=-255 to 255 do Table[i]:=(Alpha*i)shr 8; c1:=Dst.Bits; c2:=Src1.Bits; c3:=Src2.Bits; for y:=0 to Dst.Height-1 do begin for x:=0 to Dst.Width-1 do begin c1.b:=Table[c2.b-c3.b]+c3.b; c1.g:=Table[c2.g-c3.g]+c3.g; c1.r:=Table[c2.r-c3.r]+c3.r; Inc(c1); Inc(c2); Inc(c3); end; c1:=Pointer(PtrInt(c1)+Dst.RowGap); c2:=Pointer(PtrInt(c2)+Src1.RowGap); c3:=Pointer(PtrInt(c3)+Src2.RowGap); end; end; end.