moparisthebest
/
Simba
mirror of https://github.com/moparisthebest/Simba
1
0
Fork 0
Code Issues Releases Wiki Activity

Tell me if I missed anything. 

git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@125 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Wizzup? 2009-10-12 15:04:52 +00:00
parent bd5f01d4c0
commit 6c1938cc7f
18 changed files with 2080 additions and 1856 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
Projects/SAMufasaGUI/project1.lpi
View File

@ -7,7 +7,7 @@
<TargetFileExt Value=""/>
<Title Value="Mufasa Stand Alone"/>
<UseXPManifest Value="True"/>
<ActiveEditorIndexAtStart Value="4"/>
<ActiveEditorIndexAtStart Value="10"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
@ -38,7 +38,7 @@
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
<CursorPos X="71" Y="10"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="0"/>
<UsageCount Value="191"/>
@ -170,11 +170,9 @@
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="TestUnit"/>
<CursorPos X="111" Y="8"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="13"/>
<UsageCount Value="157"/>
<Loaded Value="True"/>
</Unit18>
<Unit19>
<Filename Value="../cogat/Units/CogatUnits/compcolors.pas"/>
@ -302,7 +300,7 @@
<Filename Value="../../Units/MMLCore/client.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Client"/>
<CursorPos X="47" Y="3"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="4"/>
<UsageCount Value="156"/>
@ -392,8 +390,8 @@
<Filename Value="../../Units/MMLAddon/mmlthread.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MMLThread"/>
<CursorPos X="10" Y="62"/>
<TopLine Value="50"/>
<CursorPos X="63" Y="64"/>
<TopLine Value="52"/>
<UsageCount Value="147"/>
</Unit48>
<Unit49>
@ -406,8 +404,8 @@
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="mmlpsthread"/>
<CursorPos X="31" Y="135"/>
<TopLine Value="117"/>
<CursorPos X="47" Y="11"/>
<TopLine Value="1"/>
<EditorIndex Value="9"/>
<UsageCount Value="145"/>
<Loaded Value="True"/>
@ -517,11 +515,9 @@
</Unit65>
<Unit66>
<Filename Value="../../Units/MMLAddon/PSInc/pscompile.inc"/>
<CursorPos X="42" Y="79"/>
<TopLine Value="48"/>
<EditorIndex Value="11"/>
<CursorPos X="51" Y="18"/>
<TopLine Value="1"/>
<UsageCount Value="46"/>
<Loaded Value="True"/>
</Unit66>
<Unit67>
<Filename Value="../../../FPC/FPCCheckout/rtl/win/tthread.inc"/>
@ -554,18 +550,16 @@
</Unit70>
<Unit71>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/colour.inc"/>
<CursorPos X="86" Y="33"/>
<TopLine Value="10"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="16"/>
</Unit71>
<Unit72>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/bitmap.inc"/>
<IsPartOfProject Value="True"/>
<CursorPos X="26" Y="93"/>
<CursorPos X="55" Y="24"/>
<TopLine Value="1"/>
<EditorIndex Value="10"/>
<UsageCount Value="134"/>
<Loaded Value="True"/>
</Unit72>
<Unit73>
<Filename Value="../../../FPC/FPCCheckout/packages/fcl-image/src/fpcanvas.inc"/>
@ -712,13 +706,13 @@
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/mouse.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="9"/>
<UsageCount Value="10"/>
</Unit94>
<Unit95>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/other.inc"/>
<CursorPos X="1" Y="1"/>
<CursorPos X="41" Y="15"/>
<TopLine Value="1"/>
<UsageCount Value="8"/>
<UsageCount Value="10"/>
</Unit95>
<Unit96>
<Filename Value="../../Units/PascalScript/uPSCompiler.pas"/>
@ -756,8 +750,8 @@
<Filename Value="../../Units/MMLAddon/plugins.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="plugins"/>
<CursorPos X="86" Y="128"/>
<TopLine Value="128"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="111"/>
</Unit101>
<Unit102>
@ -790,7 +784,9 @@
<Filename Value="../../Units/MMLAddon/PSInc/psdefines.inc"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<EditorIndex Value="10"/>
<UsageCount Value="12"/>
<Loaded Value="True"/>
</Unit106>
<Unit107>
<Filename Value="../../Units/PascalScript/x86.inc"/>
@ -806,9 +802,9 @@
</Unit108>
<Unit109>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/math.inc"/>
<CursorPos X="10" Y="1"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="7"/>
<UsageCount Value="10"/>
</Unit109>
<Unit110>
<Filename Value="../../../lazarus/lcl/controls.pp"/>
@ -865,11 +861,9 @@
<Filename Value="../../Units/MMLAddon/colourpicker.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="colourpicker"/>
<CursorPos X="53" Y="33"/>
<TopLine Value="15"/>
<EditorIndex Value="12"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="88"/>
<Loaded Value="True"/>
</Unit117>
<Unit118>
<Filename Value="../../../cogat/Units/CogatUnits/compdragger.pas"/>
@ -892,8 +886,8 @@
<Filename Value="../../Units/MMLAddon/windowselector.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="windowselector"/>
<CursorPos X="76" Y="83"/>
<TopLine Value="65"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="78"/>
</Unit120>
<Unit121>
@ -941,8 +935,8 @@
</Unit126>
<Unit127>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/dtm.inc"/>
<CursorPos X="2" Y="23"/>
<TopLine Value="6"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="22"/>
</Unit127>
<Unit128>
@ -996,127 +990,119 @@
<UsageCount Value="10"/>
</Unit134>
</Units>
<JumpHistory Count="30" HistoryIndex="29">
<JumpHistory Count="28" HistoryIndex="27">
<Position1>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="11" Column="130" TopLine="1"/>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="78" Column="129" TopLine="68"/>
</Position1>
<Position2>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="10" Column="112" TopLine="1"/>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="270" Column="13" TopLine="242"/>
</Position2>
<Position3>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="8" Column="83" TopLine="1"/>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="4" Column="116" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="36" Column="43" TopLine="2"/>
</Position4>
<Position5>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="57" Column="52" TopLine="16"/>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="38" Column="90" TopLine="10"/>
</Position5>
<Position6>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="78" Column="129" TopLine="68"/>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="579" Column="25" TopLine="542"/>
</Position6>
<Position7>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="270" Column="13" TopLine="242"/>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="7" Column="132" TopLine="1"/>
</Position7>
<Position8>
<Filename Value="../../Units/MMLCore/bitmaps.pas"/>
<Caret Line="4" Column="116" TopLine="1"/>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="124" Column="19" TopLine="96"/>
</Position8>
<Position9>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="36" Column="43" TopLine="2"/>
<Caret Line="207" Column="19" TopLine="179"/>
</Position9>
<Position10>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="38" Column="90" TopLine="10"/>
<Caret Line="582" Column="53" TopLine="543"/>
</Position10>
<Position11>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="579" Column="25" TopLine="542"/>
<Caret Line="38" Column="53" TopLine="1"/>
</Position11>
<Position12>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="7" Column="132" TopLine="1"/>
<Caret Line="570" Column="127" TopLine="527"/>
</Position12>
<Position13>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="124" Column="19" TopLine="96"/>
<Caret Line="546" Column="51" TopLine="543"/>
</Position13>
<Position14>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="207" Column="19" TopLine="179"/>
<Caret Line="540" Column="32" TopLine="525"/>
</Position14>
<Position15>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="582" Column="53" TopLine="543"/>
<Caret Line="38" Column="68" TopLine="38"/>
</Position15>
<Position16>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="38" Column="53" TopLine="1"/>
<Caret Line="540" Column="46" TopLine="525"/>
</Position16>
<Position17>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="570" Column="127" TopLine="527"/>
<Caret Line="38" Column="46" TopLine="38"/>
</Position17>
<Position18>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="546" Column="51" TopLine="543"/>
<Caret Line="10" Column="137" TopLine="1"/>
</Position18>
<Position19>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="540" Column="32" TopLine="525"/>
<Caret Line="124" Column="19" TopLine="96"/>
</Position19>
<Position20>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="38" Column="68" TopLine="38"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="135" Column="23" TopLine="120"/>
</Position20>
<Position21>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="540" Column="46" TopLine="525"/>
<Caret Line="36" Column="1" TopLine="1"/>
</Position21>
<Position22>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="38" Column="46" TopLine="38"/>
<Caret Line="8" Column="7" TopLine="1"/>
</Position22>
<Position23>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="10" Column="137" TopLine="1"/>
<Filename Value="../../Units/MMLCore/client.pas"/>
<Caret Line="23" Column="8" TopLine="1"/>
</Position23>
<Position24>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="124" Column="19" TopLine="96"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="157" Column="22" TopLine="136"/>
</Position24>
<Position25>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="135" Column="23" TopLine="120"/>
<Caret Line="159" Column="23" TopLine="136"/>
</Position25>
<Position26>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/bitmap.inc"/>
<Caret Line="108" Column="19" TopLine="61"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="160" Column="22" TopLine="136"/>
</Position26>
<Position27>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="36" Column="1" TopLine="1"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="161" Column="22" TopLine="136"/>
</Position27>
<Position28>
<Filename Value="../../Units/MMLAddon/PSInc/Wrappers/bitmap.inc"/>
<Caret Line="114" Column="27" TopLine="77"/>
<Filename Value="../../Units/MMLAddon/mmlpsthread.pas"/>
<Caret Line="162" Column="21" TopLine="136"/>
</Position28>
<Position29>
<Filename Value="../../Units/MMLCore/finder.pas"/>
<Caret Line="8" Column="7" TopLine="1"/>
</Position29>
<Position30>
<Filename Value="../../Units/MMLCore/client.pas"/>
<Caret Line="23" Column="8" TopLine="1"/>
</Position30>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>

