1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-08-13 16:53:59 -04:00

Bmp stuff + normal font size in GUI.

git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@120 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2009-10-09 22:17:35 +00:00
parent 4c144e7b3d
commit 50218e9320
9 changed files with 2120 additions and 1917 deletions

File diff suppressed because it is too large Load Diff

View File

@ -5,7 +5,7 @@ object Form1: TForm1
Width = 723
ActiveControl = SynEdit1
Caption = 'Mufasa v2'
ClientHeight = 528
ClientHeight = 533
ClientWidth = 723
Menu = MainMenu1
OnCreate = FormCreate
@ -18,13 +18,14 @@ object Form1: TForm1
Top = 32
Width = 704
Align = alCustom
Font.Height = -10
Font.Height = -13
Font.Name = 'Courier New'
Font.Pitch = fpFixed
Font.Quality = fqNonAntialiased
ParentColor = False
ParentFont = False
TabOrder = 0
BookMarkOptions.OnChange = nil
Gutter.Width = 57
Gutter.MouseActions = <
item
@ -710,19 +711,6 @@ object Form1: TForm1
end
end
end
object Memo1: TMemo
Left = 8
Height = 120
Top = 368
Width = 704
Font.Height = -8
Lines.Strings = (
'Memo1'
)
ParentFont = False
ScrollBars = ssAutoBoth
TabOrder = 1
end
object ToolBar1: TToolBar
Left = 0
Height = 24
@ -830,6 +818,14 @@ object Form1: TForm1
OnClick = ToTray
end
end
object Memo1: TMemo
Left = 13
Height = 134
Top = 370
Width = 694
ScrollBars = ssAutoBoth
TabOrder = 1
end
object SynFreePascalSyn1: TSynFreePascalSyn
Enabled = False
CompilerMode = pcmObjFPC

File diff suppressed because it is too large Load Diff

View File

@ -21,9 +21,9 @@ type
{ TForm1 }
TForm1 = class(TForm)
Memo1: TMemo;
Mufasa_Image_List: TImageList;
MainMenu1: TMainMenu;
Memo1: TMemo;
MenuItemScript: TMenuItem;
MenuItemRun: TMenuItem;
SynEdit1: TSynEdit;

View File

@ -38,6 +38,11 @@ begin;
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);
@ -102,3 +107,26 @@ begin
exit;
mBMP.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;

View File

