moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-22 23:38:50 -05:00
Code Issues Releases Wiki Activity

GetDebugImage now ported to PS, thanks to Wizzups leet Bitmap.FromRawImage :D

Browse Source 
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@340 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2009-12-25 23:56:25 +00:00
parent 6e0136acfc
commit 49b18d677a
6 changed files with 297 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

246
Projects/SAMufasaGUI/debugimage.pas
View File

@ -1,124 +1,122 @@
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Image debug window for Mufasa Macro Library
}
unit debugimage;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls, bitmaps;
type
{ TDebugImgForm }
TDebugImgForm = class(TForm)
DrawImage: TImage;
procedure FormCreate(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ private declarations }
public
DispSize : TPoint;
ToDrawBmp: TMufasaBitmap;//The bitmap we should draw!
procedure BlackDebugImage;
procedure DrawBitmap;
procedure GetDebugImage(out bmp : TMufasaBitmap);
procedure ShowDebugImgForm; //Uses the global var for w/h
{ public declarations }
end;
var
DebugImgForm: TDebugImgForm;
implementation
uses
MufasaTypes, math,windowutil,graphtype, IntfGraphics,TestUnit,lclintf,colour_conv,InterfaceBase;
{ TDebugImgForm }
procedure TDebugImgForm.FormCreate(Sender: TObject);
begin
BlackDebugImage;
end;
procedure TDebugImgForm.FormHide(Sender: TObject);
begin
Form1.MenuItemDebugImage.Checked := False;
end;
procedure TDebugImgForm.FormResize(Sender: TObject);
begin
DrawImage.Picture.Graphic.Width := DrawImage.Width;
DrawImage.Picture.Graphic.Height := DrawImage.Height;
BlackDebugImage;
end;
procedure TDebugImgForm.BlackDebugImage;
begin
DrawImage.Canvas.Brush.Color:= clBlack;
DrawImage.Canvas.Pen.Color:= clBlack;
DrawImage.Canvas.Rectangle(0,0,DrawImage.Width,DrawImage.Height);
end;
procedure TDebugImgForm.DrawBitmap;
var
rawImage : TRawImage;
Bitmap : Graphics.TBitmap;
begin
if ToDrawBmp = nil then
raise Exception.Create('ERROR in TDebugImgForm.DrawBitmap: ToDrawBmp = nil');
ArrDataToRawImage(ToDrawBmp.FData,Point(ToDrawBmp.width,ToDrawBmp.height),RawImage);
Bitmap := Graphics.TBitmap.Create;
Bitmap.LoadFromRawImage(Rawimage,false);
DrawImage.Canvas.Draw(0,0,Bitmap);
Bitmap.Free;
end;
procedure TDebugImgForm.GetDebugImage(out bmp: TMufasaBitmap);
begin;
DrawImage.Picture.SaveToFile(MainDir + DS + 'stupidwayofdoingthis.bmp');
bmp := TMufasaBitmap.Create;
bmp.LoadFromFile(MainDir + DS + 'stupidwayofdoingthis.bmp');
DeleteFile(MainDir + DS + 'stupidwayofdoingthis.bmp');
end;
procedure TDebugImgForm.ShowDebugImgForm;
begin
Show;
if (DispSize.x <> Width) or (DispSize.y <> height) then
begin;
Width := DispSize.x;
Height := DispSize.y;
end;
end;
initialization
{$I debugimage.lrs}
end.
{
This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution,
for details about the copyright.
Image debug window for Mufasa Macro Library
}
unit debugimage;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls, bitmaps;
type
{ TDebugImgForm }
TDebugImgForm = class(TForm)
DrawImage: TImage;
procedure FormCreate(Sender: TObject);
procedure FormHide(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ private declarations }
public
DispSize : TPoint;
ToDrawBmp: TMufasaBitmap;//The bitmap we should draw!
GetDbgBmp : TMufasaBitmap;
procedure BlackDebugImage;
procedure DrawBitmap;
procedure GetDebugImage;
procedure ShowDebugImgForm; //Uses the global var for w/h
{ public declarations }
end;
var
DebugImgForm: TDebugImgForm;
implementation
uses
MufasaTypes, math,windowutil,graphtype, IntfGraphics,TestUnit,lclintf,colour_conv,InterfaceBase;
{ TDebugImgForm }
procedure TDebugImgForm.FormCreate(Sender: TObject);
begin
BlackDebugImage;
end;
procedure TDebugImgForm.FormHide(Sender: TObject);
begin
Form1.MenuItemDebugImage.Checked := False;
end;
procedure TDebugImgForm.FormResize(Sender: TObject);
begin
DrawImage.Picture.Graphic.Width := DrawImage.Width;
DrawImage.Picture.Graphic.Height := DrawImage.Height;
BlackDebugImage;
end;
procedure TDebugImgForm.BlackDebugImage;
begin
DrawImage.Canvas.Brush.Color:= clBlack;
DrawImage.Canvas.Pen.Color:= clBlack;
DrawImage.Canvas.Rectangle(0,0,DrawImage.Width,DrawImage.Height);
end;
procedure TDebugImgForm.DrawBitmap;
var
rawImage : TRawImage;
Bitmap : Graphics.TBitmap;
begin
if ToDrawBmp = nil then
raise Exception.Create('ERROR in TDebugImgForm.DrawBitmap: ToDrawBmp = nil');
ArrDataToRawImage(ToDrawBmp.FData,Point(ToDrawBmp.width,ToDrawBmp.height),RawImage);
Bitmap := Graphics.TBitmap.Create;
Bitmap.LoadFromRawImage(Rawimage,false);
DrawImage.Canvas.Draw(0,0,Bitmap);
Bitmap.Free;
end;
procedure TDebugImgForm.GetDebugImage;
begin;
GetDbgBmp.LoadFromRawImage(DrawImage.Picture.Bitmap.RawImage);
end;
procedure TDebugImgForm.ShowDebugImgForm;
begin
Show;
if (DispSize.x <> Width) or (DispSize.y <> height) then
begin;
Width := DispSize.x;
Height := DispSize.y;
end;
end;
initialization
{$I debugimage.lrs}
end.

