From 4157568bdebe9ddfd84ca54de31a5fea49c8062c Mon Sep 17 00:00:00 2001 From: Wizzup? Date: Tue, 27 Oct 2009 01:03:37 +0000 Subject: [PATCH] Please use svn:eol-style native for every new file. git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@160 3f818213-9676-44b0-a9b4-5e4c4e03d09d --- Units/MMLAddon/PSInc/Wrappers/bitmap.inc | 510 ++--- Units/MMLAddon/PSInc/Wrappers/other.inc | 112 +- Units/MMLAddon/PSInc/Wrappers/window.inc | 96 +- Units/MMLAddon/PSInc/pscompile.inc | 272 +-- Units/MMLAddon/colourpicker.pas | 470 ++-- Units/MMLCore/bitmaps.pas | 1814 +++++++-------- Units/MMLCore/colour_conv.pas | 608 ++--- Units/MMLCore/finder.pas | 2558 +++++++++++----------- 8 files changed, 3220 insertions(+), 3220 deletions(-) diff --git a/Units/MMLAddon/PSInc/Wrappers/bitmap.inc b/Units/MMLAddon/PSInc/Wrappers/bitmap.inc index db309a4..a7f9d73 100644 --- a/Units/MMLAddon/PSInc/Wrappers/bitmap.inc +++ b/Units/MMLAddon/PSInc/Wrappers/bitmap.inc @@ -1,255 +1,255 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Bitmap.inc for the Mufasa Macro Library -} - -function CreateBitmap(w,h : integer):integer; -begin - result := CurrThread.Client.MBitmaps.CreateBMP(w,h); -end; - -procedure FreeBitmap(Number : integer); -begin - CurrThread.Client.MBitmaps.FreeBMP(Number); -end; - -procedure SaveBitmap(Bmp : integer; path : string); -begin; - CurrThread.Client.MBitmaps.Bmp[Bmp].SaveToFile(Path); -end; - -function BitmapFromString(Width,height : integer; Data : string) : integer; -begin; - Result := CurrThread.Client.MBitmaps.CreateBMPFromString(Width,Height,Data); -end; - -function LoadBitmap(Path : String) : integer; -begin; - Result := CurrThread.Client.MBitmaps.CreateBMPFromFile(Path); -end; - -procedure SetBitmapSize(Bmp,NewW,NewH : integer); -begin; - if (NewW>=0) and (NewH >=0) then - CurrThread.Client.MBitmaps.Bmp[Bmp].SetSize(NewW,NewH) - else - raise exception.createfmt('Wrong Width or Height in SetBitmapSize: (%d,%d)',[NewW,NewH]); -end; - -procedure StretchBitmapResize(Bmp,NewW,NewH : integer); -begin; - if (NewW>=0) and (NewH >=0) then - CurrThread.Client.MBitmaps.Bmp[Bmp].StretchResize(NewW,NewH) - else - raise exception.createfmt('Wrong Width or Height in ScretchResize: (%d,%d)',[NewW,NewH]); -end; - -procedure GetBitmapSize(Bmp : integer; var BmpW,BmpH : integer); -begin; - With CurrThread.Client.MBitmaps.Bmp[bmp] do - begin; - BmpW := width; - BmpH := Height; - end; -end; - -procedure SetBitmapName(Bmp : integer; name : string); -begin; - CurrThread.Client.MBitmaps.Bmp[Bmp].BmpName:= name; -end; - -function CreateMirroredBitmap(Bmp : integer) : integer; -begin; - Result := CurrThread.Client.MBitmaps.CreateMirroredBitmap(Bmp, MirrorWidth); -end; - -function CreateMirroredBitmapEx(Bmp : integer; MirrorStyle : TBmpMirrorStyle) : integer; -begin; - Result := CurrThread.Client.MBitmaps.CreateMirroredBitmap(Bmp,MirrorStyle); -end; - -function FastGetPixel(bmp,x,y : integer) : LongWord; -begin; - Result := CurrThread.Client.MBitmaps.Bmp[Bmp].FastGetPixel(x,y); -end; - -function FastGetPixels(bmp : integer; TPA : TPointArray) : TIntegerArray; -begin; - result := CurrThread.Client.MBitmaps.Bmp[Bmp].FastGetPixels(TPA); -end; - -procedure FastSetPixel(Bmp,x,y : integer; Color : TColor); -begin - CurrThread.Client.MBitmaps.Bmp[bmp].FastSetPixel(x,y,color); -end; - -procedure FastSetPixels(Bmp : integer; TPA : TPointArray; Colors : TIntegerArray); -begin; - CurrThread.Client.MBitmaps.Bmp[Bmp].FastSetPixels(TPA,Colors); -end; - -procedure FastDrawClear(bmp : integer; Color : TColor); -begin; - CurrThread.Client.MBitmaps.Bmp[bmp].FastDrawClear(Color); -end; - -procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer); -begin; - CurrThread.Client.MBitmaps.Bmp[SourceBitmap].FastDrawTransparent(x,y,CurrThread.Client.MBitmaps.Bmp[TargetBitmap]); -end; - -procedure SetTransparentColor(Bmp : integer; Color : TColor); -begin - CurrThread.Client.MBitmaps.Bmp[Bmp].SetTransparentColor(Color); -end; - -function GetTransparentColor(Bmp : integer) : TColor; -begin; - Result := CurrThread.Client.MBitmaps.Bmp[bmp].GetTransparentColor; -end; - -procedure FastReplaceColor(bmp: Integer; OldColor, NewColor: TColor); -begin - CurrThread.Client.MBitmaps.Bmp[Bmp].FastReplaceColor(OldColor,NewColor); -end; - -procedure ps_CopyClientToBitmap(bmp, xs, ys, xe, ye: Integer); -begin - CurrThread.Client.MBitmaps.GetBMP(bmp).CopyClientToBitmap(CurrThread.Client.MWindow, xs, ys, xe, ye); -end; - -function FindBitmap(Bitmap: integer; var x, y: Integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmap( MBitmaps.Bmp[bitmap],x,y); -end; - -function FindBitmapIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmapIn( MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye); -end; - -function FindBitmapToleranceIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmapToleranceIn( MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye,tolerance); -end; - - -function FindBitmapSpiral(bitmap: Integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmapSpiral(Mbitmaps.bmp[bitmap],x,y,xs,ys,xe,ye); -end; - -function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmapsSpiralTolerance(MBitmaps.Bmp[bitmap],x,y,points,xs,ys,xe,ye,tolerance); -end; - -function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean; -begin; - with CurrThread.Client do - result := MFinder.FindBitmapSpiralTolerance(MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye,tolerance); -end; - -function RotateBitmap(bitmap: Integer; angle: Extended): Integer; -begin; - with CurrThread.Client.MBitmaps do - begin; - Result := CreateBMP(0,0); - Bmp[Bitmap].RotateBitmap(angle,Bmp[result]); - end; -end; - -function Desaturate(Bitmap : integer) : integer; -begin; - with CurrThread.Client.MBitmaps do - begin; - result := CreateBMP(0,0); - Bmp[Bitmap].Desaturate(Bmp[result]); - end; -end; -procedure InvertBitmap(Bitmap : integer); -begin; - CurrThread.Client.MBitmaps.Bmp[Bitmap].Invert; -end; -function CopyBitmap(Bitmap : integer) : integer; -begin; - result := Currthread.Client.MBitmaps.CopyBMP(bitmap); -end; -function GreyScaleBitmap(Bitmap : integer) : integer; -begin; - with CurrThread.Client.MBitmaps do - begin; - result := CreateBMP(0,0); - Bmp[Bitmap].GreyScale(Bmp[result]); - end; -end; -function BrightnessBitmap(Bitmap,br : integer) : integer; -begin; - with CurrThread.Client.MBitmaps do - begin; - result := CreateBMP(0,0); - Bmp[Bitmap].Brightness(Bmp[result],br); - end; -end; -function ContrastBitmap(bitmap : integer; co : extended) : integer; -begin; - with CurrThread.Client.MBitmaps do - begin; - result := CreateBMP(0,0); - Bmp[Bitmap].Contrast(Bmp[result],co); - end; -end; - -function PosterizeBitmap(Bitmap : integer; po : integer) : integer; -begin; - with CurrThread.Client.MBitmaps do - begin - result := CreateBMP(0,0); - Bmp[bitmap].Posterize(Bmp[result],po); - end; -end; -function CreateBitmapMask(Bitmap : integer) : TMask; -begin; - result := CurrThread.Client.MBitmaps.Bmp[Bitmap].CreateTMask; -end; - -function FindMaskTolerance(mask: TMask; var x, y: Integer; xs,ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; -begin; - result := CurrThread.Client.MFinder.FindBitmapMaskTolerance(Mask,x,y,xs,ys,xe,ye,tolerance,contourtolerance); -end; -function FindBitmapMaskTolerance(mask: Integer; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; -begin; - Writeln('Better be using FindMaskTolerance in combination with CreateBitmapMask, more efficient.'); - with CurrThread.Client do - result := MFinder.FindBitmapMaskTolerance(MBitmaps.bmp[mask].CreateTMask,x,y,xs,ys,xe,ye,tolerance,contourtolerance); -end; - -function FindDeformedBitmapToleranceIn(bitmap: integer; var x, - y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; - AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; -begin; - result := CurrThread.Client.MFinder.FindDeformedBitmapToleranceIn(CurrThread.Client.MBitmaps.bmp[Bitmap],x,y,xs,ys,xe,ye,tolerance,range,AllowPartialAccuracy,accuracy); -end; +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Bitmap.inc for the Mufasa Macro Library +} + +function CreateBitmap(w,h : integer):integer; +begin + result := CurrThread.Client.MBitmaps.CreateBMP(w,h); +end; + +procedure FreeBitmap(Number : integer); +begin + CurrThread.Client.MBitmaps.FreeBMP(Number); +end; + +procedure SaveBitmap(Bmp : integer; path : string); +begin; + CurrThread.Client.MBitmaps.Bmp[Bmp].SaveToFile(Path); +end; + +function BitmapFromString(Width,height : integer; Data : string) : integer; +begin; + Result := CurrThread.Client.MBitmaps.CreateBMPFromString(Width,Height,Data); +end; + +function LoadBitmap(Path : String) : integer; +begin; + Result := CurrThread.Client.MBitmaps.CreateBMPFromFile(Path); +end; + +procedure SetBitmapSize(Bmp,NewW,NewH : integer); +begin; + if (NewW>=0) and (NewH >=0) then + CurrThread.Client.MBitmaps.Bmp[Bmp].SetSize(NewW,NewH) + else + raise exception.createfmt('Wrong Width or Height in SetBitmapSize: (%d,%d)',[NewW,NewH]); +end; + +procedure StretchBitmapResize(Bmp,NewW,NewH : integer); +begin; + if (NewW>=0) and (NewH >=0) then + CurrThread.Client.MBitmaps.Bmp[Bmp].StretchResize(NewW,NewH) + else + raise exception.createfmt('Wrong Width or Height in ScretchResize: (%d,%d)',[NewW,NewH]); +end; + +procedure GetBitmapSize(Bmp : integer; var BmpW,BmpH : integer); +begin; + With CurrThread.Client.MBitmaps.Bmp[bmp] do + begin; + BmpW := width; + BmpH := Height; + end; +end; + +procedure SetBitmapName(Bmp : integer; name : string); +begin; + CurrThread.Client.MBitmaps.Bmp[Bmp].BmpName:= name; +end; + +function CreateMirroredBitmap(Bmp : integer) : integer; +begin; + Result := CurrThread.Client.MBitmaps.CreateMirroredBitmap(Bmp, MirrorWidth); +end; + +function CreateMirroredBitmapEx(Bmp : integer; MirrorStyle : TBmpMirrorStyle) : integer; +begin; + Result := CurrThread.Client.MBitmaps.CreateMirroredBitmap(Bmp,MirrorStyle); +end; + +function FastGetPixel(bmp,x,y : integer) : LongWord; +begin; + Result := CurrThread.Client.MBitmaps.Bmp[Bmp].FastGetPixel(x,y); +end; + +function FastGetPixels(bmp : integer; TPA : TPointArray) : TIntegerArray; +begin; + result := CurrThread.Client.MBitmaps.Bmp[Bmp].FastGetPixels(TPA); +end; + +procedure FastSetPixel(Bmp,x,y : integer; Color : TColor); +begin + CurrThread.Client.MBitmaps.Bmp[bmp].FastSetPixel(x,y,color); +end; + +procedure FastSetPixels(Bmp : integer; TPA : TPointArray; Colors : TIntegerArray); +begin; + CurrThread.Client.MBitmaps.Bmp[Bmp].FastSetPixels(TPA,Colors); +end; + +procedure FastDrawClear(bmp : integer; Color : TColor); +begin; + CurrThread.Client.MBitmaps.Bmp[bmp].FastDrawClear(Color); +end; + +procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer); +begin; + CurrThread.Client.MBitmaps.Bmp[SourceBitmap].FastDrawTransparent(x,y,CurrThread.Client.MBitmaps.Bmp[TargetBitmap]); +end; + +procedure SetTransparentColor(Bmp : integer; Color : TColor); +begin + CurrThread.Client.MBitmaps.Bmp[Bmp].SetTransparentColor(Color); +end; + +function GetTransparentColor(Bmp : integer) : TColor; +begin; + Result := CurrThread.Client.MBitmaps.Bmp[bmp].GetTransparentColor; +end; + +procedure FastReplaceColor(bmp: Integer; OldColor, NewColor: TColor); +begin + CurrThread.Client.MBitmaps.Bmp[Bmp].FastReplaceColor(OldColor,NewColor); +end; + +procedure ps_CopyClientToBitmap(bmp, xs, ys, xe, ye: Integer); +begin + CurrThread.Client.MBitmaps.GetBMP(bmp).CopyClientToBitmap(CurrThread.Client.MWindow, xs, ys, xe, ye); +end; + +function FindBitmap(Bitmap: integer; var x, y: Integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmap( MBitmaps.Bmp[bitmap],x,y); +end; + +function FindBitmapIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmapIn( MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye); +end; + +function FindBitmapToleranceIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmapToleranceIn( MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye,tolerance); +end; + + +function FindBitmapSpiral(bitmap: Integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmapSpiral(Mbitmaps.bmp[bitmap],x,y,xs,ys,xe,ye); +end; + +function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmapsSpiralTolerance(MBitmaps.Bmp[bitmap],x,y,points,xs,ys,xe,ye,tolerance); +end; + +function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean; +begin; + with CurrThread.Client do + result := MFinder.FindBitmapSpiralTolerance(MBitmaps.Bmp[bitmap],x,y,xs,ys,xe,ye,tolerance); +end; + +function RotateBitmap(bitmap: Integer; angle: Extended): Integer; +begin; + with CurrThread.Client.MBitmaps do + begin; + Result := CreateBMP(0,0); + Bmp[Bitmap].RotateBitmap(angle,Bmp[result]); + end; +end; + +function Desaturate(Bitmap : integer) : integer; +begin; + with CurrThread.Client.MBitmaps do + begin; + result := CreateBMP(0,0); + Bmp[Bitmap].Desaturate(Bmp[result]); + end; +end; +procedure InvertBitmap(Bitmap : integer); +begin; + CurrThread.Client.MBitmaps.Bmp[Bitmap].Invert; +end; +function CopyBitmap(Bitmap : integer) : integer; +begin; + result := Currthread.Client.MBitmaps.CopyBMP(bitmap); +end; +function GreyScaleBitmap(Bitmap : integer) : integer; +begin; + with CurrThread.Client.MBitmaps do + begin; + result := CreateBMP(0,0); + Bmp[Bitmap].GreyScale(Bmp[result]); + end; +end; +function BrightnessBitmap(Bitmap,br : integer) : integer; +begin; + with CurrThread.Client.MBitmaps do + begin; + result := CreateBMP(0,0); + Bmp[Bitmap].Brightness(Bmp[result],br); + end; +end; +function ContrastBitmap(bitmap : integer; co : extended) : integer; +begin; + with CurrThread.Client.MBitmaps do + begin; + result := CreateBMP(0,0); + Bmp[Bitmap].Contrast(Bmp[result],co); + end; +end; + +function PosterizeBitmap(Bitmap : integer; po : integer) : integer; +begin; + with CurrThread.Client.MBitmaps do + begin + result := CreateBMP(0,0); + Bmp[bitmap].Posterize(Bmp[result],po); + end; +end; +function CreateBitmapMask(Bitmap : integer) : TMask; +begin; + result := CurrThread.Client.MBitmaps.Bmp[Bitmap].CreateTMask; +end; + +function FindMaskTolerance(mask: TMask; var x, y: Integer; xs,ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; +begin; + result := CurrThread.Client.MFinder.FindBitmapMaskTolerance(Mask,x,y,xs,ys,xe,ye,tolerance,contourtolerance); +end; +function FindBitmapMaskTolerance(mask: Integer; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; +begin; + Writeln('Better be using FindMaskTolerance in combination with CreateBitmapMask, more efficient.'); + with CurrThread.Client do + result := MFinder.FindBitmapMaskTolerance(MBitmaps.bmp[mask].CreateTMask,x,y,xs,ys,xe,ye,tolerance,contourtolerance); +end; + +function FindDeformedBitmapToleranceIn(bitmap: integer; var x, + y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; + AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; +begin; + result := CurrThread.Client.MFinder.FindDeformedBitmapToleranceIn(CurrThread.Client.MBitmaps.bmp[Bitmap],x,y,xs,ys,xe,ye,tolerance,range,AllowPartialAccuracy,accuracy); +end; diff --git a/Units/MMLAddon/PSInc/Wrappers/other.inc b/Units/MMLAddon/PSInc/Wrappers/other.inc index 9a97e44..26d6438 100644 --- a/Units/MMLAddon/PSInc/Wrappers/other.inc +++ b/Units/MMLAddon/PSInc/Wrappers/other.inc @@ -1,56 +1,56 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Other.inc for the Mufasa Macro Library -} - -procedure Wait(t: Integer); -begin - Sleep(t); -end; - -procedure SaveScreenshot(FileName: string); -var - w,h : integer; -begin; - with CurrThread.Client.MWindow do - begin; - GetDimensions(w,h); - with CopyClientToBitmap(0,0,w-1,h-1) do - begin; - SaveToFile(FileName); - Free; - end; - end; -end; - -function CreateForm : TForm; -begin; - result := TForm.Create(nil); -end; -function CreateButton(Owner : TComponent) : TButton; -begin; - Result := TButton.Create(Owner); -end; - -function Distance(x1, y1, x2, y2: Integer): Integer; -begin; - Result := Round(Sqrt(Sqr(x2-x1) + Sqr(y2-y1))); -end; +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Other.inc for the Mufasa Macro Library +} + +procedure Wait(t: Integer); +begin + Sleep(t); +end; + +procedure SaveScreenshot(FileName: string); +var + w,h : integer; +begin; + with CurrThread.Client.MWindow do + begin; + GetDimensions(w,h); + with CopyClientToBitmap(0,0,w-1,h-1) do + begin; + SaveToFile(FileName); + Free; + end; + end; +end; + +function CreateForm : TForm; +begin; + result := TForm.Create(nil); +end; +function CreateButton(Owner : TComponent) : TButton; +begin; + Result := TButton.Create(Owner); +end; + +function Distance(x1, y1, x2, y2: Integer): Integer; +begin; + Result := Round(Sqrt(Sqr(x2-x1) + Sqr(y2-y1))); +end; diff --git a/Units/MMLAddon/PSInc/Wrappers/window.inc b/Units/MMLAddon/PSInc/Wrappers/window.inc index 289739a..01b0a5b 100644 --- a/Units/MMLAddon/PSInc/Wrappers/window.inc +++ b/Units/MMLAddon/PSInc/Wrappers/window.inc @@ -1,48 +1,48 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - window.inc for the Mufasa Macro Library -} - -procedure SetDesktopAsClient; -begin; - CurrThread.Client.MWindow.SetDesktop; -end; - -procedure SetTargetBitmap(bitmap: Integer); -begin; - With CurrThread.Client do - MWindow.SetTarget(MBitmaps.Bmp[Bitmap]); -end; - -procedure GetClientDimensions(var w, h: integer); -begin - CurrThread.Client.MWindow.GetDimensions(w, h); -end; - -function Freeze: boolean; -begin - result := CurrThread.Client.MWindow.Freeze(); -end; - -function Unfreeze: boolean; -begin - result := CurrThread.Client.MWindow.Unfreeze; -end; +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + window.inc for the Mufasa Macro Library +} + +procedure SetDesktopAsClient; +begin; + CurrThread.Client.MWindow.SetDesktop; +end; + +procedure SetTargetBitmap(bitmap: Integer); +begin; + With CurrThread.Client do + MWindow.SetTarget(MBitmaps.Bmp[Bitmap]); +end; + +procedure GetClientDimensions(var w, h: integer); +begin + CurrThread.Client.MWindow.GetDimensions(w, h); +end; + +function Freeze: boolean; +begin + result := CurrThread.Client.MWindow.Freeze(); +end; + +function Unfreeze: boolean; +begin + result := CurrThread.Client.MWindow.Unfreeze; +end; diff --git a/Units/MMLAddon/PSInc/pscompile.inc b/Units/MMLAddon/PSInc/pscompile.inc index ecea66d..dd2473d 100644 --- a/Units/MMLAddon/PSInc/pscompile.inc +++ b/Units/MMLAddon/PSInc/pscompile.inc @@ -1,136 +1,136 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - PSCompile.inc for the Mufasa Macro Library -} - -Sender.Comp.AddConstantN('AppPath','string').SetString(CurrThread.AppPath); -Sender.Comp.AddConstantN('ScriptPath','string').SetString(CurrThread.ScriptPath); -Sender.Comp.AddTypeS('TIntegerArray', 'Array of integer'); -Sender.Comp.AddTypeS('TPointArray','Array of TPoint'); -Sender.Comp.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)'); -Sender.Comp.AddTypeS('TMask','record White, Black : TPointArray; WhiteHi,BlackHi : integer; W,H : integer;end;'); - - -Sender.Comp.AddTypes('TDTMPointDef', 'record x, y, Color, Tolerance, AreaSize, AreaShape: integer; end;'); -Sender.Comp.AddTypes('TDTMPointDefArray', 'Array Of TDTMPointDef;'); -Sender.Comp.AddTypes('TDTM','record MainPoint: TDTMPointDef; SubPoints: TDTMPointDefArray; end;'); -Sender.Comp.AddTypeS('pDTM','record p: TPointArray; c, t, asz, ash: TIntegerArray; end'); -Sender.Comp.AddTypeS('T2DExtendedArray', 'array of array of extended'); - -Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;'); -Sender.AddFunction(@psWriteln,'procedure writeln(s : string);'); - -{ DTM } - -Sender.AddFunction(@PrintpDTM, 'Procedure PrintpDTM(tDTM : pDTM);'); -Sender.AddFunction(@ps_GetDTM ,'function GetDTM(index: Integer; var dtm: pDTM): Boolean;'); -Sender.AddFunction(@pDTMToTDTM, 'Function pDTMToTDTM(Const DTM: pDTM): TDTM;'); -Sender.AddFunction(@tDTMTopDTM, 'Function tDTMTopDTM(Const DTM: TDTM): pDTM;'); -Sender.AddFunction(@ps_DTMFromString, 'function DTMFromString(DTMString: String): Integer;'); -Sender.AddFunction(@ps_FreeDTM, 'procedure FreeDTM(DTM: Integer);'); -Sender.AddFunction(@ps_FindDTM, 'function FindDTM(DTM: Integer; var x, y: Integer; x1, y1, x2, y2: Integer): Boolean;'); -Sender.AddFunction(@ps_FindDTMs, 'function FindDTMs(DTM: Integer; var p: TPointArray; x1, y1, x2, y2: Integer): Boolean;'); -Sender.AddFunction(@ps_FindDTMRotated, 'function FindDTMRotated(DTM: Integer; var x, y: Integer; x1, y1, x2, y2: Integer; sAngle, eAngle, aStep: Extended; var aFound: Extended): Boolean;'); -Sender.AddFunction(@ps_FindDTMsRotated, 'function FindDTMsRotated(DTM: Integer; var Points: TPointArray; x1, y1, x2, y2: Integer; sAngle, eAngle, aStep: Extended; var aFound: T2DExtendedArray) : Boolean;'); -Sender.AddFunction(@ps_addDTM, 'function AddDTM(d: TDTM): Integer;'); -Sender.AddFunction(@ps_addpDTM, 'function AddpDTM(d: pDTM): Integer;'); - -{maths} -sender.AddFunction(@power,'function pow(base,exponent : extended) : extended'); -Sender.AddFunction(@max,'function Max(a, b: Integer): Integer;'); -Sender.AddFunction(@min,'function Min(a, b: Integer): Integer;'); -Sender.AddFunction(@pssqr,'function Sqr(e : extended) : extended;'); -Sender.AddFunction(@classes.point,'function Point(x,y:integer) : TPoint;'); -Sender.AddFunction(@Distance,'function Distance(x1,y1,x2,y2 : integer) : integer;'); - -{window} -Sender.AddFunction(@Freeze, 'function freeze:boolean;'); -Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;'); -Sender.AddFunction(@GetClientDimensions, 'procedure GetClientDimensions(var w, h:integer);'); -Sender.AddFunction(@SetTargetBitmap,'procedure SetTargetBitmap(Bitmap : integer);'); -Sender.AddFunction(@SetDesktopAsClient,'procedure SetDesktopAsClient'); - - -{other} -Sender.AddFunction(@SaveScreenshot,'procedure SaveScreenshot(FileName: string);'); -Sender.AddFunction(@Wait, 'procedure wait(t: integer);'); -Sender.AddFunction(@GetTickCount, 'function GetSystemTime: Integer;'); -Sender.AddFunction(@CreateForm,'function CreateForm : TForm;'); -Sender.AddFunction(@CreateButton,'function CreateButton(Owner : TComponent) : TButton'); - - -{Color + Color Finders} -Sender.AddFunction(@GetColor,'function GetColor(x, y: Integer): Integer;'); -Sender.AddFunction(@FindColor, 'function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;'); -Sender.AddFunction(@FindColorTolerance, 'function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;'); -Sender.AddFunction(@FindColors, 'function findcolors(var TPA: TPointArray; color, x1, y1, x2, y2: integer): boolean;'); -Sender.AddFunction(@SimilarColors,'function SimilarColors(Col1,Col2,Tolerance : integer) : boolean'); -Sender.AddFunction(@CountColorTolerance,'function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer;'); -Sender.AddFunction(@FindColorsTolerance,'function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tolerance: Integer): Boolean;'); -Sender.AddFunction(@FindColorSpiral,'function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean;'); -Sender.AddFunction(@FindColorsSpiralTolerance,'function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean;'); -Sender.AddFunction(@SetColorToleranceSpeed, 'procedure SetColorToleranceSpeed(cts: integer);'); - -{Mouse etc.} -Sender.AddFunction(@MoveMouse, 'procedure MoveMouse(x, y: integer);'); -Sender.AddFunction(@GetMousePos, 'procedure GetMousePos(var x, y: integer);'); - - -{Bitmaps} -Sender.AddFunction(@CreateBitmap,'function CreateBitmap(w,h :integer) : integer;'); -Sender.AddFunction(@FreeBitmap,'procedure FreeBitmap(Bmp : integer);'); -Sender.AddFunction(@SaveBitmap,'procedure SaveBitmap(Bmp : integer; path : string);'); -Sender.AddFunction(@BitmapFromString,'function BitmapFromString(Width,Height : integer; Data : string): integer;'); -Sender.AddFunction(@LoadBitmap,'function LoadBitmap(Path : string) : integer;'); -Sender.AddFunction(@SetBitmapSize,'procedure SetBitmapSize(Bmp,NewW,NewH : integer);'); -Sender.AddFunction(@GetBitmapSize,'procedure GetBitmapSize(Bmp : integer; Var BmpW,BmpH : integer);'); -Sender.AddFunction(@StretchBitmapResize,'procedure StretchBitmapResize(Bmp,NewW,NewH : integer);'); -Sender.AddFunction(@CreateMirroredBitmap,'function CreateMirroredBitmap(Bmp : integer) : integer;'); -Sender.AddFunction(@CreateMirroredBitmapEx,'function CreateMirroredBitmapEx(Bmp : integer; MirrorStyle : TBmpMirrorStyle) : integer;'); -Sender.AddFunction(@FastSetPixel,'procedure FastSetPixel(bmp,x,y : integer; Color : TColor);'); -Sender.AddFunction(@FastSetPixels,'procedure FastSetPixels(bmp : integer; TPA : TPointArray; Colors : TIntegerArray);'); -Sender.AddFunction(@FastGetPixel,'function FastGetPixel(bmp, x,y : integer) : TColor;'); -Sender.AddFunction(@FastGetPixels,'function FastGetPixels(Bmp : integer; TPA : TPointArray) : TIntegerArray;'); -Sender.AddFunction(@FastDrawClear,'procedure FastDrawClear(bmp : integer; Color : TColor)'); -Sender.AddFunction(@FastDrawTransparent,'procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer);'); -Sender.AddFunction(@SetTransparentColor,'procedure SetTransparentColor(bmp : integer; Color : TColor);'); -Sender.AddFunction(@GetTransparentColor,'function GetTransparentColor(bmp: integer) : TColor;'); -Sender.AddFunction(@FastReplaceColor,'procedure FastReplaceColor(Bmp : integer; OldColor,NewColor : TColor);'); -Sender.AddFunction(@ps_CopyClientToBitmap, 'procedure CopyClientToBitmap(bmp, xs, ys, xe, ye: Integer);'); -Sender.AddFunction(@SetBitmapName, 'procedure SetBitmapName(Bmp : integer; name : string);'); -Sender.AddFunction(@FindBitmap,'function FindBitmap(bitmap: integer; var x, y: Integer): Boolean;'); -Sender.AddFunction(@FindBitmapIn,'function FindBitmapIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean;'); -sender.AddFunction(@FindBitmapToleranceIn,'function FindBitmapToleranceIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean;'); -Sender.AddFunction(@FindBitmapSpiral,'function FindBitmapSpiral(bitmap: Integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean;'); -Sender.AddFunction(@FindBitmapsSpiralTolerance,'function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean;'); -Sender.AddFunction(@FindBitmapSpiralTolerance,'function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean;'); -Sender.AddFunction(@RotateBitmap,'function RotateBitmap(bitmap: Integer; angle: Extended): Integer;'); -Sender.AddFunction(@Desaturate,'function DesaturateBitmap(Bitmap : integer) : integer;'); -sender.AddFunction(@InvertBitmap,'procedure InvertBitmap(Bitmap : integer);'); -Sender.AddFunction(@CopyBitmap,'function CopyBitmap(Bitmap: integer) : integer)'); -Sender.AddFunction(@GreyScaleBitmap,'function GreyScaleBitmap(bitmap : integer) : integer'); -Sender.AddFunction(@BrightnessBitmap,'function BrightnessBitmap(Bitmap,br : integer) : integer;'); -Sender.AddFunction(@ContrastBitmap,'function ContrastBitmap(bitmap : integer; co : extended) : integer;'); -Sender.AddFunction(@PosterizeBitmap,'function PosterizeBitmap(Bitmap : integer; po : integer) : integer;'); -Sender.AddFunction(@CreateBitmapMask,'function CreateBitmapMask(Bitmap : integer) : TMask;'); -Sender.AddFunction(@FindMaskTolerance,'function FindMaskTolerance(mask: TMask; var x, y: Integer; xs,ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean;'); -Sender.AddFunction(@FindBitmapMaskTolerance,'function FindBitmapMaskTolerance(mask: Integer; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean;'); -Sender.AddFunction(@FindDeformedBitmapToleranceIn,'function FindDeformedBitmapToleranceIn(bitmap: integer; var x,y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean;'); +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + PSCompile.inc for the Mufasa Macro Library +} + +Sender.Comp.AddConstantN('AppPath','string').SetString(CurrThread.AppPath); +Sender.Comp.AddConstantN('ScriptPath','string').SetString(CurrThread.ScriptPath); +Sender.Comp.AddTypeS('TIntegerArray', 'Array of integer'); +Sender.Comp.AddTypeS('TPointArray','Array of TPoint'); +Sender.Comp.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)'); +Sender.Comp.AddTypeS('TMask','record White, Black : TPointArray; WhiteHi,BlackHi : integer; W,H : integer;end;'); + + +Sender.Comp.AddTypes('TDTMPointDef', 'record x, y, Color, Tolerance, AreaSize, AreaShape: integer; end;'); +Sender.Comp.AddTypes('TDTMPointDefArray', 'Array Of TDTMPointDef;'); +Sender.Comp.AddTypes('TDTM','record MainPoint: TDTMPointDef; SubPoints: TDTMPointDefArray; end;'); +Sender.Comp.AddTypeS('pDTM','record p: TPointArray; c, t, asz, ash: TIntegerArray; end'); +Sender.Comp.AddTypeS('T2DExtendedArray', 'array of array of extended'); + +Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;'); +Sender.AddFunction(@psWriteln,'procedure writeln(s : string);'); + +{ DTM } + +Sender.AddFunction(@PrintpDTM, 'Procedure PrintpDTM(tDTM : pDTM);'); +Sender.AddFunction(@ps_GetDTM ,'function GetDTM(index: Integer; var dtm: pDTM): Boolean;'); +Sender.AddFunction(@pDTMToTDTM, 'Function pDTMToTDTM(Const DTM: pDTM): TDTM;'); +Sender.AddFunction(@tDTMTopDTM, 'Function tDTMTopDTM(Const DTM: TDTM): pDTM;'); +Sender.AddFunction(@ps_DTMFromString, 'function DTMFromString(DTMString: String): Integer;'); +Sender.AddFunction(@ps_FreeDTM, 'procedure FreeDTM(DTM: Integer);'); +Sender.AddFunction(@ps_FindDTM, 'function FindDTM(DTM: Integer; var x, y: Integer; x1, y1, x2, y2: Integer): Boolean;'); +Sender.AddFunction(@ps_FindDTMs, 'function FindDTMs(DTM: Integer; var p: TPointArray; x1, y1, x2, y2: Integer): Boolean;'); +Sender.AddFunction(@ps_FindDTMRotated, 'function FindDTMRotated(DTM: Integer; var x, y: Integer; x1, y1, x2, y2: Integer; sAngle, eAngle, aStep: Extended; var aFound: Extended): Boolean;'); +Sender.AddFunction(@ps_FindDTMsRotated, 'function FindDTMsRotated(DTM: Integer; var Points: TPointArray; x1, y1, x2, y2: Integer; sAngle, eAngle, aStep: Extended; var aFound: T2DExtendedArray) : Boolean;'); +Sender.AddFunction(@ps_addDTM, 'function AddDTM(d: TDTM): Integer;'); +Sender.AddFunction(@ps_addpDTM, 'function AddpDTM(d: pDTM): Integer;'); + +{maths} +sender.AddFunction(@power,'function pow(base,exponent : extended) : extended'); +Sender.AddFunction(@max,'function Max(a, b: Integer): Integer;'); +Sender.AddFunction(@min,'function Min(a, b: Integer): Integer;'); +Sender.AddFunction(@pssqr,'function Sqr(e : extended) : extended;'); +Sender.AddFunction(@classes.point,'function Point(x,y:integer) : TPoint;'); +Sender.AddFunction(@Distance,'function Distance(x1,y1,x2,y2 : integer) : integer;'); + +{window} +Sender.AddFunction(@Freeze, 'function freeze:boolean;'); +Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;'); +Sender.AddFunction(@GetClientDimensions, 'procedure GetClientDimensions(var w, h:integer);'); +Sender.AddFunction(@SetTargetBitmap,'procedure SetTargetBitmap(Bitmap : integer);'); +Sender.AddFunction(@SetDesktopAsClient,'procedure SetDesktopAsClient'); + + +{other} +Sender.AddFunction(@SaveScreenshot,'procedure SaveScreenshot(FileName: string);'); +Sender.AddFunction(@Wait, 'procedure wait(t: integer);'); +Sender.AddFunction(@GetTickCount, 'function GetSystemTime: Integer;'); +Sender.AddFunction(@CreateForm,'function CreateForm : TForm;'); +Sender.AddFunction(@CreateButton,'function CreateButton(Owner : TComponent) : TButton'); + + +{Color + Color Finders} +Sender.AddFunction(@GetColor,'function GetColor(x, y: Integer): Integer;'); +Sender.AddFunction(@FindColor, 'function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;'); +Sender.AddFunction(@FindColorTolerance, 'function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;'); +Sender.AddFunction(@FindColors, 'function findcolors(var TPA: TPointArray; color, x1, y1, x2, y2: integer): boolean;'); +Sender.AddFunction(@SimilarColors,'function SimilarColors(Col1,Col2,Tolerance : integer) : boolean'); +Sender.AddFunction(@CountColorTolerance,'function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer;'); +Sender.AddFunction(@FindColorsTolerance,'function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tolerance: Integer): Boolean;'); +Sender.AddFunction(@FindColorSpiral,'function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean;'); +Sender.AddFunction(@FindColorsSpiralTolerance,'function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean;'); +Sender.AddFunction(@SetColorToleranceSpeed, 'procedure SetColorToleranceSpeed(cts: integer);'); + +{Mouse etc.} +Sender.AddFunction(@MoveMouse, 'procedure MoveMouse(x, y: integer);'); +Sender.AddFunction(@GetMousePos, 'procedure GetMousePos(var x, y: integer);'); + + +{Bitmaps} +Sender.AddFunction(@CreateBitmap,'function CreateBitmap(w,h :integer) : integer;'); +Sender.AddFunction(@FreeBitmap,'procedure FreeBitmap(Bmp : integer);'); +Sender.AddFunction(@SaveBitmap,'procedure SaveBitmap(Bmp : integer; path : string);'); +Sender.AddFunction(@BitmapFromString,'function BitmapFromString(Width,Height : integer; Data : string): integer;'); +Sender.AddFunction(@LoadBitmap,'function LoadBitmap(Path : string) : integer;'); +Sender.AddFunction(@SetBitmapSize,'procedure SetBitmapSize(Bmp,NewW,NewH : integer);'); +Sender.AddFunction(@GetBitmapSize,'procedure GetBitmapSize(Bmp : integer; Var BmpW,BmpH : integer);'); +Sender.AddFunction(@StretchBitmapResize,'procedure StretchBitmapResize(Bmp,NewW,NewH : integer);'); +Sender.AddFunction(@CreateMirroredBitmap,'function CreateMirroredBitmap(Bmp : integer) : integer;'); +Sender.AddFunction(@CreateMirroredBitmapEx,'function CreateMirroredBitmapEx(Bmp : integer; MirrorStyle : TBmpMirrorStyle) : integer;'); +Sender.AddFunction(@FastSetPixel,'procedure FastSetPixel(bmp,x,y : integer; Color : TColor);'); +Sender.AddFunction(@FastSetPixels,'procedure FastSetPixels(bmp : integer; TPA : TPointArray; Colors : TIntegerArray);'); +Sender.AddFunction(@FastGetPixel,'function FastGetPixel(bmp, x,y : integer) : TColor;'); +Sender.AddFunction(@FastGetPixels,'function FastGetPixels(Bmp : integer; TPA : TPointArray) : TIntegerArray;'); +Sender.AddFunction(@FastDrawClear,'procedure FastDrawClear(bmp : integer; Color : TColor)'); +Sender.AddFunction(@FastDrawTransparent,'procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer);'); +Sender.AddFunction(@SetTransparentColor,'procedure SetTransparentColor(bmp : integer; Color : TColor);'); +Sender.AddFunction(@GetTransparentColor,'function GetTransparentColor(bmp: integer) : TColor;'); +Sender.AddFunction(@FastReplaceColor,'procedure FastReplaceColor(Bmp : integer; OldColor,NewColor : TColor);'); +Sender.AddFunction(@ps_CopyClientToBitmap, 'procedure CopyClientToBitmap(bmp, xs, ys, xe, ye: Integer);'); +Sender.AddFunction(@SetBitmapName, 'procedure SetBitmapName(Bmp : integer; name : string);'); +Sender.AddFunction(@FindBitmap,'function FindBitmap(bitmap: integer; var x, y: Integer): Boolean;'); +Sender.AddFunction(@FindBitmapIn,'function FindBitmapIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean;'); +sender.AddFunction(@FindBitmapToleranceIn,'function FindBitmapToleranceIn(bitmap: integer; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean;'); +Sender.AddFunction(@FindBitmapSpiral,'function FindBitmapSpiral(bitmap: Integer; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean;'); +Sender.AddFunction(@FindBitmapsSpiralTolerance,'function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean;'); +Sender.AddFunction(@FindBitmapSpiralTolerance,'function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean;'); +Sender.AddFunction(@RotateBitmap,'function RotateBitmap(bitmap: Integer; angle: Extended): Integer;'); +Sender.AddFunction(@Desaturate,'function DesaturateBitmap(Bitmap : integer) : integer;'); +sender.AddFunction(@InvertBitmap,'procedure InvertBitmap(Bitmap : integer);'); +Sender.AddFunction(@CopyBitmap,'function CopyBitmap(Bitmap: integer) : integer)'); +Sender.AddFunction(@GreyScaleBitmap,'function GreyScaleBitmap(bitmap : integer) : integer'); +Sender.AddFunction(@BrightnessBitmap,'function BrightnessBitmap(Bitmap,br : integer) : integer;'); +Sender.AddFunction(@ContrastBitmap,'function ContrastBitmap(bitmap : integer; co : extended) : integer;'); +Sender.AddFunction(@PosterizeBitmap,'function PosterizeBitmap(Bitmap : integer; po : integer) : integer;'); +Sender.AddFunction(@CreateBitmapMask,'function CreateBitmapMask(Bitmap : integer) : TMask;'); +Sender.AddFunction(@FindMaskTolerance,'function FindMaskTolerance(mask: TMask; var x, y: Integer; xs,ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean;'); +Sender.AddFunction(@FindBitmapMaskTolerance,'function FindBitmapMaskTolerance(mask: Integer; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean;'); +Sender.AddFunction(@FindDeformedBitmapToleranceIn,'function FindDeformedBitmapToleranceIn(bitmap: integer; var x,y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean;'); diff --git a/Units/MMLAddon/colourpicker.pas b/Units/MMLAddon/colourpicker.pas index 46d4a2c..37ccb00 100644 --- a/Units/MMLAddon/colourpicker.pas +++ b/Units/MMLAddon/colourpicker.pas @@ -1,235 +1,235 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Colourpicker for the Mufasa Macro Library -} - -unit colourpicker; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, LCLIntf,LCLType,InterfaceBase,Forms,Controls,ExtCtrls, - Graphics, - Window,MufasaTypes - - {$IFNDEF PICKER_CLIENT} - {$IFDEF LINUX} - ,x - {$ENDIF} - {$ENDIF} - ; - -type - TPickEvent = procedure (Sender: TObject; Color, X, Y: Integer); - - TMColorPicker = class(TObject) - constructor Create(aWindow: TMWindow); - destructor Destroy; override; - - procedure Pick(Out C, X, Y: Integer); - - procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer ); - procedure TimorTimer(Sender: TObject); - Procedure ColorPickDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); - public - // Will give us CopyClientToBitmap - Window: TMWindow; - ColourHistory: TList; // for colour history - - Form : TForm; - Image: TImage; - Timor : TTimer; - Bitmap : Graphics.TBitmap; - Note : Graphics.TBitmap; - Brush : TBrush; - Text : string; - FPickEvent : TPickEvent; - - oldx, oldy, Color, colorx, colory: Integer; - - TheChangedEvent,TheChangingEvent : TNotifyEvent; - NoteHandle, BitmapHandle, ImageHandle : HDC; - public - property OnPick: TPickEvent read FPickEvent write FPickEvent; - end; - - -implementation - -constructor TMColorPicker.Create(aWindow: TMWindow); -begin - Self.Window := aWindow; - -end; - -destructor TMColorPicker.Destroy; -begin - -end; - -procedure TMColorPicker.Pick(Out C, X, Y: Integer); -var - w, h: integer; - bmp: TBitmap; - - {$IFNDEF PICKER_CLIENT} - {$IFDEF LINUX} - OldWindow: TWindow; - {$ELSE} - OldWindow: HWND; - {$ENDIF} - {$ENDIF} - -begin - Form := TForm.Create(Application.MainForm); - {$IFNDEF PICKER_CLIENT} - {$IFDEF LINUX} - OldWindow := Window.CurWindow; - {$ELSE} - OldWindow := Window.TargetHandle; - {$ENDIF} - Window.SetDesktop; - {$ENDIF} - w := 0; - h := 0; - Window.GetDimensions(w, h); - - Form.Width := w; - Form.Height := h; - Form.Top := 0; - Form.left := 0; - Form.WindowState := wsmaximized; - Form.BorderStyle:= bsNone; - - Image := TImage.Create(Form); - Image.Parent := Form; - Image.left := 0; - image.Width := 0; - Image.width := Form.Width - 1; - Image.Height := Form.Height - 1; - Image.Cursor:= crCross; - Image.OnMouseDown:= @ColorPickDown; - Image.OnMouseMove:=@ImageMouseMove; - Image.Canvas.Brush.Color := 14811135; - Bitmap := Graphics.TBitmap.create; - Bitmap.width := Form.Width; - Bitmap.Height := Form.Height; - Note := Graphics.TBitmap.create; - Note.Canvas.Brush.Color := 14811135; - Note.Width := 148; - Note.Height := 33; - Note.Canvas.Rectangle(0, 0, 147, 33); - Note.Canvas.Rectangle(89, 3, 115, 29); - Note.Canvas.Pen.Style:= psClear; - - bmp := Window.CopyClientToBitmap(0, 0, w - 1, h - 1); - BitBlt(Image.Canvas.Handle, 0,0,w ,h , bmp.Canvas.Handle,0,0,SRCCOPY); - BitBlt(Bitmap.Canvas.Handle, 0,0,w ,h , bmp.Canvas.Handle,0,0,SRCCOPY); - bmp.Free; - - ImageHandle:= Image.Canvas.Handle; - BitmapHandle:= Bitmap.Canvas.Handle; - NoteHandle:= Note.Canvas.Handle; - TheChangedEvent := Image.Canvas.OnChange; - TheChangingEvent := Image.Canvas.OnChanging; - - Brush := Image.Canvas.Brush; - Timor := TTimer.Create(Form); - - Timor.OnTimer:= @TimorTimer; - Timor.Interval:= 50; - Timor.Enabled:= False; - - Form.ShowModal; - - // add x to history here. - c := Color; - x := Colorx; - y := Colory; - - {$IFNDEF PICKER_CLIENT} - {$IFDEF LINUX} - Window.SetTarget(OldWindow); - {$ELSE} - Window.SetTarget(OldWindow, w_Window); - {$ENDIF} - {$ENDIF} - - Note.Free; - Bitmap.Free; - Timor.Free; - Image.Free; - Form.Free; -end; - -procedure TMColorPicker.ImageMouseMove(Sender: TObject; Shift: TShiftState; X, - Y: Integer); -begin - Timor.Enabled:= True; -end; - -procedure TMColorPicker.TimorTimer(Sender: TObject); -var - TempPoint : TPoint; -begin -// GetCursorPos(TempPoint); - TempPoint := Mouse.CursorPos; - - { If a form cannot be fully set to 0,0 } - TempPoint.X := TempPoint.X - Form.Left; - TempPoint.Y := TempPoint.Y - Form.Top; - - BitBlt(ImageHandle, oldx + 5, oldy + 5,147,33,BitmapHandle,oldx + 5,oldy + 5,SRCCOPY); - Color := WidgetSet.DCGetPixel(ImageHandle, TempPoint.X, TempPoint.Y); - Rectangle(NoteHandle,1,1,85,32); -// Text:='Pos: ' + inttostr(TempPoint.x - Client.Rect.Left) + ',' + inttostr(TempPoint.y - Client.Rect.Bottom); - Text:='Pos: ' + inttostr(TempPoint.x) + ',' + inttostr(TempPoint.y); - ExtTextOut(NoteHandle, 5, 3,0,nil,pchar(text),length(text),nil); - Text := 'Color: ' + inttostr(Color); - ExtTextOut(NoteHandle, 5, 15,0,nil,pchar(text),length(text),nil); - BitBlt( ImageHandle, TempPoint.x + 5, TempPoint.y + 5,147,33,NoteHandle,0,0,SRCCOPY); - Brush.Color := Color; - Image.Canvas.Rectangle(TempPoint.x + 123, TempPoint.y + 8, tempPoint.x + 149, temppoint.y + 34); -// Rectangle(ImageHandle,TempPoint.x + 123, TempPoint.y + 8, tempPoint.x + 149, temppoint.y + 34); - TheChangingEvent(Sender); - StretchBlt(ImageHandle,TempPoint.x + 95, TempPoint.y + 9, 24,24, BitmapHandle, TempPoint.x - 1, TempPoint.y-1,3,3, SRCCOPY); - TheChangedEvent(Sender); - Oldx := TempPoint.x; - Oldy := TempPoint.y; - Timor.Enabled:= False; -end; - -procedure TMColorPicker.ColorPickDown(Sender: TObject; Button: TMouseButton; - Shift: TShiftState; X, Y: Integer); -begin; - Color:= WidgetSet.DCGetPixel(Image.Canvas.Handle,x,y); - Self.Colorx := x; - Self.Colory := y; - Timor.enabled := false; - if OnPick <> nil then - Onpick(Sender,Color,x,y); - Form.Close; -end; - -end. - +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Colourpicker for the Mufasa Macro Library +} + +unit colourpicker; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LCLIntf,LCLType,InterfaceBase,Forms,Controls,ExtCtrls, + Graphics, + Window,MufasaTypes + + {$IFNDEF PICKER_CLIENT} + {$IFDEF LINUX} + ,x + {$ENDIF} + {$ENDIF} + ; + +type + TPickEvent = procedure (Sender: TObject; Color, X, Y: Integer); + + TMColorPicker = class(TObject) + constructor Create(aWindow: TMWindow); + destructor Destroy; override; + + procedure Pick(Out C, X, Y: Integer); + + procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer ); + procedure TimorTimer(Sender: TObject); + Procedure ColorPickDown(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); + public + // Will give us CopyClientToBitmap + Window: TMWindow; + ColourHistory: TList; // for colour history + + Form : TForm; + Image: TImage; + Timor : TTimer; + Bitmap : Graphics.TBitmap; + Note : Graphics.TBitmap; + Brush : TBrush; + Text : string; + FPickEvent : TPickEvent; + + oldx, oldy, Color, colorx, colory: Integer; + + TheChangedEvent,TheChangingEvent : TNotifyEvent; + NoteHandle, BitmapHandle, ImageHandle : HDC; + public + property OnPick: TPickEvent read FPickEvent write FPickEvent; + end; + + +implementation + +constructor TMColorPicker.Create(aWindow: TMWindow); +begin + Self.Window := aWindow; + +end; + +destructor TMColorPicker.Destroy; +begin + +end; + +procedure TMColorPicker.Pick(Out C, X, Y: Integer); +var + w, h: integer; + bmp: TBitmap; + + {$IFNDEF PICKER_CLIENT} + {$IFDEF LINUX} + OldWindow: TWindow; + {$ELSE} + OldWindow: HWND; + {$ENDIF} + {$ENDIF} + +begin + Form := TForm.Create(Application.MainForm); + {$IFNDEF PICKER_CLIENT} + {$IFDEF LINUX} + OldWindow := Window.CurWindow; + {$ELSE} + OldWindow := Window.TargetHandle; + {$ENDIF} + Window.SetDesktop; + {$ENDIF} + w := 0; + h := 0; + Window.GetDimensions(w, h); + + Form.Width := w; + Form.Height := h; + Form.Top := 0; + Form.left := 0; + Form.WindowState := wsmaximized; + Form.BorderStyle:= bsNone; + + Image := TImage.Create(Form); + Image.Parent := Form; + Image.left := 0; + image.Width := 0; + Image.width := Form.Width - 1; + Image.Height := Form.Height - 1; + Image.Cursor:= crCross; + Image.OnMouseDown:= @ColorPickDown; + Image.OnMouseMove:=@ImageMouseMove; + Image.Canvas.Brush.Color := 14811135; + Bitmap := Graphics.TBitmap.create; + Bitmap.width := Form.Width; + Bitmap.Height := Form.Height; + Note := Graphics.TBitmap.create; + Note.Canvas.Brush.Color := 14811135; + Note.Width := 148; + Note.Height := 33; + Note.Canvas.Rectangle(0, 0, 147, 33); + Note.Canvas.Rectangle(89, 3, 115, 29); + Note.Canvas.Pen.Style:= psClear; + + bmp := Window.CopyClientToBitmap(0, 0, w - 1, h - 1); + BitBlt(Image.Canvas.Handle, 0,0,w ,h , bmp.Canvas.Handle,0,0,SRCCOPY); + BitBlt(Bitmap.Canvas.Handle, 0,0,w ,h , bmp.Canvas.Handle,0,0,SRCCOPY); + bmp.Free; + + ImageHandle:= Image.Canvas.Handle; + BitmapHandle:= Bitmap.Canvas.Handle; + NoteHandle:= Note.Canvas.Handle; + TheChangedEvent := Image.Canvas.OnChange; + TheChangingEvent := Image.Canvas.OnChanging; + + Brush := Image.Canvas.Brush; + Timor := TTimer.Create(Form); + + Timor.OnTimer:= @TimorTimer; + Timor.Interval:= 50; + Timor.Enabled:= False; + + Form.ShowModal; + + // add x to history here. + c := Color; + x := Colorx; + y := Colory; + + {$IFNDEF PICKER_CLIENT} + {$IFDEF LINUX} + Window.SetTarget(OldWindow); + {$ELSE} + Window.SetTarget(OldWindow, w_Window); + {$ENDIF} + {$ENDIF} + + Note.Free; + Bitmap.Free; + Timor.Free; + Image.Free; + Form.Free; +end; + +procedure TMColorPicker.ImageMouseMove(Sender: TObject; Shift: TShiftState; X, + Y: Integer); +begin + Timor.Enabled:= True; +end; + +procedure TMColorPicker.TimorTimer(Sender: TObject); +var + TempPoint : TPoint; +begin +// GetCursorPos(TempPoint); + TempPoint := Mouse.CursorPos; + + { If a form cannot be fully set to 0,0 } + TempPoint.X := TempPoint.X - Form.Left; + TempPoint.Y := TempPoint.Y - Form.Top; + + BitBlt(ImageHandle, oldx + 5, oldy + 5,147,33,BitmapHandle,oldx + 5,oldy + 5,SRCCOPY); + Color := WidgetSet.DCGetPixel(ImageHandle, TempPoint.X, TempPoint.Y); + Rectangle(NoteHandle,1,1,85,32); +// Text:='Pos: ' + inttostr(TempPoint.x - Client.Rect.Left) + ',' + inttostr(TempPoint.y - Client.Rect.Bottom); + Text:='Pos: ' + inttostr(TempPoint.x) + ',' + inttostr(TempPoint.y); + ExtTextOut(NoteHandle, 5, 3,0,nil,pchar(text),length(text),nil); + Text := 'Color: ' + inttostr(Color); + ExtTextOut(NoteHandle, 5, 15,0,nil,pchar(text),length(text),nil); + BitBlt( ImageHandle, TempPoint.x + 5, TempPoint.y + 5,147,33,NoteHandle,0,0,SRCCOPY); + Brush.Color := Color; + Image.Canvas.Rectangle(TempPoint.x + 123, TempPoint.y + 8, tempPoint.x + 149, temppoint.y + 34); +// Rectangle(ImageHandle,TempPoint.x + 123, TempPoint.y + 8, tempPoint.x + 149, temppoint.y + 34); + TheChangingEvent(Sender); + StretchBlt(ImageHandle,TempPoint.x + 95, TempPoint.y + 9, 24,24, BitmapHandle, TempPoint.x - 1, TempPoint.y-1,3,3, SRCCOPY); + TheChangedEvent(Sender); + Oldx := TempPoint.x; + Oldy := TempPoint.y; + Timor.Enabled:= False; +end; + +procedure TMColorPicker.ColorPickDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin; + Color:= WidgetSet.DCGetPixel(Image.Canvas.Handle,x,y); + Self.Colorx := x; + Self.Colory := y; + Timor.enabled := false; + if OnPick <> nil then + Onpick(Sender,Color,x,y); + Form.Close; +end; + +end. + diff --git a/Units/MMLCore/bitmaps.pas b/Units/MMLCore/bitmaps.pas index 8b3dbd3..1f5d9a8 100644 --- a/Units/MMLCore/bitmaps.pas +++ b/Units/MMLCore/bitmaps.pas @@ -1,907 +1,907 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Bitmaps class for the Mufasa Macro Library -} - -unit bitmaps; - -{$mode objfpc}{$H+} - -interface -uses - Classes, SysUtils, FPImgCanv,FPImage,IntfGraphics,graphtype,MufasaTypes,graphics; - -type - - { TMufasaBitmap } - TMufasaBitmap = class(TObject) - private - w,h : integer; - TransparentColor : TRGB32; - TransparentSet : boolean; - public - OnDestroy : procedure(Bitmap : TMufasaBitmap) of object; - FData : PRGB32; - Index : integer; - BmpName : string; //Optional? - procedure SetSize(AWidth,AHeight : integer); - procedure StretchResize(AWidth,AHeight : integer); - property Width : Integer read w; - property Height : Integer read h; - procedure ValidatePoint(x,y : integer); - function SaveToFile(const FileName : string) :boolean; - procedure LoadFromFile(const FileName : string); - procedure FastSetPixel(x,y : integer; Color : TColor); - procedure FastSetPixels(TPA : TPointArray; Colors : TIntegerArray); - function FastGetPixel(x,y : integer) : TColor; - function FastGetPixels(TPA : TPointArray) : TIntegerArray; - Procedure SetTransparentColor(Col : TColor); - Function GetTransparentColor : TColor; - property TransparentColorSet : boolean read TransparentSet; - procedure FastDrawClear(Color : TColor); - procedure FastDrawTransparent(x, y: Integer; TargetBitmap: TMufasaBitmap); - procedure FastReplaceColor(OldColor, NewColor: TColor); - procedure CopyClientToBitmap(MWindow : TObject; xs, ys, xe, ye: Integer); - procedure RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); - procedure Desaturate;overload; - procedure Desaturate(TargetBitmap : TMufasaBitmap); overload; - procedure GreyScale(TargetBitmap : TMufasaBitmap);overload; - procedure GreyScale; - procedure Brightness(br: integer);overload; - procedure Brightness(TargetBitmap : TMufasaBitmap; br : integer); overload; - procedure Contrast(co: Extended);overload; - procedure Contrast(TargetBitmap : TMufasaBitmap; co : Extended);overload; - procedure Invert; - procedure Posterize(TargetBitmap : TMufasaBitmap; Po : integer);overload; - procedure Posterize(Po : integer);overload; - function CreateTMask : TMask; - constructor Create; - destructor Destroy;override; - end; - - TMufasaBmpArray = Array of TMufasaBitmap; - { TMBitmaps } - TMBitmaps = class(TObject) - protected - Client : TObject; - FreeSpots : Array of integer; - BmpArray : TMufasaBmpArray; - BmpsCurr,BmpsHigh,FreeSpotsHigh,FreeSpotsLen : integer; - public - function GetBMP(Index : integer) : TMufasaBitmap; - property Bmp[Index : integer]: TMufasaBitmap read GetBMP; - function CreateBMP(w, h: integer): Integer; - function CopyBMP( Bitmap : integer) : Integer; - function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer; - function CreateBMPFromFile(const Path : string) : integer; - function CreateBMPFromString(width,height : integer; Data : string) : integer;overload; - function CreateBMPFromString(BmpName : string; width,height : integer; Data : string) : integer;overload; - procedure FreeBMP( Number : integer); - constructor Create(Owner : TObject); - destructor Destroy;override; - end; - - -implementation - -uses - Windowutil,paszlib,DCPbase64,mmath,math, - colour_conv,window; - -function Min(a,b:integer) : integer; -begin - if a < b then - result := a - else - result := b; -end; - -{ TMBitmaps } - - -function TMBitmaps.GetBMP(Index: integer): TMufasaBitmap; -begin - Result := nil; - if (Index >= 0) and (Index <= BmpsCurr) then - if BmpArray[Index] <> nil then - Result := BmpArray[Index]; - if Result = nil then - raise Exception.CreateFmt('The bitmap[%d] does not exist',[Index]); -end; - -function TMBitmaps.CreateBMP(w,h : integer): Integer; -begin - if BmpsCurr < BmpsHigh then - begin; - inc(BmpsCurr); - Result := BmpsCurr; - end else if (FreeSpotsHigh > -1) then - begin; - Result := FreeSpots[FreeSpotsHigh]; - dec(FreeSpotsHigh); - end else - begin; - SetLength(BmpArray, BmpsHigh + 6); - BmpsHigh := BmpsHigh + 5; - inc(BmpsCurr); - Result := BmpsCurr; - end; - BmpArray[Result] := TMufasaBitmap.Create; - BmpArray[Result].SetSize(w,h); - BmpArray[Result].Index:= Result; -end; - -function TMBitmaps.CopyBMP(Bitmap: integer): Integer; -var - InputBMP : TMufasaBitmap; - OutputBMP : TMUfasaBitmap; -begin - InputBMP := GetBMP(Bitmap); - Result := CreateBMP(InputBmp.w,InputBMP.h); - OutputBMP := GetBMP(Result); - Move(InputBMP.FData[0],OutPutBMP.FData[0],InputBMP.w * InputBMP.h * SizeOf(TRGB32)); -end; - -function TMBitmaps.CreateMirroredBitmap(bitmap: Integer; - MirrorStyle: TBmpMirrorStyle): Integer; -var - w,h : integer; - y,x : integer; - Source,Dest : PRGB32; -begin - Source := Bmp[Bitmap].FData; - w := BmpArray[Bitmap].Width; - h := BmpArray[Bitmap].Height; - if MirrorStyle = MirrorLine then - Result := CreateBMP(h,w) - else - Result := CreateBMP(w,h); - Dest := BmpArray[Result].FData; - case MirrorStyle of - MirrorWidth : for y := (h-1) downto 0 do - for x := (w-1) downto 0 do - Dest[y*w+x] := Source[y*w+w-1-x]; - MirrorHeight : for y := (h-1) downto 0 do - Move(Source[y*w],Dest[(h-1 - y) * w],w*SizeOf(TRGB32)); - MirrorLine : for y := (h-1) downto 0 do - for x := (w-1) downto 0 do - Dest[x*h+y] := Source[y*w+x]; - - end; -//Can be optmized, this is just proof of concept -end; - -function TMBitmaps.CreateBMPFromFile(const Path: string): integer; -begin - Result := CreateBMP(0,0); - BmpArray[result].LoadFromFile(Path); -end; - -function HexToInt(HexNum: string): LongInt;inline; -begin - Result:=StrToInt('$' + HexNum); -end; - -function TMBitmaps.CreateBMPFromString(width, height: integer; Data: string): integer; -var - I,II,x,y: LongWord; - DestLen : LongWord; - Dest,Source : string; - DestPoint, Point : PByte; - LazIntf : TLazIntfImage; - -begin - Result := CreateBMP(width,height); - if (Data <> '') and (Length(Data) <> 6) then - begin; - Point := Pointer(BmpArray[Result].FData); - if Data[1] = 'b' then - begin; - Source := Base64DecodeStr(Copy(Data,2,Length(Data) - 1)); - Destlen := Width * Height * 3; - Setlength(Dest,DestLen); - if uncompress(PChar(Dest),Destlen,pchar(Source), Length(Source)) = Z_OK then - begin; - DestPoint := @Dest[1]; - i := 0; - ii := 2; - Dec(DestLen); - if DestLen > 2 then - begin; - while (ii < DestLen) do - Begin; - Point[i]:= DestPoint[ii+2]; - Point[i+1]:= DestPoint[ii+1]; - Point[i+2]:= DestPoint[ii]; - ii := ii + 3; - i := i + 4; - end; - Point[i] := DestPoint[1]; - Point[i+1] := DestPoint[0]; - Point[i+2] := DestPoint[ii]; - end else if (Width = 1) and (Height =1 ) then - begin; - Point[0] := DestPoint[1]; - Point[1] := DestPoint[0]; - Point[2] := DestPoint[2]; - end; - end; - end else if Data[1] = 'z' then - begin; - Destlen := Width * Height * 3 *2; - Setlength(Dest,DestLen); - ii := (Length(Data) - 1) div 2; - SetLength(Source,ii); - for i := 1 to ii do - Source[i] := Chr(HexToInt(Data[i * 2] + Data[i * 2+1])); - if uncompress(PChar(Dest),Destlen,pchar(Source), ii) = Z_OK then - begin; - ii := 1; - i := 0; - while (II < DestLen) do - begin; - Point[i+2]:= HexToInt(Dest[ii] + Dest[ii + 1]); - Point[i+1]:= HexToInt(Dest[ii+2] + Dest[ii + 3]); - Point[i]:= HexToInt(Dest[ii+4] + Dest[ii + 5]); - ii := ii + 6; - i := i + 4; - end; - end; - end else if LongWord(Length(Data)) = (Width * Height * 3 * 2) then - begin; - ii := 1; - i := 0; - Destlen := Width * Height * 3 * 2; - while (II < DestLen) do - begin; - Point[i+2]:= HexToInt(Data[ii] + Data[ii + 1]); - Point[i+1]:= HexToInt(Data[ii+2] + Data[ii + 3]); - Point[i]:= HexToInt(Data[ii+4] + Data[ii + 5]); - ii := ii + 6; - i := i + 4; - end; - end; - end else - begin; - if Length(data) = 6 then - BmpArray[Result].FastDrawClear(HexToInt(Data)); -// else -// FastDrawClear(Result,clBlack); - end; -end; - -function TMBitmaps.CreateBMPFromString(BmpName: string; width, height: integer; - Data: string): integer; -begin - Result := Self.CreateBMPFromString(width,height,data); - Bmp[Result].BmpName:= BmpName; - -end; - -procedure TMBitmaps.FreeBMP(Number: integer); -var - ToDestroy : TMufasaBitmap; -begin - ToDestroy := GetBMP(Number); - if Number = BmpsCurr then - Dec(BmpsCurr) - else - begin; - inc(FreeSpotsHigh); - if FreeSpotsHigh = FreeSpotsLen then - begin; - inc(FreeSpotsLen); - SetLength(FreeSpots, FreeSpotsLen); - end; - FreeSpots[FreeSpotsHigh] := Number; - end; - //Just for testing purposes - if ToDestroy.BmpName = '' then - Writeln(Format('BMP[%d] has been freed.',[number])) - else - Writeln(Format('BMP[%s] has been freed.',[ToDestroy.BmpName])); - FreeAndNil(ToDestroy); -end; - -function TMufasaBitmap.SaveToFile(const FileName: string): boolean; -var - rawImage : TRawImage; - Bmp : TLazIntfImage; -begin - ArrDataToRawImage(FData,Point(w,h),RawImage); -// Bmp := Graphics.TBitmap.Create; - Bmp := TLazIntfImage.Create(RawImage,false); - Bmp.SaveToFile(FileName); - Bmp.Free; -end; - -procedure TMufasaBitmap.LoadFromFile(const FileName: string); -var - LazIntf : TLazIntfImage; - RawImageDesc : TRawImageDescription; -begin - if FileExists(FileName) then - begin; - LazIntf := TLazIntfImage.Create(0,0); - RawImageDesc.Init_BPP32_B8G8R8_BIO_TTB(LazIntf.Width,LazIntf.Height); - LazIntf.DataDescription := RawImageDesc; - LazIntf.LoadFromFile(FileName); - if Assigned(FData) then - Freemem(FData); - Self.W := LazIntf.Width; - Self.H := LazIntf.Height; - FData := GetMem(Self.W*Self.H*SizeOf(TRGB32)); - Move(LazIntf.PixelData[0],FData[0],w*h*sizeOf(TRGB32)); - LazIntf.Free; - end; -end; - -function RGBToBGR(Color : TColor) : TRGB32; inline; -begin; - Result.R := Color and $ff; - Result.G := Color shr 8 and $ff; - Result.B := Color shr 16 and $ff; -end; - -function BGRToRGB(BGR : TRGB32) : TColor;inline; -begin; - Result := BGR.R or BGR.g shl 8 or BGR.b shl 16; -end; - -procedure TMufasaBitmap.FastSetPixel(x, y: integer; Color: TColor); -begin - ValidatePoint(x,y); - FData[y*w+x] := RGBToBGR(Color); -end; - -procedure TMufasaBitmap.FastSetPixels(TPA: TPointArray; Colors: TIntegerArray); -var - i,len : integer; -begin - len := High(TPA); - if Len <> High(colors) then - Raise Exception.CreateFMT('TPA/Colors Length differ',[]); - for i := 0 to len do - begin; - ValidatePoint(TPA[i].x,TPA[i].y); - FData[TPA[i].y * w + TPA[i].x] := RGBToBGR(Colors[i]); - end; -end; - -function TMufasaBitmap.FastGetPixel(x, y: integer): TColor; -begin - ValidatePoint(x,y); - Result := BGRToRGB(FData[y*w+x]); -end; - -function TMufasaBitmap.FastGetPixels(TPA: TPointArray): TIntegerArray; -var - i,len : integer; -begin - len := high(TPA); - SetLength(result,len+1); - for i := 0 to len do - begin; - ValidatePoint(TPA[i].x,TPA[i].y); - Result[i] := BGRToRGB(FData[TPA[i].y*w + TPA[i].x]); - end; -end; - -procedure TMufasaBitmap.SetTransparentColor(Col: TColor); -begin - TransparentColor:= RGBToBGR(Col); - TransparentSet:= True; -end; - -function TMufasaBitmap.GetTransparentColor: TColor; -begin - if TransparentSet then - Result := BGRToRGB(TransparentColor) - else - raise Exception.CreateFmt('Transparent color for Bitmap[%d] isn''t set',[index]); -end; - -procedure TMufasaBitmap.FastDrawClear(Color: TColor); -var - i : integer; - Rec : TRGB32; -begin - Rec := RGBToBGR(Color); - if h > 0 then - begin; - for i := (w-1) downto 0 do - FData[i] := Rec; - for i := (h-1) downto 1 do - Move(FData[0],FData[i*w],w*SizeOf(TRGB32)); - end; -end; - -procedure TMufasaBitmap.FastDrawTransparent(x, y: Integer; - TargetBitmap: TMufasaBitmap); -var - MinW,MinH,TargetW,TargetH : Integer; - loopx,loopy : integer; -begin - ValidatePoint(x,y); - TargetW := TargetBitmap.Width; - TargetH := TargetBitmap.height; - MinW := Min(w-1,TargetW-x-1); - MinH := Min(h-1,TargetH-y-1); - if TransparentSet then - begin; - for loopy := 0 to MinH do - for loopx := 0 to MinW do - if LongWord(FData[loopy * w + loopx]) <> LongWord(TransparentColor) then - TargetBitmap.FData[(loopy + y) * TargetW + loopx + x] := FData[Loopy * w + loopx]; - - end - else - for loopy := 0 to MinH do - Move(FData[loopy*w],TargetBitmap.FData[(loopy+y) * TargetW + x],(MinW+1) * SizeOf(TRGB32)); - -end; - -procedure TMufasaBitmap.FastReplaceColor(OldColor, NewColor: TColor); -var - OldCol,NewCol : TRGB32; - i : integer; -begin - OldCol := RGBToBGR(OldColor); - NewCol := RGBToBGR(NewColor); - for i := w*h-1 downto 0 do - if LongWord(FData[i]) = LongWord(OldCol) then - FData[i] := NewCol; -end; - -procedure TMufasaBitmap.CopyClientToBitmap(MWindow : TObject; xs, ys, xe, ye: Integer); -var - wi,hi,y : integer; - PtrRet : TRetData; - Rows : integer; -begin - wi := Min(xe-xs + 1,Self.w); - hi := Min(ye-ys + 1,Self.h); - PtrRet := TMWindow(MWindow).ReturnData(xs,ys,wi,hi); - for y := 0 to (hi-1) do - Move(PtrRet.Ptr[y * (wi + PtrRet.IncPtrWith)], FData[y * self.w],wi * SizeOf(TRGB32)); - TMWindow(MWindow).FreeReturnData; -end; - - -function RotatePointEdited(p: TPoint; angle, mx, my: Extended): TPoint; - -begin - Result.X := Ceil(mx + cos(angle) * (p.x - mx) - sin(angle) * (p.y - my)); - Result.Y := Ceil(my + sin(angle) * (p.x - mx) + cos(angle) * (p.y- my)); -end; - -//Scar rotates unit circle-wise.. Oh, scar doesnt update the bounds, so kinda crops ur image. -procedure TMufasaBitmap.RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); -var - NewW,NewH : integer; - CosAngle,SinAngle : extended; - MinX,MinY,MaxX,MaxY : integer; - i : integer; - x,y : integer; - OldX,OldY : integer; - MiddlePoint : TPoint; - NewCorners : array[1..4] of TPoint; //(xs,ye);(xe,ye);(xe,ys);(xs,ys) -begin - MiddlePoint := Point((w-1) div 2,(h-1) div 2); - CosAngle := Cos(Angle); - SinAngle := Sin(Angle); - MinX := MaxInt; - MinY := MaxInt; - MaxX := 0; - MaxY := 0; - NewCorners[1]:= RotatePointEdited(Point(0,h-1),angle,middlepoint.x,middlepoint.y); - NewCorners[2]:= RotatePointEdited(Point(w-1,h-1),angle,middlepoint.x,middlepoint.y); - NewCorners[3]:= RotatePointEdited(Point(w-1,0),angle,middlepoint.x,middlepoint.y); - NewCorners[4]:= RotatePointEdited(Point(0,0),angle,middlepoint.x,middlepoint.y); - for i := 1 to 4 do - begin; - if NewCorners[i].x > MaxX then - MaxX := NewCorners[i].x; - if NewCorners[i].Y > MaxY then - MaxY := NewCorners[i].y; - if NewCorners[i].x < MinX then - MinX := NewCorners[i].x; - if NewCorners[i].y < MinY then - MinY := NewCorners[i].y; - end; - Writeln(Format('Min: (%d,%d) Max : (%d,%d)',[MinX,MinY,MaxX,MaxY])); - NewW := MaxX - MinX+1; - NewH := MaxY - MinY+1; - Writeln(format('New bounds: %d,%d',[NewW,NewH])); - TargetBitmap.SetSize(NewW,NewH); - for y := NewH - 1 downto 0 do - for x := NewW - 1 downto 0 do - begin; - Oldx := Round(MiddlePoint.x + CosAngle * (x + MinX-MiddlePoint.x) - SinAngle * (y + MinY - MiddlePoint.y)); - Oldy := Round(MiddlePoint.y + SinAngle * (x + MinX-MiddlePoint.x) + CosAngle * (y + MinY-MiddlePoint.y)); - if not ((Oldx <0) or (Oldx >= w) or (Oldy < 0) or (Oldy >= h)) then - TargetBitmap.FData[ y * NewW + x] := Self.FData[OldY * W + OldX]; - end; -end; - -procedure TMufasaBitmap.Desaturate; -var - I : integer; - He,Se,Le : extended; - Ptr : PRGB32; -begin - Ptr := FData; - for i := (h*w-1) downto 0 do - begin; - RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,He,Se,Le); - HSLtoRGB(He,0.0,Le,Ptr^.R,Ptr^.G,Ptr^.B); - inc(ptr); - end; -end; - -procedure TMufasaBitmap.Desaturate(TargetBitmap: TMufasaBitmap); -var - I : integer; - He,Se,Le : extended; - PtrOld,PtrNew : PRGB32; -begin - TargetBitmap.SetSize(w,h); - PtrOld := Self.FData; - PtrNew := TargetBitmap.FData; - for i := (h*w-1) downto 0 do - begin; - RGBToHSL(PtrOld^.R,PtrOld^.G,PtrOld^.B,He,Se,Le); - HSLtoRGB(He,0.0,Le,PtrNew^.R,PtrNew^.G,PtrNew^.B); - inc(ptrOld); - inc(PtrNew); - end; -end; - -procedure TMufasaBitmap.GreyScale(TargetBitmap: TMufasaBitmap); -var - I : integer; - Lum : byte; - PtrOld,PtrNew : PRGB32; -begin - TargetBitmap.SetSize(w,h); - PtrOld := Self.FData; - PtrNew := TargetBitmap.FData; - for i := (h*w-1) downto 0 do - begin; - Lum := Round(PtrOld^.r * 0.3 + PtrOld^.g * 0.59 + PtrOld^.b * 0.11); - PtrNew^.r := Lum; - PtrNew^.g := Lum; - PtrNew^.b := Lum; - inc(ptrOld); - inc(PtrNew); - end; -end; - -procedure TMufasaBitmap.GreyScale; -var - I : integer; - Lum : Byte; - Ptr: PRGB32; -begin - Ptr := Self.FData; - for i := (h*w-1) downto 0 do - begin; - Lum := Round(Ptr^.r * 0.3 + Ptr^.g * 0.59 + Ptr^.b * 0.11); - Ptr^.r := Lum; - Ptr^.g := Lum; - Ptr^.b := Lum; - inc(ptr); - end; -end; - -function BrigthnessAdjust(Col: byte; br : integer): byte;inline; -var - temp : integer; -begin; - Temp := Col + Br; - if temp < 0 then - temp := 0 - else if temp > 255 then - temp := 255; - result := temp; -end; -procedure TMufasaBitmap.Brightness(br: integer); -var - I : integer; - Ptr: PRGB32; -begin - Ptr := Self.FData; - for i := (h*w-1) downto 0 do - begin; - Ptr^.r := BrigthnessAdjust(Ptr^.r,br); - Ptr^.g := BrigthnessAdjust(Ptr^.g,br); - Ptr^.b := BrigthnessAdjust(Ptr^.b,br); - inc(ptr); - end; -end; - -procedure TMufasaBitmap.Brightness(TargetBitmap: TMufasaBitmap; br: integer); -var - I : integer; - PtrOld,PtrNew : PRGB32; -begin - TargetBitmap.SetSize(w,h); - PtrOld := Self.FData; - PtrNew := TargetBitmap.FData; - for i := (h*w-1) downto 0 do - begin; - PtrNew^.r := BrigthnessAdjust(PtrOld^.r,br); - PtrNew^.g := BrigthnessAdjust(PtrOld^.g,br); - PtrNew^.b := BrigthnessAdjust(PtrOld^.b,br); - inc(ptrOld); - inc(PtrNew); - end; -end; - -const - Grey = 128; -function ContrastAdjust(Col: byte; co : extended): byte;inline; -var - temp : integer; -begin; - Temp := floor((col - Grey) * co) + grey; - if temp < 0 then - temp := 0 - else if temp > 255 then - temp := 255; - result := temp; -end; - -procedure TMufasaBitmap.Contrast(co: Extended); -var - I : integer; - Ptr: PRGB32; -begin - Ptr := Self.FData; - for i := (h*w-1) downto 0 do - begin; - Ptr^.r := ContrastAdjust(Ptr^.r,co); - Ptr^.g := ContrastAdjust(Ptr^.g,co); - Ptr^.b := ContrastAdjust(Ptr^.b,co); - inc(ptr); - end; -end; - -procedure TMufasaBitmap.Contrast(TargetBitmap: TMufasaBitmap; co: Extended); -var - I : integer; - PtrOld,PtrNew : PRGB32; -begin - TargetBitmap.SetSize(w,h); - PtrOld := Self.FData; - PtrNew := TargetBitmap.FData; - for i := (h*w-1) downto 0 do - begin; - PtrNew^.r := ContrastAdjust(PtrOld^.r,co); - PtrNew^.g := ContrastAdjust(PtrOld^.g,co); - PtrNew^.b := ContrastAdjust(PtrOld^.b,co); - inc(ptrOld); - inc(PtrNew); - end; -end; - -procedure TMufasaBitmap.Invert; -var - Ptr : PRGB32; - i : integer; -begin - ptr := Self.FData; - for i := (h*w-1) downto 0 do - begin; - Self.FData[i].r := not Self.FData[i].r; - Self.FData[i].g := not Self.FData[i].g; - Self.Fdata[i].b := not Self.FData[i].b; - end; -end; - -procedure TMufasaBitmap.Posterize(TargetBitmap: TMufasaBitmap; Po: integer); -var - I : integer; - PtrOld,PtrNew : PRGB32; -begin - if not InRange(Po,1,255) then - Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); - TargetBitmap.SetSize(w,h); - PtrOld := Self.FData; - PtrNew := TargetBitmap.FData; - for i := (h*w-1) downto 0 do - begin; - PtrNew^.r := Round(PtrOld^.r / po) * Po; - PtrNew^.g := Round(PtrOld^.g / po) * Po; - PtrNew^.b := Round(PtrOld^.b / po) * Po; - inc(ptrOld); - inc(PtrNew); - end; -end; - -procedure TMufasaBitmap.Posterize(Po: integer); -var - I : integer; - Ptr: PRGB32; -begin - if not InRange(Po,1,255) then - Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); - Ptr := Self.FData; - for i := (h*w-1) downto 0 do - begin; - ptr^.r := Round(ptr^.r / po) * Po; - ptr^.g := Round(ptr^.g / po) * Po; - ptr^.b := Round(ptr^.b / po) * Po; - inc(ptr); - end; -end; - -function TMufasaBitmap.CreateTMask: TMask; -var - x,y : integer; - dX,dY : integer; -begin - Result.BlackHi:= -1; - Result.WhiteHi:= -1; - Result.W := Self.Width; - Result.H := Self.Height; - SetLength(result.Black,w*h); - SetLength(result.White,w*h); - dX := w-1; - dY := h-1; - //Search it like | | | | | instead of horizontal -> for X loop first. - for x := 0 to dX do - for y := 0 to dY do - //Check for non-white/black pixels? Not for now atleast. - if FData[y*w+x].r = 255 then - begin; - inc(Result.WhiteHi); - Result.White[Result.WhiteHi].x := x; - Result.White[Result.WhiteHi].y := y; - end else - begin; - inc(Result.BlackHi); - Result.Black[Result.BlackHi].x := x; - Result.Black[Result.BlackHi].y := y; - end; - SetLength(result.Black,Result.BlackHi+1); - SetLength(result.White,Result.WhiteHi+1); -end; - - - -constructor TMBitmaps.Create(Owner: TObject); -begin - inherited Create; - SetLength(BmpArray,50); - SetLength(FreeSpots, 50); - FreeSpotsLen := 50; - BmpsHigh := 49; - BmpsCurr := -1; - FreeSpotsHigh := -1; - Self.Client := Owner; -end; - -destructor TMBitmaps.Destroy; -var - I : integer; -begin - for i := 0 to BmpsCurr do - if BmpArray[i] <> nil then - begin; - if BmpArray[i].BmpName = '' then - Writeln(Format('BMP[%d] has not been freed in the script, freeing it now.',[i])) - else - Writeln(Format('BMP[%s] has not been freed in the script, freeing it now.',[BmpArray[i].BmpName])); - FreeAndNil(BmpArray[i]); - end; - SetLength(BmpArray,0); - SetLength(FreeSpots,0); - inherited Destroy; -end; - - -{ TMufasaBitmap } -procedure TMufasaBitmap.SetSize(Awidth, Aheight: integer); -var - NewData : PRGB32; - i,minw,minh : integer; -begin - if (AWidth <> w) or (AHeight <> h) then - begin; - if AWidth*AHeight <> 0 then - begin; - NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); - FillDWord(NewData[0],AWidth*AHeight,0); - end - else - NewData := nil; - if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then - begin; - minw := Min(AWidth,w); - minh := Min(AHeight,h); - for i := 0 to minh - 1 do - Move(FData[i*w],Newdata[i*AWidth],minw * SizeOf(TRGB32)); - end; - if Assigned(FData) then - FreeMem(FData); - FData := NewData; - w := AWidth; - h := AHeight; - end; -end; - -procedure TMufasaBitmap.StretchResize(AWidth, AHeight: integer); -var - NewData : PRGB32; - i: integer; - x,y : integer; -begin - if (AWidth <> w) or (AHeight <> h) then - begin; - if AWidth*AHeight <> 0 then - begin; - NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); - FillDWord(NewData[0],AWidth*AHeight,0); - end - else - NewData := nil; - if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then - begin; - for y := 0 to AHeight - 1 do - for x := 0 to AWidth -1 do - NewData[y*AWidth + x] := FData[((y * h)div aheight) * W+ (x * W) div awidth]; - end; - if Assigned(FData) then - FreeMem(FData); - FData := NewData; - w := AWidth; - h := AHeight; - end; -end; - -procedure TMufasaBitmap.ValidatePoint(x, y: integer); -begin - if (x <0) or (x >= w) or (y < 0) or (y >= h) then - raise Exception.CreateFmt('You are accesing an invalid point, (%d,%d) at bitmap[%d]',[x,y,index]); -end; - -constructor TMufasaBitmap.Create; -begin - inherited Create; - BmpName:= ''; - FData:= nil; - TransparentSet:= False; - w := 0; - h := 0; -end; - -destructor TMufasaBitmap.Destroy; -begin - if Assigned(OnDestroy) then - OnDestroy(Self); - if Assigned(FData) then - Freemem(FData); - inherited Destroy; -end; - -end. - +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Bitmaps class for the Mufasa Macro Library +} + +unit bitmaps; + +{$mode objfpc}{$H+} + +interface +uses + Classes, SysUtils, FPImgCanv,FPImage,IntfGraphics,graphtype,MufasaTypes,graphics; + +type + + { TMufasaBitmap } + TMufasaBitmap = class(TObject) + private + w,h : integer; + TransparentColor : TRGB32; + TransparentSet : boolean; + public + OnDestroy : procedure(Bitmap : TMufasaBitmap) of object; + FData : PRGB32; + Index : integer; + BmpName : string; //Optional? + procedure SetSize(AWidth,AHeight : integer); + procedure StretchResize(AWidth,AHeight : integer); + property Width : Integer read w; + property Height : Integer read h; + procedure ValidatePoint(x,y : integer); + function SaveToFile(const FileName : string) :boolean; + procedure LoadFromFile(const FileName : string); + procedure FastSetPixel(x,y : integer; Color : TColor); + procedure FastSetPixels(TPA : TPointArray; Colors : TIntegerArray); + function FastGetPixel(x,y : integer) : TColor; + function FastGetPixels(TPA : TPointArray) : TIntegerArray; + Procedure SetTransparentColor(Col : TColor); + Function GetTransparentColor : TColor; + property TransparentColorSet : boolean read TransparentSet; + procedure FastDrawClear(Color : TColor); + procedure FastDrawTransparent(x, y: Integer; TargetBitmap: TMufasaBitmap); + procedure FastReplaceColor(OldColor, NewColor: TColor); + procedure CopyClientToBitmap(MWindow : TObject; xs, ys, xe, ye: Integer); + procedure RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); + procedure Desaturate;overload; + procedure Desaturate(TargetBitmap : TMufasaBitmap); overload; + procedure GreyScale(TargetBitmap : TMufasaBitmap);overload; + procedure GreyScale; + procedure Brightness(br: integer);overload; + procedure Brightness(TargetBitmap : TMufasaBitmap; br : integer); overload; + procedure Contrast(co: Extended);overload; + procedure Contrast(TargetBitmap : TMufasaBitmap; co : Extended);overload; + procedure Invert; + procedure Posterize(TargetBitmap : TMufasaBitmap; Po : integer);overload; + procedure Posterize(Po : integer);overload; + function CreateTMask : TMask; + constructor Create; + destructor Destroy;override; + end; + + TMufasaBmpArray = Array of TMufasaBitmap; + { TMBitmaps } + TMBitmaps = class(TObject) + protected + Client : TObject; + FreeSpots : Array of integer; + BmpArray : TMufasaBmpArray; + BmpsCurr,BmpsHigh,FreeSpotsHigh,FreeSpotsLen : integer; + public + function GetBMP(Index : integer) : TMufasaBitmap; + property Bmp[Index : integer]: TMufasaBitmap read GetBMP; + function CreateBMP(w, h: integer): Integer; + function CopyBMP( Bitmap : integer) : Integer; + function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer; + function CreateBMPFromFile(const Path : string) : integer; + function CreateBMPFromString(width,height : integer; Data : string) : integer;overload; + function CreateBMPFromString(BmpName : string; width,height : integer; Data : string) : integer;overload; + procedure FreeBMP( Number : integer); + constructor Create(Owner : TObject); + destructor Destroy;override; + end; + + +implementation + +uses + Windowutil,paszlib,DCPbase64,mmath,math, + colour_conv,window; + +function Min(a,b:integer) : integer; +begin + if a < b then + result := a + else + result := b; +end; + +{ TMBitmaps } + + +function TMBitmaps.GetBMP(Index: integer): TMufasaBitmap; +begin + Result := nil; + if (Index >= 0) and (Index <= BmpsCurr) then + if BmpArray[Index] <> nil then + Result := BmpArray[Index]; + if Result = nil then + raise Exception.CreateFmt('The bitmap[%d] does not exist',[Index]); +end; + +function TMBitmaps.CreateBMP(w,h : integer): Integer; +begin + if BmpsCurr < BmpsHigh then + begin; + inc(BmpsCurr); + Result := BmpsCurr; + end else if (FreeSpotsHigh > -1) then + begin; + Result := FreeSpots[FreeSpotsHigh]; + dec(FreeSpotsHigh); + end else + begin; + SetLength(BmpArray, BmpsHigh + 6); + BmpsHigh := BmpsHigh + 5; + inc(BmpsCurr); + Result := BmpsCurr; + end; + BmpArray[Result] := TMufasaBitmap.Create; + BmpArray[Result].SetSize(w,h); + BmpArray[Result].Index:= Result; +end; + +function TMBitmaps.CopyBMP(Bitmap: integer): Integer; +var + InputBMP : TMufasaBitmap; + OutputBMP : TMUfasaBitmap; +begin + InputBMP := GetBMP(Bitmap); + Result := CreateBMP(InputBmp.w,InputBMP.h); + OutputBMP := GetBMP(Result); + Move(InputBMP.FData[0],OutPutBMP.FData[0],InputBMP.w * InputBMP.h * SizeOf(TRGB32)); +end; + +function TMBitmaps.CreateMirroredBitmap(bitmap: Integer; + MirrorStyle: TBmpMirrorStyle): Integer; +var + w,h : integer; + y,x : integer; + Source,Dest : PRGB32; +begin + Source := Bmp[Bitmap].FData; + w := BmpArray[Bitmap].Width; + h := BmpArray[Bitmap].Height; + if MirrorStyle = MirrorLine then + Result := CreateBMP(h,w) + else + Result := CreateBMP(w,h); + Dest := BmpArray[Result].FData; + case MirrorStyle of + MirrorWidth : for y := (h-1) downto 0 do + for x := (w-1) downto 0 do + Dest[y*w+x] := Source[y*w+w-1-x]; + MirrorHeight : for y := (h-1) downto 0 do + Move(Source[y*w],Dest[(h-1 - y) * w],w*SizeOf(TRGB32)); + MirrorLine : for y := (h-1) downto 0 do + for x := (w-1) downto 0 do + Dest[x*h+y] := Source[y*w+x]; + + end; +//Can be optmized, this is just proof of concept +end; + +function TMBitmaps.CreateBMPFromFile(const Path: string): integer; +begin + Result := CreateBMP(0,0); + BmpArray[result].LoadFromFile(Path); +end; + +function HexToInt(HexNum: string): LongInt;inline; +begin + Result:=StrToInt('$' + HexNum); +end; + +function TMBitmaps.CreateBMPFromString(width, height: integer; Data: string): integer; +var + I,II,x,y: LongWord; + DestLen : LongWord; + Dest,Source : string; + DestPoint, Point : PByte; + LazIntf : TLazIntfImage; + +begin + Result := CreateBMP(width,height); + if (Data <> '') and (Length(Data) <> 6) then + begin; + Point := Pointer(BmpArray[Result].FData); + if Data[1] = 'b' then + begin; + Source := Base64DecodeStr(Copy(Data,2,Length(Data) - 1)); + Destlen := Width * Height * 3; + Setlength(Dest,DestLen); + if uncompress(PChar(Dest),Destlen,pchar(Source), Length(Source)) = Z_OK then + begin; + DestPoint := @Dest[1]; + i := 0; + ii := 2; + Dec(DestLen); + if DestLen > 2 then + begin; + while (ii < DestLen) do + Begin; + Point[i]:= DestPoint[ii+2]; + Point[i+1]:= DestPoint[ii+1]; + Point[i+2]:= DestPoint[ii]; + ii := ii + 3; + i := i + 4; + end; + Point[i] := DestPoint[1]; + Point[i+1] := DestPoint[0]; + Point[i+2] := DestPoint[ii]; + end else if (Width = 1) and (Height =1 ) then + begin; + Point[0] := DestPoint[1]; + Point[1] := DestPoint[0]; + Point[2] := DestPoint[2]; + end; + end; + end else if Data[1] = 'z' then + begin; + Destlen := Width * Height * 3 *2; + Setlength(Dest,DestLen); + ii := (Length(Data) - 1) div 2; + SetLength(Source,ii); + for i := 1 to ii do + Source[i] := Chr(HexToInt(Data[i * 2] + Data[i * 2+1])); + if uncompress(PChar(Dest),Destlen,pchar(Source), ii) = Z_OK then + begin; + ii := 1; + i := 0; + while (II < DestLen) do + begin; + Point[i+2]:= HexToInt(Dest[ii] + Dest[ii + 1]); + Point[i+1]:= HexToInt(Dest[ii+2] + Dest[ii + 3]); + Point[i]:= HexToInt(Dest[ii+4] + Dest[ii + 5]); + ii := ii + 6; + i := i + 4; + end; + end; + end else if LongWord(Length(Data)) = (Width * Height * 3 * 2) then + begin; + ii := 1; + i := 0; + Destlen := Width * Height * 3 * 2; + while (II < DestLen) do + begin; + Point[i+2]:= HexToInt(Data[ii] + Data[ii + 1]); + Point[i+1]:= HexToInt(Data[ii+2] + Data[ii + 3]); + Point[i]:= HexToInt(Data[ii+4] + Data[ii + 5]); + ii := ii + 6; + i := i + 4; + end; + end; + end else + begin; + if Length(data) = 6 then + BmpArray[Result].FastDrawClear(HexToInt(Data)); +// else +// FastDrawClear(Result,clBlack); + end; +end; + +function TMBitmaps.CreateBMPFromString(BmpName: string; width, height: integer; + Data: string): integer; +begin + Result := Self.CreateBMPFromString(width,height,data); + Bmp[Result].BmpName:= BmpName; + +end; + +procedure TMBitmaps.FreeBMP(Number: integer); +var + ToDestroy : TMufasaBitmap; +begin + ToDestroy := GetBMP(Number); + if Number = BmpsCurr then + Dec(BmpsCurr) + else + begin; + inc(FreeSpotsHigh); + if FreeSpotsHigh = FreeSpotsLen then + begin; + inc(FreeSpotsLen); + SetLength(FreeSpots, FreeSpotsLen); + end; + FreeSpots[FreeSpotsHigh] := Number; + end; + //Just for testing purposes + if ToDestroy.BmpName = '' then + Writeln(Format('BMP[%d] has been freed.',[number])) + else + Writeln(Format('BMP[%s] has been freed.',[ToDestroy.BmpName])); + FreeAndNil(ToDestroy); +end; + +function TMufasaBitmap.SaveToFile(const FileName: string): boolean; +var + rawImage : TRawImage; + Bmp : TLazIntfImage; +begin + ArrDataToRawImage(FData,Point(w,h),RawImage); +// Bmp := Graphics.TBitmap.Create; + Bmp := TLazIntfImage.Create(RawImage,false); + Bmp.SaveToFile(FileName); + Bmp.Free; +end; + +procedure TMufasaBitmap.LoadFromFile(const FileName: string); +var + LazIntf : TLazIntfImage; + RawImageDesc : TRawImageDescription; +begin + if FileExists(FileName) then + begin; + LazIntf := TLazIntfImage.Create(0,0); + RawImageDesc.Init_BPP32_B8G8R8_BIO_TTB(LazIntf.Width,LazIntf.Height); + LazIntf.DataDescription := RawImageDesc; + LazIntf.LoadFromFile(FileName); + if Assigned(FData) then + Freemem(FData); + Self.W := LazIntf.Width; + Self.H := LazIntf.Height; + FData := GetMem(Self.W*Self.H*SizeOf(TRGB32)); + Move(LazIntf.PixelData[0],FData[0],w*h*sizeOf(TRGB32)); + LazIntf.Free; + end; +end; + +function RGBToBGR(Color : TColor) : TRGB32; inline; +begin; + Result.R := Color and $ff; + Result.G := Color shr 8 and $ff; + Result.B := Color shr 16 and $ff; +end; + +function BGRToRGB(BGR : TRGB32) : TColor;inline; +begin; + Result := BGR.R or BGR.g shl 8 or BGR.b shl 16; +end; + +procedure TMufasaBitmap.FastSetPixel(x, y: integer; Color: TColor); +begin + ValidatePoint(x,y); + FData[y*w+x] := RGBToBGR(Color); +end; + +procedure TMufasaBitmap.FastSetPixels(TPA: TPointArray; Colors: TIntegerArray); +var + i,len : integer; +begin + len := High(TPA); + if Len <> High(colors) then + Raise Exception.CreateFMT('TPA/Colors Length differ',[]); + for i := 0 to len do + begin; + ValidatePoint(TPA[i].x,TPA[i].y); + FData[TPA[i].y * w + TPA[i].x] := RGBToBGR(Colors[i]); + end; +end; + +function TMufasaBitmap.FastGetPixel(x, y: integer): TColor; +begin + ValidatePoint(x,y); + Result := BGRToRGB(FData[y*w+x]); +end; + +function TMufasaBitmap.FastGetPixels(TPA: TPointArray): TIntegerArray; +var + i,len : integer; +begin + len := high(TPA); + SetLength(result,len+1); + for i := 0 to len do + begin; + ValidatePoint(TPA[i].x,TPA[i].y); + Result[i] := BGRToRGB(FData[TPA[i].y*w + TPA[i].x]); + end; +end; + +procedure TMufasaBitmap.SetTransparentColor(Col: TColor); +begin + TransparentColor:= RGBToBGR(Col); + TransparentSet:= True; +end; + +function TMufasaBitmap.GetTransparentColor: TColor; +begin + if TransparentSet then + Result := BGRToRGB(TransparentColor) + else + raise Exception.CreateFmt('Transparent color for Bitmap[%d] isn''t set',[index]); +end; + +procedure TMufasaBitmap.FastDrawClear(Color: TColor); +var + i : integer; + Rec : TRGB32; +begin + Rec := RGBToBGR(Color); + if h > 0 then + begin; + for i := (w-1) downto 0 do + FData[i] := Rec; + for i := (h-1) downto 1 do + Move(FData[0],FData[i*w],w*SizeOf(TRGB32)); + end; +end; + +procedure TMufasaBitmap.FastDrawTransparent(x, y: Integer; + TargetBitmap: TMufasaBitmap); +var + MinW,MinH,TargetW,TargetH : Integer; + loopx,loopy : integer; +begin + ValidatePoint(x,y); + TargetW := TargetBitmap.Width; + TargetH := TargetBitmap.height; + MinW := Min(w-1,TargetW-x-1); + MinH := Min(h-1,TargetH-y-1); + if TransparentSet then + begin; + for loopy := 0 to MinH do + for loopx := 0 to MinW do + if LongWord(FData[loopy * w + loopx]) <> LongWord(TransparentColor) then + TargetBitmap.FData[(loopy + y) * TargetW + loopx + x] := FData[Loopy * w + loopx]; + + end + else + for loopy := 0 to MinH do + Move(FData[loopy*w],TargetBitmap.FData[(loopy+y) * TargetW + x],(MinW+1) * SizeOf(TRGB32)); + +end; + +procedure TMufasaBitmap.FastReplaceColor(OldColor, NewColor: TColor); +var + OldCol,NewCol : TRGB32; + i : integer; +begin + OldCol := RGBToBGR(OldColor); + NewCol := RGBToBGR(NewColor); + for i := w*h-1 downto 0 do + if LongWord(FData[i]) = LongWord(OldCol) then + FData[i] := NewCol; +end; + +procedure TMufasaBitmap.CopyClientToBitmap(MWindow : TObject; xs, ys, xe, ye: Integer); +var + wi,hi,y : integer; + PtrRet : TRetData; + Rows : integer; +begin + wi := Min(xe-xs + 1,Self.w); + hi := Min(ye-ys + 1,Self.h); + PtrRet := TMWindow(MWindow).ReturnData(xs,ys,wi,hi); + for y := 0 to (hi-1) do + Move(PtrRet.Ptr[y * (wi + PtrRet.IncPtrWith)], FData[y * self.w],wi * SizeOf(TRGB32)); + TMWindow(MWindow).FreeReturnData; +end; + + +function RotatePointEdited(p: TPoint; angle, mx, my: Extended): TPoint; + +begin + Result.X := Ceil(mx + cos(angle) * (p.x - mx) - sin(angle) * (p.y - my)); + Result.Y := Ceil(my + sin(angle) * (p.x - mx) + cos(angle) * (p.y- my)); +end; + +//Scar rotates unit circle-wise.. Oh, scar doesnt update the bounds, so kinda crops ur image. +procedure TMufasaBitmap.RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); +var + NewW,NewH : integer; + CosAngle,SinAngle : extended; + MinX,MinY,MaxX,MaxY : integer; + i : integer; + x,y : integer; + OldX,OldY : integer; + MiddlePoint : TPoint; + NewCorners : array[1..4] of TPoint; //(xs,ye);(xe,ye);(xe,ys);(xs,ys) +begin + MiddlePoint := Point((w-1) div 2,(h-1) div 2); + CosAngle := Cos(Angle); + SinAngle := Sin(Angle); + MinX := MaxInt; + MinY := MaxInt; + MaxX := 0; + MaxY := 0; + NewCorners[1]:= RotatePointEdited(Point(0,h-1),angle,middlepoint.x,middlepoint.y); + NewCorners[2]:= RotatePointEdited(Point(w-1,h-1),angle,middlepoint.x,middlepoint.y); + NewCorners[3]:= RotatePointEdited(Point(w-1,0),angle,middlepoint.x,middlepoint.y); + NewCorners[4]:= RotatePointEdited(Point(0,0),angle,middlepoint.x,middlepoint.y); + for i := 1 to 4 do + begin; + if NewCorners[i].x > MaxX then + MaxX := NewCorners[i].x; + if NewCorners[i].Y > MaxY then + MaxY := NewCorners[i].y; + if NewCorners[i].x < MinX then + MinX := NewCorners[i].x; + if NewCorners[i].y < MinY then + MinY := NewCorners[i].y; + end; + Writeln(Format('Min: (%d,%d) Max : (%d,%d)',[MinX,MinY,MaxX,MaxY])); + NewW := MaxX - MinX+1; + NewH := MaxY - MinY+1; + Writeln(format('New bounds: %d,%d',[NewW,NewH])); + TargetBitmap.SetSize(NewW,NewH); + for y := NewH - 1 downto 0 do + for x := NewW - 1 downto 0 do + begin; + Oldx := Round(MiddlePoint.x + CosAngle * (x + MinX-MiddlePoint.x) - SinAngle * (y + MinY - MiddlePoint.y)); + Oldy := Round(MiddlePoint.y + SinAngle * (x + MinX-MiddlePoint.x) + CosAngle * (y + MinY-MiddlePoint.y)); + if not ((Oldx <0) or (Oldx >= w) or (Oldy < 0) or (Oldy >= h)) then + TargetBitmap.FData[ y * NewW + x] := Self.FData[OldY * W + OldX]; + end; +end; + +procedure TMufasaBitmap.Desaturate; +var + I : integer; + He,Se,Le : extended; + Ptr : PRGB32; +begin + Ptr := FData; + for i := (h*w-1) downto 0 do + begin; + RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,He,Se,Le); + HSLtoRGB(He,0.0,Le,Ptr^.R,Ptr^.G,Ptr^.B); + inc(ptr); + end; +end; + +procedure TMufasaBitmap.Desaturate(TargetBitmap: TMufasaBitmap); +var + I : integer; + He,Se,Le : extended; + PtrOld,PtrNew : PRGB32; +begin + TargetBitmap.SetSize(w,h); + PtrOld := Self.FData; + PtrNew := TargetBitmap.FData; + for i := (h*w-1) downto 0 do + begin; + RGBToHSL(PtrOld^.R,PtrOld^.G,PtrOld^.B,He,Se,Le); + HSLtoRGB(He,0.0,Le,PtrNew^.R,PtrNew^.G,PtrNew^.B); + inc(ptrOld); + inc(PtrNew); + end; +end; + +procedure TMufasaBitmap.GreyScale(TargetBitmap: TMufasaBitmap); +var + I : integer; + Lum : byte; + PtrOld,PtrNew : PRGB32; +begin + TargetBitmap.SetSize(w,h); + PtrOld := Self.FData; + PtrNew := TargetBitmap.FData; + for i := (h*w-1) downto 0 do + begin; + Lum := Round(PtrOld^.r * 0.3 + PtrOld^.g * 0.59 + PtrOld^.b * 0.11); + PtrNew^.r := Lum; + PtrNew^.g := Lum; + PtrNew^.b := Lum; + inc(ptrOld); + inc(PtrNew); + end; +end; + +procedure TMufasaBitmap.GreyScale; +var + I : integer; + Lum : Byte; + Ptr: PRGB32; +begin + Ptr := Self.FData; + for i := (h*w-1) downto 0 do + begin; + Lum := Round(Ptr^.r * 0.3 + Ptr^.g * 0.59 + Ptr^.b * 0.11); + Ptr^.r := Lum; + Ptr^.g := Lum; + Ptr^.b := Lum; + inc(ptr); + end; +end; + +function BrigthnessAdjust(Col: byte; br : integer): byte;inline; +var + temp : integer; +begin; + Temp := Col + Br; + if temp < 0 then + temp := 0 + else if temp > 255 then + temp := 255; + result := temp; +end; +procedure TMufasaBitmap.Brightness(br: integer); +var + I : integer; + Ptr: PRGB32; +begin + Ptr := Self.FData; + for i := (h*w-1) downto 0 do + begin; + Ptr^.r := BrigthnessAdjust(Ptr^.r,br); + Ptr^.g := BrigthnessAdjust(Ptr^.g,br); + Ptr^.b := BrigthnessAdjust(Ptr^.b,br); + inc(ptr); + end; +end; + +procedure TMufasaBitmap.Brightness(TargetBitmap: TMufasaBitmap; br: integer); +var + I : integer; + PtrOld,PtrNew : PRGB32; +begin + TargetBitmap.SetSize(w,h); + PtrOld := Self.FData; + PtrNew := TargetBitmap.FData; + for i := (h*w-1) downto 0 do + begin; + PtrNew^.r := BrigthnessAdjust(PtrOld^.r,br); + PtrNew^.g := BrigthnessAdjust(PtrOld^.g,br); + PtrNew^.b := BrigthnessAdjust(PtrOld^.b,br); + inc(ptrOld); + inc(PtrNew); + end; +end; + +const + Grey = 128; +function ContrastAdjust(Col: byte; co : extended): byte;inline; +var + temp : integer; +begin; + Temp := floor((col - Grey) * co) + grey; + if temp < 0 then + temp := 0 + else if temp > 255 then + temp := 255; + result := temp; +end; + +procedure TMufasaBitmap.Contrast(co: Extended); +var + I : integer; + Ptr: PRGB32; +begin + Ptr := Self.FData; + for i := (h*w-1) downto 0 do + begin; + Ptr^.r := ContrastAdjust(Ptr^.r,co); + Ptr^.g := ContrastAdjust(Ptr^.g,co); + Ptr^.b := ContrastAdjust(Ptr^.b,co); + inc(ptr); + end; +end; + +procedure TMufasaBitmap.Contrast(TargetBitmap: TMufasaBitmap; co: Extended); +var + I : integer; + PtrOld,PtrNew : PRGB32; +begin + TargetBitmap.SetSize(w,h); + PtrOld := Self.FData; + PtrNew := TargetBitmap.FData; + for i := (h*w-1) downto 0 do + begin; + PtrNew^.r := ContrastAdjust(PtrOld^.r,co); + PtrNew^.g := ContrastAdjust(PtrOld^.g,co); + PtrNew^.b := ContrastAdjust(PtrOld^.b,co); + inc(ptrOld); + inc(PtrNew); + end; +end; + +procedure TMufasaBitmap.Invert; +var + Ptr : PRGB32; + i : integer; +begin + ptr := Self.FData; + for i := (h*w-1) downto 0 do + begin; + Self.FData[i].r := not Self.FData[i].r; + Self.FData[i].g := not Self.FData[i].g; + Self.Fdata[i].b := not Self.FData[i].b; + end; +end; + +procedure TMufasaBitmap.Posterize(TargetBitmap: TMufasaBitmap; Po: integer); +var + I : integer; + PtrOld,PtrNew : PRGB32; +begin + if not InRange(Po,1,255) then + Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); + TargetBitmap.SetSize(w,h); + PtrOld := Self.FData; + PtrNew := TargetBitmap.FData; + for i := (h*w-1) downto 0 do + begin; + PtrNew^.r := Round(PtrOld^.r / po) * Po; + PtrNew^.g := Round(PtrOld^.g / po) * Po; + PtrNew^.b := Round(PtrOld^.b / po) * Po; + inc(ptrOld); + inc(PtrNew); + end; +end; + +procedure TMufasaBitmap.Posterize(Po: integer); +var + I : integer; + Ptr: PRGB32; +begin + if not InRange(Po,1,255) then + Raise exception.CreateFmt('Posterize Po(%d) out of range[1,255]',[Po]); + Ptr := Self.FData; + for i := (h*w-1) downto 0 do + begin; + ptr^.r := Round(ptr^.r / po) * Po; + ptr^.g := Round(ptr^.g / po) * Po; + ptr^.b := Round(ptr^.b / po) * Po; + inc(ptr); + end; +end; + +function TMufasaBitmap.CreateTMask: TMask; +var + x,y : integer; + dX,dY : integer; +begin + Result.BlackHi:= -1; + Result.WhiteHi:= -1; + Result.W := Self.Width; + Result.H := Self.Height; + SetLength(result.Black,w*h); + SetLength(result.White,w*h); + dX := w-1; + dY := h-1; + //Search it like | | | | | instead of horizontal -> for X loop first. + for x := 0 to dX do + for y := 0 to dY do + //Check for non-white/black pixels? Not for now atleast. + if FData[y*w+x].r = 255 then + begin; + inc(Result.WhiteHi); + Result.White[Result.WhiteHi].x := x; + Result.White[Result.WhiteHi].y := y; + end else + begin; + inc(Result.BlackHi); + Result.Black[Result.BlackHi].x := x; + Result.Black[Result.BlackHi].y := y; + end; + SetLength(result.Black,Result.BlackHi+1); + SetLength(result.White,Result.WhiteHi+1); +end; + + + +constructor TMBitmaps.Create(Owner: TObject); +begin + inherited Create; + SetLength(BmpArray,50); + SetLength(FreeSpots, 50); + FreeSpotsLen := 50; + BmpsHigh := 49; + BmpsCurr := -1; + FreeSpotsHigh := -1; + Self.Client := Owner; +end; + +destructor TMBitmaps.Destroy; +var + I : integer; +begin + for i := 0 to BmpsCurr do + if BmpArray[i] <> nil then + begin; + if BmpArray[i].BmpName = '' then + Writeln(Format('BMP[%d] has not been freed in the script, freeing it now.',[i])) + else + Writeln(Format('BMP[%s] has not been freed in the script, freeing it now.',[BmpArray[i].BmpName])); + FreeAndNil(BmpArray[i]); + end; + SetLength(BmpArray,0); + SetLength(FreeSpots,0); + inherited Destroy; +end; + + +{ TMufasaBitmap } +procedure TMufasaBitmap.SetSize(Awidth, Aheight: integer); +var + NewData : PRGB32; + i,minw,minh : integer; +begin + if (AWidth <> w) or (AHeight <> h) then + begin; + if AWidth*AHeight <> 0 then + begin; + NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); + FillDWord(NewData[0],AWidth*AHeight,0); + end + else + NewData := nil; + if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then + begin; + minw := Min(AWidth,w); + minh := Min(AHeight,h); + for i := 0 to minh - 1 do + Move(FData[i*w],Newdata[i*AWidth],minw * SizeOf(TRGB32)); + end; + if Assigned(FData) then + FreeMem(FData); + FData := NewData; + w := AWidth; + h := AHeight; + end; +end; + +procedure TMufasaBitmap.StretchResize(AWidth, AHeight: integer); +var + NewData : PRGB32; + i: integer; + x,y : integer; +begin + if (AWidth <> w) or (AHeight <> h) then + begin; + if AWidth*AHeight <> 0 then + begin; + NewData := GetMem(AWidth * AHeight * SizeOf(TRGB32)); + FillDWord(NewData[0],AWidth*AHeight,0); + end + else + NewData := nil; + if Assigned(FData) and Assigned(NewData) and (w*H <> 0) then + begin; + for y := 0 to AHeight - 1 do + for x := 0 to AWidth -1 do + NewData[y*AWidth + x] := FData[((y * h)div aheight) * W+ (x * W) div awidth]; + end; + if Assigned(FData) then + FreeMem(FData); + FData := NewData; + w := AWidth; + h := AHeight; + end; +end; + +procedure TMufasaBitmap.ValidatePoint(x, y: integer); +begin + if (x <0) or (x >= w) or (y < 0) or (y >= h) then + raise Exception.CreateFmt('You are accesing an invalid point, (%d,%d) at bitmap[%d]',[x,y,index]); +end; + +constructor TMufasaBitmap.Create; +begin + inherited Create; + BmpName:= ''; + FData:= nil; + TransparentSet:= False; + w := 0; + h := 0; +end; + +destructor TMufasaBitmap.Destroy; +begin + if Assigned(OnDestroy) then + OnDestroy(Self); + if Assigned(FData) then + Freemem(FData); + inherited Destroy; +end; + +end. + diff --git a/Units/MMLCore/colour_conv.pas b/Units/MMLCore/colour_conv.pas index f37c84b..89d5df3 100644 --- a/Units/MMLCore/colour_conv.pas +++ b/Units/MMLCore/colour_conv.pas @@ -1,304 +1,304 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Colour Conversion Utilities for the Mufasa Macro Library -} - -unit colour_conv; - -{$mode objfpc}{$H+} - -interface - -uses - Classes, SysUtils, - Graphics, - Math; - - -Function RGBtoColor(r,g,b : byte) : TColor; overload; inline; -Function RGBtoColor(r,g,b : integer) : TColor; overload; inline; -Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline; -Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline; -Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline; -Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline; -Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline; -Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Byte); inline;overload; -Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline;overload; -Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; - -implementation - -Const - OneDivThree = 1/3.0; - TwoDivThree = 2 / 3.0; - OneDivTwoPointFour = 1 / 2.4; - -Function RGBtoColor(r,g,b : byte): TColor; overload; inline; -begin; - Result := R or g shl 8 or b shl 16; -end; - -{/\ - Translates the given Red (R), Green (G) and Blue (B) components to a TColor. - R, G and B are integers. -/\} - -Function RGBtoColor(r,g,b : integer): TColor; overload; inline; -begin; - Result := R or g shl 8 or b shl 16; -end; - -{/\ - Translates the given win-32 color in the Red (R), Green (G) and Blue (B) - components. R, G and B are bytes. -/\} - -Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline; -begin - R := Color and $ff; - G := Color shr 8 and $ff; - B := Color shr 16 and $ff; -end; - -{/\ - Translates the given win-32 color in the Red (R), Green (G) and Blue (B) - components. R, G and B are integers. -/\} - -Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline; -begin - R := Color and $ff; - G := Color shr 8 and $ff; - B := Color shr 16 and $ff; -end; - -{/\ - Translates the given Red (R), Green (G) and Blue (B) components to - X, Y and Z components. -/\} - -Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline; -var - Red,Green,Blue : Extended; -begin; - Red := R / 255; - Green := G / 255; - Blue := B / 255; - if Red > 0.04045 then - Red := Power( ( Red + 0.055 ) / 1.055 , 2.4) * 100 - else - Red := Red / 7.73994; - if Green > 0.04045 then - Green := Power( ( Green + 0.055 ) / 1.055 , 2.4) * 100 - else - Green := Green / 7.73994; - if Blue > 0.04045 then - Blue := Power( ( Blue + 0.055 ) / 1.055 , 2.4) * 100 - else - Blue := Blue / 7.73994; - X := Red * 0.4124 + Green * 0.3576 + Blue * 0.1805; - Y := Red * 0.2126 + Green * 0.7152 + Blue * 0.0722; - Z := Red * 0.0193 + Green * 0.1192 + Blue * 0.9505; -end; - -{/\ - Translates the given X, Y and Z components to - Red (R), Green (G) and Blue (B) components. -/\} - -Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline; -var - TempR,TempG,TempB,Tempx,tempy,tempz : Extended; -begin; - Tempx := X / 100; - tempy := Y / 100; - tempz := Z / 100; - TempR := Tempx * 3.2406 + tempy * -1.5372 + tempz * -0.4986; - TempG := Tempx * -0.9689 + tempy * 1.8758 + tempz * 0.0415; - TempB := Tempx * 0.0557 + tempy * -0.2040 + tempz * 1.0570; - if TempR > 0.0031308 then - TempR := 1.055 * ( Power(TempR, (OneDivTwoPointFour)) ) - 0.055 - else - TempR := 12.92 * TempR; - if TempG > 0.0031308 then - TempG := 1.055 * ( Power(TempG, ( OneDivTwoPointFour)) ) - 0.055 - else - TempG := 12.92 * TempG; - if TempB > 0.0031308 then - TempB := 1.055 * ( Power(TempB , ( OneDivTwoPointFour )) ) - 0.055 - else - TempB := 12.92 * TempB; - R := Round(TempR * 255); - G := Round(TempG * 255); - B := Round(TempB * 255); -end; - -{/\ - Translates the given Red (R), Green (G) and Blue (B) components to - H (Hue), S (Saturation) and L (Luminance) components. -/\} - -Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline; -var - R, G, B, D, Cmax, Cmin: Extended; -begin - R := RR / 255; - G := GG / 255; - B := BB / 255; - CMin := R; - if G < Cmin then Cmin := G; - if B < Cmin then Cmin := B; - CMax := R; - if G > Cmax then Cmax := G; - if B > Cmax then Cmax := B; - L := 0.5 * (Cmax + Cmin); - if Cmax = Cmin then - begin - H := 0; - S := 0; - end else - begin; - D := Cmax - Cmin; - if L < 0.5 then - S := D / (Cmax + Cmin) - else - S := D / (2 - Cmax - Cmin); - if R = Cmax then - H := (G - B) / D - else - if G = Cmax then - H := 2 + (B - R) / D - else - H := 4 + (R - G) / D; - H := H / 6; - if H < 0 then - H := H + 1; - end; - H := H * 100; - S := S * 100; - L := L * 100; -end; - -{/\ - Translates the given H (Hue), S (Saturation) and L (Luminance) components to - Red (R), Green (G) and Blue (B) components. -/\} - -procedure HSLtoRGB(H, S, L: extended; var R, G, B: Byte); inline; overload; -var - Temp,Temp2 : Extended; -//begin - -Function Hue2RGB(TempHue : Extended) : integer; -begin; - if TempHue < 0 then - TempHue := TempHue + 1 - else if TempHue > 1 then - TempHue := TempHue - 1; - if ( ( 6 * TempHue ) < 1 ) then - Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue ))) - else if ( ( 2 * TempHue ) < 1 ) then - Result :=Round(255 * Temp2) - else if ( ( 3 * TempHue ) < 2 ) then - Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6)) - else - Result :=Round(255 * Temp); -end; - -begin; - H := H / 100; - S := S / 100; - L := L / 100; - if s = 0 then - begin; - R := Byte(Round(L * 255)); - G := R; - B := R; - end else - begin; - if (L < 0.5) then - Temp2 := L * ( 1 + S ) - else - Temp2 := (L + S) - ( S * L); - Temp := 2 * L - Temp2; - R := Hue2RGB( H + ( OneDivThree ) ); - G := Hue2RGB( H ); - B := Hue2RGB( H - ( OneDivThree ) ); - end; -end; - -Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline; -var - Temp,Temp2 : Extended; -//begin - -Function Hue2RGB(TempHue : Extended) : integer; -begin; - if TempHue < 0 then - TempHue := TempHue + 1 - else if TempHue > 1 then - TempHue := TempHue - 1; - if ( ( 6 * TempHue ) < 1 ) then - Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue ))) - else if ( ( 2 * TempHue ) < 1 ) then - Result :=Round(255 * Temp2) - else if ( ( 3 * TempHue ) < 2 ) then - Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6)) - else - Result :=Round(255 * Temp); -end; - -begin; - H := H / 100; - S := S / 100; - L := L / 100; - if s = 0 then - begin; - R := Round(L * 255); - G := R; - B := R; - end else - begin; - if (L < 0.5) then - Temp2 := L * ( 1 + S ) - else - Temp2 := (L + S) - ( S * L); - Temp := 2 * L - Temp2; - R := Hue2RGB( H + ( OneDivThree ) ); - G := Hue2RGB( H ); - B := Hue2RGB( H - ( OneDivThree ) ); - end; -end; - -{/\ - Split the Given Color col in H, S, L components. -/\} - -Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; -Var - R, G, B: Integer; -Begin - ColorToRGB(Col, R, G, B); - RGBToHSL(R, G, B, H, S, L); -End; - -end. - +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Colour Conversion Utilities for the Mufasa Macro Library +} + +unit colour_conv; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + Graphics, + Math; + + +Function RGBtoColor(r,g,b : byte) : TColor; overload; inline; +Function RGBtoColor(r,g,b : integer) : TColor; overload; inline; +Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline; +Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline; +Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline; +Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline; +Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline; +Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Byte); inline;overload; +Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline;overload; +Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; + +implementation + +Const + OneDivThree = 1/3.0; + TwoDivThree = 2 / 3.0; + OneDivTwoPointFour = 1 / 2.4; + +Function RGBtoColor(r,g,b : byte): TColor; overload; inline; +begin; + Result := R or g shl 8 or b shl 16; +end; + +{/\ + Translates the given Red (R), Green (G) and Blue (B) components to a TColor. + R, G and B are integers. +/\} + +Function RGBtoColor(r,g,b : integer): TColor; overload; inline; +begin; + Result := R or g shl 8 or b shl 16; +end; + +{/\ + Translates the given win-32 color in the Red (R), Green (G) and Blue (B) + components. R, G and B are bytes. +/\} + +Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline; +begin + R := Color and $ff; + G := Color shr 8 and $ff; + B := Color shr 16 and $ff; +end; + +{/\ + Translates the given win-32 color in the Red (R), Green (G) and Blue (B) + components. R, G and B are integers. +/\} + +Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline; +begin + R := Color and $ff; + G := Color shr 8 and $ff; + B := Color shr 16 and $ff; +end; + +{/\ + Translates the given Red (R), Green (G) and Blue (B) components to + X, Y and Z components. +/\} + +Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline; +var + Red,Green,Blue : Extended; +begin; + Red := R / 255; + Green := G / 255; + Blue := B / 255; + if Red > 0.04045 then + Red := Power( ( Red + 0.055 ) / 1.055 , 2.4) * 100 + else + Red := Red / 7.73994; + if Green > 0.04045 then + Green := Power( ( Green + 0.055 ) / 1.055 , 2.4) * 100 + else + Green := Green / 7.73994; + if Blue > 0.04045 then + Blue := Power( ( Blue + 0.055 ) / 1.055 , 2.4) * 100 + else + Blue := Blue / 7.73994; + X := Red * 0.4124 + Green * 0.3576 + Blue * 0.1805; + Y := Red * 0.2126 + Green * 0.7152 + Blue * 0.0722; + Z := Red * 0.0193 + Green * 0.1192 + Blue * 0.9505; +end; + +{/\ + Translates the given X, Y and Z components to + Red (R), Green (G) and Blue (B) components. +/\} + +Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline; +var + TempR,TempG,TempB,Tempx,tempy,tempz : Extended; +begin; + Tempx := X / 100; + tempy := Y / 100; + tempz := Z / 100; + TempR := Tempx * 3.2406 + tempy * -1.5372 + tempz * -0.4986; + TempG := Tempx * -0.9689 + tempy * 1.8758 + tempz * 0.0415; + TempB := Tempx * 0.0557 + tempy * -0.2040 + tempz * 1.0570; + if TempR > 0.0031308 then + TempR := 1.055 * ( Power(TempR, (OneDivTwoPointFour)) ) - 0.055 + else + TempR := 12.92 * TempR; + if TempG > 0.0031308 then + TempG := 1.055 * ( Power(TempG, ( OneDivTwoPointFour)) ) - 0.055 + else + TempG := 12.92 * TempG; + if TempB > 0.0031308 then + TempB := 1.055 * ( Power(TempB , ( OneDivTwoPointFour )) ) - 0.055 + else + TempB := 12.92 * TempB; + R := Round(TempR * 255); + G := Round(TempG * 255); + B := Round(TempB * 255); +end; + +{/\ + Translates the given Red (R), Green (G) and Blue (B) components to + H (Hue), S (Saturation) and L (Luminance) components. +/\} + +Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline; +var + R, G, B, D, Cmax, Cmin: Extended; +begin + R := RR / 255; + G := GG / 255; + B := BB / 255; + CMin := R; + if G < Cmin then Cmin := G; + if B < Cmin then Cmin := B; + CMax := R; + if G > Cmax then Cmax := G; + if B > Cmax then Cmax := B; + L := 0.5 * (Cmax + Cmin); + if Cmax = Cmin then + begin + H := 0; + S := 0; + end else + begin; + D := Cmax - Cmin; + if L < 0.5 then + S := D / (Cmax + Cmin) + else + S := D / (2 - Cmax - Cmin); + if R = Cmax then + H := (G - B) / D + else + if G = Cmax then + H := 2 + (B - R) / D + else + H := 4 + (R - G) / D; + H := H / 6; + if H < 0 then + H := H + 1; + end; + H := H * 100; + S := S * 100; + L := L * 100; +end; + +{/\ + Translates the given H (Hue), S (Saturation) and L (Luminance) components to + Red (R), Green (G) and Blue (B) components. +/\} + +procedure HSLtoRGB(H, S, L: extended; var R, G, B: Byte); inline; overload; +var + Temp,Temp2 : Extended; +//begin + +Function Hue2RGB(TempHue : Extended) : integer; +begin; + if TempHue < 0 then + TempHue := TempHue + 1 + else if TempHue > 1 then + TempHue := TempHue - 1; + if ( ( 6 * TempHue ) < 1 ) then + Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue ))) + else if ( ( 2 * TempHue ) < 1 ) then + Result :=Round(255 * Temp2) + else if ( ( 3 * TempHue ) < 2 ) then + Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6)) + else + Result :=Round(255 * Temp); +end; + +begin; + H := H / 100; + S := S / 100; + L := L / 100; + if s = 0 then + begin; + R := Byte(Round(L * 255)); + G := R; + B := R; + end else + begin; + if (L < 0.5) then + Temp2 := L * ( 1 + S ) + else + Temp2 := (L + S) - ( S * L); + Temp := 2 * L - Temp2; + R := Hue2RGB( H + ( OneDivThree ) ); + G := Hue2RGB( H ); + B := Hue2RGB( H - ( OneDivThree ) ); + end; +end; + +Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline; +var + Temp,Temp2 : Extended; +//begin + +Function Hue2RGB(TempHue : Extended) : integer; +begin; + if TempHue < 0 then + TempHue := TempHue + 1 + else if TempHue > 1 then + TempHue := TempHue - 1; + if ( ( 6 * TempHue ) < 1 ) then + Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue ))) + else if ( ( 2 * TempHue ) < 1 ) then + Result :=Round(255 * Temp2) + else if ( ( 3 * TempHue ) < 2 ) then + Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6)) + else + Result :=Round(255 * Temp); +end; + +begin; + H := H / 100; + S := S / 100; + L := L / 100; + if s = 0 then + begin; + R := Round(L * 255); + G := R; + B := R; + end else + begin; + if (L < 0.5) then + Temp2 := L * ( 1 + S ) + else + Temp2 := (L + S) - ( S * L); + Temp := 2 * L - Temp2; + R := Hue2RGB( H + ( OneDivThree ) ); + G := Hue2RGB( H ); + B := Hue2RGB( H - ( OneDivThree ) ); + end; +end; + +{/\ + Split the Given Color col in H, S, L components. +/\} + +Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; +Var + R, G, B: Integer; +Begin + ColorToRGB(Col, R, G, B); + RGBToHSL(R, G, B, H, S, L); +End; + +end. + diff --git a/Units/MMLCore/finder.pas b/Units/MMLCore/finder.pas index 007892b..0fae817 100644 --- a/Units/MMLCore/finder.pas +++ b/Units/MMLCore/finder.pas @@ -1,1279 +1,1279 @@ -{ - This file is part of the Mufasa Macro Library (MML) - Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer - - MML is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - MML is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with MML. If not, see . - - See the file COPYING, included in this distribution, - for details about the copyright. - - Finder class for the Mufasa Macro Library -} - -unit finder; - -{$mode objfpc}{$H+} - -interface - -{$define CheckAllBackground}//Undefine this to only check the first white point against the background (in masks). -uses - Classes, SysUtils,bitmaps, MufasaTypes; // Types - -{ TMFinder Class } - -{ - Should be 100% independant, as all platform dependant code is in the - Window and Input classes. - - Let's try not to use any OS-specific defines here? ;) -} - -type - TMFinder = class(TObject) - constructor Create(aClient: TObject); - destructor Destroy; override; - private - Procedure UpdateCachedValues(NewWidth,NewHeight : integer); - procedure DefaultOperations(var xs,ys,xe,ye : integer); - //Loads the Spiral into ClientTPA (Will not cause problems) - procedure LoadSpiralPath(startX, startY, x1, y1, x2, y2: Integer); - public - function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer; - procedure SetToleranceSpeed(nCTS: Integer); - function SimilarColors(Color1,Color2,Tolerance : Integer) : boolean; - // Possibly turn x, y into a TPoint var. - function FindColor(var x, y: Integer; Color, xs, ys, xe, ye: Integer): Boolean; - function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean; - function FindColorTolerance(var x, y: Integer; Color, xs, ys, xe, ye, tol: Integer): Boolean; - function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tol: Integer): Boolean; - function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean; - function FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean; - //Mask - function FindBitmapMaskTolerance(mask: TMask; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; - procedure CheckMask(Mask : TMask); - //Bitmap functions - function FindBitmap(bitmap: TMufasaBitmap; var x, y: Integer): Boolean; - function FindBitmapIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; - function FindBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean; - function FindBitmapSpiral(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; - function FindBitmapSpiralTolerance(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean; - function FindBitmapsSpiralTolerance(bitmap: TMufasaBitmap; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; - function FindDeformedBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; - protected - Client: TObject; - CachedWidth, CachedHeight : integer; - ClientTPA : TPointArray; - hueMod, satMod: Extended; - CTS: Integer; - end; - -implementation -uses - Client, // For the Client Casts. - colour_conv, // For RGBToColor, etc. - math //min/max - ; -type - TPRGB32Array = array of PRGB32; - -procedure TMFinder.LoadSpiralPath(startX, startY, x1, y1, x2, y2: Integer); -var - i,y,x,c,Ring : integer; - CurrBox : TBox; -begin; - i := 0; - Ring := 1; - c := 0; - CurrBox.x1 := Startx-1; - CurrBox.y1 := Starty-1; - CurrBox.x2 := Startx+1; - CurrBox.y2 := Starty+1; - if (startx >= x1) and (startx <= x2) and (starty >= y1) and (starty <= y2) then - begin; - ClientTPA[c] := Point(Startx, StartY); - inc(c); - end; - Repeat - if (CurrBox.x2 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y1 >= y1) and (Currbox.y1 <= y2) then - for i := CurrBox.x1 + 1 to CurrBox.x2 do - if (I >= x1) and ( I <= x2) then - begin; - ClientTPA[c] := Point(i,CurrBox.y1); - inc(c); - end; - if (CurrBox.x2 >= x1) and (CurrBox.x2 <= x2) and (Currbox.y2 >= y1) and (Currbox.y1 <= y2) then - for i := CurrBox.y1 + 1 to CurrBox.y2 do - if (I >= y1) and ( I <= y2) then - begin; - ClientTPA[c] := Point(Currbox.x2, I); - inc(c); - end; - if (CurrBox.x2 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y2 >= y1) and (Currbox.y2 <= y2) then - for i := CurrBox.x2 - 1 downto CurrBox.x1 do - if (I >= x1) and ( I <= x2) then - begin; - ClientTPA[c] := Point(i,CurrBox.y2); - inc(c); - end; - if (CurrBox.x1 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y2 >= y1) and (Currbox.y1 <= y2) then - for i := CurrBox.y2 - 1 downto CurrBox.y1 do - if (I >= y1) and ( I <= y2) then - begin; - ClientTPA[c] := Point(Currbox.x1, I); - inc(c); - end; - inc(ring); - CurrBox.x1 := Startx-ring; - CurrBox.y1 := Starty-Ring; - CurrBox.x2 := Startx+Ring; - CurrBox.y2 := Starty+Ring; - until (Currbox.x1 < x1) and (Currbox.x2 > x2) and (currbox.y1 < y1) and (currbox.y2 > y2); -end; - -function CalculateRowPtrs(ReturnData : TRetData; RowCount : integer) : TPRGB32Array;overload; -var - I : integer; -begin; - setlength(result,RowCount); - for i := 0 to RowCount - 1 do - result[i] := ReturnData.Ptr + ReturnData.RowLen * i; -end; - -function CalculateRowPtrs(Bitmap : TMufasaBitmap) : TPRGB32Array;overload; -var - I : integer; -begin; - setlength(result,Bitmap.Height); - for i := 0 to Bitmap.Height - 1 do - result[i] := Bitmap.FData + Bitmap.Width * i; -end; -//SkipCoords[y][x] = False/True; True means its "transparent" and therefore not needed to be checked. -procedure CalculateBitmapSkipCoords(Bitmap : TMufasaBitmap; out SkipCoords : T2DBoolArray); -var - x,y : integer; - R,G,B : byte; - Ptr : PRGB32; -begin; - r := 0; - g := 0; - b := 0; - if Bitmap.TransparentColorSet then - ColorToRGB(Bitmap.GetTransparentColor,r,g,b); - Ptr := Bitmap.FData; - SetLength(SkipCoords,Bitmap.Height,Bitmap.Width); - for y := 0 to Bitmap.Height - 1 do - for x := 0 to Bitmap.Width - 1 do - begin; - if (Ptr^.r = r) and (Ptr^.g = g) and (Ptr^.b = b) then - SkipCoords[y][x] := True - else - SkipCoords[y][x] := false; - inc(ptr); - end; -end; -//Points left holds the amount of points that are "left" to be checked (Including the point itself.. So for example Pointsleft[0][0] would hold the total amount of pixels that are to be checked. -procedure CalculateBitmapSkipCoordsEx(Bitmap : TMufasaBitmap; out SkipCoords : T2DBoolArray;out TotalPoints : integer; out PointsLeft : T2DIntArray); -var - x,y : integer; - R,G,B : byte; - Ptr : PRGB32; - TotalC : integer; -begin; - r := 0; - g := 0; - b := 0; - TotalC := 0; - if Bitmap.TransparentColorSet then - ColorToRGB(Bitmap.GetTransparentColor,r,g,b); - Ptr := Bitmap.FData; - SetLength(SkipCoords,Bitmap.Height,Bitmap.Width); - SetLength(PointsLeft,Bitmap.Height,Bitmap.Width); - for y := 0 to Bitmap.Height - 1 do - for x := 0 to Bitmap.Width - 1 do - begin; - if (Ptr^.r = r) and (Ptr^.g = g) and (Ptr^.b = b) then - SkipCoords[y][x] := True - else - begin; - SkipCoords[y][x] := false; - inc(TotalC); - end; - inc(ptr); - end; - TotalPoints:= TotalC; - for y := 0 to Bitmap.Height - 1 do - for x := 0 to Bitmap.Width - 1 do - begin; - PointsLeft[y][x] := TotalC; - if not SkipCoords[y][x] then - Dec(TotalC); - end; -end; - -constructor TMFinder.Create(aClient: TObject); - -begin - inherited Create; - - Self.Client := aClient; - Self.CTS := 1; - Self.hueMod := 0.2; - Self.satMod := 0.2; - -end; - -destructor TMFinder.Destroy; -begin - - inherited; -end; - -procedure TMFinder.SetToleranceSpeed(nCTS: Integer); -begin - if (nCTS < 0) or (nCTS > 2) then - raise Exception.CreateFmt('The given CTS ([%d]) is invalid.',[nCTS]); - Self.CTS := nCTS; -end; - -function TMFinder.SimilarColors(Color1, Color2,Tolerance: Integer) : boolean; -var - R1,G1,B1,R2,G2,B2 : Byte; - H1,S1,L1,H2,S2,L2 : extended; -begin - Result := False; - ColorToRGB(Color1,R1,G1,B1); - ColorToRGB(Color2,R2,G2,B2); - if Color1 = Color2 then - Result := true - else - case CTS of - 0: Result := ((Abs(R1-R2) <= Tolerance) and (Abs(G1-G2) <= Tolerance) and (Abs(B1-B2) <= Tolerance)); - 1: Result := (Sqrt(sqr(R1-R2) + sqr(G1-G2) + sqr(B1-B2)) <= Tolerance); - 2: begin - RGBToHSL(R1,g1,b1,H1,S1,L1); - RGBToHSL(R2,g2,b2,H2,S2,L2); - Result := ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S2-S1) <= (satMod * Tolerance)) and (abs(L1-L2) <= Tolerance)); - end; - end; -end; - - -function ColorSame(var CTS,Tolerance : Integer; var R1,G1,B1,R2,G2,B2 : byte; var H1,S1,L1,huemod,satmod : extended) : boolean; inline; -var - H2,S2,L2 : extended; -begin - Result := False; - case CTS of - 0: Result := ((Abs(R1-R2) <= Tolerance) and (Abs(G1-G2) <= Tolerance) and (Abs(B1-B2) <= Tolerance)); - 1: Result := (Sqrt(sqr(R1-R2) + sqr(G1-G2) + sqr(B1-B2)) <= Tolerance); - 2: begin - RGBToHSL(R1,g1,b1,H1,S1,L1); - RGBToHSL(R2,g2,b2,H2,S2,L2); - Result := ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S2-S1) <= (satMod * Tolerance)) and (abs(L1-L2) <= Tolerance)); - end; - end; -end; - -procedure TMFinder.UpdateCachedValues(NewWidth, NewHeight: integer); -begin - CachedWidth := NewWidth; - CachedHeight := NewHeight; - SetLength(ClientTPA,NewWidth * NewHeight); -end; - -procedure TMFinder.DefaultOperations(var xs, ys, xe, ye: integer); -var - w,h : integer; -begin - if xs > xe then - raise Exception.CreateFMT('Finder function: Xs > xe (%d,%d)',[xs,xe]); - if ys > ye then - raise Exception.CreateFMT('Finder function: Ys > ye (%d,%d)',[ys,ye]); - if xs < 0 then - // xs := 0; - raise Exception.createFMT('Any Find Function, you did not pass a ' + - 'correct xs: %d.', [xs]); - if ys < 0 then -// ys := 0; - raise Exception.createFMT('Any Find Function, you did not pass a ' + - 'correct ys: %d.', [ys]); - - TClient(Self.Client).MWindow.GetDimensions(w,h); - if (w <> CachedWidth) or (h <> CachedHeight) then - UpdateCachedValues(w,h); - if xe >= w then -// xe := w-1; - raise Exception.createFMT('Any Find Function, you did not pass a ' + - 'correct xe: %d.', [xe]); - if ye >= h then -// ye := h-1; - raise Exception.createFMT('Any Find Function, you did not pass a ' + - 'correct ye: %d.', [ye]); -end; - -function TMFinder.CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer; -var - PtrData: TRetData; - Ptr: PRGB32; - PtrInc: Integer; - clR, clG, clB : byte; - dX, dY, xx, yy: Integer; - h,s,l,hmod,smod : extended; - Ccts : integer; -begin - Result := 0; - DefaultOperations(xs, ys, xe, ye); - dX := xe - xs; - dY := ye - ys; - ColorToRGB(Color, clR, clG, clB); - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - Ptr := PtrData.Ptr; - PtrInc := PtrData.IncPtrWith; - CCts := Self.CTS; - result := 0; - if cts = 2 then - begin; - RGBToHSL(clR,clG,clB,h,s,l); - hmod := Self.hueMod; - smod := Self.satMod; - end; - for yy := ys to ye do - begin; - for xx := xs to xe do - begin; - if ColorSame(CCts,Tolerance,clR,clG,clB,Ptr^.r,Ptr^.g,Ptr^.b,H,S,L,hmod,smod) then - inc(result); - Inc(Ptr); - end; - Inc(Ptr, PtrInc) - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColor(var x, y: Integer; Color, xs, ys, xe, ye: Integer): Boolean; -var - PtrData: TRetData; - Ptr: PRGB32; - PtrInc: Integer; - dX, dY, clR, clG, clB, xx, yy: Integer; - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - //next, convert the color to r,g,b - ColorToRGB(Color, clR, clG, clB); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - - // Do we want to "cache" these vars? - // We will, for now. Easier to type. - Ptr := PtrData.Ptr; - PtrInc := PtrData.IncPtrWith; - - for yy := ys to ye do - begin; - for xx := xs to xe do - begin; - // Colour comparison here. Possibly with tolerance? ;) - if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then - begin - Result := True; - x := xx; - y := yy; - - TClient(Client).MWindow.FreeReturnData; - Exit; - end; - Inc(Ptr); - end; - Inc(Ptr, PtrInc) - end; - - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColorSpiral(var x, y: Integer; color, xs, ys, xe, - ye: Integer): Boolean; -var - PtrData: TRetData; - RowData : TPRGB32Array; - dX, dY, clR, clG, clB, i,HiSpiral: Integer; - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - //next, convert the color to r,g,b - ColorToRGB(Color, clR, clG, clB); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Load rowdata - RowData:= CalculateRowPtrs(ptrdata,dy+1); - //Load the spiral path - LoadSpiralPath(x-xs,y-ys,0,0,dx,dy); - - - HiSpiral := (dy+1) * (dx + 1) -1; - for i := 0 to HiSpiral do - if (RowData[ClientTPA[i].y][ClientTPA[i].x].R = clR) and (RowData[ClientTPA[i].y][ClientTPA[i].x].G = clG) - and (RowData[ClientTPA[i].y][ClientTPA[i].x].B = clB) then - begin - Result := True; - x := ClientTPA[i].x + xs; - y := ClientTPA[i].y + ys; - TClient(Client).MWindow.FreeReturnData; - Exit; - end; - - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColorTolerance(var x, y: Integer; Color, xs, ys, xe, ye, tol: Integer): Boolean; -var - PtrData: TRetData; - Ptr: PRGB32; - PtrInc: Integer; - dX, dY, clR, clG, clB, xx, yy: Integer; - H1, S1, L1, H2, S2, L2: Extended; - - label Hit; - label Miss; - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - //next, convert the color to r,g,b - ColorToRGB(Color, clR, clG, clB); - ColorToHSL(Color, H1, S1, L1); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - - // Do we want to "cache" these vars? - // We will, for now. Easier to type. - Ptr := PtrData.Ptr; - PtrInc := PtrData.IncPtrWith; - - case CTS of - 0: - for yy := ys to ye do - begin - for xx := xs to xe do - begin - if ((abs(clB-Ptr^.B) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clR-Ptr^.R) <= Tol)) then - goto Hit; - inc(Ptr); - end; - Inc(Ptr, PtrInc); - end; - - 1: - begin - Tol := Sqr(Tol); - - for yy := ys to ye do - begin - for xx := xs to xe do - begin - if (sqr(clB - Ptr^.B) + sqr(clG - Ptr^.G) + sqr(clR-Ptr^.R)) <= Tol then - goto Hit; - inc(ptr); - end; - Inc(Ptr, PtrInc); - end; - - end; - 2: - // Can be optimized a lot... RGBToHSL isn't really inline, - // and hueMod * tol is also calculated every time. - begin - for yy := ys to ye do - for xx := xs to xe do - begin - RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,H2,S2,L2); - if ((abs(H1 - H2) <= (hueMod * tol)) and (abs(S1 - S2) <= (satMod * tol)) and (abs(L1 - L2) <= Tol)) then - goto Hit; - inc(Ptr); - end; - Inc(Ptr, PtrInc); - end; - end; - Result := False; - TClient(Client).MWindow.FreeReturnData; - Exit; - - Hit: - Result := True; - x := xx; - y := yy; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColorsTolerance(var Points: TPointArray; Color, xs, ys, - xe, ye, Tol: Integer): Boolean; -var - PtrData: TRetData; - Ptr: PRGB32; - PtrInc,C: Integer; - dX, dY, clR, clG, clB, xx, yy: Integer; - H1, S1, L1, H2, S2, L2: Extended; -begin - Result := false; - DefaultOperations(xs,ys,xe,ye); - - dX := xe - xs; - dY := ye - ys; - //next, convert the color to r,g,b - ColorToRGB(Color, clR, clG, clB); - ColorToHSL(Color, H1, S1, L1); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - - // Do we want to "cache" these vars? - // We will, for now. Easier to type. - Ptr := PtrData.Ptr; - PtrInc := PtrData.IncPtrWith; - c := 0; - case CTS of - 0: - for yy := ys to ye do - begin - for xx := xs to xe do - begin - if ((abs(clB-Ptr^.B) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clR-Ptr^.R) <= Tol)) then - begin; - ClientTPA[c].x := xx; - ClientTPA[c].y := yy; - inc(c); - end; - inc(Ptr); - end; - Inc(Ptr, PtrInc); - end; - - 1: - for yy := ys to ye do - begin - for xx := xs to xe do - begin - if (Sqrt(sqr(clR-Ptr^.R) + sqr(clG - Ptr^.G) + sqr(clB - Ptr^.B)) <= Tol) then - begin; - ClientTPA[c].x := xx; - ClientTPA[c].y := yy; - inc(c); - end; - inc(ptr); - end; - Inc(Ptr, PtrInc); - end; - 2: - begin - for yy := ys to ye do - for xx := xs to xe do - begin - RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,H2,S2,L2); - if ((abs(H1 - H2) <= (hueMod * tol)) and (abs(S1 - S2) <= (satMod * tol)) and (abs(L1 - L2) <= Tol)) then - begin; - ClientTPA[c].x := xx; - ClientTPA[c].y := yy; - inc(c); - end; - inc(Ptr); - end; - Inc(Ptr, PtrInc); - end; - end; - SetLength(Points, C); - Move(ClientTPA[0], Points[0], C * SizeOf(TPoint)); - Result := C > 0; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColorsSpiralTolerance(x, y: Integer; - var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer - ): boolean; -var - PtrData: TRetData; - c : integer; - RowData : TPRGB32Array; - dX, dY, clR, clG, clB, i,SpiralHi: Integer; - H1, S1, L1, H2, S2, L2: Extended; -begin - Result := false; - DefaultOperations(xs,ys,xe,ye); - - dX := xe - xs; - dY := ye - ys; - //next, convert the color to r,g,b - ColorToRGB(Color, clR, clG, clB); - ColorToHSL(Color, H1, S1, L1); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - - c := 0; - - //Load rowdata - RowData:= CalculateRowPtrs(ptrdata,dy+1); - //Load the spiral path - LoadSpiralPath(x-xs,y-ys,0,0,dx,dy); - SpiralHi := (dx + 1) * (dy + 1) - 1; - case CTS of - 0: - for i := 0 to SpiralHi do - if ((abs(clB-RowData[ClientTPA[i].y][ClientTPA[i].x].B) <= Tolerance) and - (abs(clG-RowData[ClientTPA[i].y][ClientTPA[i].x].G) <= Tolerance) and - (Abs(clR-RowData[ClientTPA[i].y][ClientTPA[i].x].R) <= Tolerance)) then - begin; - ClientTPA[c].x := ClientTPA[i].x + xs; - ClientTPA[c].y := ClientTPA[i].y + ys; - inc(c); - end; - - - 1: - for i := 0 to SpiralHi do - if (Sqrt(sqr(clR - RowData[ClientTPA[i].y][ClientTPA[i].x].R) + - sqr(clG - RowData[ClientTPA[i].y][ClientTPA[i].x].G) + - sqr(clB - RowData[ClientTPA[i].y][ClientTPA[i].x].B)) <= Tolerance) then - begin; - ClientTPA[c].x := ClientTPA[i].x + xs; - ClientTPA[c].y := ClientTPA[i].y + ys; - inc(c); - end; - - 2: - for i := 0 to SpiralHi do - begin; - RGBToHSL(RowData[ClientTPA[i].y][ClientTPA[i].x].R, - RowData[ClientTPA[i].y][ClientTPA[i].x].G, - RowData[ClientTPA[i].y][ClientTPA[i].x].B,H2,S2,L2); - if ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S1 - S2) <= (satMod * Tolerance)) and (abs(L1 - L2) <= Tolerance)) then - begin; - ClientTPA[c].x := ClientTPA[i].x + xs; - ClientTPA[c].y := ClientTPA[i].y + ys; - inc(c); - end; - end; - end; - SetLength(Points, C); - Move(ClientTPA[0], Points[0], C * SizeOf(TPoint)); - Result := C > 0; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean; -var - PtrData: TRetData; - Ptr: PRGB32; - PtrInc: Integer; - dX, dY, clR, clG, clB, xx, yy, i: Integer; - -begin - Result := false; - DefaultOperations(xs,ys,xe,ye); - - dX := xe - xs; - dY := ye - ys; - - I := 0; - - ColorToRGB(Color, clR, clG, clB); - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - - Ptr := PtrData.Ptr; - PtrInc := PtrData.IncPtrWith; - - for yy := ys to ye do - begin; - for xx := xs to xe do - begin; - if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then - begin - Self.ClientTPA[I].x := xx; - Self.ClientTPA[i].y := yy; - Inc(I); - end; - Inc(Ptr); - end; - Inc(Ptr, PtrInc); - end; - - SetLength(TPA, I); - - Move(ClientTPA[0], TPA[0], i * SizeOf(TPoint)); - - Result := I > 0; - - TClient(Client).MWindow.FreeReturnData; -end; - -//Only works with CTS 1 for now.. Since Colorsame doesn't return a boolean :-( -//We do not check whether every white pixel is in tol range with every other white pixel.. - -function TMFinder.FindBitmapMaskTolerance(mask: TMask; var x, y: Integer; xs, - ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; -var - MainRowdata : TPRGB32Array; - PtrData : TRetData; - MaskW,MaskH : integer; - CheckerWhite,CheckerBlack,CurrWhite,CurrBlack: TRGB32; - i,ii : integer; - dX, dY, xx, yy: Integer; -label NotFoundMask; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - //Check the mask. - CheckMask(Mask); - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - - //Get the 'fixed' mask size - MaskW := Mask.W; - MaskH := Mask.H; - //Heck our mask cannot be outside the search area - dX := dX - MaskW; - dY := dY - MaskH; - for yy := 0 to dY do - for xx := 0 to dX do - begin; - CheckerWhite := MainRowdata[yy + mask.White[0].y][xx + mask.white[0].x]; - CheckerBlack := MainRowdata[yy + mask.Black[0].y][xx + mask.Black[0].x]; - //Just check two 'random' points against eachother, might be a time saver in some circumstances. - if (Sqrt(sqr(CheckerWhite.r-CheckerBlack.r) + sqr(CheckerWhite.G-CheckerBlack.G) + sqr(CheckerWhite.b-CheckerBlack.B)) - <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference, so continue with looking! - continue; - for i := 0 to mask.WhiteHi do - begin; - CurrWhite := MainRowdata[yy + mask.White[i].y][xx + mask.white[i].x]; - if (Sqrt(sqr(CheckerWhite.r-CurrWhite.r) + sqr(CheckerWhite.G-CurrWhite.G) + sqr(CheckerWhite.b-CurrWhite.B)) - > Tolerance) then //The white checkpoint n' this point aren't in the same tol range -> goto nomatch; - goto NotFoundMask; - {$ifdef CheckAllBackground} - for ii := 0 to mask.BlackHi do - begin - CurrBlack := MainRowdata[yy + mask.Black[ii].y][xx + mask.Black[ii].x]; - if (Sqrt(sqr(CurrWhite.r-CurrBlack.r) + sqr(CurrWhite.G-CurrBlack.G) + sqr(CurrWhite.b-CurrBlack.B)) - <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference -> goto nomatch; - goto NotFoundMask; - end; - {$endif} - end; - {$ifndef CheckAllBackground} - for ii := 0 to mask.BlackHi do - begin - CurrBlack := MainRowdata[yy + mask.Black[ii].y][xx + mask.Black[ii].x]; - if (Sqrt(sqr(CheckerWhite.r-CurrBlack.r) + sqr(CheckerWhite.G-CurrBlack.G) + sqr(CheckerWhite.b-CurrBlack.B)) - <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference -> goto nomatch; - goto NotFoundMask; - end; - {$endif} - //We have found the mask appearntly, otherwise we would have jumped! Gna Gna. - x := xx + xs; - y := yy + ys; - TClient(Client).MWindow.FreeReturnData; - Exit(true); - //Bah not found the mask, lets do nothing and continue! - NotFoundMask: - end; - TClient(Client).MWindow.FreeReturnData; -end; - -procedure TMFinder.CheckMask(Mask: TMask); -begin - if (Mask.W < 1) or (Mask.H < 1) or (Mask.WhiteHi < 0) or (Mask.BlackHi < 0) then - raise exception.CreateFMT('Mask is invalid. Width/Height: (%d,%d). WhiteHi/BlackHi: (%d,%d)',[Mask.W,Mask.H,Mask.WhiteHi,Mask.BlackHi]); -end; - -function TMFinder.FindBitmap(bitmap: TMufasaBitmap; var x, y: Integer): Boolean; -var - w,h : integer; -begin - TClient(Client).MWindow.GetDimensions(w,h); - result := Self.FindBitmapIn(bitmap,x,y,0,0,w-1,h-1); -end; - -function TMFinder.FindBitmapIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, - ys, xe, ye: Integer): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - tmpY : integer; - dX, dY, xx, yy: Integer; - SkipCoords : T2DBoolArray; -label NotFoundBmp; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //Get the "skip coords". - CalculateBitmapSkipCoords(Bitmap,SkipCoords); - for yy := 0 to dY do - for xx := 0 to dX do - begin; - for yBmp:= 0 to BmpH do - begin; - tmpY := yBmp + yy; - for xBmp := 0 to BmpW do - if not SkipCoords[yBmp][xBmp] then - if (BmpRowData[yBmp][xBmp].R <> MainRowdata[tmpY][xBmp + xx].R) or - (BmpRowData[yBmp][xBmp].G <> MainRowdata[tmpY][xBmp + xx].G) or - (BmpRowData[yBmp][xBmp].B <> MainRowdata[tmpY][xBmp + xx].B) then - goto NotFoundBmp; - - end; - //We did find the Bmp, otherwise we would be at the part below - TClient(Client).MWindow.FreeReturnData; - x := xx + xs; - y := yy + ys; - result := true; - exit; - NotFoundBmp: - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, - ys, xe, ye: Integer; tolerance: Integer): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - tmpY : integer; - dX, dY, xx, yy: Integer; - CCTS : integer; - H,S,L,HMod,SMod : extended; - SkipCoords : T2DBoolArray; -label NotFoundBmp; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //We wont want HSL comparison with BMPs, right? Not for now atleast. - CCTS := Self.CTS; - if CCTS > 1 then - CCTS := 1; - //Get the "skip coords". - CalculateBitmapSkipCoords(Bitmap,SkipCoords); - for yy := 0 to dY do - for xx := 0 to dX do - begin; - for yBmp:= 0 to BmpH do - begin; - tmpY := yBmp + yy; - for xBmp := 0 to BmpW do - if not SkipCoords[yBmp][xBmp] then - if not ColorSame(CCTS,tolerance, - BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, - MainRowdata[tmpY][xBmp + xx].R,MainRowdata[tmpY][xBmp + xx].G,MainRowdata[tmpY][xBmp + xx].B, - H,S,L,HMod,SMod) then - goto NotFoundBmp; - - end; - //We did find the Bmp, otherwise we would be at the part below - TClient(Client).MWindow.FreeReturnData; - x := xx + xs; - y := yy + ys; - result := true; - exit; - NotFoundBmp: - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindBitmapSpiral(bitmap: TMufasaBitmap; var x, y: Integer; - xs, ys, xe, ye: Integer): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - tmpY : integer; - dX, dY, i,HiSpiral: Integer; - SkipCoords : T2DBoolArray; -label NotFoundBmp; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck, our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //Load the spiral into memory - LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); - HiSpiral := (dx+1) * (dy+1) - 1; - //Get the "skip coords". - CalculateBitmapSkipCoords(Bitmap,SkipCoords); - for i := 0 to HiSpiral do - begin; - for yBmp:= 0 to BmpH do - begin; - tmpY := yBmp + ClientTPA[i].y; - for xBmp := 0 to BmpW do - if not SkipCoords[yBmp][xBmp] then - if (BmpRowData[yBmp][xBmp].R <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].R) or - (BmpRowData[yBmp][xBmp].G <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].G) or - (BmpRowData[yBmp][xBmp].B <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].B) then - goto NotFoundBmp; - - end; - //We did find the Bmp, otherwise we would be at the part below - TClient(Client).MWindow.FreeReturnData; - x := ClientTPA[i].x + xs; - y := ClientTPA[i].y + ys; - result := true; - exit; - NotFoundBmp: - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindBitmapSpiralTolerance(bitmap: TMufasaBitmap; var x, - y: Integer; xs, ys, xe, ye, tolerance: integer): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - tmpY : integer; - dX, dY, i,HiSpiral: Integer; - CCTS : integer; - H,S,L,HMod,SMod : extended; - SkipCoords : T2DBoolArray; -label NotFoundBmp; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck, our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //Load the spiral into memory - LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); - HiSpiral := (dx+1) * (dy+1) - 1; - //NO HSL. - CCTS := Self.CTS; - if CCTS > 1 then - CCTS := 1; - //Get the "skip coords". - CalculateBitmapSkipCoords(Bitmap,SkipCoords); - for i := 0 to HiSpiral do - begin; - for yBmp:= 0 to BmpH do - begin; - tmpY := yBmp + ClientTPA[i].y; - for xBmp := 0 to BmpW do - if not SkipCoords[yBmp][xBmp] then - if not ColorSame(CCTS,tolerance, - BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, - MainRowdata[tmpY][xBmp + ClientTPA[i].x].R,MainRowdata[tmpY][xBmp + ClientTPA[i].x].G, - MainRowdata[tmpY][xBmp + ClientTPA[i].x].B, - H,S,L,HMod,SMod) then - goto NotFoundBmp; - - end; - //We did find the Bmp, otherwise we would be at the part below - x := ClientTPA[i].x + xs; - y := ClientTPA[i].y + ys; - result := true; - exit; - NotFoundBmp: - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindBitmapsSpiralTolerance(bitmap: TMufasaBitmap; x, - y: Integer; var Points: TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - tmpY : integer; - dX, dY, i,HiSpiral: Integer; - FoundC : integer; - CCTS : integer; - H,S,L,HMod,SMod : extended; - SkipCoords : T2DBoolArray; -label NotFoundBmp; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck, our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //Load the spiral into memory - LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); - HiSpiral := (dx+1) * (dy+1) - 1; - //NO HSL. - CCTS := Self.CTS; - if CCTS > 1 then - CCTS := 1; - FoundC := 0; - //Get the "skip coords". - CalculateBitmapSkipCoords(Bitmap,SkipCoords); - for i := 0 to HiSpiral do - begin; - for yBmp:= 0 to BmpH do - begin; - tmpY := yBmp + ClientTPA[i].y; - for xBmp := 0 to BmpW do - if not SkipCoords[yBmp][xBmp] then - if not ColorSame(CCTS,tolerance, - BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, - MainRowdata[tmpY][xBmp + ClientTPA[i].x].R,MainRowdata[tmpY][xBmp + ClientTPA[i].x].G, - MainRowdata[tmpY][xBmp + ClientTPA[i].x].B, - H,S,L,HMod,SMod) then - goto NotFoundBmp; - - end; - //We did find the Bmp, otherwise we would be at the part below - ClientTPA[FoundC].x := ClientTPA[i].x + xs; - ClientTPA[FoundC].y := ClientTPA[i].y + ys; - inc(FoundC); - NotFoundBmp: - end; - if FoundC > 0 then - begin; - result := true; - SetLength(Points,FoundC); - Move(ClientTPA[0], Points[0], FoundC * SizeOf(TPoint)); - end; - TClient(Client).MWindow.FreeReturnData; -end; - -function TMFinder.FindDeformedBitmapToleranceIn(bitmap: TMufasaBitmap; var x, - y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; - AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; -var - MainRowdata : TPRGB32Array; - BmpRowData : TPRGB32Array; - PtrData : TRetData; - BmpW,BmpH : integer; - xBmp,yBmp : integer; - dX, dY, xx, yy: Integer; - SearchdX,SearchdY : integer; - GoodCount : integer;//Save the amount of pixels who have found a correspondening pixel - BestCount : integer;//The best amount of pixels till now.. - BestPT : TPoint; //The point where it found the most pixels. - RangeX,RangeY : Integer; - yStart,yEnd,xStart,xEnd : integer; - TotalC : integer; - SkipCoords : T2DBoolArray; - PointsLeft : T2DIntArray; -label FoundBMPPoint, Madness; - //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. - -begin - Result := false; - // checks for valid xs,ys,xe,ye? (may involve GetDimensions) - DefaultOperations(xs,ys,xe,ye); - - // calculate delta x and y - dX := xe - xs; - dY := ye - ys; - SearchDx := dX; - SearchDy := dY; - PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); - //Caculate the row ptrs - MainRowdata:= CalculateRowPtrs(PtrData,dy+1); - BmpRowData:= CalculateRowPtrs(bitmap); - //Get the 'fixed' bmp size - BmpW := bitmap.Width - 1; - BmpH := bitmap.Height - 1; - //Heck our bitmap cannot be outside the search area - dX := dX - bmpW; - dY := dY - bmpH; - //Reset the accuracy :-) - Accuracy := 0; - BestCount := -1; - BestPT := Point(-1,-1); - //Get the "skip coords". and PointsLeft (so we can calc whether we should stop searching or not ;-). - CalculateBitmapSkipCoordsEx(Bitmap,SkipCoords,TotalC,PointsLeft); - - for yy := 0 to dY do - for xx := 0 to dX do - begin; - GoodCount := 0; - for yBmp:= 0 to BmpH do - begin; - for xBmp := 0 to BmpW do - begin; - //We do not have to check this point, win win win <--- triple win <-- JACKPOT! - if SkipCoords[yBmp][xBmp] then - Continue; - //Calculate points of the BMP left against Goodcount (if it cannot possibly get more points skip this x,y? - if bestCount > (GoodCount + PointsLeft[yBmp][xBmp]) then - goto Madness; - //The point on the bitmap + the the coordinate we are on at the "screen" minus the range. - yStart := max(yBmp + yy-Range,0); - yEnd := Min(yBmp + yy+range,SearchdY); - for RangeY := yStart to yEnd do - begin; - xStart := max(xx-Range + xBmp,0); - xEnd := Min(xx+range + xBmp,SearchdX); - for RangeX := xStart to xEnd do - begin; - if Sqrt(sqr(BmpRowData[yBmp][xBmp].R - MainRowdata[RangeY][RangeX].R) + sqr(BmpRowData[yBmp][xBmp].G - MainRowdata[RangeY][RangeX].G) - +sqr(BmpRowData[yBmp][xBmp].B - MainRowdata[RangeY][RangeX].B)) <= tolerance then - goto FoundBMPPoint; - end; - end; - //We did not find a good point so were continueing! - Continue; - FoundBMPPoint: - //We found a pooint woot! - inc(GoodCount); - end; - end; - //If we jumped to Madness it means we did not have enuf points left to beat tha fu-king score. - Madness: - if GoodCount > BestCount then //This x,y has the best Acc so far! - begin; - BestCount := GoodCount; - BestPT := Point(xx+xs,yy+ys); - if GoodCount = TotalC then - begin; - TClient(Client).MWindow.FreeReturnData; - x := BestPT.x; - y := BestPT.y; - accuracy:= 1; - Exit(true); - end; - end; - end; - TClient(Client).MWindow.FreeReturnData; - if BestCount = 0 then - Exit; - accuracy := BestCount / TotalC; - if (accuracy = 1) or AllowPartialAccuracy then - begin - x := BestPT.x; - y := BestPT.y; - Exit(true); - end; -end; - -end. - +{ + This file is part of the Mufasa Macro Library (MML) + Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer + + MML is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + MML is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with MML. If not, see . + + See the file COPYING, included in this distribution, + for details about the copyright. + + Finder class for the Mufasa Macro Library +} + +unit finder; + +{$mode objfpc}{$H+} + +interface + +{$define CheckAllBackground}//Undefine this to only check the first white point against the background (in masks). +uses + Classes, SysUtils,bitmaps, MufasaTypes; // Types + +{ TMFinder Class } + +{ + Should be 100% independant, as all platform dependant code is in the + Window and Input classes. + + Let's try not to use any OS-specific defines here? ;) +} + +type + TMFinder = class(TObject) + constructor Create(aClient: TObject); + destructor Destroy; override; + private + Procedure UpdateCachedValues(NewWidth,NewHeight : integer); + procedure DefaultOperations(var xs,ys,xe,ye : integer); + //Loads the Spiral into ClientTPA (Will not cause problems) + procedure LoadSpiralPath(startX, startY, x1, y1, x2, y2: Integer); + public + function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer; + procedure SetToleranceSpeed(nCTS: Integer); + function SimilarColors(Color1,Color2,Tolerance : Integer) : boolean; + // Possibly turn x, y into a TPoint var. + function FindColor(var x, y: Integer; Color, xs, ys, xe, ye: Integer): Boolean; + function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean; + function FindColorTolerance(var x, y: Integer; Color, xs, ys, xe, ye, tol: Integer): Boolean; + function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tol: Integer): Boolean; + function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean; + function FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean; + //Mask + function FindBitmapMaskTolerance(mask: TMask; var x, y: Integer; xs, ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; + procedure CheckMask(Mask : TMask); + //Bitmap functions + function FindBitmap(bitmap: TMufasaBitmap; var x, y: Integer): Boolean; + function FindBitmapIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; + function FindBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer): Boolean; + function FindBitmapSpiral(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer): Boolean; + function FindBitmapSpiralTolerance(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean; + function FindBitmapsSpiralTolerance(bitmap: TMufasaBitmap; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; + function FindDeformedBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; + protected + Client: TObject; + CachedWidth, CachedHeight : integer; + ClientTPA : TPointArray; + hueMod, satMod: Extended; + CTS: Integer; + end; + +implementation +uses + Client, // For the Client Casts. + colour_conv, // For RGBToColor, etc. + math //min/max + ; +type + TPRGB32Array = array of PRGB32; + +procedure TMFinder.LoadSpiralPath(startX, startY, x1, y1, x2, y2: Integer); +var + i,y,x,c,Ring : integer; + CurrBox : TBox; +begin; + i := 0; + Ring := 1; + c := 0; + CurrBox.x1 := Startx-1; + CurrBox.y1 := Starty-1; + CurrBox.x2 := Startx+1; + CurrBox.y2 := Starty+1; + if (startx >= x1) and (startx <= x2) and (starty >= y1) and (starty <= y2) then + begin; + ClientTPA[c] := Point(Startx, StartY); + inc(c); + end; + Repeat + if (CurrBox.x2 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y1 >= y1) and (Currbox.y1 <= y2) then + for i := CurrBox.x1 + 1 to CurrBox.x2 do + if (I >= x1) and ( I <= x2) then + begin; + ClientTPA[c] := Point(i,CurrBox.y1); + inc(c); + end; + if (CurrBox.x2 >= x1) and (CurrBox.x2 <= x2) and (Currbox.y2 >= y1) and (Currbox.y1 <= y2) then + for i := CurrBox.y1 + 1 to CurrBox.y2 do + if (I >= y1) and ( I <= y2) then + begin; + ClientTPA[c] := Point(Currbox.x2, I); + inc(c); + end; + if (CurrBox.x2 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y2 >= y1) and (Currbox.y2 <= y2) then + for i := CurrBox.x2 - 1 downto CurrBox.x1 do + if (I >= x1) and ( I <= x2) then + begin; + ClientTPA[c] := Point(i,CurrBox.y2); + inc(c); + end; + if (CurrBox.x1 >= x1) and (CurrBox.x1 <= x2) and (Currbox.y2 >= y1) and (Currbox.y1 <= y2) then + for i := CurrBox.y2 - 1 downto CurrBox.y1 do + if (I >= y1) and ( I <= y2) then + begin; + ClientTPA[c] := Point(Currbox.x1, I); + inc(c); + end; + inc(ring); + CurrBox.x1 := Startx-ring; + CurrBox.y1 := Starty-Ring; + CurrBox.x2 := Startx+Ring; + CurrBox.y2 := Starty+Ring; + until (Currbox.x1 < x1) and (Currbox.x2 > x2) and (currbox.y1 < y1) and (currbox.y2 > y2); +end; + +function CalculateRowPtrs(ReturnData : TRetData; RowCount : integer) : TPRGB32Array;overload; +var + I : integer; +begin; + setlength(result,RowCount); + for i := 0 to RowCount - 1 do + result[i] := ReturnData.Ptr + ReturnData.RowLen * i; +end; + +function CalculateRowPtrs(Bitmap : TMufasaBitmap) : TPRGB32Array;overload; +var + I : integer; +begin; + setlength(result,Bitmap.Height); + for i := 0 to Bitmap.Height - 1 do + result[i] := Bitmap.FData + Bitmap.Width * i; +end; +//SkipCoords[y][x] = False/True; True means its "transparent" and therefore not needed to be checked. +procedure CalculateBitmapSkipCoords(Bitmap : TMufasaBitmap; out SkipCoords : T2DBoolArray); +var + x,y : integer; + R,G,B : byte; + Ptr : PRGB32; +begin; + r := 0; + g := 0; + b := 0; + if Bitmap.TransparentColorSet then + ColorToRGB(Bitmap.GetTransparentColor,r,g,b); + Ptr := Bitmap.FData; + SetLength(SkipCoords,Bitmap.Height,Bitmap.Width); + for y := 0 to Bitmap.Height - 1 do + for x := 0 to Bitmap.Width - 1 do + begin; + if (Ptr^.r = r) and (Ptr^.g = g) and (Ptr^.b = b) then + SkipCoords[y][x] := True + else + SkipCoords[y][x] := false; + inc(ptr); + end; +end; +//Points left holds the amount of points that are "left" to be checked (Including the point itself.. So for example Pointsleft[0][0] would hold the total amount of pixels that are to be checked. +procedure CalculateBitmapSkipCoordsEx(Bitmap : TMufasaBitmap; out SkipCoords : T2DBoolArray;out TotalPoints : integer; out PointsLeft : T2DIntArray); +var + x,y : integer; + R,G,B : byte; + Ptr : PRGB32; + TotalC : integer; +begin; + r := 0; + g := 0; + b := 0; + TotalC := 0; + if Bitmap.TransparentColorSet then + ColorToRGB(Bitmap.GetTransparentColor,r,g,b); + Ptr := Bitmap.FData; + SetLength(SkipCoords,Bitmap.Height,Bitmap.Width); + SetLength(PointsLeft,Bitmap.Height,Bitmap.Width); + for y := 0 to Bitmap.Height - 1 do + for x := 0 to Bitmap.Width - 1 do + begin; + if (Ptr^.r = r) and (Ptr^.g = g) and (Ptr^.b = b) then + SkipCoords[y][x] := True + else + begin; + SkipCoords[y][x] := false; + inc(TotalC); + end; + inc(ptr); + end; + TotalPoints:= TotalC; + for y := 0 to Bitmap.Height - 1 do + for x := 0 to Bitmap.Width - 1 do + begin; + PointsLeft[y][x] := TotalC; + if not SkipCoords[y][x] then + Dec(TotalC); + end; +end; + +constructor TMFinder.Create(aClient: TObject); + +begin + inherited Create; + + Self.Client := aClient; + Self.CTS := 1; + Self.hueMod := 0.2; + Self.satMod := 0.2; + +end; + +destructor TMFinder.Destroy; +begin + + inherited; +end; + +procedure TMFinder.SetToleranceSpeed(nCTS: Integer); +begin + if (nCTS < 0) or (nCTS > 2) then + raise Exception.CreateFmt('The given CTS ([%d]) is invalid.',[nCTS]); + Self.CTS := nCTS; +end; + +function TMFinder.SimilarColors(Color1, Color2,Tolerance: Integer) : boolean; +var + R1,G1,B1,R2,G2,B2 : Byte; + H1,S1,L1,H2,S2,L2 : extended; +begin + Result := False; + ColorToRGB(Color1,R1,G1,B1); + ColorToRGB(Color2,R2,G2,B2); + if Color1 = Color2 then + Result := true + else + case CTS of + 0: Result := ((Abs(R1-R2) <= Tolerance) and (Abs(G1-G2) <= Tolerance) and (Abs(B1-B2) <= Tolerance)); + 1: Result := (Sqrt(sqr(R1-R2) + sqr(G1-G2) + sqr(B1-B2)) <= Tolerance); + 2: begin + RGBToHSL(R1,g1,b1,H1,S1,L1); + RGBToHSL(R2,g2,b2,H2,S2,L2); + Result := ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S2-S1) <= (satMod * Tolerance)) and (abs(L1-L2) <= Tolerance)); + end; + end; +end; + + +function ColorSame(var CTS,Tolerance : Integer; var R1,G1,B1,R2,G2,B2 : byte; var H1,S1,L1,huemod,satmod : extended) : boolean; inline; +var + H2,S2,L2 : extended; +begin + Result := False; + case CTS of + 0: Result := ((Abs(R1-R2) <= Tolerance) and (Abs(G1-G2) <= Tolerance) and (Abs(B1-B2) <= Tolerance)); + 1: Result := (Sqrt(sqr(R1-R2) + sqr(G1-G2) + sqr(B1-B2)) <= Tolerance); + 2: begin + RGBToHSL(R1,g1,b1,H1,S1,L1); + RGBToHSL(R2,g2,b2,H2,S2,L2); + Result := ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S2-S1) <= (satMod * Tolerance)) and (abs(L1-L2) <= Tolerance)); + end; + end; +end; + +procedure TMFinder.UpdateCachedValues(NewWidth, NewHeight: integer); +begin + CachedWidth := NewWidth; + CachedHeight := NewHeight; + SetLength(ClientTPA,NewWidth * NewHeight); +end; + +procedure TMFinder.DefaultOperations(var xs, ys, xe, ye: integer); +var + w,h : integer; +begin + if xs > xe then + raise Exception.CreateFMT('Finder function: Xs > xe (%d,%d)',[xs,xe]); + if ys > ye then + raise Exception.CreateFMT('Finder function: Ys > ye (%d,%d)',[ys,ye]); + if xs < 0 then + // xs := 0; + raise Exception.createFMT('Any Find Function, you did not pass a ' + + 'correct xs: %d.', [xs]); + if ys < 0 then +// ys := 0; + raise Exception.createFMT('Any Find Function, you did not pass a ' + + 'correct ys: %d.', [ys]); + + TClient(Self.Client).MWindow.GetDimensions(w,h); + if (w <> CachedWidth) or (h <> CachedHeight) then + UpdateCachedValues(w,h); + if xe >= w then +// xe := w-1; + raise Exception.createFMT('Any Find Function, you did not pass a ' + + 'correct xe: %d.', [xe]); + if ye >= h then +// ye := h-1; + raise Exception.createFMT('Any Find Function, you did not pass a ' + + 'correct ye: %d.', [ye]); +end; + +function TMFinder.CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer; +var + PtrData: TRetData; + Ptr: PRGB32; + PtrInc: Integer; + clR, clG, clB : byte; + dX, dY, xx, yy: Integer; + h,s,l,hmod,smod : extended; + Ccts : integer; +begin + Result := 0; + DefaultOperations(xs, ys, xe, ye); + dX := xe - xs; + dY := ye - ys; + ColorToRGB(Color, clR, clG, clB); + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + Ptr := PtrData.Ptr; + PtrInc := PtrData.IncPtrWith; + CCts := Self.CTS; + result := 0; + if cts = 2 then + begin; + RGBToHSL(clR,clG,clB,h,s,l); + hmod := Self.hueMod; + smod := Self.satMod; + end; + for yy := ys to ye do + begin; + for xx := xs to xe do + begin; + if ColorSame(CCts,Tolerance,clR,clG,clB,Ptr^.r,Ptr^.g,Ptr^.b,H,S,L,hmod,smod) then + inc(result); + Inc(Ptr); + end; + Inc(Ptr, PtrInc) + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColor(var x, y: Integer; Color, xs, ys, xe, ye: Integer): Boolean; +var + PtrData: TRetData; + Ptr: PRGB32; + PtrInc: Integer; + dX, dY, clR, clG, clB, xx, yy: Integer; + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + //next, convert the color to r,g,b + ColorToRGB(Color, clR, clG, clB); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + + // Do we want to "cache" these vars? + // We will, for now. Easier to type. + Ptr := PtrData.Ptr; + PtrInc := PtrData.IncPtrWith; + + for yy := ys to ye do + begin; + for xx := xs to xe do + begin; + // Colour comparison here. Possibly with tolerance? ;) + if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then + begin + Result := True; + x := xx; + y := yy; + + TClient(Client).MWindow.FreeReturnData; + Exit; + end; + Inc(Ptr); + end; + Inc(Ptr, PtrInc) + end; + + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColorSpiral(var x, y: Integer; color, xs, ys, xe, + ye: Integer): Boolean; +var + PtrData: TRetData; + RowData : TPRGB32Array; + dX, dY, clR, clG, clB, i,HiSpiral: Integer; + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + //next, convert the color to r,g,b + ColorToRGB(Color, clR, clG, clB); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Load rowdata + RowData:= CalculateRowPtrs(ptrdata,dy+1); + //Load the spiral path + LoadSpiralPath(x-xs,y-ys,0,0,dx,dy); + + + HiSpiral := (dy+1) * (dx + 1) -1; + for i := 0 to HiSpiral do + if (RowData[ClientTPA[i].y][ClientTPA[i].x].R = clR) and (RowData[ClientTPA[i].y][ClientTPA[i].x].G = clG) + and (RowData[ClientTPA[i].y][ClientTPA[i].x].B = clB) then + begin + Result := True; + x := ClientTPA[i].x + xs; + y := ClientTPA[i].y + ys; + TClient(Client).MWindow.FreeReturnData; + Exit; + end; + + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColorTolerance(var x, y: Integer; Color, xs, ys, xe, ye, tol: Integer): Boolean; +var + PtrData: TRetData; + Ptr: PRGB32; + PtrInc: Integer; + dX, dY, clR, clG, clB, xx, yy: Integer; + H1, S1, L1, H2, S2, L2: Extended; + + label Hit; + label Miss; + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + //next, convert the color to r,g,b + ColorToRGB(Color, clR, clG, clB); + ColorToHSL(Color, H1, S1, L1); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + + // Do we want to "cache" these vars? + // We will, for now. Easier to type. + Ptr := PtrData.Ptr; + PtrInc := PtrData.IncPtrWith; + + case CTS of + 0: + for yy := ys to ye do + begin + for xx := xs to xe do + begin + if ((abs(clB-Ptr^.B) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clR-Ptr^.R) <= Tol)) then + goto Hit; + inc(Ptr); + end; + Inc(Ptr, PtrInc); + end; + + 1: + begin + Tol := Sqr(Tol); + + for yy := ys to ye do + begin + for xx := xs to xe do + begin + if (sqr(clB - Ptr^.B) + sqr(clG - Ptr^.G) + sqr(clR-Ptr^.R)) <= Tol then + goto Hit; + inc(ptr); + end; + Inc(Ptr, PtrInc); + end; + + end; + 2: + // Can be optimized a lot... RGBToHSL isn't really inline, + // and hueMod * tol is also calculated every time. + begin + for yy := ys to ye do + for xx := xs to xe do + begin + RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,H2,S2,L2); + if ((abs(H1 - H2) <= (hueMod * tol)) and (abs(S1 - S2) <= (satMod * tol)) and (abs(L1 - L2) <= Tol)) then + goto Hit; + inc(Ptr); + end; + Inc(Ptr, PtrInc); + end; + end; + Result := False; + TClient(Client).MWindow.FreeReturnData; + Exit; + + Hit: + Result := True; + x := xx; + y := yy; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColorsTolerance(var Points: TPointArray; Color, xs, ys, + xe, ye, Tol: Integer): Boolean; +var + PtrData: TRetData; + Ptr: PRGB32; + PtrInc,C: Integer; + dX, dY, clR, clG, clB, xx, yy: Integer; + H1, S1, L1, H2, S2, L2: Extended; +begin + Result := false; + DefaultOperations(xs,ys,xe,ye); + + dX := xe - xs; + dY := ye - ys; + //next, convert the color to r,g,b + ColorToRGB(Color, clR, clG, clB); + ColorToHSL(Color, H1, S1, L1); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + + // Do we want to "cache" these vars? + // We will, for now. Easier to type. + Ptr := PtrData.Ptr; + PtrInc := PtrData.IncPtrWith; + c := 0; + case CTS of + 0: + for yy := ys to ye do + begin + for xx := xs to xe do + begin + if ((abs(clB-Ptr^.B) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clR-Ptr^.R) <= Tol)) then + begin; + ClientTPA[c].x := xx; + ClientTPA[c].y := yy; + inc(c); + end; + inc(Ptr); + end; + Inc(Ptr, PtrInc); + end; + + 1: + for yy := ys to ye do + begin + for xx := xs to xe do + begin + if (Sqrt(sqr(clR-Ptr^.R) + sqr(clG - Ptr^.G) + sqr(clB - Ptr^.B)) <= Tol) then + begin; + ClientTPA[c].x := xx; + ClientTPA[c].y := yy; + inc(c); + end; + inc(ptr); + end; + Inc(Ptr, PtrInc); + end; + 2: + begin + for yy := ys to ye do + for xx := xs to xe do + begin + RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,H2,S2,L2); + if ((abs(H1 - H2) <= (hueMod * tol)) and (abs(S1 - S2) <= (satMod * tol)) and (abs(L1 - L2) <= Tol)) then + begin; + ClientTPA[c].x := xx; + ClientTPA[c].y := yy; + inc(c); + end; + inc(Ptr); + end; + Inc(Ptr, PtrInc); + end; + end; + SetLength(Points, C); + Move(ClientTPA[0], Points[0], C * SizeOf(TPoint)); + Result := C > 0; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColorsSpiralTolerance(x, y: Integer; + var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer + ): boolean; +var + PtrData: TRetData; + c : integer; + RowData : TPRGB32Array; + dX, dY, clR, clG, clB, i,SpiralHi: Integer; + H1, S1, L1, H2, S2, L2: Extended; +begin + Result := false; + DefaultOperations(xs,ys,xe,ye); + + dX := xe - xs; + dY := ye - ys; + //next, convert the color to r,g,b + ColorToRGB(Color, clR, clG, clB); + ColorToHSL(Color, H1, S1, L1); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + + c := 0; + + //Load rowdata + RowData:= CalculateRowPtrs(ptrdata,dy+1); + //Load the spiral path + LoadSpiralPath(x-xs,y-ys,0,0,dx,dy); + SpiralHi := (dx + 1) * (dy + 1) - 1; + case CTS of + 0: + for i := 0 to SpiralHi do + if ((abs(clB-RowData[ClientTPA[i].y][ClientTPA[i].x].B) <= Tolerance) and + (abs(clG-RowData[ClientTPA[i].y][ClientTPA[i].x].G) <= Tolerance) and + (Abs(clR-RowData[ClientTPA[i].y][ClientTPA[i].x].R) <= Tolerance)) then + begin; + ClientTPA[c].x := ClientTPA[i].x + xs; + ClientTPA[c].y := ClientTPA[i].y + ys; + inc(c); + end; + + + 1: + for i := 0 to SpiralHi do + if (Sqrt(sqr(clR - RowData[ClientTPA[i].y][ClientTPA[i].x].R) + + sqr(clG - RowData[ClientTPA[i].y][ClientTPA[i].x].G) + + sqr(clB - RowData[ClientTPA[i].y][ClientTPA[i].x].B)) <= Tolerance) then + begin; + ClientTPA[c].x := ClientTPA[i].x + xs; + ClientTPA[c].y := ClientTPA[i].y + ys; + inc(c); + end; + + 2: + for i := 0 to SpiralHi do + begin; + RGBToHSL(RowData[ClientTPA[i].y][ClientTPA[i].x].R, + RowData[ClientTPA[i].y][ClientTPA[i].x].G, + RowData[ClientTPA[i].y][ClientTPA[i].x].B,H2,S2,L2); + if ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S1 - S2) <= (satMod * Tolerance)) and (abs(L1 - L2) <= Tolerance)) then + begin; + ClientTPA[c].x := ClientTPA[i].x + xs; + ClientTPA[c].y := ClientTPA[i].y + ys; + inc(c); + end; + end; + end; + SetLength(Points, C); + Move(ClientTPA[0], Points[0], C * SizeOf(TPoint)); + Result := C > 0; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean; +var + PtrData: TRetData; + Ptr: PRGB32; + PtrInc: Integer; + dX, dY, clR, clG, clB, xx, yy, i: Integer; + +begin + Result := false; + DefaultOperations(xs,ys,xe,ye); + + dX := xe - xs; + dY := ye - ys; + + I := 0; + + ColorToRGB(Color, clR, clG, clB); + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + + Ptr := PtrData.Ptr; + PtrInc := PtrData.IncPtrWith; + + for yy := ys to ye do + begin; + for xx := xs to xe do + begin; + if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then + begin + Self.ClientTPA[I].x := xx; + Self.ClientTPA[i].y := yy; + Inc(I); + end; + Inc(Ptr); + end; + Inc(Ptr, PtrInc); + end; + + SetLength(TPA, I); + + Move(ClientTPA[0], TPA[0], i * SizeOf(TPoint)); + + Result := I > 0; + + TClient(Client).MWindow.FreeReturnData; +end; + +//Only works with CTS 1 for now.. Since Colorsame doesn't return a boolean :-( +//We do not check whether every white pixel is in tol range with every other white pixel.. + +function TMFinder.FindBitmapMaskTolerance(mask: TMask; var x, y: Integer; xs, + ys, xe, ye: Integer; Tolerance, ContourTolerance: Integer): Boolean; +var + MainRowdata : TPRGB32Array; + PtrData : TRetData; + MaskW,MaskH : integer; + CheckerWhite,CheckerBlack,CurrWhite,CurrBlack: TRGB32; + i,ii : integer; + dX, dY, xx, yy: Integer; +label NotFoundMask; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + //Check the mask. + CheckMask(Mask); + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + + //Get the 'fixed' mask size + MaskW := Mask.W; + MaskH := Mask.H; + //Heck our mask cannot be outside the search area + dX := dX - MaskW; + dY := dY - MaskH; + for yy := 0 to dY do + for xx := 0 to dX do + begin; + CheckerWhite := MainRowdata[yy + mask.White[0].y][xx + mask.white[0].x]; + CheckerBlack := MainRowdata[yy + mask.Black[0].y][xx + mask.Black[0].x]; + //Just check two 'random' points against eachother, might be a time saver in some circumstances. + if (Sqrt(sqr(CheckerWhite.r-CheckerBlack.r) + sqr(CheckerWhite.G-CheckerBlack.G) + sqr(CheckerWhite.b-CheckerBlack.B)) + <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference, so continue with looking! + continue; + for i := 0 to mask.WhiteHi do + begin; + CurrWhite := MainRowdata[yy + mask.White[i].y][xx + mask.white[i].x]; + if (Sqrt(sqr(CheckerWhite.r-CurrWhite.r) + sqr(CheckerWhite.G-CurrWhite.G) + sqr(CheckerWhite.b-CurrWhite.B)) + > Tolerance) then //The white checkpoint n' this point aren't in the same tol range -> goto nomatch; + goto NotFoundMask; + {$ifdef CheckAllBackground} + for ii := 0 to mask.BlackHi do + begin + CurrBlack := MainRowdata[yy + mask.Black[ii].y][xx + mask.Black[ii].x]; + if (Sqrt(sqr(CurrWhite.r-CurrBlack.r) + sqr(CurrWhite.G-CurrBlack.G) + sqr(CurrWhite.b-CurrBlack.B)) + <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference -> goto nomatch; + goto NotFoundMask; + end; + {$endif} + end; + {$ifndef CheckAllBackground} + for ii := 0 to mask.BlackHi do + begin + CurrBlack := MainRowdata[yy + mask.Black[ii].y][xx + mask.Black[ii].x]; + if (Sqrt(sqr(CheckerWhite.r-CurrBlack.r) + sqr(CheckerWhite.G-CurrBlack.G) + sqr(CheckerWhite.b-CurrBlack.B)) + <= ContourTolerance) then //The Tol between the white and black is lower than the minimum difference -> goto nomatch; + goto NotFoundMask; + end; + {$endif} + //We have found the mask appearntly, otherwise we would have jumped! Gna Gna. + x := xx + xs; + y := yy + ys; + TClient(Client).MWindow.FreeReturnData; + Exit(true); + //Bah not found the mask, lets do nothing and continue! + NotFoundMask: + end; + TClient(Client).MWindow.FreeReturnData; +end; + +procedure TMFinder.CheckMask(Mask: TMask); +begin + if (Mask.W < 1) or (Mask.H < 1) or (Mask.WhiteHi < 0) or (Mask.BlackHi < 0) then + raise exception.CreateFMT('Mask is invalid. Width/Height: (%d,%d). WhiteHi/BlackHi: (%d,%d)',[Mask.W,Mask.H,Mask.WhiteHi,Mask.BlackHi]); +end; + +function TMFinder.FindBitmap(bitmap: TMufasaBitmap; var x, y: Integer): Boolean; +var + w,h : integer; +begin + TClient(Client).MWindow.GetDimensions(w,h); + result := Self.FindBitmapIn(bitmap,x,y,0,0,w-1,h-1); +end; + +function TMFinder.FindBitmapIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, + ys, xe, ye: Integer): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + tmpY : integer; + dX, dY, xx, yy: Integer; + SkipCoords : T2DBoolArray; +label NotFoundBmp; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //Get the "skip coords". + CalculateBitmapSkipCoords(Bitmap,SkipCoords); + for yy := 0 to dY do + for xx := 0 to dX do + begin; + for yBmp:= 0 to BmpH do + begin; + tmpY := yBmp + yy; + for xBmp := 0 to BmpW do + if not SkipCoords[yBmp][xBmp] then + if (BmpRowData[yBmp][xBmp].R <> MainRowdata[tmpY][xBmp + xx].R) or + (BmpRowData[yBmp][xBmp].G <> MainRowdata[tmpY][xBmp + xx].G) or + (BmpRowData[yBmp][xBmp].B <> MainRowdata[tmpY][xBmp + xx].B) then + goto NotFoundBmp; + + end; + //We did find the Bmp, otherwise we would be at the part below + TClient(Client).MWindow.FreeReturnData; + x := xx + xs; + y := yy + ys; + result := true; + exit; + NotFoundBmp: + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindBitmapToleranceIn(bitmap: TMufasaBitmap; var x, y: Integer; xs, + ys, xe, ye: Integer; tolerance: Integer): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + tmpY : integer; + dX, dY, xx, yy: Integer; + CCTS : integer; + H,S,L,HMod,SMod : extended; + SkipCoords : T2DBoolArray; +label NotFoundBmp; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //We wont want HSL comparison with BMPs, right? Not for now atleast. + CCTS := Self.CTS; + if CCTS > 1 then + CCTS := 1; + //Get the "skip coords". + CalculateBitmapSkipCoords(Bitmap,SkipCoords); + for yy := 0 to dY do + for xx := 0 to dX do + begin; + for yBmp:= 0 to BmpH do + begin; + tmpY := yBmp + yy; + for xBmp := 0 to BmpW do + if not SkipCoords[yBmp][xBmp] then + if not ColorSame(CCTS,tolerance, + BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, + MainRowdata[tmpY][xBmp + xx].R,MainRowdata[tmpY][xBmp + xx].G,MainRowdata[tmpY][xBmp + xx].B, + H,S,L,HMod,SMod) then + goto NotFoundBmp; + + end; + //We did find the Bmp, otherwise we would be at the part below + TClient(Client).MWindow.FreeReturnData; + x := xx + xs; + y := yy + ys; + result := true; + exit; + NotFoundBmp: + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindBitmapSpiral(bitmap: TMufasaBitmap; var x, y: Integer; + xs, ys, xe, ye: Integer): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + tmpY : integer; + dX, dY, i,HiSpiral: Integer; + SkipCoords : T2DBoolArray; +label NotFoundBmp; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck, our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //Load the spiral into memory + LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); + HiSpiral := (dx+1) * (dy+1) - 1; + //Get the "skip coords". + CalculateBitmapSkipCoords(Bitmap,SkipCoords); + for i := 0 to HiSpiral do + begin; + for yBmp:= 0 to BmpH do + begin; + tmpY := yBmp + ClientTPA[i].y; + for xBmp := 0 to BmpW do + if not SkipCoords[yBmp][xBmp] then + if (BmpRowData[yBmp][xBmp].R <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].R) or + (BmpRowData[yBmp][xBmp].G <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].G) or + (BmpRowData[yBmp][xBmp].B <> MainRowdata[tmpY][xBmp + ClientTPA[i].x].B) then + goto NotFoundBmp; + + end; + //We did find the Bmp, otherwise we would be at the part below + TClient(Client).MWindow.FreeReturnData; + x := ClientTPA[i].x + xs; + y := ClientTPA[i].y + ys; + result := true; + exit; + NotFoundBmp: + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindBitmapSpiralTolerance(bitmap: TMufasaBitmap; var x, + y: Integer; xs, ys, xe, ye, tolerance: integer): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + tmpY : integer; + dX, dY, i,HiSpiral: Integer; + CCTS : integer; + H,S,L,HMod,SMod : extended; + SkipCoords : T2DBoolArray; +label NotFoundBmp; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck, our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //Load the spiral into memory + LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); + HiSpiral := (dx+1) * (dy+1) - 1; + //NO HSL. + CCTS := Self.CTS; + if CCTS > 1 then + CCTS := 1; + //Get the "skip coords". + CalculateBitmapSkipCoords(Bitmap,SkipCoords); + for i := 0 to HiSpiral do + begin; + for yBmp:= 0 to BmpH do + begin; + tmpY := yBmp + ClientTPA[i].y; + for xBmp := 0 to BmpW do + if not SkipCoords[yBmp][xBmp] then + if not ColorSame(CCTS,tolerance, + BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, + MainRowdata[tmpY][xBmp + ClientTPA[i].x].R,MainRowdata[tmpY][xBmp + ClientTPA[i].x].G, + MainRowdata[tmpY][xBmp + ClientTPA[i].x].B, + H,S,L,HMod,SMod) then + goto NotFoundBmp; + + end; + //We did find the Bmp, otherwise we would be at the part below + x := ClientTPA[i].x + xs; + y := ClientTPA[i].y + ys; + result := true; + exit; + NotFoundBmp: + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindBitmapsSpiralTolerance(bitmap: TMufasaBitmap; x, + y: Integer; var Points: TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + tmpY : integer; + dX, dY, i,HiSpiral: Integer; + FoundC : integer; + CCTS : integer; + H,S,L,HMod,SMod : extended; + SkipCoords : T2DBoolArray; +label NotFoundBmp; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck, our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //Load the spiral into memory + LoadSpiralPath(x-xs,y-ys,0,0,dX,dY); + HiSpiral := (dx+1) * (dy+1) - 1; + //NO HSL. + CCTS := Self.CTS; + if CCTS > 1 then + CCTS := 1; + FoundC := 0; + //Get the "skip coords". + CalculateBitmapSkipCoords(Bitmap,SkipCoords); + for i := 0 to HiSpiral do + begin; + for yBmp:= 0 to BmpH do + begin; + tmpY := yBmp + ClientTPA[i].y; + for xBmp := 0 to BmpW do + if not SkipCoords[yBmp][xBmp] then + if not ColorSame(CCTS,tolerance, + BmpRowData[yBmp][xBmp].R,BmpRowData[yBmp][xBmp].G,BmpRowData[yBmp][xBmp].B, + MainRowdata[tmpY][xBmp + ClientTPA[i].x].R,MainRowdata[tmpY][xBmp + ClientTPA[i].x].G, + MainRowdata[tmpY][xBmp + ClientTPA[i].x].B, + H,S,L,HMod,SMod) then + goto NotFoundBmp; + + end; + //We did find the Bmp, otherwise we would be at the part below + ClientTPA[FoundC].x := ClientTPA[i].x + xs; + ClientTPA[FoundC].y := ClientTPA[i].y + ys; + inc(FoundC); + NotFoundBmp: + end; + if FoundC > 0 then + begin; + result := true; + SetLength(Points,FoundC); + Move(ClientTPA[0], Points[0], FoundC * SizeOf(TPoint)); + end; + TClient(Client).MWindow.FreeReturnData; +end; + +function TMFinder.FindDeformedBitmapToleranceIn(bitmap: TMufasaBitmap; var x, + y: Integer; xs, ys, xe, ye: Integer; tolerance: Integer; Range: Integer; + AllowPartialAccuracy: Boolean; var accuracy: Extended): Boolean; +var + MainRowdata : TPRGB32Array; + BmpRowData : TPRGB32Array; + PtrData : TRetData; + BmpW,BmpH : integer; + xBmp,yBmp : integer; + dX, dY, xx, yy: Integer; + SearchdX,SearchdY : integer; + GoodCount : integer;//Save the amount of pixels who have found a correspondening pixel + BestCount : integer;//The best amount of pixels till now.. + BestPT : TPoint; //The point where it found the most pixels. + RangeX,RangeY : Integer; + yStart,yEnd,xStart,xEnd : integer; + TotalC : integer; + SkipCoords : T2DBoolArray; + PointsLeft : T2DIntArray; +label FoundBMPPoint, Madness; + //Don't know if the compiler has any speed-troubles with goto jumping in nested for loops. + +begin + Result := false; + // checks for valid xs,ys,xe,ye? (may involve GetDimensions) + DefaultOperations(xs,ys,xe,ye); + + // calculate delta x and y + dX := xe - xs; + dY := ye - ys; + SearchDx := dX; + SearchDy := dY; + PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1); + //Caculate the row ptrs + MainRowdata:= CalculateRowPtrs(PtrData,dy+1); + BmpRowData:= CalculateRowPtrs(bitmap); + //Get the 'fixed' bmp size + BmpW := bitmap.Width - 1; + BmpH := bitmap.Height - 1; + //Heck our bitmap cannot be outside the search area + dX := dX - bmpW; + dY := dY - bmpH; + //Reset the accuracy :-) + Accuracy := 0; + BestCount := -1; + BestPT := Point(-1,-1); + //Get the "skip coords". and PointsLeft (so we can calc whether we should stop searching or not ;-). + CalculateBitmapSkipCoordsEx(Bitmap,SkipCoords,TotalC,PointsLeft); + + for yy := 0 to dY do + for xx := 0 to dX do + begin; + GoodCount := 0; + for yBmp:= 0 to BmpH do + begin; + for xBmp := 0 to BmpW do + begin; + //We do not have to check this point, win win win <--- triple win <-- JACKPOT! + if SkipCoords[yBmp][xBmp] then + Continue; + //Calculate points of the BMP left against Goodcount (if it cannot possibly get more points skip this x,y? + if bestCount > (GoodCount + PointsLeft[yBmp][xBmp]) then + goto Madness; + //The point on the bitmap + the the coordinate we are on at the "screen" minus the range. + yStart := max(yBmp + yy-Range,0); + yEnd := Min(yBmp + yy+range,SearchdY); + for RangeY := yStart to yEnd do + begin; + xStart := max(xx-Range + xBmp,0); + xEnd := Min(xx+range + xBmp,SearchdX); + for RangeX := xStart to xEnd do + begin; + if Sqrt(sqr(BmpRowData[yBmp][xBmp].R - MainRowdata[RangeY][RangeX].R) + sqr(BmpRowData[yBmp][xBmp].G - MainRowdata[RangeY][RangeX].G) + +sqr(BmpRowData[yBmp][xBmp].B - MainRowdata[RangeY][RangeX].B)) <= tolerance then + goto FoundBMPPoint; + end; + end; + //We did not find a good point so were continueing! + Continue; + FoundBMPPoint: + //We found a pooint woot! + inc(GoodCount); + end; + end; + //If we jumped to Madness it means we did not have enuf points left to beat tha fu-king score. + Madness: + if GoodCount > BestCount then //This x,y has the best Acc so far! + begin; + BestCount := GoodCount; + BestPT := Point(xx+xs,yy+ys); + if GoodCount = TotalC then + begin; + TClient(Client).MWindow.FreeReturnData; + x := BestPT.x; + y := BestPT.y; + accuracy:= 1; + Exit(true); + end; + end; + end; + TClient(Client).MWindow.FreeReturnData; + if BestCount = 0 then + Exit; + accuracy := BestCount / TotalC; + if (accuracy = 1) or AllowPartialAccuracy then + begin + x := BestPT.x; + y := BestPT.y; + Exit(true); + end; +end; + +end. +