23
Projects/SAMufasaGUI/project1.lpr
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
SAMufasaGUI for the Mufasa Macro Library
}
program project1;
{$mode objfpc}{$H+}

7
Projects/SAMufasaGUI/testunit.lfm
View File

@ -5,7 +5,7 @@ object Form1: TForm1
Width = 723
ActiveControl = SynEdit1
Caption = 'Mufasa v2'
ClientHeight = 533
ClientHeight = 528
ClientWidth = 723
Menu = MainMenu1
OnCreate = FormCreate
@ -25,8 +25,7 @@ object Form1: TForm1
ParentColor = False
ParentFont = False
TabOrder = 0
BookMarkOptions.OnChange = nil
Gutter.Width = 57
Gutter.Width = 61
Gutter.MouseActions = <
item
Shift = []
@ -608,7 +607,7 @@ object Form1: TForm1
Width = 23
end
object TSynGutterLineNumber
Width = 17
Width = 21
MouseActions = <>
MarkupInfo.Background = clBtnFace
MarkupInfo.Foreground = clNone

1525
Projects/SAMufasaGUI/testunit.lrs
View File

File diff suppressed because it is too large Load Diff

23
Projects/SAMufasaGUI/testunit.pas
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
TestUnit/GUI for the Mufasa Macro Library
}
unit TestUnit;
{$mode objfpc}{$H+}

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

