initial import

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@2280 8e941d3f-bd1b-0410-a28a-d453659cc2b4

applications/draw_test/filecache.pas

@@ -0,0 +1,89 @@
+unit FileCache;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Graphics;
+
+type
+  TFileCacheItem = record
+    start: longint;
+    length: longint;
+    number: integer;
+  end;
+
+  { TFileCache }
+
+  TFileCache = class
+  private
+    cache_stream: TFileStream;
+    FCount: integer;
+    FCacheList: array of TFileCacheItem;
+  public
+    constructor Create(AFileName: string);
+    destructor Destroy; override;
+
+    property Count: integer read FCount;
+    function GetData(Number: integer; var Bitmap: TPortableNetworkGraphic): boolean;
+    procedure Add(Number: integer; Bitmap: TPortableNetworkGraphic);
+    procedure Clear;
+  end;
+
+implementation
+
+{ TFileCache }
+
+constructor TFileCache.Create(AFileName: string);
+begin
+  FCount := 0;
+  cache_stream := TFileStream.Create(AFileName, fmCreate);
+end;
+
+destructor TFileCache.Destroy;
+begin
+  Clear;
+  cache_stream.Free;
+
+  inherited Destroy;
+end;
+
+function TFileCache.GetData(Number: integer; var Bitmap: TPortableNetworkGraphic): boolean;
+var
+  i: integer;
+begin
+  for i := 0 to FCount - 1 do
+    if FCacheList[i].number = Number then
+    begin
+      cache_stream.Position := FCacheList[i].start;
+      Bitmap.LoadFromStream(cache_stream, FCacheList[i].length);
+    end;
+end;
+
+procedure TFileCache.Add(Number: integer; Bitmap: TPortableNetworkGraphic);
+begin
+  if Bitmap = nil then
+    exit;
+
+  Inc(FCount);
+  SetLength(FCacheList, FCount);
+
+  FCacheList[FCount - 1].number := Number;
+
+  //move to the end of the stream
+  cache_stream.Position := cache_stream.Size;
+
+  FCacheList[FCount - 1].start := cache_stream.Position;
+  Bitmap.SaveToStream(cache_stream);
+  FCacheList[FCount - 1].length := cache_stream.Position - FCacheList[FCount - 1].start;
+end;
+
+procedure TFileCache.Clear;
+begin
+  FCount := 0;
+  SetLength(FCacheList, FCount);
+end;
+
+end.
+

applications/draw_test/mydrawingcontrol.pas

@@ -0,0 +1,39 @@
+unit MyDrawingControl;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Controls, Graphics, LCLType;
+
+type
+
+  { TMyDrawingControl }
+
+  TMyDrawingControl = class(TCustomControl)
+  private
+    FBitmap: TPortableNetworkGraphic;
+  public
+    property Bitmap: TPortableNetworkGraphic read FBitmap write FBitmap;
+    procedure EraseBackground(DC: HDC); override;
+    procedure Paint; override;
+  end;
+
+implementation
+
+procedure TMyDrawingControl.EraseBackground(DC: HDC);
+begin
+  //Uncomment this to enable default background erasing
+  //inherited EraseBackground(DC);
+end;
+
+procedure TMyDrawingControl.Paint;
+begin
+  if Assigned(Bitmap) then
+    Canvas.Draw(0, 0, Bitmap);
+
+  inherited Paint;
+end;
+
+end.

applications/draw_test/project1.lpi

@@ -0,0 +1,104 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <PathDelim Value="\"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="project1"/>
+      <ResourceType Value="res"/>
+      <UseXPManifest Value="True"/>
+      <Icon Value="0"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="4">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="project1"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <IsPartOfProject Value="True"/>
+        <ComponentName Value="Form1"/>
+        <ResourceBaseClass Value="Form"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="filecache.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="FileCache"/>
+      </Unit2>
+      <Unit3>
+        <Filename Value="mydrawingcontrol.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="MyDrawingControl"/>
+      </Unit3>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <PathDelim Value="\"/>
+    <Target>
+      <Filename Value="project1"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="..\.."/>
+      <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+    <Linking>
+      <Debugging>
+        <UseHeaptrc Value="True"/>
+      </Debugging>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerMessages>
+        <MsgFileName Value=""/>
+      </CompilerMessages>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

applications/draw_test/project1.lpr

@@ -0,0 +1,21 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, { this includes the LCL widgetset}
+ Forms, Unit1, MyDrawingControl, FileCache
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource := True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+

applications/draw_test/unit1.lfm

