moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-08-13 16:53:59 -04:00
Code Issues Releases Wiki Activity

Bmp stuff + normal font size in GUI.

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

438
Projects/SAMufasaGUI/project1.lpi
View File

File diff suppressed because it is too large Load Diff

26
Projects/SAMufasaGUI/testunit.lfm
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

1526
Projects/SAMufasaGUI/testunit.lrs
View File

File diff suppressed because it is too large Load Diff

2
Projects/SAMufasaGUI/testunit.pas
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;

236
Units/MMLAddon/PSInc/Wrappers/bitmap.inc
View File

@ -1,104 +1,132 @@
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);
end;
procedure GetBitmapSize(Bmp : integer; var BmpW,BmpH : integer);
begin;
With CurrThread.Client.MBitmaps.Bmp[bmp] do
begin;
BmpW := width;
BmpH := Height;
end;
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);
var
mBMP: TMufasaBitmap;
begin
mBMP := CurrThread.Client.MBitmaps.GetBMP(bmp);
if mBMP = nil then
exit;
mBMP.CopyClientToBitmap(CurrThread.Client.MWindow, xs, ys, xe, ye);
end;
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);
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);
var
mBMP: TMufasaBitmap;
begin
mBMP := CurrThread.Client.MBitmaps.GetBMP(bmp);
if mBMP = nil then
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;

168
Units/MMLAddon/PSInc/pscompile.inc
View File