@ -1,147 +1,170 @@
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;
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,ye,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;
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
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);
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;
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,ye,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;

121
Units/MMLAddon/PSInc/Wrappers/colour.inc
View File

@ -1,49 +1,72 @@
function GetColor(x,y : integer) : TColor;
begin;
Result := CurrThread.Client.MWindow.GetColor(x,y);
end;
function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;
begin
Result := CurrThread.Client.MFinder.FindColor(x, y, color, x1, y1, x2, y2);
end;
function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;
begin
Result := CurrThread.Client.MFinder.FindColorTolerance(x, y, color, x1, y1, x2, y2, tol);
end;
function FindColors(var TPA: TPointArray; Color, x1, y1, x2, y2: Integer): Boolean;
begin
Result := CurrThread.Client.MFinder.FindColors(TPA, color, x1, y1, x2, y2);
end;
procedure SetColorToleranceSpeed(cts: Integer);
begin
CurrThread.Client.MFinder.SetToleranceSpeed(cts);
end;
function SimilarColors(Col1,Col2,Tol : integer) : boolean;
begin;
Result := CurrThread.Client.MFinder.SimilarColors(Col1,Col2,Tol);
end;
function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer;
begin;
result := CurrThread.Client.MFinder.CountColorTolerance(color,xs,ys,xe,ye,tolerance);
end;
function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tolerance: Integer): Boolean;
begin;
result := CurrThread.Client.MFinder.FindColorsTolerance(points,color,xs,ys,xe,ye,tolerance);
end;
function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean;
begin;
result := CurrThread.Client.MFinder.FindColorSpiral(x,y,color,xs,ys,xe,ye);
end;
function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean;
begin;
result := CurrThread.Client.MFinder.FindColorsSpiralTolerance(x,y,Points,color,xs,ys,xe,ye,tolerance);
end;
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Colour.inc for the Mufasa Macro Library
}
function GetColor(x,y : integer) : TColor;
begin;
Result := CurrThread.Client.MWindow.GetColor(x,y);
end;
function findcolor(var x, y: integer; color, x1, y1, x2, y2: integer): boolean;
begin
Result := CurrThread.Client.MFinder.FindColor(x, y, color, x1, y1, x2, y2);
end;
function findcolortolerance(var x, y: integer; color, x1, y1, x2, y2, tol: integer): boolean;
begin
Result := CurrThread.Client.MFinder.FindColorTolerance(x, y, color, x1, y1, x2, y2, tol);
end;
function FindColors(var TPA: TPointArray; Color, x1, y1, x2, y2: Integer): Boolean;
begin
Result := CurrThread.Client.MFinder.FindColors(TPA, color, x1, y1, x2, y2);
end;
procedure SetColorToleranceSpeed(cts: Integer);
begin
CurrThread.Client.MFinder.SetToleranceSpeed(cts);
end;
function SimilarColors(Col1,Col2,Tol : integer) : boolean;
begin;
Result := CurrThread.Client.MFinder.SimilarColors(Col1,Col2,Tol);
end;
function CountColorTolerance(Color, xs, ys, xe, ye, Tolerance: Integer): Integer;
begin;
result := CurrThread.Client.MFinder.CountColorTolerance(color,xs,ys,xe,ye,tolerance);
end;
function FindColorsTolerance(var Points: TPointArray; Color, xs, ys, xe, ye, Tolerance: Integer): Boolean;
begin;
result := CurrThread.Client.MFinder.FindColorsTolerance(points,color,xs,ys,xe,ye,tolerance);
end;
function FindColorSpiral(var x, y: Integer; color, xs, ys, xe, ye: Integer): Boolean;
begin;
result := CurrThread.Client.MFinder.FindColorSpiral(x,y,color,xs,ys,xe,ye);
end;
function FindColorsSpiralTolerance(x, y: Integer; var Points: TPointArray; color, xs, ys, xe, ye: Integer; Tolerance: Integer) : boolean;
begin;
result := CurrThread.Client.MFinder.FindColorsSpiralTolerance(x,y,Points,color,xs,ys,xe,ye,tolerance);
end;