321
Projects/SAMufasaGUI/framefunctionlist.pas
View File

@ -1,158 +1,163 @@
unit framefunctionlist;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, ComCtrls, StdCtrls, Controls;
type
{ TFunctionListFrame }
TFunctionListFrame = class(TFrame)
editSearchList: TEdit;
FunctionList: TTreeView;
procedure editSearchListChange(Sender: TObject);
procedure FunctionListMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FunctionListMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DockFormOnClose(Sender: TObject; var CloseAction: TCloseAction);
private
{ private declarations }
public
DraggingNode : TTreeNode;
ScriptNode : TTreeNode;
InCodeCompletion : boolean;
CompletionCaret : TPoint;
StartWordCompletion : TPoint;
CompletionLine : string;
CompletionStart : string;
function Find(Next : boolean) : boolean;
{ public declarations }
end;
implementation
uses
TestUnit, Graphics, simpleanalyzer;
{ TFunctionListFrame }
procedure TFunctionListFrame.editSearchListChange(Sender: TObject);
begin
Find(false);
end;
procedure TFunctionListFrame.DockFormOnClose(Sender: TObject; var CloseAction: TCloseAction);
begin
CloseAction := caHide;
Form1.MenuItemFunctionList.Checked := False;
end;
function TFunctionListFrame.Find(Next : boolean) : boolean;
var
Start,i,index,posi: Integer;
FoundFunction : boolean;
str : string;
Node : TTreeNode;
begin
if(editSearchList.Text = '')then
begin
editSearchList.Color := clWhite;
FunctionList.FullCollapse;
if InCodeCompletion then
begin;
Form1.CurrScript.SynEdit.Lines[CompletionCaret.y - 1] := CompletionStart;
Form1.CurrScript.SynEdit.LogicalCaretXY:= point(CompletionCaret.x,CompletionCaret.y);
Form1.CurrScript.SynEdit.SelEnd:= Form1.CurrScript.SynEdit.SelStart;
end;
exit;
end;
FoundFunction := False;
if FunctionList.Selected <> nil then
begin
Start := FunctionList.Selected.AbsoluteIndex;
if(next)then
inc(Start);
end else
Start := 0;
for i := start to start + FunctionList.Items.Count - 1 do
if(FunctionList.Items[i mod FunctionList.Items.Count].Level = 1)then
if(pos(lowercase(editSearchList.Text), lowercase(FunctionList.Items[i mod FunctionList.Items.Count].Text)) > 0)then
begin
FoundFunction := True;
index := i mod FunctionList.Items.Count;
break;
end;
Result := FoundFunction;
if Result then
begin;
Writeln(FunctionList.Items[Index].Text);
FunctionList.FullCollapse;
FunctionList.Items[Index].Selected := true;
FunctionList.Items[index].ExpandParents;
editSearchList.Color := clWhite;
if InCodeCompletion then
begin;
str := format(CompletionLine, [FunctionList.items[index].text]);
with Form1.CurrScript.SynEdit do
begin;
Lines[CompletionCaret.y - 1] := str;
LogicalCaretXY:= StartWordCompletion;
i := SelStart;
posi := pos(lowercase(editSearchList.text), lowercase(FunctionList.items[index].text));
SelStart := i + length(editSearchList.Text) + posi - 1;
SelEnd := i + Length(str);
end;
end;
end else
begin
editSearchList.Color := 6711039;
if InCodeCompletion then
Form1.CurrScript.SynEdit.Lines[CompletionCaret.y - 1] := CompletionStart;
end;
end;
procedure TFunctionListFrame.FunctionListMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
N: TTreeNode;
begin
N := Self.FunctionList.GetNodeAt(x, y);
if(N = nil)then
begin
Self.DragKind := dkDock;
Self.BeginDrag(false, 40);
exit;
end;
Self.DragKind := dkDrag;
if(Button = mbLeft) and (N.Level > 0)then
Self.BeginDrag(False, 10);
DraggingNode := N;
end;
procedure TFunctionListFrame.FunctionListMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
F: ^TCustomDockForm;
begin
if(Self.Parent is TCustomDockForm)then
begin
F := @Self.Parent; //can't typecast parent as a TCustomDockForm
F^.Caption := 'Function List';
F^.BorderStyle := bsSizeable;
F^.OnClose := @DockFormOnClose;
Form1.Splitter1.Hide;
end;
end;
initialization
{$I framefunctionlist.lrs}
end.
unit framefunctionlist;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, ComCtrls, StdCtrls, Controls;
type
{ TFunctionListFrame }
TFunctionListFrame = class(TFrame)
editSearchList: TEdit;
FunctionList: TTreeView;
procedure editSearchListChange(Sender: TObject);
procedure FunctionListMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FunctionListMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DockFormOnClose(Sender: TObject; var CloseAction: TCloseAction);
private
{ private declarations }
public
DraggingNode : TTreeNode;
ScriptNode : TTreeNode;
InCodeCompletion : boolean;
CompletionCaret : TPoint;
StartWordCompletion : TPoint;
CompletionLine : string;
CompletionStart : string;
function Find(Next : boolean) : boolean;
{ public declarations }
end;
implementation
uses
TestUnit, Graphics, simpleanalyzer;
{ TFunctionListFrame }
procedure TFunctionListFrame.editSearchListChange(Sender: TObject);
begin
Find(false);
end;
procedure TFunctionListFrame.DockFormOnClose(Sender: TObject; var CloseAction: TCloseAction);
begin
CloseAction := caHide;
Form1.MenuItemFunctionList.Checked := False;
end;
function TFunctionListFrame.Find(Next : boolean) : boolean;
var
Start,i,index,posi: Integer;
FoundFunction : boolean;
str : string;
Node : TTreeNode;
begin
if(editSearchList.Text = '')then
begin
editSearchList.Color := clWhite;
FunctionList.FullCollapse;
if InCodeCompletion then
begin;
Form1.CurrScript.SynEdit.Lines[CompletionCaret.y - 1] := CompletionStart;
Form1.CurrScript.SynEdit.LogicalCaretXY:= point(CompletionCaret.x,CompletionCaret.y);
Form1.CurrScript.SynEdit.SelEnd:= Form1.CurrScript.SynEdit.SelStart;
end;
exit;
end;
FoundFunction := False;
if FunctionList.Selected <> nil then
begin
Start := FunctionList.Selected.AbsoluteIndex;
if(next)then
inc(Start);
end else
Start := 0;
for i := start to start + FunctionList.Items.Count - 1 do
if(FunctionList.Items[i mod FunctionList.Items.Count].Level = 1)then
if(pos(lowercase(editSearchList.Text), lowercase(FunctionList.Items[i mod FunctionList.Items.Count].Text)) > 0)then
begin
FoundFunction := True;
index := i mod FunctionList.Items.Count;
break;
end;
Result := FoundFunction;
if Result then
begin;
Writeln(FunctionList.Items[Index].Text);
FunctionList.FullCollapse;
FunctionList.Items[Index].Selected := true;
FunctionList.Items[index].ExpandParents;
editSearchList.Color := clWhite;
if InCodeCompletion then
begin;
str := format(CompletionLine, [FunctionList.items[index].text]);
with Form1.CurrScript.SynEdit do
begin;
Lines[CompletionCaret.y - 1] := str;
LogicalCaretXY:= StartWordCompletion;
i := SelStart;
posi := pos(lowercase(editSearchList.text), lowercase(FunctionList.items[index].text));
SelStart := i + length(editSearchList.Text) + posi - 1;
SelEnd := i + Length(str);
end;
end;
end else
begin
editSearchList.Color := 6711039;
if InCodeCompletion then
Form1.CurrScript.SynEdit.Lines[CompletionCaret.y - 1] := CompletionStart;
end;
end;
procedure TFunctionListFrame.FunctionListMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
N: TTreeNode;
begin
if InCodeCompletion then
begin;
Writeln('Not yet implemented');
exit;
end;
N := Self.FunctionList.GetNodeAt(x, y);
if(N = nil)then
begin
Self.DragKind := dkDock;
Self.BeginDrag(false, 40);
exit;
end;
Self.DragKind := dkDrag;
if(Button = mbLeft) and (N.Level > 0)then
Self.BeginDrag(False, 10);
DraggingNode := N;
end;
procedure TFunctionListFrame.FunctionListMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
F: ^TCustomDockForm;
begin
if(Self.Parent is TCustomDockForm)then
begin
F := @Self.Parent; //can't typecast parent as a TCustomDockForm
F^.Caption := 'Function List';
F^.BorderStyle := bsSizeable;
F^.OnClose := @DockFormOnClose;
Form1.Splitter1.Hide;
end;
end;
initialization
{$I framefunctionlist.lrs}
end.

