mirror of
https://github.com/moparisthebest/Simba
synced 2024-11-22 01:02:17 -05:00
Fixed Finder
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@54 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond
parent
c2c6f2e09a
commit
ade23dff0d
@ -1,14 +1,19 @@
|
|||||||
function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;
|
function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;
|
||||||
begin
|
begin
|
||||||
Result := CurrThread.Client.MFinder.FindColor(x, y, color, x1, y1, x2, y2);
|
Result := CurrThread.Client.MFinder.FindColor(x, y, color, x1, y1, x2, y2);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;
|
function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;
|
||||||
begin
|
begin
|
||||||
Result := CurrThread.Client.MFinder.FindColorTolerance(x, y, color, x1, y1, x2, y2, tol);
|
Result := CurrThread.Client.MFinder.FindColorTolerance(x, y, color, x1, y1, x2, y2, tol);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure SetColorToleranceSpeed(cts: Integer);
|
procedure SetColorToleranceSpeed(cts: Integer);
|
||||||
begin
|
begin
|
||||||
CurrThread.Client.MFinder.SetToleranceSpeed(cts);
|
CurrThread.Client.MFinder.SetToleranceSpeed(cts);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function SimilarColors(Col1,Col2,Tol : integer) : boolean;
|
||||||
|
begin;
|
||||||
|
Result := CurrThread.Client.MFinder.SimilarColors(Col1,Col2,Tol);
|
||||||
|
end;
|
||||||
|
|||||||
@ -1,43 +1,44 @@
|
|||||||
|
|
||||||
Sender.Comp.AddTypeS('TIntegerArray', 'Array of integer');
|
Sender.Comp.AddTypeS('TIntegerArray', 'Array of integer');
|
||||||
Sender.Comp.AddTypeS('TPointArray','Array of TPoint');
|
Sender.Comp.AddTypeS('TPointArray','Array of TPoint');
|
||||||
|
|
||||||
|
|
||||||
Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;');
|
Sender.AddFunction(@ThreadSafeCall,'function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;');
|
||||||
Sender.AddFunction(@psWriteln,'procedure writeln(s : string);');
|
Sender.AddFunction(@psWriteln,'procedure writeln(s : string);');
|
||||||
|
|
||||||
Sender.AddFunction(@FindColor, 'function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;');
|
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(@FindColorTolerance, 'function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;');
|
||||||
|
Sender.AddFunction(@SimilarColors,'function SimilarColors(Col1,Col2,Tolerance : integer) : boolean');
|
||||||
Sender.AddFunction(@MoveMouse, 'procedure MoveMouse(x, y: integer);');
|
|
||||||
Sender.AddFunction(@GetMousePos, 'procedure GetMousePos(var x, y: integer);');
|
Sender.AddFunction(@MoveMouse, 'procedure MoveMouse(x, y: integer);');
|
||||||
|
Sender.AddFunction(@GetMousePos, 'procedure GetMousePos(var x, y: integer);');
|
||||||
Sender.AddFunction(@Wait, 'procedure wait(t: integer);');
|
|
||||||
Sender.AddFunction(@GetClientDimensions, 'procedure GetClientDimensions(var w, h:integer);');
|
Sender.AddFunction(@Wait, 'procedure wait(t: integer);');
|
||||||
Sender.AddFunction(@SetColorToleranceSpeed, 'procedure SetColorToleranceSpeed(cts: integer);');
|
Sender.AddFunction(@GetClientDimensions, 'procedure GetClientDimensions(var w, h:integer);');
|
||||||
Sender.AddFunction(@GetTickCount, 'function GetSystemTime: Integer;');
|
Sender.AddFunction(@SetColorToleranceSpeed, 'procedure SetColorToleranceSpeed(cts: integer);');
|
||||||
|
Sender.AddFunction(@GetTickCount, 'function GetSystemTime: Integer;');
|
||||||
Sender.AddFunction(@CreateBitmap,'function CreateBitmap(w,h :integer) : integer;');
|
|
||||||
Sender.AddFunction(@FreeBitmap,'procedure FreeBitmap(Bmp : integer);');
|
Sender.AddFunction(@CreateBitmap,'function CreateBitmap(w,h :integer) : integer;');
|
||||||
Sender.AddFunction(@SaveBitmap,'procedure SaveBitmap(Bmp : integer; path : string);');
|
Sender.AddFunction(@FreeBitmap,'procedure FreeBitmap(Bmp : integer);');
|
||||||
Sender.AddFunction(@BitmapFromString,'function BitmapFromString(Width,Height : integer; Data : string): integer;');
|
Sender.AddFunction(@SaveBitmap,'procedure SaveBitmap(Bmp : integer; path : string);');
|
||||||
Sender.AddFunction(@LoadBitmap,'function LoadBitmap(Path : string) : integer;');
|
Sender.AddFunction(@BitmapFromString,'function BitmapFromString(Width,Height : integer; Data : string): integer;');
|
||||||
Sender.AddFunction(@SetBitmapSize,'procedure SetBitmapSize(Bmp,NewW,NewH : integer);');
|
Sender.AddFunction(@LoadBitmap,'function LoadBitmap(Path : string) : integer;');
|
||||||
Sender.AddFunction(@GetBitmapSize,'procedure GetBitmapSize(Bmp : integer; Var BmpW,BmpH : integer);');
|
Sender.AddFunction(@SetBitmapSize,'procedure SetBitmapSize(Bmp,NewW,NewH : integer);');
|
||||||
Sender.AddFunction(@CreateMirroredBitmap,'function CreateMirroredBitmap(Bmp : integer) : integer;');
|
Sender.AddFunction(@GetBitmapSize,'procedure GetBitmapSize(Bmp : integer; Var BmpW,BmpH : integer);');
|
||||||
Sender.AddFunction(@FastSetPixel,'procedure FastSetPixel(bmp,x,y : integer; Color : TColor);');
|
Sender.AddFunction(@CreateMirroredBitmap,'function CreateMirroredBitmap(Bmp : integer) : integer;');
|
||||||
Sender.AddFunction(@FastSetPixels,'procedure FastSetPixels(bmp : integer; TPA : TPointArray; Colors : TIntegerArray);');
|
Sender.AddFunction(@FastSetPixel,'procedure FastSetPixel(bmp,x,y : integer; Color : TColor);');
|
||||||
Sender.AddFunction(@FastGetPixel,'function FastGetPixel(bmp, x,y : integer) : TColor;');
|
Sender.AddFunction(@FastSetPixels,'procedure FastSetPixels(bmp : integer; TPA : TPointArray; Colors : TIntegerArray);');
|
||||||
Sender.AddFunction(@FastGetPixels,'function FastGetPixels(Bmp : integer; TPA : TPointArray) : TIntegerArray;');
|
Sender.AddFunction(@FastGetPixel,'function FastGetPixel(bmp, x,y : integer) : TColor;');
|
||||||
Sender.AddFunction(@FastDrawClear,'procedure FastDrawClear(bmp : integer; Color : TColor)');
|
Sender.AddFunction(@FastGetPixels,'function FastGetPixels(Bmp : integer; TPA : TPointArray) : TIntegerArray;');
|
||||||
Sender.AddFunction(@FastDrawTransparent,'procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer);');
|
Sender.AddFunction(@FastDrawClear,'procedure FastDrawClear(bmp : integer; Color : TColor)');
|
||||||
Sender.AddFunction(@SetTransparentColor,'procedure SetTransparentColor(bmp : integer; Color : TColor);');
|
Sender.AddFunction(@FastDrawTransparent,'procedure FastDrawTransparent(x, y: Integer; SourceBitmap, TargetBitmap: Integer);');
|
||||||
Sender.AddFunction(@GetTransparentColor,'function GetTransparentColor(bmp: integer) : TColor;');
|
Sender.AddFunction(@SetTransparentColor,'procedure SetTransparentColor(bmp : integer; Color : TColor);');
|
||||||
Sender.AddFunction(@FastReplaceColor,'procedure FastReplaceColor(Bmp : integer; OldColor,NewColor : TColor);');
|
Sender.AddFunction(@GetTransparentColor,'function GetTransparentColor(bmp: integer) : TColor;');
|
||||||
|
Sender.AddFunction(@FastReplaceColor,'procedure FastReplaceColor(Bmp : integer; OldColor,NewColor : TColor);');
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,254 +1,254 @@
|
|||||||
unit mmlpsthread;
|
unit mmlpsthread;
|
||||||
|
|
||||||
{$mode objfpc}{$H+}
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
interface
|
interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,SynMemo;
|
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,SynMemo;
|
||||||
|
|
||||||
type
|
type
|
||||||
|
|
||||||
{ TMMLPSThread }
|
{ TMMLPSThread }
|
||||||
|
|
||||||
TMMLPSThread = class(TThread)
|
TMMLPSThread = class(TThread)
|
||||||
protected
|
protected
|
||||||
// PSScript : TPSScript;
|
// PSScript : TPSScript;
|
||||||
// PSClient : TPSScript;
|
// PSClient : TPSScript;
|
||||||
// Client: TClient;
|
// Client: TClient;
|
||||||
// DebugTo : TStrings;
|
// DebugTo : TStrings;
|
||||||
PSScript : TPSScript;
|
PSScript : TPSScript;
|
||||||
DebugTo : TSynMemo;
|
DebugTo : TSynMemo;
|
||||||
procedure OnCompile(Sender: TPSScript);
|
procedure OnCompile(Sender: TPSScript);
|
||||||
procedure AfterExecute(Sender : TPSScript);
|
procedure AfterExecute(Sender : TPSScript);
|
||||||
function RequireFile(Sender: TObject; const OriginFileName: String;
|
function RequireFile(Sender: TObject; const OriginFileName: String;
|
||||||
var FileName, OutPut: string): Boolean;
|
var FileName, OutPut: string): Boolean;
|
||||||
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
|
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
|
||||||
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
|
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
|
||||||
procedure OutputMessages;
|
procedure OutputMessages;
|
||||||
procedure OnThreadTerminate(Sender: TObject);
|
procedure OnThreadTerminate(Sender: TObject);
|
||||||
procedure Execute; override;
|
procedure Execute; override;
|
||||||
public
|
public
|
||||||
Client : TClient;
|
Client : TClient;
|
||||||
procedure SetPSScript(Script : string);
|
procedure SetPSScript(Script : string);
|
||||||
procedure SetDebug( Strings : TSynMemo );
|
procedure SetDebug( Strings : TSynMemo );
|
||||||
// function CompilePSScript : boolean;
|
// function CompilePSScript : boolean;
|
||||||
// function
|
// function
|
||||||
constructor Create(CreateSuspended: Boolean);
|
constructor Create(CreateSuspended: Boolean);
|
||||||
destructor Destroy; override;
|
destructor Destroy; override;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
uses
|
uses
|
||||||
MufasaTypes,
|
MufasaTypes,
|
||||||
{$ifdef mswindows}windows,{$endif}
|
{$ifdef mswindows}windows,{$endif}
|
||||||
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
|
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
|
||||||
uPSC_extctrls, //Compile-libs
|
uPSC_extctrls, //Compile-libs
|
||||||
|
|
||||||
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
|
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
|
||||||
uPSR_extctrls, //Runtime-libs
|
uPSR_extctrls, //Runtime-libs
|
||||||
Graphics, //For Graphics types
|
Graphics, //For Graphics types
|
||||||
lclintf; // for GetTickCount and others.
|
lclintf; // for GetTickCount and others.
|
||||||
|
|
||||||
|
|
||||||
threadvar
|
threadvar
|
||||||
CurrThread : TMMLPSThread;
|
CurrThread : TMMLPSThread;
|
||||||
|
|
||||||
{Some General PS Functions here}
|
{Some General PS Functions here}
|
||||||
procedure psWriteln(str : string);
|
procedure psWriteln(str : string);
|
||||||
begin
|
begin
|
||||||
{$IFNDEF MSWINDOWS}
|
{$IFNDEF MSWINDOWS}
|
||||||
writeln(str);
|
writeln(str);
|
||||||
{$ELSE}
|
{$ELSE}
|
||||||
if CurrThread.DebugTo <> nil then
|
if CurrThread.DebugTo <> nil then
|
||||||
CurrThread.DebugTo.Lines.Add(Str);
|
CurrThread.DebugTo.Lines.Add(Str);
|
||||||
{$ENDIF}
|
{$ENDIF}
|
||||||
//Just overwriting itz.. soz.
|
//Just overwriting itz.. soz.
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
|
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
|
||||||
var
|
var
|
||||||
i : integer;
|
i : integer;
|
||||||
begin;
|
begin;
|
||||||
Writeln('We have a length of: ' + inttostr(length(v)));
|
Writeln('We have a length of: ' + inttostr(length(v)));
|
||||||
Try
|
Try
|
||||||
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
|
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
|
||||||
Except
|
Except
|
||||||
Writeln('We has some errors :-(');
|
Writeln('We has some errors :-(');
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
{
|
{
|
||||||
Note to Raymond: For PascalScript, Create it on the .Create,
|
Note to Raymond: For PascalScript, Create it on the .Create,
|
||||||
Execute it on the .Execute, and don't forget to Destroy it on .Destroy.
|
Execute it on the .Execute, and don't forget to Destroy it on .Destroy.
|
||||||
|
|
||||||
Furthermore, all the wrappers can be in the unit "implementation" section.
|
Furthermore, all the wrappers can be in the unit "implementation" section.
|
||||||
Better still to create an .inc for it, otherwise this unit will become huge.
|
Better still to create an .inc for it, otherwise this unit will become huge.
|
||||||
(You can even split up the .inc's in stuff like color, bitmap, etc. )
|
(You can even split up the .inc's in stuff like color, bitmap, etc. )
|
||||||
|
|
||||||
Also, don't add PS to this unit, but make a seperate unit for it.
|
Also, don't add PS to this unit, but make a seperate unit for it.
|
||||||
Unit "MMLPSThread", perhaps?
|
Unit "MMLPSThread", perhaps?
|
||||||
|
|
||||||
See the TestUnit for use of this thread, it's pretty straightforward.
|
See the TestUnit for use of this thread, it's pretty straightforward.
|
||||||
|
|
||||||
It may also be wise to turn the "Importing of wrappers" into an include as
|
It may also be wise to turn the "Importing of wrappers" into an include as
|
||||||
well, it will really make the unit more straightforward to use and read.
|
well, it will really make the unit more straightforward to use and read.
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
constructor TMMLPSThread.Create(CreateSuspended : boolean);
|
constructor TMMLPSThread.Create(CreateSuspended : boolean);
|
||||||
begin
|
begin
|
||||||
Client := TClient.Create;
|
Client := TClient.Create;
|
||||||
|
|
||||||
PSScript := TPSScript.Create(nil);
|
PSScript := TPSScript.Create(nil);
|
||||||
PSScript.UsePreProcessor:= True;
|
PSScript.UsePreProcessor:= True;
|
||||||
PSScript.OnNeedFile := @RequireFile;
|
PSScript.OnNeedFile := @RequireFile;
|
||||||
|
|
||||||
PSScript.OnCompile:= @OnCompile;
|
PSScript.OnCompile:= @OnCompile;
|
||||||
PSScript.OnCompImport:= @OnCompImport;
|
PSScript.OnCompImport:= @OnCompImport;
|
||||||
PSScript.OnExecImport:= @OnExecImport;
|
PSScript.OnExecImport:= @OnExecImport;
|
||||||
PSScript.OnAfterExecute:= @AfterExecute;
|
PSScript.OnAfterExecute:= @AfterExecute;
|
||||||
|
|
||||||
// Set some defines
|
// Set some defines
|
||||||
{$I PSInc/psdefines.inc}
|
{$I PSInc/psdefines.inc}
|
||||||
|
|
||||||
|
|
||||||
FreeOnTerminate := True;
|
FreeOnTerminate := True;
|
||||||
Self.OnTerminate := @Self.OnThreadTerminate;
|
Self.OnTerminate := @Self.OnThreadTerminate;
|
||||||
inherited Create(CreateSuspended);
|
inherited Create(CreateSuspended);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
|
procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
|
||||||
begin
|
begin
|
||||||
// Writeln('Terminating the thread');
|
// Writeln('Terminating the thread');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
destructor TMMLPSThread.Destroy;
|
destructor TMMLPSThread.Destroy;
|
||||||
begin
|
begin
|
||||||
Client.Free;
|
Client.Free;
|
||||||
PSScript.Free;
|
PSScript.Free;
|
||||||
inherited;
|
inherited;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
// include PS wrappers
|
// include PS wrappers
|
||||||
{$I PSInc/Wrappers/other.inc}
|
{$I PSInc/Wrappers/other.inc}
|
||||||
{$I PSInc/Wrappers/bitmap.inc}
|
{$I PSInc/Wrappers/bitmap.inc}
|
||||||
{$I PSInc/Wrappers/colour.inc}
|
{$I PSInc/Wrappers/colour.inc}
|
||||||
{$I PSInc/Wrappers/mouse.inc}
|
{$I PSInc/Wrappers/mouse.inc}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
procedure TMMLPSThread.OnCompile(Sender: TPSScript);
|
procedure TMMLPSThread.OnCompile(Sender: TPSScript);
|
||||||
begin
|
begin
|
||||||
//Here we add all the initalizing, of BMPArray etc
|
//Here we add all the initalizing, of BMPArray etc
|
||||||
|
|
||||||
// ^ This will all be done with Client.Create;
|
// ^ This will all be done with Client.Create;
|
||||||
|
|
||||||
// Here we add all the functions to the engine.
|
// Here we add all the functions to the engine.
|
||||||
{$I PSInc/pscompile.inc}
|
{$I PSInc/pscompile.inc}
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
|
procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
|
||||||
begin
|
begin
|
||||||
//Here we add all the Script-freeing-leftovers (like BMParray etc)
|
//Here we add all the Script-freeing-leftovers (like BMParray etc)
|
||||||
// ^ This will all be done with Client.Destroy;
|
// ^ This will all be done with Client.Destroy;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
function TMMLPSThread.RequireFile(Sender: TObject;
|
function TMMLPSThread.RequireFile(Sender: TObject;
|
||||||
const OriginFileName: String; var FileName, OutPut: string): Boolean;
|
const OriginFileName: String; var FileName, OutPut: string): Boolean;
|
||||||
begin
|
begin
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
|
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
|
||||||
begin
|
begin
|
||||||
SIRegister_Std(x);
|
SIRegister_Std(x);
|
||||||
SIRegister_Controls(x);
|
SIRegister_Controls(x);
|
||||||
SIRegister_Classes(x, true);
|
SIRegister_Classes(x, true);
|
||||||
SIRegister_Graphics(x, true);
|
SIRegister_Graphics(x, true);
|
||||||
SIRegister_stdctrls(x);
|
SIRegister_stdctrls(x);
|
||||||
SIRegister_Forms(x);
|
SIRegister_Forms(x);
|
||||||
SIRegister_ExtCtrls(x);
|
SIRegister_ExtCtrls(x);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
|
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
|
||||||
x: TPSRuntimeClassImporter);
|
x: TPSRuntimeClassImporter);
|
||||||
begin
|
begin
|
||||||
RIRegister_Std(x);
|
RIRegister_Std(x);
|
||||||
RIRegister_Classes(x, True);
|
RIRegister_Classes(x, True);
|
||||||
RIRegister_Controls(x);
|
RIRegister_Controls(x);
|
||||||
RIRegister_Graphics(x, True);
|
RIRegister_Graphics(x, True);
|
||||||
RIRegister_stdctrls(x);
|
RIRegister_stdctrls(x);
|
||||||
RIRegister_Forms(x);
|
RIRegister_Forms(x);
|
||||||
RIRegister_ExtCtrls(x);
|
RIRegister_ExtCtrls(x);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.OutputMessages;
|
procedure TMMLPSThread.OutputMessages;
|
||||||
var
|
var
|
||||||
l: Longint;
|
l: Longint;
|
||||||
b: Boolean;
|
b: Boolean;
|
||||||
begin
|
begin
|
||||||
b := False;
|
b := False;
|
||||||
for l := 0 to PSScript.CompilerMessageCount - 1 do
|
for l := 0 to PSScript.CompilerMessageCount - 1 do
|
||||||
begin
|
begin
|
||||||
psWriteln(PSScript.CompilerErrorToStr(l));
|
psWriteln(PSScript.CompilerErrorToStr(l));
|
||||||
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
|
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
|
||||||
begin
|
begin
|
||||||
b := True;
|
b := True;
|
||||||
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
|
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
|
||||||
|
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.Execute;
|
procedure TMMLPSThread.Execute;
|
||||||
var
|
var
|
||||||
time, i, ii: Integer;
|
time, i, ii: Integer;
|
||||||
begin;
|
begin;
|
||||||
CurrThread := Self;
|
CurrThread := Self;
|
||||||
time := lclintf.GetTickCount;
|
time := lclintf.GetTickCount;
|
||||||
try
|
try
|
||||||
if PSScript.Compile then
|
if PSScript.Compile then
|
||||||
begin
|
begin
|
||||||
OutputMessages;
|
OutputMessages;
|
||||||
psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
|
psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
|
||||||
// if not (ScriptState = SCompiling) then
|
// if not (ScriptState = SCompiling) then
|
||||||
if not PSScript.Execute then
|
if not PSScript.Execute then
|
||||||
begin
|
begin
|
||||||
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
|
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
|
||||||
psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
|
psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
|
||||||
+Inttostr(PSScript.ExecErrorByteCodePosition));
|
+Inttostr(PSScript.ExecErrorByteCodePosition));
|
||||||
end else psWriteln('Succesfully executed');
|
end else psWriteln('Succesfully executed');
|
||||||
end else
|
end else
|
||||||
begin
|
begin
|
||||||
OutputMessages;
|
OutputMessages;
|
||||||
psWriteln('Compiling failed');
|
psWriteln('Compiling failed');
|
||||||
end;
|
end;
|
||||||
except
|
except
|
||||||
on E : Exception do
|
on E : Exception do
|
||||||
psWriteln('Error: ' + E.Message);
|
psWriteln('Error: ' + E.Message);
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.SetPSScript(Script: string);
|
procedure TMMLPSThread.SetPSScript(Script: string);
|
||||||
begin
|
begin
|
||||||
PSScript.Script.Text:= Script;
|
PSScript.Script.Text:= Script;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMMLPSThread.SetDebug(Strings: TSynMemo);
|
procedure TMMLPSThread.SetDebug(Strings: TSynMemo);
|
||||||
begin
|
begin
|
||||||
DebugTo := Strings;
|
DebugTo := Strings;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
|
||||||
{ Include stuff here? }
|
{ Include stuff here? }
|
||||||
|
|
||||||
//{$I inc/colors.inc}
|
//{$I inc/colors.inc}
|
||||||
//{$I inc/bitmaps.inc}
|
//{$I inc/bitmaps.inc}
|
||||||
|
|
||||||
|
|
||||||
end.
|
end.
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,227 +1,250 @@
|
|||||||
unit finder;
|
unit finder;
|
||||||
|
|
||||||
{$mode objfpc}{$H+}
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
interface
|
interface
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, SysUtils, MufasaTypes; // Types
|
Classes, SysUtils, MufasaTypes; // Types
|
||||||
|
|
||||||
{ TMFinder Class }
|
{ TMFinder Class }
|
||||||
|
|
||||||
{
|
{
|
||||||
Should be 100% independant, as all platform dependant code is in the
|
Should be 100% independant, as all platform dependant code is in the
|
||||||
Window and Input classes.
|
Window and Input classes.
|
||||||
|
|
||||||
Let's try not to use any OS-specific defines here? ;)
|
Let's try not to use any OS-specific defines here? ;)
|
||||||
}
|
}
|
||||||
|
|
||||||
type
|
type
|
||||||
TMFinder = class(TObject)
|
TMFinder = class(TObject)
|
||||||
constructor Create(aClient: TObject);
|
constructor Create(aClient: TObject);
|
||||||
destructor Destroy; override;
|
destructor Destroy; override;
|
||||||
private
|
private
|
||||||
Procedure UpdateCachedValues(NewWidth,NewHeight : integer);
|
Procedure UpdateCachedValues(NewWidth,NewHeight : integer);
|
||||||
procedure DefaultOperations(var x1,y1,x2,y2 : integer);
|
procedure DefaultOperations(var x1,y1,x2,y2 : integer);
|
||||||
public
|
public
|
||||||
procedure SetToleranceSpeed(nCTS: Integer);
|
procedure SetToleranceSpeed(nCTS: Integer);
|
||||||
|
function SimilarColors(Color1,Color2,Tolerance : Integer) : boolean;
|
||||||
// Possibly turn x, y into a TPoint var.
|
// Possibly turn x, y into a TPoint var.
|
||||||
function FindColor(var x, y: Integer; Color, x1, y1, x2, y2: Integer): Boolean;
|
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 FindColorTolerance(var x, y: Integer; Color, x1, y1, x2, y2, tol: Integer): Boolean;
|
||||||
protected
|
protected
|
||||||
Client: TObject;
|
Client: TObject;
|
||||||
CachedWidth, CachedHeight : integer;
|
CachedWidth, CachedHeight : integer;
|
||||||
ClientTPA : TPointArray;
|
ClientTPA : TPointArray;
|
||||||
hueMod, satMod: Extended;
|
hueMod, satMod: Extended;
|
||||||
CTS: Integer;
|
CTS: Integer;
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
uses
|
uses
|
||||||
Client, // For the Client Casts.
|
Client, // For the Client Casts.
|
||||||
colour_conv // For RGBToColor, etc.
|
colour_conv // For RGBToColor, etc.
|
||||||
;
|
;
|
||||||
|
|
||||||
|
|
||||||
constructor TMFinder.Create(aClient: TObject);
|
constructor TMFinder.Create(aClient: TObject);
|
||||||
|
|
||||||
begin
|
begin
|
||||||
inherited Create;
|
inherited Create;
|
||||||
|
|
||||||
Self.Client := aClient;
|
Self.Client := aClient;
|
||||||
Self.CTS := 1;
|
Self.CTS := 1;
|
||||||
Self.hueMod := 0.2;
|
Self.hueMod := 0.2;
|
||||||
Self.satMod := 0.2;
|
Self.satMod := 0.2;
|
||||||
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
destructor TMFinder.Destroy;
|
destructor TMFinder.Destroy;
|
||||||
begin
|
begin
|
||||||
|
|
||||||
inherited;
|
inherited;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMFinder.SetToleranceSpeed(nCTS: Integer);
|
procedure TMFinder.SetToleranceSpeed(nCTS: Integer);
|
||||||
begin
|
begin
|
||||||
if (CTS < 0) or (CTS > 2) then
|
if (nCTS < 0) or (nCTS > 2) then
|
||||||
cts := 1;
|
raise Exception.CreateFmt('The given CTS ([%d]) is invalid.',[nCTS]);
|
||||||
Self.CTS := nCTS;
|
Self.CTS := nCTS;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TMFinder.UpdateCachedValues(NewWidth, NewHeight: integer);
|
function TMFinder.SimilarColors(Color1, Color2,Tolerance: Integer) : boolean;
|
||||||
begin
|
var
|
||||||
CachedWidth := NewWidth;
|
R1,G1,B1,R2,G2,B2 : Byte;
|
||||||
CachedHeight := NewHeight;
|
H1,S1,L1,H2,S2,L2 : extended;
|
||||||
SetLength(ClientTPA,NewWidth * NewHeight);
|
begin
|
||||||
end;
|
Result := False;
|
||||||
|
ColorToRGB(Color1,R1,G1,B1);
|
||||||
procedure TMFinder.DefaultOperations(var x1, y1, x2, y2: integer);
|
ColorToRGB(Color2,R2,G2,B2);
|
||||||
var
|
if Color1 = Color2 then
|
||||||
w,h : integer;
|
Result := true
|
||||||
begin
|
else
|
||||||
{ if x1 > x2 then
|
case CTS of
|
||||||
Swap(x1,x2);
|
0: Result := ((Abs(R1-R2) <= Tolerance) and (Abs(G1-G2) <= Tolerance) and (Abs(B1-B2) <= Tolerance));
|
||||||
if y1 > y2 then
|
1: Result := (Sqrt(sqr(R1-R2) + sqr(G1-G2) + sqr(B1-B2)) <= Tolerance);
|
||||||
Swap(y1,y2);}
|
2: begin
|
||||||
if x1 < 0 then
|
RGBToHSL(R1,g1,b1,H1,S1,L1);
|
||||||
x1 := 0;
|
RGBToHSL(R2,g2,b2,H2,S2,L2);
|
||||||
if y1 < 0 then
|
Result := ((abs(H1 - H2) <= (hueMod * Tolerance)) and (abs(S2-S1) <= (satMod * Tolerance)) and (abs(L1-L2) <= Tolerance));
|
||||||
y1 := 0;
|
end;
|
||||||
TClient(Self.Client).MWindow.GetDimensions(w,h);
|
end;
|
||||||
if (w <> CachedWidth) or (h <> CachedHeight) then
|
end;
|
||||||
UpdateCachedValues(w,h);
|
|
||||||
if x2 >= w then
|
procedure TMFinder.UpdateCachedValues(NewWidth, NewHeight: integer);
|
||||||
x2 := w-1;
|
begin
|
||||||
if y2 >= h then
|
CachedWidth := NewWidth;
|
||||||
y2 := h-1;
|
CachedHeight := NewHeight;
|
||||||
end;
|
SetLength(ClientTPA,NewWidth * NewHeight);
|
||||||
|
end;
|
||||||
function TMFinder.FindColor(var x, y: Integer; Color, x1, y1, x2, y2: Integer): Boolean;
|
|
||||||
var
|
procedure TMFinder.DefaultOperations(var x1, y1, x2, y2: integer);
|
||||||
PtrData: TRetData;
|
var
|
||||||
Ptr: PRGB32;
|
w,h : integer;
|
||||||
PtrInc: Integer;
|
begin
|
||||||
dX, dY, clR, clG, clB, xx, yy: Integer;
|
{ if x1 > x2 then
|
||||||
|
Swap(x1,x2);
|
||||||
begin
|
if y1 > y2 then
|
||||||
|
Swap(y1,y2);}
|
||||||
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
|
if x1 < 0 then
|
||||||
DefaultOperations(x1,y1,x2,y2);
|
x1 := 0;
|
||||||
|
if y1 < 0 then
|
||||||
// calculate delta x and y
|
y1 := 0;
|
||||||
dX := x2 - x1;
|
TClient(Self.Client).MWindow.GetDimensions(w,h);
|
||||||
dY := y2 - y1;
|
if (w <> CachedWidth) or (h <> CachedHeight) then
|
||||||
|
UpdateCachedValues(w,h);
|
||||||
//next, convert the color to r,g,b
|
if x2 >= w then
|
||||||
ColorToRGB(Color, clR, clG, clB);
|
x2 := w-1;
|
||||||
|
if y2 >= h then
|
||||||
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
|
y2 := h-1;
|
||||||
|
end;
|
||||||
// Do we want to "cache" these vars?
|
|
||||||
// We will, for now. Easier to type.
|
function TMFinder.FindColor(var x, y: Integer; Color, x1, y1, x2, y2: Integer): Boolean;
|
||||||
Ptr := PtrData.Ptr;
|
var
|
||||||
PtrInc := PtrData.IncPtrWith;
|
PtrData: TRetData;
|
||||||
|
Ptr: PRGB32;
|
||||||
for yy := y1 to y2 do
|
PtrInc: Integer;
|
||||||
begin;
|
dX, dY, clR, clG, clB, xx, yy: Integer;
|
||||||
for xx := x1 to x2 do
|
|
||||||
begin;
|
begin
|
||||||
// Colour comparison here. Possibly with tolerance? ;)
|
|
||||||
if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then
|
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
|
||||||
begin
|
DefaultOperations(x1,y1,x2,y2);
|
||||||
Result := True;
|
|
||||||
x := xx;
|
// calculate delta x and y
|
||||||
y := yy;
|
dX := x2 - x1;
|
||||||
|
dY := y2 - y1;
|
||||||
TClient(Client).MWindow.FreeReturnData;
|
|
||||||
Exit;
|
//next, convert the color to r,g,b
|
||||||
end;
|
ColorToRGB(Color, clR, clG, clB);
|
||||||
Inc(Ptr);
|
|
||||||
end;
|
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
|
||||||
Inc(Ptr, PtrInc)
|
|
||||||
end;
|
// Do we want to "cache" these vars?
|
||||||
|
// We will, for now. Easier to type.
|
||||||
TClient(Client).MWindow.FreeReturnData;
|
Ptr := PtrData.Ptr;
|
||||||
end;
|
PtrInc := PtrData.IncPtrWith;
|
||||||
|
|
||||||
function TMFinder.FindColorTolerance(var x, y: Integer; Color, x1, y1, x2, y2, tol: Integer): Boolean;
|
for yy := y1 to y2 do
|
||||||
var
|
begin;
|
||||||
PtrData: TRetData;
|
for xx := x1 to x2 do
|
||||||
Ptr: PRGB32;
|
begin;
|
||||||
PtrInc: Integer;
|
// Colour comparison here. Possibly with tolerance? ;)
|
||||||
dX, dY, clR, clG, clB, xx, yy: Integer;
|
if (Ptr^.R = clR) and (Ptr^.G = clG) and (Ptr^.B = clB) then
|
||||||
H1, S1, L1, H2, S2, L2: Extended;
|
begin
|
||||||
|
Result := True;
|
||||||
label Hit;
|
x := xx;
|
||||||
label Miss;
|
y := yy;
|
||||||
|
|
||||||
begin
|
TClient(Client).MWindow.FreeReturnData;
|
||||||
|
Exit;
|
||||||
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
|
end;
|
||||||
DefaultOperations(x1,y1,x2,y2);
|
Inc(Ptr);
|
||||||
|
end;
|
||||||
// calculate delta x and y
|
Inc(Ptr, PtrInc)
|
||||||
dX := x2 - x1;
|
end;
|
||||||
dY := y2 - y1;
|
|
||||||
//next, convert the color to r,g,b
|
TClient(Client).MWindow.FreeReturnData;
|
||||||
ColorToRGB(Color, clR, clG, clB);
|
end;
|
||||||
ColorToHSL(Color, H1, S1, L1);
|
|
||||||
|
function TMFinder.FindColorTolerance(var x, y: Integer; Color, x1, y1, x2, y2, tol: Integer): Boolean;
|
||||||
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
|
var
|
||||||
|
PtrData: TRetData;
|
||||||
// Do we want to "cache" these vars?
|
Ptr: PRGB32;
|
||||||
// We will, for now. Easier to type.
|
PtrInc: Integer;
|
||||||
Ptr := PtrData.Ptr;
|
dX, dY, clR, clG, clB, xx, yy: Integer;
|
||||||
PtrInc := PtrData.IncPtrWith;
|
H1, S1, L1, H2, S2, L2: Extended;
|
||||||
|
|
||||||
case CTS of
|
label Hit;
|
||||||
0:
|
label Miss;
|
||||||
for yy := y1 to y2 do
|
|
||||||
begin
|
begin
|
||||||
for xx := x1 to x2 do
|
|
||||||
begin
|
// checks for valid x1,y1,x2,y2? (may involve GetDimensions)
|
||||||
if ((abs(clR-Ptr^.R) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clG-Ptr^.B) <= Tol)) then
|
DefaultOperations(x1,y1,x2,y2);
|
||||||
goto Hit;
|
|
||||||
end;
|
// calculate delta x and y
|
||||||
Inc(Ptr, PtrInc);
|
dX := x2 - x1;
|
||||||
end;
|
dY := y2 - y1;
|
||||||
|
//next, convert the color to r,g,b
|
||||||
1:
|
ColorToRGB(Color, clR, clG, clB);
|
||||||
for yy := y1 to y2 do
|
ColorToHSL(Color, H1, S1, L1);
|
||||||
begin
|
|
||||||
for xx := x1 to x2 do
|
PtrData := TClient(Client).MWindow.ReturnData(x1, y1, dX + 1, dY + 1);
|
||||||
begin
|
|
||||||
if (Sqrt(sqr(clR-Ptr^.R) + sqr(clG - Ptr^.G) + sqr(clB - Ptr^.B)) <= Tol) then
|
// Do we want to "cache" these vars?
|
||||||
goto Hit;
|
// We will, for now. Easier to type.
|
||||||
end;
|
Ptr := PtrData.Ptr;
|
||||||
Inc(Ptr, PtrInc);
|
PtrInc := PtrData.IncPtrWith;
|
||||||
end;
|
|
||||||
2:
|
case CTS of
|
||||||
begin
|
0:
|
||||||
for yy := y1 to y2 do
|
for yy := y1 to y2 do
|
||||||
for xx := x1 to x2 do
|
begin
|
||||||
begin
|
for xx := x1 to x2 do
|
||||||
RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,H2,S2,L2);
|
begin
|
||||||
if ((abs(H1 - H2) <= (hueMod * tol)) and (abs(S1 - S2) <= (satMod * tol)) and (abs(L1 - L2) <= Tol)) then
|
if ((abs(clR-Ptr^.R) <= Tol) and (abs(clG-Ptr^.G) <= Tol) and (Abs(clG-Ptr^.B) <= Tol)) then
|
||||||
goto Hit;
|
goto Hit;
|
||||||
end;
|
inc(Ptr);
|
||||||
Inc(Ptr, PtrInc);
|
end;
|
||||||
end;
|
Inc(Ptr, PtrInc);
|
||||||
end;
|
end;
|
||||||
Result := False;
|
|
||||||
TClient(Client).MWindow.FreeReturnData;
|
1:
|
||||||
Exit;
|
for yy := y1 to y2 do
|
||||||
|
begin
|
||||||
Hit:
|
for xx := x1 to x2 do
|
||||||
|
begin
|
||||||
Result := True;
|
if (Sqrt(sqr(clR-Ptr^.R) + sqr(clG - Ptr^.G) + sqr(clB - Ptr^.B)) <= Tol) then
|
||||||
x := xx;
|
goto Hit;
|
||||||
y := yy;
|
inc(ptr);
|
||||||
|
end;
|
||||||
TClient(Client).MWindow.FreeReturnData;
|
Inc(Ptr, PtrInc);
|
||||||
end;
|
end;
|
||||||
|
2:
|
||||||
end.
|
begin
|
||||||
|
for yy := y1 to y2 do
|
||||||
|
for xx := x1 to x2 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;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user