23
Units/MMLAddon/PSInc/Wrappers/dtm.inc
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
DTM.inc for the Mufasa Macro Library
}
function ps_FindDTM(DTM: Integer; var x, y: Integer; x1, y1, x2, y2: Integer): Boolean;
begin
Result := CurrThread.Client.MDTM.FindDTM(DTM, x, y, x1, y1, x2, y2);

31
Units/MMLAddon/PSInc/Wrappers/math.inc
View File

@ -1,4 +1,27 @@
function psSqr( e : extended) : extended;
begin;
result := sqr(e);
end;
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Math.inc for the Mufasa Macro Library
}
function psSqr( e : extended) : extended;
begin;
result := sqr(e);
end;

23
Units/MMLAddon/PSInc/Wrappers/mouse.inc
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Mouse.inc for the Mufasa Macro Library
}
procedure MoveMouse(x, y: integer);
begin
CurrThread.Client.MInput.SetMousePos(X, Y);

23
Units/MMLAddon/PSInc/Wrappers/other.inc
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Other.inc for the Mufasa Macro Library
}
procedure GetClientDimensions(var w, h: integer);
begin
CurrThread.Client.MWindow.GetDimensions(w, h);

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

@ -1,84 +1,106 @@
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(@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(@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;');
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;');
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
PSCompile.inc for the Mufasa Macro Library
}
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(@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(@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;');
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;');

51
Units/MMLAddon/PSInc/psdefines.inc
View File

@ -1,14 +1,37 @@
{$IFDEF CPU386 }
PSScript.Defines.Add('CPU386');
{$ENDIF }
PSScript.Defines.Add('MUFASA');
PSScript.Defines.Add('COGAT');
PSScript.Defines.Add('RAYMONDPOWNS');
{$IFDEF MSWINDOWS }
PSScript.Defines.Add('MSWINDOWS');
PSScript.Defines.Add('WIN32');
PSScript.Defines.Add('WINDOWS');
{$ENDIF }
{$IFDEF LINUX }
PSScript.Defines.Add('LINUX');
{$ENDIF }
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
PSDefines.inc for the Mufasa Macro Library
}
{$IFDEF CPU386 }
PSScript.Defines.Add('CPU386');
{$ENDIF }
PSScript.Defines.Add('MUFASA');
PSScript.Defines.Add('COGAT');
PSScript.Defines.Add('RAYMONDPOWNS');
{$IFDEF MSWINDOWS }
PSScript.Defines.Add('MSWINDOWS');
PSScript.Defines.Add('WIN32');
PSScript.Defines.Add('WINDOWS');
{$ENDIF }
{$IFDEF LINUX }
PSScript.Defines.Add('LINUX');
{$ENDIF }

23
Units/MMLAddon/colourpicker.pas
View File

@ -1,3 +1,26 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Colourpicker for the Mufasa Macro Library
}
unit colourpicker;
{$mode objfpc}{$H+}

587
Units/MMLAddon/mmlpsthread.pas
View File

@ -1,282 +1,305 @@
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.
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
MMLPSThread for the Mufasa Macro Library
}
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.

81
Units/MMLAddon/mmlthread.pas
View File