@@ -0,0 +1,121 @@
+object Form1: TForm1
+  Left = 342
+  Height = 555
+  Top = 135
+  Width = 569
+  Caption = 'Form1'
+  ClientHeight = 535
+  ClientWidth = 569
+  Menu = MainMenu1
+  OnCreate = FormCreate
+  OnDestroy = FormDestroy
+  LCLVersion = '0.9.31'
+  object PageControl1: TPageControl
+    Left = 0
+    Height = 535
+    Top = 0
+    Width = 362
+    ActivePage = GraphicControlTabSheet
+    Align = alClient
+    TabIndex = 2
+    TabOrder = 0
+    object PaintBoxTabSheet: TTabSheet
+      Caption = 'TPaintBox'
+      ClientHeight = 509
+      ClientWidth = 354
+      object PaintBox1: TPaintBox
+        Left = 0
+        Height = 509
+        Top = 0
+        Width = 354
+        Align = alClient
+        OnPaint = PaintBox1Paint
+      end
+    end
+    object ImageTabSheet: TTabSheet
+      Caption = 'TImage'
+      ClientHeight = 509
+      ClientWidth = 354
+      object Image1: TImage
+        Left = 0
+        Height = 509
+        Top = 0
+        Width = 354
+        Align = alClient
+      end
+    end
+    object GraphicControlTabSheet: TTabSheet
+      Caption = 'TGraphicControl'
+    end
+  end
+  object ListView1: TListView
+    Left = 367
+    Height = 535
+    Top = 0
+    Width = 202
+    Align = alRight
+    Columns = <    
+      item
+        Caption = 'Method'
+        Width = 100
+      end    
+      item
+        AutoSize = True
+        Caption = 'FPS'
+        Width = 98
+      end>
+    TabOrder = 1
+    ViewStyle = vsReport
+  end
+  object Splitter1: TSplitter
+    Left = 362
+    Height = 535
+    Top = 0
+    Width = 5
+    Align = alRight
+    ResizeAnchor = akRight
+  end
+  object MainMenu1: TMainMenu
+    left = 447
+    top = 88
+    object MenuItem1: TMenuItem
+      Caption = 'Cache'
+      object MenuItem9: TMenuItem
+        Caption = 'Use cache'
+        object mnuHD50: TMenuItem
+          Caption = '50% HD (940x540)'
+          Checked = True
+          RadioItem = True
+          OnClick = mnuHD50Click
+        end
+        object mnuHD: TMenuItem
+          Caption = 'HD (1920x1050)'
+          RadioItem = True
+          OnClick = mnuHDClick
+        end
+      end
+    end
+    object MenuItem2: TMenuItem
+      Caption = 'Run tests'
+      object mnuTPaintBox: TMenuItem
+        Caption = 'TPaintbox'
+        OnClick = mnuTPaintBoxClick
+      end
+      object mnuTImage: TMenuItem
+        Caption = 'TImage'
+        OnClick = mnuTImageClick
+      end
+      object mnuTGraphicControl: TMenuItem
+        Caption = 'TGraphicControl'
+        OnClick = mnuTGraphicControlClick
+      end
+      object MenuItem7: TMenuItem
+        Caption = '-'
+      end
+      object MenuItem5: TMenuItem
+        Caption = 'Run all'
+        OnClick = MenuItem5Click
+      end
+    end
+  end
+end

applications/draw_test/unit1.pas