@ -1,82 +1,86 @@
Sender.Comp.AddTypeS('TIntegerArray', 'Array of integer');
Sender.Comp.AddTypeS('TPointArray','Array of TPoint');
Sender.Comp.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)');
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(@point,'function Point(x,y:integer) : TPoint;');
Sender.AddFunction(@Freeze, 'function freeze:boolean;');
Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;');
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(@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(@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(@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(@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.Comp.AddTypeS('TIntegerArray', 'Array of integer');
Sender.Comp.AddTypeS('TPointArray','Array of TPoint');
Sender.Comp.AddTypeS('TBmpMirrorStyle','(MirrorWidth,MirrorHeight,MirrorLine)');
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(@Freeze, 'function freeze:boolean;');
Sender.AddFunction(@Unfreeze, 'function unfreeze: boolean;');
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(@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(@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(@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(@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;');

565
Units/MMLAddon/mmlpsthread.pas
View File

@ -1,283 +1,282 @@
unit mmlpsthread;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor;
type
{ TMMLPSThread }
TMMLPSThread = class(TThread)
procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: string; var Continue: Boolean);
protected
DebugTo : TMemo;
PluginsToload : Array of integer;
procedure OnCompile(Sender: TPSScript);
procedure AfterExecute(Sender : TPSScript);
function RequireFile(Sender: TObject; const OriginFileName: String;
var FileName, OutPut: string): Boolean;
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
procedure OutputMessages;
procedure OnThreadTerminate(Sender: TObject);
procedure Execute; override;
public
PSScript : TPSScript; // Moved to public, as we can't kill it otherwise.
Client : TClient;
procedure SetPSScript(Script : string);
procedure SetDebug( Strings : TMemo );
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
end;
implementation
uses
MufasaTypes, dtmutil,
{$ifdef mswindows}windows,{$endif}
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
uPSC_extctrls, //Compile-libs
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
uPSR_extctrls, //Runtime-libs
Graphics, //For Graphics types
math, //Maths!
bitmaps,
lclintf; // for GetTickCount and others.
threadvar
CurrThread : TMMLPSThread;
{Some General PS Functions here}
procedure psWriteln(str : string);
begin
{$IFNDEF MSWINDOWS}
writeln(str);
{$ELSE}
if CurrThread.DebugTo <> nil then
CurrThread.DebugTo.lines.add(str);
{$ENDIF}
end;
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
begin;
Writeln('We have a length of: ' + inttostr(length(v)));
Try
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
Except
Writeln('We has some errors :-(');
end;
end;
{
Note to Raymond: For PascalScript, Create it on the .Create,
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.
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. )
Also, don't add PS to this unit, but make a seperate unit for it.
Unit "MMLPSThread", perhaps?
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
well, it will really make the unit more straightforward to use and read.
}
constructor TMMLPSThread.Create(CreateSuspended : boolean);
begin
SetLength(PluginsToLoad,0);
Client := TClient.Create;
PSScript := TPSScript.Create(nil);
PSScript.UsePreProcessor:= True;
PSScript.OnNeedFile := @RequireFile;
PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective;
PSScript.OnCompile:= @OnCompile;
PSScript.OnCompImport:= @OnCompImport;
PSScript.OnExecImport:= @OnExecImport;
PSScript.OnAfterExecute:= @AfterExecute;
// Set some defines
{$I PSInc/psdefines.inc}
FreeOnTerminate := True;
Self.OnTerminate := @Self.OnThreadTerminate;
inherited Create(CreateSuspended);
end;
procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
begin
// Writeln('Terminating the thread');
end;
destructor TMMLPSThread.Destroy;
begin
SetLength(PluginsToLoad,0);
Client.Free;
PSScript.Free;
inherited;
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}
{$I PSInc/Wrappers/dtm.inc}
procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: string; var Continue: Boolean);
var
TempNum : integer;
I: integer;
begin
if DirectiveName= 'LOADDLL' then
if DirectiveParam <> '' then
begin;
TempNum := PluginsGlob.LoadPlugin(DirectiveParam);
if TempNum < 0 then
Writeln(Format('Your DLL %s has not been found',[DirectiveParam]))
else
begin;
for i := High(PluginsToLoad) downto 0 do
if PluginsToLoad[i] = TempNum then
Exit;
SetLength(PluginsToLoad,Length(PluginsToLoad)+1);
PluginsToLoad[High(PluginsToLoad)] := TempNum;
end;
end;
Continue:= True;
end;
procedure TMMLPSThread.OnCompile(Sender: TPSScript);
var
i,ii : integer;
begin
for i := high(PluginsToLoad) downto 0 do
for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do
PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr,
PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall);
// Here we add all the functions to the engine.
{$I PSInc/pscompile.inc}
end;
procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
begin
//Here we add all the Script-freeing-leftovers (like BMParray etc)
// ^ This will all be done with Client.Destroy;
end;
function TMMLPSThread.RequireFile(Sender: TObject;
const OriginFileName: String; var FileName, OutPut: string): Boolean;
begin
Result := False;
end;
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
begin
SIRegister_Std(x);
SIRegister_Controls(x);
SIRegister_Classes(x, true);
SIRegister_Graphics(x, true);
SIRegister_stdctrls(x);
SIRegister_Forms(x);
SIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
x: TPSRuntimeClassImporter);
begin
RIRegister_Std(x);
RIRegister_Classes(x, True);
RIRegister_Controls(x);
RIRegister_Graphics(x, True);
RIRegister_stdctrls(x);
RIRegister_Forms(x);
RIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OutputMessages;
var
l: Longint;
b: Boolean;
begin
b := False;
for l := 0 to PSScript.CompilerMessageCount - 1 do
begin
psWriteln(PSScript.CompilerErrorToStr(l));
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
begin
b := True;
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
end;
end;
end;
procedure TMMLPSThread.Execute;
var
time: Integer;
begin;
CurrThread := Self;
time := lclintf.GetTickCount;
try
if PSScript.Compile then
begin
OutputMessages;
psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
// if not (ScriptState = SCompiling) then
if not PSScript.Execute then
begin
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
+Inttostr(PSScript.ExecErrorByteCodePosition));
end else psWriteln('Succesfully executed');
end else
begin
OutputMessages;
psWriteln('Compiling failed');
end;
except
on E : Exception do
psWriteln('Error: ' + E.Message);
end;
end;
procedure TMMLPSThread.SetPSScript(Script: string);
begin
PSScript.Script.Text:= Script;
end;
procedure TMMLPSThread.SetDebug(Strings: TMemo);
begin
DebugTo := Strings;
end;
{ Include stuff here? }
//{$I inc/colors.inc}
//{$I inc/bitmaps.inc}
end.
unit mmlpsthread;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor;
type
{ TMMLPSThread }
TMMLPSThread = class(TThread)
procedure PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: string; var Continue: Boolean);
protected
DebugTo : TMemo;
PluginsToload : Array of integer;
procedure OnCompile(Sender: TPSScript);
procedure AfterExecute(Sender : TPSScript);
function RequireFile(Sender: TObject; const OriginFileName: String;
var FileName, OutPut: string): Boolean;
procedure OnCompImport(Sender: TObject; x: TPSPascalCompiler);
procedure OnExecImport(Sender: TObject; se: TPSExec; x: TPSRuntimeClassImporter);
procedure OutputMessages;
procedure OnThreadTerminate(Sender: TObject);
procedure Execute; override;
public
PSScript : TPSScript; // Moved to public, as we can't kill it otherwise.
Client : TClient;
procedure SetPSScript(Script : string);
procedure SetDebug( Strings : TMemo );
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
end;
implementation
uses
MufasaTypes, dtmutil,
{$ifdef mswindows}windows,{$endif}
uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms,
uPSC_extctrls, //Compile-libs
uPSR_std, uPSR_controls,uPSR_classes,uPSR_graphics,uPSR_stdctrls,uPSR_forms,
uPSR_extctrls, //Runtime-libs
Graphics, //For Graphics types
math, //Maths!
bitmaps,
lclintf; // for GetTickCount and others.
threadvar
CurrThread : TMMLPSThread;
{Some General PS Functions here}
procedure psWriteln(str : string);
begin
{$IFNDEF MSWINDOWS}
writeln(str);
{$ELSE}
if CurrThread.DebugTo <> nil then
CurrThread.DebugTo.lines.add(str);
{$ENDIF}
end;
function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant;
begin;
Writeln('We have a length of: ' + inttostr(length(v)));
Try
Result := CurrThread.PSScript.Exec.RunProcPVar(v,CurrThread.PSScript.Exec.GetProc(Procname));
Except
Writeln('We has some errors :-(');
end;
end;
{
Note to Raymond: For PascalScript, Create it on the .Create,
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.
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. )
Also, don't add PS to this unit, but make a seperate unit for it.
Unit "MMLPSThread", perhaps?
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
well, it will really make the unit more straightforward to use and read.
}
constructor TMMLPSThread.Create(CreateSuspended : boolean);
begin
SetLength(PluginsToLoad,0);
Client := TClient.Create;
PSScript := TPSScript.Create(nil);
PSScript.UsePreProcessor:= True;
PSScript.OnNeedFile := @RequireFile;
PSScript.OnProcessUnknowDirective:=@PSScriptProcessUnknowDirective;
PSScript.OnCompile:= @OnCompile;
PSScript.OnCompImport:= @OnCompImport;
PSScript.OnExecImport:= @OnExecImport;
PSScript.OnAfterExecute:= @AfterExecute;
// Set some defines
{$I PSInc/psdefines.inc}
FreeOnTerminate := True;
Self.OnTerminate := @Self.OnThreadTerminate;
inherited Create(CreateSuspended);
end;
procedure TMMLPSThread.OnThreadTerminate(Sender: TObject);
begin
// Writeln('Terminating the thread');
end;
destructor TMMLPSThread.Destroy;
begin
SetLength(PluginsToLoad,0);
Client.Free;
PSScript.Free;
inherited;
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}
{$I PSInc/Wrappers/dtm.inc}
procedure TMMLPSThread.PSScriptProcessUnknowDirective(Sender: TPSPreProcessor;
Parser: TPSPascalPreProcessorParser; const Active: Boolean;
const DirectiveName, DirectiveParam: string; var Continue: Boolean);
var
TempNum : integer;
I: integer;
begin
if DirectiveName= 'LOADDLL' then
if DirectiveParam <> '' then
begin;
TempNum := PluginsGlob.LoadPlugin(DirectiveParam);
if TempNum < 0 then
Writeln(Format('Your DLL %s has not been found',[DirectiveParam]))
else
begin;
for i := High(PluginsToLoad) downto 0 do
if PluginsToLoad[i] = TempNum then
Exit;
SetLength(PluginsToLoad,Length(PluginsToLoad)+1);
PluginsToLoad[High(PluginsToLoad)] := TempNum;
end;
end;
Continue:= True;
end;
procedure TMMLPSThread.OnCompile(Sender: TPSScript);
var
i,ii : integer;
begin
for i := high(PluginsToLoad) downto 0 do
for ii := 0 to PluginsGlob.MPlugins[PluginsToLoad[i]].MethodLen - 1 do
PSScript.AddFunctionEx(PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncPtr,
PluginsGlob.MPlugins[PluginsToLoad[i]].Methods[i].FuncStr, cdStdCall);
// Here we add all the functions to the engine.
{$I PSInc/pscompile.inc}
end;
procedure TMMLPSThread.AfterExecute(Sender: TPSScript);
begin
//Here we add all the Script-freeing-leftovers (like BMParray etc)
// ^ This will all be done with Client.Destroy;
end;
function TMMLPSThread.RequireFile(Sender: TObject;
const OriginFileName: String; var FileName, OutPut: string): Boolean;
begin
Result := False;
end;
procedure TMMLPSThread.OnCompImport(Sender: TObject; x: TPSPascalCompiler);
begin
SIRegister_Std(x);
SIRegister_Controls(x);
SIRegister_Classes(x, true);
SIRegister_Graphics(x, true);
SIRegister_stdctrls(x);
SIRegister_Forms(x);
SIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OnExecImport(Sender: TObject; se: TPSExec;
x: TPSRuntimeClassImporter);
begin
RIRegister_Std(x);
RIRegister_Classes(x, True);
RIRegister_Controls(x);
RIRegister_Graphics(x, True);
RIRegister_stdctrls(x);
RIRegister_Forms(x);
RIRegister_ExtCtrls(x);
end;
procedure TMMLPSThread.OutputMessages;
var
l: Longint;
b: Boolean;
begin
b := False;
for l := 0 to PSScript.CompilerMessageCount - 1 do
begin
psWriteln(PSScript.CompilerErrorToStr(l));
if (not b) and (PSScript.CompilerMessages[l] is TIFPSPascalCompilerError) then
begin
b := True;
// FormMain.CurrSynEdit.SelStart := PSScript.CompilerMessages[l].Pos;
end;
end;
end;
procedure TMMLPSThread.Execute;
var
time: Integer;
begin;
CurrThread := Self;
time := lclintf.GetTickCount;
try
if PSScript.Compile then
begin
OutputMessages;
psWriteln('Compiled succesfully in ' + IntToStr(GetTickCount - time) + ' ms.');
// if not (ScriptState = SCompiling) then
if not PSScript.Execute then
begin
// FormMain.CurrSynEdit.SelStart := Script.PSScript.ExecErrorPosition;
psWriteln(PSScript.ExecErrorToString +' at '+Inttostr(PSScript.ExecErrorProcNo)+'.'
+Inttostr(PSScript.ExecErrorByteCodePosition));
end else psWriteln('Succesfully executed');
end else
begin
OutputMessages;
psWriteln('Compiling failed');
end;
except
on E : Exception do
psWriteln('Error: ' + E.Message);
end;
end;
procedure TMMLPSThread.SetPSScript(Script: string);
begin
PSScript.Script.Text:= Script;
end;
procedure TMMLPSThread.SetDebug(Strings: TMemo);
begin
DebugTo := Strings;
end;
{ Include stuff here? }
//{$I inc/colors.inc}
//{$I inc/bitmaps.inc}
end.

24
Units/MMLCore/bitmaps.pas
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;

1052
Units/MMLCore/finder.pas
View File

File diff suppressed because it is too large Load Diff