@ -1,81 +0,0 @@
unit MMLThread;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, client;
type
TMMLThread = class(TThread)
protected
Client: TClient;
procedure Execute; override;
public
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
end;
implementation
{
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 TMMLThread.Create(CreateSuspended : boolean);
begin
Client := TClient.Create;
// Create Stuff here
FreeOnTerminate := True;
inherited Create(CreateSuspended);
end;
destructor TMMLThread.Destroy;
begin
Client.Destroy;
inherited Destroy;
end;
procedure TMMLThread.Execute;
var
i,w,h: Integer;
begin
w := 0;
h := 0;
i := 0;
while (not Terminated) and (i < 10) do
begin
Sleep(1000);
Client.MWindow.GetDimensions(W, H);
writeln(inttostr(w) + ', ' + inttostr(h));
Inc(i);
end;
end;
{ Include stuff here? }
//{$I inc/colors.inc}
//{$I inc/bitmaps.inc}
end.

401
Units/MMLAddon/plugins.pas
View File

@ -1,189 +1,212 @@
unit plugins;
{
Problems with SMART; you cannot free the plugin when smart is open..
Therefore, loading & free-ing plugins per script run is not an option.
Assigning a TMPlugin per Tab might be a do-able solution, but will still cope with the SMART Problems..
So the question is: Plugins Per Tab,Per Run or Global?
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,dynlibs;
type
TMPluginMethod = record
FuncPtr : pointer;
FuncStr : string;
end;
TMPlugin = record
Methods : Array of TMPluginMethod;
dllHandle : TLibHandle;
filename : string;
MethodLen : integer;
end;
TMPluginArray = array of TMPlugin;
{ TMPlugins }
TMPlugins = class (TObject)
private
Plugins : TMPluginArray;
PluginLen : integer;
procedure FreePlugins;
public
PluginDirs : TStringList;
procedure ValidateDirs;
procedure LoadPluginsDir( DirIndex : integer);
function LoadPlugin(PluginName : string) : integer;
property Count : integer read PluginLen;
property MPlugins : TMPluginArray read Plugins;
constructor Create;
destructor Destroy;override;
end;
implementation
uses
MufasaTypes,FileUtil;
{ TMPlugins }
procedure TMPlugins.FreePlugins;
var
I : integer;
begin
for i := 0 to PluginLen - 1 do
begin;
if (Plugins[i].dllHandle > 0) then
try
Writeln(inttostr(I));
FreeLibrary(Plugins[i].dllHandle);
except
end;
end;
SetLength(Plugins,0);
PluginLen:= 0;
end;
procedure TMPlugins.ValidateDirs;
var
i : integer;
TempStr : string;
begin
for i := 0 to PluginDirs.Count - 1 do
begin;
if DirectoryExists(PluginDirs.Strings[i]) = false then
raise Exception.createFMT('Directory(%s) does not exist',[PluginDirs[i]]);
TempStr := PluginDirs.Strings[i];
if (TempStr[Length(TempStr)] <> DS) then
begin;
if (TempStr[Length(TempStr)] = '\') or (TempStr[Length(TempStr)] = '/') then
TempStr[Length(TempStr)] := DS
else
TempStr := TempStr + DS;
PluginDirs.Strings[i] := TempStr;
end;
end;
end;
procedure TMPlugins.LoadPluginsDir(DirIndex: integer);
var
PlugExt: String = {$IFDEF LINUX}'*.so';{$ELSE}'*.dll';{$ENDIF}
FileSearcher : TSearchRec;
begin
if (DirIndex < 0) or (DirIndex >= PluginDirs.Count) then
Exit;
if FindFirst(PluginDirs.Strings[DirIndex] + PlugExt, faAnyFile, FileSearcher) <> 0 then
begin;
FindClose(FileSearcher);
Exit;
end;
repeat
LoadPlugin(FileSearcher.Name);
until FindNext(FileSearcher) <> 0;
FindClose(FileSearcher);
end;
function TMPlugins.LoadPlugin(PluginName: string): Integer;
var
i, ii : integer;
pntrArrc : function : integer; stdcall;
GetFuncInfo : function (x: Integer; var ProcAddr: Pointer; var ProcDef: PChar) : Integer; stdcall;
GetTypeCount : function : Integer; stdcall;
GetTypeInfo : function (x: Integer; var sType, sTypeDef: string): Integer; stdcall;
PD : PChar;
pntr : Pointer;
arrc : integer;
Status : LongInt;
PlugExt: String = {$IFDEF LINUX}'.so';{$ELSE}'.dll';{$ENDIF}
begin
ii := -1;
result := -1;
if PluginDirs.Count = 0 then
Exit;
ValidateDirs;
PluginName := ExtractFileNameWithoutExt(PluginName);
for i := 0 to PluginDirs.Count - 1 do
if FileExists(PluginDirs.Strings[i] + Pluginname + PlugExt) then
begin;
if ii <> -1 then
Raise Exception.CreateFmt('Plugin(%s) has been found multiple times',[PluginName]);
ii := i;
end;
if ii = -1 then
raise Exception.CreateFMT('Plugins(%s) has not been found',[PluginName]);
for i := 0 to PluginLen - 1 do
if Plugins[i].filename = (PluginDirs.Strings[ii] + PluginName + PlugExt) then
Exit(i);
pd := StrAlloc(255);
SetLength(Plugins,PluginLen + 1);
Writeln(Format('Loading plugin %s at %s',[PluginName,PluginDirs.Strings[ii]]));
Plugins[PluginLen].filename:= PluginDirs.Strings[ii] + Pluginname + PlugExt;
Plugins[PluginLen].dllHandle:= LoadLibrary(PChar(Plugins[PluginLen].filename));
if Plugins[PluginLen].dllHandle = 0 then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
Pointer(pntrArrc) := GetProcAddress(Plugins[PluginLen].dllHandle, PChar('GetFunctionCount'));
if @pntrArrc = nil then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
arrc := pntrArrc();
SetLength(Plugins[PluginLen].Methods, ArrC);
Pointer(GetFuncInfo) := GetProcAddress(Plugins[PluginLen].dllHandle, PChar('GetFunctionInfo'));
if @GetFuncInfo = nil then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
Plugins[PluginLen].MethodLen := Arrc;
for ii := 0 to ArrC-1 do
begin;
if (GetFuncInfo(ii, pntr, pd) < 0) then
Continue;
Plugins[Pluginlen].Methods[ii].FuncPtr := pntr;
Plugins[Pluginlen].Methods[ii].FuncStr := pd;
end;
Result := PluginLen;
inc(PluginLen);
StrDispose(pd);
end;
constructor TMPlugins.Create;
begin
inherited Create;
PluginLen := 0;
PluginDirs := TStringList.Create;
end;
destructor TMPlugins.Destroy;
begin
FreePlugins;
PluginDirs.Free;
inherited Destroy;
end;
end.
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Plugins Class for the Mufasa Macro Library
}
unit plugins;
{
Problems with SMART; you cannot free the plugin when smart is open..
Therefore, loading & free-ing plugins per script run is not an option.
Assigning a TMPlugin per Tab might be a do-able solution, but will still cope with the SMART Problems..
So the question is: Plugins Per Tab,Per Run or Global?
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,dynlibs;
type
TMPluginMethod = record
FuncPtr : pointer;
FuncStr : string;
end;
TMPlugin = record
Methods : Array of TMPluginMethod;
dllHandle : TLibHandle;
filename : string;
MethodLen : integer;
end;
TMPluginArray = array of TMPlugin;
{ TMPlugins }
TMPlugins = class (TObject)
private
Plugins : TMPluginArray;
PluginLen : integer;
procedure FreePlugins;
public
PluginDirs : TStringList;
procedure ValidateDirs;
procedure LoadPluginsDir( DirIndex : integer);
function LoadPlugin(PluginName : string) : integer;
property Count : integer read PluginLen;
property MPlugins : TMPluginArray read Plugins;
constructor Create;
destructor Destroy;override;
end;
implementation
uses
MufasaTypes,FileUtil;
{ TMPlugins }
procedure TMPlugins.FreePlugins;
var
I : integer;
begin
for i := 0 to PluginLen - 1 do
begin;
if (Plugins[i].dllHandle > 0) then
try
Writeln(inttostr(I));
FreeLibrary(Plugins[i].dllHandle);
except
end;
end;
SetLength(Plugins,0);
PluginLen:= 0;
end;
procedure TMPlugins.ValidateDirs;
var
i : integer;
TempStr : string;
begin
for i := 0 to PluginDirs.Count - 1 do
begin;
if DirectoryExists(PluginDirs.Strings[i]) = false then
raise Exception.createFMT('Directory(%s) does not exist',[PluginDirs[i]]);
TempStr := PluginDirs.Strings[i];
if (TempStr[Length(TempStr)] <> DS) then
begin;
if (TempStr[Length(TempStr)] = '\') or (TempStr[Length(TempStr)] = '/') then
TempStr[Length(TempStr)] := DS
else
TempStr := TempStr + DS;
PluginDirs.Strings[i] := TempStr;
end;
end;
end;
procedure TMPlugins.LoadPluginsDir(DirIndex: integer);
var
PlugExt: String = {$IFDEF LINUX}'*.so';{$ELSE}'*.dll';{$ENDIF}
FileSearcher : TSearchRec;
begin
if (DirIndex < 0) or (DirIndex >= PluginDirs.Count) then
Exit;
if FindFirst(PluginDirs.Strings[DirIndex] + PlugExt, faAnyFile, FileSearcher) <> 0 then
begin;
FindClose(FileSearcher);
Exit;
end;
repeat
LoadPlugin(FileSearcher.Name);
until FindNext(FileSearcher) <> 0;
FindClose(FileSearcher);
end;
function TMPlugins.LoadPlugin(PluginName: string): Integer;
var
i, ii : integer;
pntrArrc : function : integer; stdcall;
GetFuncInfo : function (x: Integer; var ProcAddr: Pointer; var ProcDef: PChar) : Integer; stdcall;
GetTypeCount : function : Integer; stdcall;
GetTypeInfo : function (x: Integer; var sType, sTypeDef: string): Integer; stdcall;
PD : PChar;
pntr : Pointer;
arrc : integer;
Status : LongInt;
PlugExt: String = {$IFDEF LINUX}'.so';{$ELSE}'.dll';{$ENDIF}
begin
ii := -1;
result := -1;
if PluginDirs.Count = 0 then
Exit;
ValidateDirs;
PluginName := ExtractFileNameWithoutExt(PluginName);
for i := 0 to PluginDirs.Count - 1 do
if FileExists(PluginDirs.Strings[i] + Pluginname + PlugExt) then
begin;
if ii <> -1 then
Raise Exception.CreateFmt('Plugin(%s) has been found multiple times',[PluginName]);
ii := i;
end;
if ii = -1 then
raise Exception.CreateFMT('Plugins(%s) has not been found',[PluginName]);
for i := 0 to PluginLen - 1 do
if Plugins[i].filename = (PluginDirs.Strings[ii] + PluginName + PlugExt) then
Exit(i);
pd := StrAlloc(255);
SetLength(Plugins,PluginLen + 1);
Writeln(Format('Loading plugin %s at %s',[PluginName,PluginDirs.Strings[ii]]));
Plugins[PluginLen].filename:= PluginDirs.Strings[ii] + Pluginname + PlugExt;
Plugins[PluginLen].dllHandle:= LoadLibrary(PChar(Plugins[PluginLen].filename));
if Plugins[PluginLen].dllHandle = 0 then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
Pointer(pntrArrc) := GetProcAddress(Plugins[PluginLen].dllHandle, PChar('GetFunctionCount'));
if @pntrArrc = nil then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
arrc := pntrArrc();
SetLength(Plugins[PluginLen].Methods, ArrC);
Pointer(GetFuncInfo) := GetProcAddress(Plugins[PluginLen].dllHandle, PChar('GetFunctionInfo'));
if @GetFuncInfo = nil then
Raise Exception.CreateFMT('Error loading plugin %s',[Plugins[PluginLen].filename]);
Plugins[PluginLen].MethodLen := Arrc;
for ii := 0 to ArrC-1 do
begin;
if (GetFuncInfo(ii, pntr, pd) < 0) then
Continue;
Plugins[Pluginlen].Methods[ii].FuncPtr := pntr;
Plugins[Pluginlen].Methods[ii].FuncStr := pd;
end;
Result := PluginLen;
inc(PluginLen);
StrDispose(pd);
end;
constructor TMPlugins.Create;
begin
inherited Create;
PluginLen := 0;
PluginDirs := TStringList.Create;
end;
destructor TMPlugins.Destroy;
begin
FreePlugins;
PluginDirs.Free;
inherited Destroy;
end;
end.

335
Units/MMLAddon/windowselector.pas
View File

@ -1,156 +1,179 @@
unit windowselector;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
ctypes,
window, windowutil,
controls,
graphics,
forms,
{$IFNDEF MSWINDOWS}x, xlib
{$ELSE}
windows
{$ENDIF}
;
type
TMWindowSelector = class(TObject)
constructor Create(aWindow: TMWindow);
destructor Destroy; override;
{$IFDEF LINUX}
function Drag: x.TWindow;
{$ELSE}
function Drag: Hwnd;
{$ENDIF}
public
Window: TMWindow;
end;
implementation
constructor TMWindowSelector.Create(aWindow: TMWindow);
begin
inherited create;
Self.Window := aWindow;
end;
destructor TMWindowSelector.Destroy;
begin
inherited;
end;
{$IFDEF LINUX}
function TMWindowSelector.Drag: x.TWindow;
var
Tempwindow : x.TWindow;
root : x.TWindow;
subwindow : x.TWindow;
x_root, y_root : cint;
xmask : cuint;
x, y : cint;
Old_Handler : TXErrorHandler;
begin
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
Result := 0;
repeat
XQueryPointer(Window.XDisplay, Window.DesktopWindow, @root,
@Tempwindow, @x_root, @y_root,
@x, @y, @xmask);
subwindow:= Tempwindow;
while subwindow <> 0 do
begin
Tempwindow := subwindow;
XQueryPointer(Window.XDisplay, Tempwindow, @root,
@subwindow, @x_root, @y_root,
@x, @y, @xmask);
end;
if Result <> Tempwindow then
begin
WriteLn('Changing Window to: ' + IntToStr(Tempwindow));
Result := Tempwindow;
end;
Sleep(16);
until (xmask and Button1Mask) = 0;
XSetErrorHandler(Old_handler);
end;
{$ELSE}
function TMWindowSelector.Drag: Hwnd;
var
TargetRect: TRect;
DC: HDC;
OldPen, Pen: hPen;
OldBrush : hBrush;
BrushHandle : THandle;
Cursor : TCursor;
TempHandle : Hwnd;
Handle : Hwnd;
begin;
Pen := CreatePen(PS_SOLID, GetSystemMetrics(SM_CXBORDER)*5, clred);
BrushHandle := GetStockObject(Null_Brush);
Cursor:= Screen.Cursor;
Screen.Cursor:= crCross;
TempHandle := GetDesktopWindow;
while GetAsyncKeyState(VK_LBUTTON) <> 0 do
begin;
Handle:= WindowFromPoint(Mouse.CursorPos);
if Handle <> TempHandle then
begin;
if TempHandle <> 0 then
begin;
Invalidaterect(temphandle, nil, true);
UpdateWindow(temphandle);
{$IFDEF MSWINDOWS}
RedrawWindow(TempHandle, nil, 0, RDW_Frame or RDW_Invalidate or RDW_Updatenow or RDW_Allchildren);
{$ENDIF}
end;
if Handle <> 0 then
begin;
GetWindowRect(Handle, TargetRect);
DC := Windows.GetWindowDC(Handle);
OldPen := SelectObject(DC, Pen);
OldBrush := SelectObject(DC, BrushHandle);
Rectangle(DC, 0, 0, TargetRect.Right - TargetRect.Left, TargetRect.Bottom - TargetRect.Top);
SelectObject(DC, OldBrush);
SelectObject(DC, OldPen);
ReleaseDC(Handle, DC);
end;
TempHandle := Handle;
end;
Sleep(64);
end;
Result := TempHandle;
Screen.Cursor:= cursor;
Invalidaterect(temphandle, nil, true);
UpdateWindow(temphandle);
RedrawWindow(TempHandle, nil, 0, RDW_Frame or RDW_Invalidate or RDW_Updatenow or RDW_Allchildren);
DeleteObject(Pen);
end;
{$ENDIF}
end.
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venentië 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 <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
WindowSelector for the Mufasa Macro Library
}
unit windowselector;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
ctypes,
window, windowutil,
controls,
graphics,
forms,
{$IFNDEF MSWINDOWS}x, xlib
{$ELSE}
windows
{$ENDIF}
;
type
TMWindowSelector = class(TObject)
constructor Create(aWindow: TMWindow);
destructor Destroy; override;
{$IFDEF LINUX}
function Drag: x.TWindow;
{$ELSE}
function Drag: Hwnd;
{$ENDIF}
public
Window: TMWindow;
end;
implementation
constructor TMWindowSelector.Create(aWindow: TMWindow);
begin
inherited create;
Self.Window := aWindow;
end;
destructor TMWindowSelector.Destroy;
begin
inherited;
end;
{$IFDEF LINUX}
function TMWindowSelector.Drag: x.TWindow;
var
Tempwindow : x.TWindow;
root : x.TWindow;
subwindow : x.TWindow;
x_root, y_root : cint;
xmask : cuint;
x, y : cint;
Old_Handler : TXErrorHandler;
begin
Old_Handler := XSetErrorHandler(@MufasaXErrorHandler);
Result := 0;
repeat
XQueryPointer(Window.XDisplay, Window.DesktopWindow, @root,
@Tempwindow, @x_root, @y_root,
@x, @y, @xmask);
subwindow:= Tempwindow;
while subwindow <> 0 do
begin
Tempwindow := subwindow;
XQueryPointer(Window.XDisplay, Tempwindow, @root,
@subwindow, @x_root, @y_root,
@x, @y, @xmask);
end;
if Result <> Tempwindow then
begin
WriteLn('Changing Window to: ' + IntToStr(Tempwindow));
Result := Tempwindow;
end;
Sleep(16);
until (xmask and Button1Mask) = 0;
XSetErrorHandler(Old_handler);
end;
{$ELSE}
function TMWindowSelector.Drag: Hwnd;
var
TargetRect: TRect;
DC: HDC;
OldPen, Pen: hPen;
OldBrush : hBrush;
BrushHandle : THandle;
Cursor : TCursor;
TempHandle : Hwnd;
Handle : Hwnd;
begin;
Pen := CreatePen(PS_SOLID, GetSystemMetrics(SM_CXBORDER)*5, clred);
BrushHandle := GetStockObject(Null_Brush);
Cursor:= Screen.Cursor;
Screen.Cursor:= crCross;
TempHandle := GetDesktopWindow;
while GetAsyncKeyState(VK_LBUTTON) <> 0 do
begin;
Handle:= WindowFromPoint(Mouse.CursorPos);
if Handle <> TempHandle then
begin;
if TempHandle <> 0 then
begin;
Invalidaterect(temphandle, nil, true);
UpdateWindow(temphandle);
{$IFDEF MSWINDOWS}
RedrawWindow(TempHandle, nil, 0, RDW_Frame or RDW_Invalidate or RDW_Updatenow or RDW_Allchildren);
{$ENDIF}
end;
if Handle <> 0 then
begin;
GetWindowRect(Handle, TargetRect);
DC := Windows.GetWindowDC(Handle);
OldPen := SelectObject(DC, Pen);
OldBrush := SelectObject(DC, BrushHandle);
Rectangle(DC, 0, 0, TargetRect.Right - TargetRect.Left, TargetRect.Bottom - TargetRect.Top);
SelectObject(DC, OldBrush);
SelectObject(DC, OldPen);
ReleaseDC(Handle, DC);
end;
TempHandle := Handle;
end;
Sleep(64);
end;
Result := TempHandle;
Screen.Cursor:= cursor;
Invalidaterect(temphandle, nil, true);
UpdateWindow(temphandle);
RedrawWindow(TempHandle, nil, 0, RDW_Frame or RDW_Invalidate or RDW_Updatenow or RDW_Allchildren);
DeleteObject(Pen);
end;
{$ENDIF}
end.