2
Projects/SAMufasaGUI/testunit.pas
View File

@ -456,6 +456,8 @@ begin
DbgImgInfo.ShowForm := @DebugImgForm.ShowDebugImgForm;
DbgImgInfo.ToDrawBitmap:= @DebugImgForm.ToDrawBmp;
DbgImgInfo.DrawBitmap:= @DebugImgForm.DrawBitmap;
DbgImgInfo.GetDebugBitmap:= @DebugImgForm.GetDbgBmp;
DbgImgInfo.GetBitmap:= @DebugImgForm.GetDebugImage;
ScriptThread.SetDbgImg(DbgImgInfo);
ScriptThread.OnError:=@ErrorThread;

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

@ -110,6 +110,13 @@ begin;
CurrThread.Synchronize(CurrThread.DebugImg.DrawBitmap);
end;
function GetDebugBitmap : integer;
begin;
result := CurrThread.Client.MBitmaps.CreateBMP(0,0);
CurrThread.DebugImg.GetDebugBitmap^ := CurrThread.Client.MBitmaps.Bmp[result];
CurrThread.Synchronize(CurrThread.DebugImg.GetBitmap);
end;
procedure TerminateScript;
begin;
CurrThread.PSScript.Stop;

1
Units/MMLAddon/PSInc/psexportedmethods.inc
View File

@ -91,6 +91,7 @@ AddFunction(@HakunaMatata,'procedure HakunaMatata;');
AddFunction(@TerminateScript,'procedure TerminateScript;');
AddFunction(@DisplayDebugImgWindow,'procedure DisplayDebugImgWindow(w,h : integer);');
AddFunction(@DrawBitmapDebugImg,'procedure DrawBitmapDebugImg(bmp : integer);');
AddFunction(@GetDebugBitmap,'function GetDebugBitmap : integer;');
AddFunction(@Random,'function Random(Int : integer): integer;');

2
Units/MMLAddon/mmlpsthread.pas
View File

@ -47,6 +47,8 @@ type
ShowForm : procedure of object;
ToDrawBitmap : ^TMufasaBitmap;
DrawBitmap : procedure of object;
GetDebugBitmap : ^TMufasaBitmap;
GetBitmap : procedure of object;
end;
PSyncInfo = ^TSyncInfo;
TErrorType = (errRuntime,errCompile);