Added DebugImageForm, see debugimageform.mufa for example.

git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@251 3f818213-9676-44b0-a9b4-5e4c4e03d09d

Projects/SAMufasaGUI/debugimage.lfm

@@ -0,0 +1,21 @@
+object DebugImgForm: TDebugImgForm
+  Left = 502
+  Height = 300
+  Top = 289
+  Width = 400
+  BorderIcons = [biSystemMenu, biMinimize]
+  BorderStyle = bsToolWindow
+  Caption = 'DebugImgForm'
+  ClientHeight = 300
+  ClientWidth = 400
+  OnCreate = FormCreate
+  OnResize = FormResize
+  LCLVersion = '0.9.29'
+  object DrawImage: TImage
+    Left = 0
+    Height = 300
+    Top = 0
+    Width = 400
+    Align = alClient
+  end
+end

Projects/SAMufasaGUI/debugimage.lrs

@@ -0,0 +1,11 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TDebugImgForm','FORMDATA',[
+  'TPF0'#13'TDebugImgForm'#12'DebugImgForm'#4'Left'#3#246#1#6'Height'#3','#1#3
+  +'Top'#3'!'#1#5'Width'#3#144#1#11'BorderIcons'#11#12'biSystemMenu'#10'biMinim'
+  +'ize'#0#11'BorderStyle'#7#12'bsToolWindow'#7'Caption'#6#12'DebugImgForm'#12
+  +'ClientHeight'#3','#1#11'ClientWidth'#3#144#1#8'OnCreate'#7#10'FormCreate'#8
+  +'OnResize'#7#10'FormResize'#10'LCLVersion'#6#6'0.9.29'#0#6'TImage'#9'DrawIma'
+  +'ge'#4'Left'#2#0#6'Height'#3','#1#3'Top'#2#0#5'Width'#3#144#1#5'Align'#7#8'a'
+  +'lClient'#0#0#0
+]);

Projects/SAMufasaGUI/debugimage.pas