@@ -0,0 +1,235 @@
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
+  ExtCtrls, ComCtrls, Menus, FileCache, MyDrawingControl;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    Image1: TImage;
+    ListView1: TListView;
+    MainMenu1: TMainMenu;
+    MenuItem1: TMenuItem;
+    mnuHD50: TMenuItem;
+    mnuHD: TMenuItem;
+    MenuItem2: TMenuItem;
+    mnuTPaintBox: TMenuItem;
+    mnuTImage: TMenuItem;
+    MenuItem5: TMenuItem;
+    mnuTGraphicControl: TMenuItem;
+    MenuItem7: TMenuItem;
+    MenuItem9: TMenuItem;
+    PageControl1: TPageControl;
+    PaintBox1: TPaintBox;
+    ImageTabSheet: TTabSheet;
+    PaintBoxTabSheet: TTabSheet;
+    Splitter1: TSplitter;
+    GraphicControlTabSheet: TTabSheet;
+    procedure FormCreate(Sender: TObject);
+    procedure FormDestroy(Sender: TObject);
+    procedure MenuItem5Click(Sender: TObject);
+    procedure mnuHD50Click(Sender: TObject);
+    procedure mnuHDClick(Sender: TObject);
+    procedure mnuTGraphicControlClick(Sender: TObject);
+    procedure mnuTImageClick(Sender: TObject);
+    procedure mnuTPaintBoxClick(Sender: TObject);
+    procedure PaintBox1Paint(Sender: TObject);
+  private
+    { private declarations }
+    FileCache50: TFileCache;
+    FileCache100: TFileCache;
+
+    img: TMyDrawingControl;
+    procedure AddTestToListBox(AName: string; FPS: double);
+  public
+    { public declarations }
+  end;
+
+var
+  Form1: TForm1;
+  png: TPortableNetworkGraphic;
+
+implementation
+
+{$R *.lfm}
+
+uses
+  GraphType;
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+var
+  i: integer;
+begin
+  FileCache50 := TFileCache.Create('.\images50.cache');
+  FileCache100 := TFileCache.Create('.\images100.cache');
+
+  png := TPortableNetworkGraphic.Create;
+
+  //load all images to the caches
+  for i := 1 to 23 do
+  begin
+    png.LoadFromFile(Format('.\images\%.4d.png', [i]));
+    FileCache100.Add(i, png);
+    png.LoadFromFile(Format('.\images_50\%.4d.png', [i]));
+    FileCache50.Add(i, png);
+  end;
+
+  //PaintBoxTabSheet.DoubleBuffered := True;
+  //ImageTabSheet.DoubleBuffered := True;
+  //GraphicControlTabSheet.DoubleBuffered := True;
+
+  img := TMyDrawingControl.Create(nil);
+  img.Parent := GraphicControlTabSheet;
+  img.Align := alClient;
+end;
+
+procedure TForm1.FormDestroy(Sender: TObject);
+begin
+  FileCache50.Free;
+  FileCache100.Free;
+
+  png.Free;
+  img.Free;
+end;
+
+procedure TForm1.MenuItem5Click(Sender: TObject);
+begin
+  mnuTPaintBoxClick(nil);
+  mnuTImageClick(nil);
+  mnuTGraphicControlClick(nil);
+end;
+
+procedure TForm1.mnuHD50Click(Sender: TObject);
+begin
+  mnuHD50.Checked := True;
+end;
+
+procedure TForm1.mnuHDClick(Sender: TObject);
+begin
+  mnuHD.Checked := True;
+end;
+
+procedure TForm1.mnuTGraphicControlClick(Sender: TObject);
+var
+  s: TDateTime;
+  i: integer;
+  j: integer;
+  f: boolean;
+begin
+  PageControl1.ActivePage := GraphicControlTabSheet;
+
+  s := Now;
+  for j := 1 to 10 do
+    for i := 1 to 23 do
+    begin
+      if mnuHD50.Checked then
+        f := FileCache50.GetData(i, png)
+      else
+        f := FileCache100.GetData(i, png);
+
+      if f then
+      begin
+        img.Bitmap := png;
+        img.Invalidate;
+        Application.ProcessMessages;
+      end;
+    end;
+
+  AddTestToListBox('TGraphicControl', 230 / ((Now - s) * 24 * 3600));
+end;
+
+procedure TForm1.mnuTImageClick(Sender: TObject);
+var
+  s: TDateTime;
+  i: integer;
+  j: integer;
+  f: boolean;
+begin
+  PageControl1.ActivePage := ImageTabSheet;
+
+  s := Now;
+  for j := 1 to 10 do
+    for i := 1 to 23 do
+    begin
+      if mnuHD50.Checked then
+        f := FileCache50.GetData(i, png)
+      else
+        f := FileCache100.GetData(i, png);
+
+      if f then
+      begin
+        Image1.Picture.Bitmap.LoadFromRawImage(png.RawImage, False);
+        Application.ProcessMessages;
+      end;
+    end;
+
+  AddTestToListBox('TImage', 230 / ((Now - s) * 24 * 3600));
+end;
+
+procedure TForm1.mnuTPaintBoxClick(Sender: TObject);
+var
+  s: TDateTime;
+  i: integer;
+  j: integer;
+  f: Boolean;
+begin
+  PageControl1.ActivePage := PaintBoxTabSheet;
+
+  s := Now;
+  for j := 1 to 10 do
+    for i := 1 to 23 do
+    begin
+      if mnuHD50.Checked then
+        f := FileCache50.GetData(i, png)
+      else
+        f := FileCache100.GetData(i, png);
+
+      if f then
+      begin
+        PaintBox1.Invalidate;
+        Application.ProcessMessages;
+      end;
+    end;
+
+  AddTestToListBox('TPaintBox', 230 / ((Now - s) * 24 * 3600));
+end;
+
+procedure TForm1.PaintBox1Paint(Sender: TObject);
+begin
+  PaintBox1.Canvas.Draw(0, 0, png);
+end;
+
+procedure TForm1.AddTestToListBox(AName: string; FPS: double);
+var
+  i: integer;
+  found: boolean = False;
+begin
+  //first check if test is already added earlier
+  for i := 0 to ListView1.Items.Count - 1 do
+  begin
+    if ListView1.Items[i].Caption = AName then
+    begin
+      found := True;
+      ListView1.Items[i].SubItems.Clear;
+      ListView1.Items[i].SubItems.Add(FloatToStr(FPS));
+    end;
+  end;
+
+  if not found then
+    with ListView1.Items.Add do
+    begin
+      Caption := AName;
+      SubItems.Add(FloatToStr(FPS));
+    end;
+end;
+
+end.