@ -33,7 +33,7 @@ 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(@point,'function Point(x,y:integer) : TPoint;');
Sender.AddFunction(@classes.point,'function Point(x,y:integer) : TPoint;');
Sender.AddFunction(@Freeze, 'function freeze:boolean;');
Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;');
@ -73,6 +73,10 @@ Sender.AddFunction(@SetTransparentColor,'procedure SetTransparentColor(bmp : int
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;');

View File

@ -133,7 +133,6 @@ end;
// include PS wrappers
{$I PSInc/Wrappers/other.inc}
{$I PSInc/Wrappers/bitmap.inc}
{$I PSInc/Wrappers/colour.inc}
{$I PSInc/Wrappers/math.inc}
{$I PSInc/Wrappers/mouse.inc}

View File

@ -18,6 +18,7 @@ type
public
FData : PRGB32;
Index : integer;
BmpName : string; //Optional?
procedure SetSize(AWidth,AHeight : integer);
property Width : Integer read w;
property Height : Integer read h;
@ -52,7 +53,8 @@ type
function CreateBMP(w, h: integer): Integer;
function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer;
function CreateBMPFromFile(const Path : string) : integer;
function CreateBMPFromString(width,height : integer; Data : 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;
@ -235,6 +237,14 @@ begin
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;
@ -252,6 +262,11 @@ begin
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;
@ -439,7 +454,13 @@ var
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;
@ -485,6 +506,7 @@ end;
constructor TMufasaBitmap.Create;
begin
inherited Create;
BmpName:= '';
FData:= nil;
TransparentSet:= False;
w := 0;

View File

@ -5,7 +5,7 @@ unit finder;
interface
uses
Classes, SysUtils, MufasaTypes; // Types
Classes, SysUtils,bitmaps, MufasaTypes; // Types
{ TMFinder Class }
@ -22,23 +22,26 @@ type
destructor Destroy; override;
private
Procedure UpdateCachedValues(NewWidth,NewHeight : integer);
procedure DefaultOperations(var x1,y1,x2,y2 : integer);
procedure DefaultOperations(var xs,ys,xe,ye : 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, x1, y1, x2, y2: Integer): Boolean;
function FindColorTolerance(var x, y: Integer; Color, x1, y1, x2, y2, tol: Integer): Boolean;
function FindColor(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 FindColors(var TPA: TPointArray; Color, x1, y1, x2, y2: Integer): Boolean;
function FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean;
//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;
protected
Client: TObject;
CachedWidth, CachedHeight : integer;
ClientTPA : TPointArray;
hueMod, satMod: Extended;
CTS: Integer;
end;
implementation
@ -46,7 +49,29 @@ uses
Client, // For the Client Casts.
colour_conv // For RGBToColor, etc.
;
type
TPRGB32Array = array of PRGB32;
function CalculateRowPtrs(ReturnData : TRetData; RowCount : integer) : TPRGB32Array;overload;
var
I : integer;
begin;
setlength(result,RowCount);
for i := 0 to RowCount - 1do
begin;
result[i] := ReturnData.Ptr;
inc(ReturnData.Ptr,ReturnData.IncPtrWith);
end;
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;
end;
constructor TMFinder.Create(aClient: TObject);
@ -96,7 +121,7 @@ begin
end;
function ColorSame(var CTS,Tolerance : Integer; var R1,B1,G1,R2,G2,B2 : byte; var H1,S1,L1,huemod,satmod : extended) : boolean; inline;
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
@ -119,34 +144,34 @@ begin
SetLength(ClientTPA,NewWidth * NewHeight);
end;
procedure TMFinder.DefaultOperations(var x1, y1, x2, y2: integer);
procedure TMFinder.DefaultOperations(var xs, ys, xe, ye: integer);
var
w,h : integer;
begin
{ if x1 > x2 then
Swap(x1,x2);
if y1 > y2 then
Swap(y1,y2);}
if x1 < 0 then
// x1 := 0;
raise Exception.createFMT('Any FindColor Function, you did not pass a ' +
'correct x1: %d.', [x1]);
if y1 < 0 then
// y1 := 0;
raise Exception.createFMT('Any FindColor Function, you did not pass a ' +
'correct y1: %d.', [y1]);
{ if xs > xe then
Swap(xs,xe);
if ys > ye then
Swap(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 x2 >= w then
// x2 := w-1;
raise Exception.createFMT('Any FindColor Function, you did not pass a ' +
'correct x2: %d.', [x2]);
if y2 >= h then
// y2 := h-1;
raise Exception.createFMT('Any FindColor Function, you did not pass a ' +
'correct y2: %d.', [y2]);
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;
@ -159,6 +184,7 @@ var
h,s,l,hmod,smod : extended;
Ccts : integer;
begin
Result := 0;
DefaultOperations(xs, ys, xe, ye);
dX := xe - xs;
dY := ye - ys;
@ -187,7 +213,7 @@ begin
TClient(Client).MWindow.FreeReturnData;
end;
function TMFinder.FindColor(var x, y: Integer; Color, x1, y1, x2, y2: Integer): Boolean;
function TMFinder.FindColor(var x, y: Integer; Color, xs, ys, xe, ye: Integer): Boolean;
var
PtrData: TRetData;
Ptr: PRGB32;
@ -195,27 +221,27 @@ var
dX, dY, clR, clG, clB, xx, yy: Integer;
begin
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
DefaultOperations(x1,y1,x2,y2);
Result := false;
// checks for valid xs,ys,xe,ye? (may involve GetDimensions)
DefaultOperations(xs,ys,xe,ye);
// calculate delta x and y
dX := x2 - x1;
dY := y2 - y1;
dX := xe - xs;
dY := ye - ys;
//next, convert the color to r,g,b
ColorToRGB(Color, clR, clG, clB);
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
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 := y1 to y2 do
for yy := ys to ye do
begin;
for xx := x1 to x2 do
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
@ -235,7 +261,7 @@ begin
TClient(Client).MWindow.FreeReturnData;
end;
function TMFinder.FindColorTolerance(var x, y: Integer; Color, x1, y1, x2, y2, tol: Integer): Boolean;
function TMFinder.FindColorTolerance(var x, y: Integer; Color, xs, ys, xe, ye, tol: Integer): Boolean;
var
PtrData: TRetData;
Ptr: PRGB32;
@ -247,18 +273,18 @@ var
label Miss;
begin
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
DefaultOperations(x1,y1,x2,y2);
Result := false;
// checks for valid xs,ys,xe,ye? (may involve GetDimensions)
DefaultOperations(xs,ys,xe,ye);
// calculate delta x and y
dX := x2 - x1;
dY := y2 - y1;
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(x1, y1, dX + 1, dY + 1);
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.
@ -267,9 +293,9 @@ begin
case CTS of
0:
for yy := y1 to y2 do
for yy := ys to ye do
begin
for xx := x1 to x2 do
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;
@ -282,9 +308,9 @@ begin
begin
Tol := Sqr(Tol);
for yy := y1 to y2 do
for yy := ys to ye do
begin
for xx := x1 to x2 do
for xx := xs to xe do
begin
if (sqr(clB - Ptr^.B) + sqr(clG - Ptr^.G) + sqr(clR-Ptr^.R)) <= Tol then
goto Hit;
@ -298,8 +324,8 @@ begin
// Can be optimized a lot... RGBToHSL isn't really inline,
// and hueMod * tol is also calculated every time.
begin
for yy := y1 to y2 do
for xx := x1 to x2 do
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
@ -329,6 +355,7 @@ var
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;
@ -399,7 +426,7 @@ begin
TClient(Client).MWindow.FreeReturnData;
end;
function TMFinder.FindColors(var TPA: TPointArray; Color, x1, y1, x2, y2: Integer): Boolean;
function TMFinder.FindColors(var TPA: TPointArray; Color, xs, ys, xe, ye: Integer): Boolean;
var
PtrData: TRetData;
Ptr: PRGB32;
@ -407,23 +434,24 @@ var
dX, dY, clR, clG, clB, xx, yy, i: Integer;
begin
DefaultOperations(x1,y1,x2,y2);
Result := false;
DefaultOperations(xs,ys,xe,ye);
dX := x2 - x1;
dY := y2 - y1;
dX := xe - xs;
dY := ye - ys;
I := 0;
ColorToRGB(Color, clR, clG, clB);
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
PtrData := TClient(Client).MWindow.ReturnData(xs, ys, dX + 1, dY + 1);
Ptr := PtrData.Ptr;
PtrInc := PtrData.IncPtrWith;
for yy := y1 to y2 do
for yy := ys to ye do
begin;
for xx := x1 to x2 do
for xx := xs to xe do
begin;
if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then
begin
@ -445,5 +473,131 @@ begin
TClient(Client).MWindow.FreeReturnData;
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;
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);
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;
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 (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;
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);
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;
CCTS := Self.CTS;
if CCTS > 1 then
CCTS := 1;
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 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;
end.