@@ -0,0 +1,118 @@
+{
+	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 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.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.
+

Projects/SAMufasaGUI/project1.lpr

@@ -30,7 +30,7 @@ uses
   cthreads, cmem,
   {$ENDIF}{$ENDIF}
   Interfaces, // this includes the LCL widgetset
-  Forms, testunit,colourhistory, About;
+  Forms, testunit,colourhistory, About, internets, debugimage;
 
 {$IFDEF WINDOWS}{$R project1.rc}{$ENDIF}
 
@@ -41,6 +41,7 @@ begin
   Application.CreateForm(TForm1, Form1);
   Application.CreateForm(TColourHistoryForm, ColourHistoryForm);
   Application.CreateForm(TAboutForm, AboutForm);
+  Application.CreateForm(TDebugImgForm, DebugImgForm);
   Application.Run;
 end.
 

Projects/SAMufasaGUI/testunit.lfm

@@ -5,7 +5,7 @@ object Form1: TForm1
   Width = 731
   ActiveControl = ScriptPanel
   Caption = 'THA FUKING MUFASA'
-  ClientHeight = 532
+  ClientHeight = 537
   ClientWidth = 731
   KeyPreview = True
   Menu = MainMenu1
@@ -166,8 +166,8 @@ object Form1: TForm1
   end
   object StatusBar: TStatusBar
     Left = 0
-    Height = 21
+    Height = 23
-    Top = 511
+    Top = 514
     Width = 731
     Panels = <    
       item
@@ -185,7 +185,7 @@ object Form1: TForm1
   object PanelMemo: TPanel
     Left = 0
     Height = 154
-    Top = 357
+    Top = 360
     Width = 731
     Align = alBottom
     ClientHeight = 154
@@ -205,25 +205,25 @@ object Form1: TForm1
     Cursor = crVSplit
     Left = 0
     Height = 5
-    Top = 352
+    Top = 355
     Width = 731
     Align = alBottom
     ResizeAnchor = akBottom
   end
   object ScriptPanel: TPanel
     Left = 0
-    Height = 328
+    Height = 331
     Top = 24
     Width = 731
     Align = alClient
     BevelOuter = bvNone
     Caption = 'ScriptPanel'
-    ClientHeight = 328
+    ClientHeight = 331
     ClientWidth = 731
     TabOrder = 4
     object PageControl1: TPageControl
       Left = 0
-      Height = 293
+      Height = 296
       Top = 0
       Width = 731
       Align = alClient
@@ -240,7 +240,7 @@ object Form1: TForm1
     object SearchPanel: TPanel
       Left = 0
       Height = 35
-      Top = 293
+      Top = 296
       Width = 731
       Align = alBottom
       BevelOuter = bvSpace
@@ -250,7 +250,7 @@ object Form1: TForm1
       Visible = False
       object LabeledEditSearch: TLabeledEdit
         Left = 104
-        Height = 27
+        Height = 21
         Top = 6
         Width = 174
         AutoSelect = False
@@ -259,10 +259,10 @@ object Form1: TForm1
         EditLabel.AnchorSideTop.Side = asrCenter
         EditLabel.AnchorSideRight.Control = LabeledEditSearch
         EditLabel.AnchorSideBottom.Control = LabeledEditSearch
-        EditLabel.Left = 67
+        EditLabel.Left = 73
-        EditLabel.Height = 18
+        EditLabel.Height = 14
-        EditLabel.Top = 10
+        EditLabel.Top = 9
-        EditLabel.Width = 34
+        EditLabel.Width = 28
         EditLabel.Caption = 'Find: '
         EditLabel.ParentColor = False
         LabelPosition = lpLeft
@@ -361,9 +361,9 @@ object Form1: TForm1
       end
       object CheckBoxMatchCase: TCheckBox
         Left = 320
-        Height = 22
+        Height = 17
         Top = 6
-        Width = 97
+        Width = 72
         Caption = 'Match case'
         OnClick = CheckBoxMatchCaseClick
         TabOrder = 1
@@ -1113,9 +1113,13 @@ object Form1: TForm1
     object MenuView: TMenuItem
       Caption = '&View'
       object MenuItemColourHistory: TMenuItem
-        Caption = '&View Colour History'
+        Caption = 'View &Colour History'
         OnClick = MenuItemColourHistoryClick
       end
+      object MenuItemDebugImage: TMenuItem
+        Caption = 'View &Debug Image'
+        OnClick = MenuItemDebugImageClick
+      end
     end
     object MenuHelp: TMenuItem
       Caption = '&Help'

Projects/SAMufasaGUI/testunit.pas

@@ -89,6 +89,7 @@ type
     MenuFile: TMenuItem;
     MenuEdit: TMenuItem;
     MenuHelp: TMenuItem;
+    MenuItemDebugImage: TMenuItem;
     MenuItemAbout: TMenuItem;
     MenuItemMainExit: TMenuItem;
     MenuItemDivider6: TMenuItem;
@@ -219,6 +220,7 @@ type
     procedure MenuEditClick(Sender: TObject);
     procedure MenuItemAboutClick(Sender: TObject);
     procedure MenuItemCloseTabsClick(Sender: TObject);
+    procedure MenuItemDebugImageClick(Sender: TObject);
     procedure MenuItemShowClick(Sender: TObject);
     procedure MenuItemTabCloseClick(Sender: TObject);
     procedure MenuItemTabCloseOthersClick(Sender: TObject);
@@ -294,8 +296,10 @@ var
 implementation
 uses
    lclintf,plugins,
-   syncobjs,
+   syncobjs, // for the critical sections
-   colourhistory; // for the critical sections
+   debugimage,
+   bitmaps,
+   colourhistory;
 
 //{$ifdef mswindows}
 
@@ -354,6 +358,8 @@ end;
 //{$ENDIF}
 
 procedure TForm1.RunScript;
+var
+  DbgImgInfo : TDbgImgInfo;
 begin
   with CurrScript do
   begin
@@ -375,7 +381,11 @@ begin
     ScriptThread.SetDebug(@formWriteln);
     {$ENDIF}
     ScriptThread.SetPSScript(CurrScript.SynEdit.Lines.Text);
-//    ScriptThread.SetDebug(Self.Memo1);
+    DbgImgInfo.DispSize := @DebugImgForm.DispSize;
+    DbgImgInfo.ShowForm := @DebugImgForm.ShowDebugImgForm;
+    DbgImgInfo.ToDrawBitmap:= @DebugImgForm.ToDrawBmp;
+    DbgImgInfo.DrawBitmap:= @DebugImgForm.DrawBitmap;
+    ScriptThread.SetDbgImg(DbgImgInfo);
 
     ScriptThread.OnError:=@ErrorThread;
     if ScriptFile <> '' then
@@ -933,6 +943,7 @@ end;
 
 procedure TForm1.FormCreate(Sender: TObject);
 begin
+  Randomize;
   //Show close buttons @ tabs
   PageControl1.Options:=PageControl1.Options+[nboShowCloseButtons];
   PageControl1.OnCloseTabClicked:=ActionCloseTab.OnExecute;
@@ -1035,6 +1046,11 @@ begin
   Self.CloseTabs;
 end;
 
+procedure TForm1.MenuItemDebugImageClick(Sender: TObject);
+begin
+  DebugImgForm.Show;
+end;
+
 procedure TForm1.MenuItemShowClick(Sender: TObject);
 begin
   Self.Show;

Tests/PS/debugimageform.mufa

@@ -0,0 +1,18 @@
+program new;
+var
+  Bmp,x,y : integer;
+begin
+  Bmp := createbItmap(100,100);
+  CopyClientToBitmap(Bmp,0,0,99,99);
+  for x := 0 to 49 do
+  begin;
+    for y := 0 to 49 do
+    begin;
+      fastsetpixel(bmp,x,y,random(clwhite));
+      fastsetpixel(bmp,y,x,random(clwhite));
+    end;
+    x := x + 5;
+  end;
+  DisplayDebugImgWindow(100,100);
+  DrawBitmapDebugImg(bmp);
+end.

Units/MMLAddon/PSInc/Wrappers/other.inc

@@ -69,6 +69,18 @@ begin;
   Result := Round(Sqrt(Sqr(x2-x1) + Sqr(y2-y1)));
 end;
 
+procedure DisplayDebugImgWindow(w,h : integer);
+begin;
+  CurrThread.DebugImg.DispSize^ := Classes.Point(w,h);
+  CurrThread.Synchronize( CurrThread.DebugImg.ShowForm);
+end;
+
+procedure DrawBitmapDebugImg(bmp : integer);
+begin;
+  CurrThread.DebugImg.ToDrawBitmap^ := CurrThread.Client.MBitmaps.Bmp[bmp];
+  CurrThread.Synchronize(CurrThread.DebugImg.DrawBitmap);
+end;
+
 procedure TerminateScript;
 begin;
   CurrThread.PSScript.Stop;

Units/MMLAddon/PSInc/pscompile.inc

@@ -93,7 +93,9 @@ Sender.AddFunction(@CreateForm,'function CreateForm : TForm;');
 Sender.AddFunction(@CreateButton,'function CreateButton(Owner : TComponent) : TButton');
 Sender.AddFunction(@HakunaMatata,'procedure HakunaMatata;');
 Sender.AddFunction(@TerminateScript,'procedure TerminateScript;');
-
+Sender.AddFunction(@DisplayDebugImgWindow,'procedure DisplayDebugImgWindow(w,h : integer);');
+Sender.AddFunction(@DrawBitmapDebugImg,'procedure DrawBitmapDebugImg(bmp : integer);');
+Sender.AddFunction(@Random,'function Random(Int : integer): integer;');
 {web}
 Sender.AddFunction(@OpenWebPage,'procedure OpenWebPage(url : string);');
 

Units/MMLAddon/internets.pas

@@ -0,0 +1,13 @@
+unit internets;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils; 
+
+implementation
+
+end.
+

Units/MMLAddon/mmlpsthread.pas

@@ -28,7 +28,7 @@ unit mmlpsthread;
 interface
 
 uses
-  Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor,MufasaTypes, web;
+  Classes, SysUtils, client, uPSComponent,uPSCompiler,uPSRuntime,stdCtrls, uPSPreProcessor,MufasaTypes, web,bitmaps;
 
 type
     { TMMLPSThread }
@@ -42,6 +42,12 @@ type
     end;
 
     TWritelnProc = procedure(s: string);
+    TDbgImgInfo = record
+      DispSize : ^TPoint;
+      ShowForm : procedure of object;
+      ToDrawBitmap : ^TMufasaBitmap;
+      DrawBitmap : procedure of object;
+    end;
 
     PSyncInfo = ^TSyncInfo;
     TErrorType = (errRuntime,errCompile);
@@ -58,6 +64,7 @@ type
     protected
       //DebugTo : TMemo;
       DebugTo: TWritelnProc;
+      DebugImg : TDbgImgInfo;
       PluginsToload : Array of integer;
       FOnError  : TOnError;
       procedure OnCompile(Sender: TPSScript);
@@ -75,6 +82,7 @@ type
       property OnError : TOnError read FOnError write FOnError;
       procedure SetPSScript(Script : string);
       procedure SetDebug( writelnProc : TWritelnProc );
+      procedure SetDbgImg( DebugImageInfo : TDbgImgInfo);
       procedure SetPaths(ScriptP,AppP : string);
       constructor Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo);
       destructor Destroy; override;
@@ -360,6 +368,11 @@ begin
   DebugTo := writelnProc;
 end;
 
+procedure TMMLPSThread.SetDbgImg(DebugImageInfo: TDbgImgInfo);
+begin
+  DebugImg := DebugImageInfo;
+end;
+
 procedure TMMLPSThread.SetPaths(ScriptP, AppP: string);
 begin
   AppPath:= AppP;