Forum > LCL

Drawing, shapes? Canvas? Disk Defrag map style

(1/4) > >>

Tony Stone:
So I have an idea to draw a 'progress map' one of my programs.  Think of the old disc derangementer disc representation squares...  See my attached screen shots.

So below is my code so far.  Works pretty good EXCEPT... it is VERY slow at creating the squares and distributing them in the scrollbox.  I may end up wanting over 100k squares...  It takes about a minute to make 400 squares on my i7 3.xghz

What could I do to make thousands and thousands of squares substantially faster?  I also need to have a hint for each square and need to change color properties as i go....  any other comments about my code would be appreciated as the truth is, i barely know what I am doing.  :D


--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---unit Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls,  Spin, StdCtrls; type   { TForm1 }   TForm1 = class(TForm)    btnCreate: TButton;    btnDestroy: TButton;    btnRedistribute: TButton;    chkDoRandom: TCheckBox;    ScrollBox1: TScrollBox;    SpinEdit1: TSpinEdit;    tmrRndDarken: TTimer;    tmrReRnd: TTimer;    procedure btnCreateClick(Sender: TObject);    procedure btnDestroyClick(Sender: TObject);    procedure btnRedistributeClick(Sender: TObject);    procedure chkDoRandomChange(Sender: TObject);    procedure Distribute(Sender: TObject);    procedure FormResize(Sender: TObject);    procedure tmrRndDarkenTimer(Sender: TObject);    procedure tmrReRndTimer(Sender: TObject);   private   public    totalsquares: Int64;    rightmost: Integer;     sqCompleteness: array of Integer;    sqReady2Dis: Boolean;    end; aSquare = record        hits: Integer;        RiClr: Integer;        GiClr: Integer;        BiClr: Integer;        square: TShape;end; var  Form1: TForm1;  aSquareArray: Array of aSquare;implementation {$R *.lfm} { TForm1 }   procedure TForm1.btnCreateClick(Sender: TObject);var  i: Int64; begin  totalsquares:=SpinEdit1.Value;  Randomize;  for i:= 0 to totalsquares-1 do begin    SetLength(aSquareArray,i+1);    aSquareArray[i].square:=TShape.Create(ScrollBox1);    aSquareArray[i].square.Parent:=ScrollBox1;    //aSquareArray[i].square.Shape:=stRoundRect;    aSquareArray[i].square.Brush.Color:=clWhite;    aSquareArray[i].RiClr:=0;    aSquareArray[i].GiClr:=0;    aSquareArray[i].BiClr:=0;    aSquareArray[i].square.hint:='Square: #' + IntToStr(i+1);  end;   btnCreate.Enabled:=False;  sqReady2Dis:=True;  Distribute(Self);end; procedure TForm1.btnDestroyClick(Sender: TObject);var  i: Integer;begin  tmrRndDarken.Enabled:=False;  chkDoRandom.Checked:=False;   for i:= 0 to totalsquares-1 do begin    aSquareArray[i].square.Destroy;  end;   SetLength(aSquareArray,0);  btnCreate.Enabled:=true;  sqReady2Dis:=False;end; procedure TForm1.btnRedistributeClick(Sender: TObject);begin  Distribute(self);end;  procedure TForm1.chkDoRandomChange(Sender: TObject);begin  tmrRndDarken.Enabled:=chkDoRandom.Checked;end;   procedure TForm1.Distribute(Sender: TObject);var  i: Integer;  lastleft: integer;  lasttop: Integer;  sqSpacing: integer = 1;  sqWidth: Integer = 10;  sqHeight: Integer = 10;  maxleft: Integer;begin   maxleft:=ScrollBox1.Width - sqWidth - sqSpacing - ScrollBox1.VertScrollBar.Size;  lastleft:=sqSpacing;  lasttop:=sqSpacing;   for i:= 0 to totalsquares-1 do begin    if lastleft > maxleft then begin      lasttop:=lasttop+sqHeight+sqSpacing;      lastleft:=sqSpacing;    end;    aSquareArray[i].square.Top:=lasttop+sqSpacing;    aSquareArray[i].square.Left:=lastleft;    aSquareArray[i].square.Width:=sqWidth;    aSquareArray[i].square.Height:=sqHeight;     lastleft:=sqWidth+aSquareArray[i].square.left+sqSpacing;   end;end; procedure TForm1.FormResize(Sender: TObject);begin  //if sqReady2Dis then Distribute(Self);end; procedure TForm1.tmrRndDarkenTimer(Sender: TObject);var  rndSQR: integer;  myR, myG, myB: Integer;begin   if totalsquares > 2 then begin     rndSQR:=random(totalsquares);    if aSquareArray[rndSQR].GiClr = 0 then begin     aSquareArray[rndSQR].GiClr:=255;    end;     if aSquareArray[rndSQR].GiClr > 1 then dec(aSquareArray[rndSQR].GiClr,1);     aSquareArray[rndSQR].square.Brush.Color:=RGBToColor(aSquareArray[rndSQR].RiClr,aSquareArray[rndSQR].GiClr,aSquareArray[rndSQR].BiClr);  end;end; procedure TForm1.tmrReRndTimer(Sender: TObject);begin  Randomize;end;  end.  

jamie:
That isn't going to spawn much fruit..

 You should not be creating a GUI control for each square, you will hit a way and things will just stop!

Also, the scrollbox has a limit on the scrolling range and client size limits will change depending on the screen size.

 You should look at the TDrawGrid and implement drawing your own square areas...

m.abudrais:
try TImage
--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---unit Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, dateutils; type   { TForm1 }   TForm1 = class(TForm)    Button1: TButton;    Image1: TImage;    Timer1: TTimer;    procedure Button1Click(Sender: TObject);    procedure Timer1Timer(Sender: TObject);  private    LastTime: TDateTime;    TimeCounter: integer;    procedure UpdateImage;  public   end; var  Form1: TForm1; implementation {$R *.lfm} { TForm1 } procedure TForm1.Button1Click(Sender: TObject);begin  TimeCounter := 0;  UpdateImage;end; procedure TForm1.Timer1Timer(Sender: TObject);var  M: int64;begin  UpdateImage;  Inc(TimeCounter);  M := MilliSecondsBetween(LastTime, Now);  if M > 5000 then  begin    Form1.Caption := round(50 * 100 * TimeCounter / (M / 1000)).ToString();    LastTime := Now;  end;end; procedure TForm1.UpdateImage;var  k: integer;  m: integer;  c: TCanvas;  R: int64;begin  c := Image1.Canvas;  c.Brush.Color := clBlack;  c.FillRect(0, 0, Image1.Width, Image1.Height);  c.Brush.Color := clBlue;  for k := 0 to 50 do  begin    for m := 0 to 100 do    begin      R := Random(10);      if R > 5 then        c.Brush.Color := clBlue      else        c.Brush.Color := clGreen;      c.FillRect(m * 10, k * 10, m * 10 + 8, k * 10 + 8);    end;  end;end; end. if you need more performance you can use other lib like https://wiki.freepascal.org/BGRABitmap

Handoko:
TCanvas is slow, and TShape uses TCanvas. Using arrays of TShape to draw thousands of shapes is both slow and not memory-wise.

Here has a simple demo showing how to draw thousands of objects using buffer for (slightly) improving the performance (try moving2):
https://forum.lazarus.freepascal.org/index.php/topic,38136.msg263143.html#msg263143

TDrawGrid as suggested by jamie or using a TImage is better than using array of TShapes. But if you need better performance, you should consider to use hardware accelerated graphics libraries like Allegro.pas, TOpenGLControl, SDL.
https://wiki.freepascal.org/Game_framework

If learning a hardware-accelerated graphics library is too difficult, you may try Graphics32. I heard it is not hardware-accelerated but still very fast.
https://en.wikipedia.org/wiki/Graphics32

Tony Stone:
So this is cool.  I copied it into a new project.  It looks like it performs quite well.  However, I would like to be able to display a Hint for each square.  Each squares is gonna represent some information so in a way I need to have some information stored with each square... which might be possible to associate the square coordinates with a mouse over event and trigger a hint.  Just seems like a lot of work.  I feel like there is something easy I am overlooking?

Thanks for your demo either way.  It is a start for sure!  And it only took you about 15 minutes to put that together?  Mine took me several hours.   :-[



--- Quote from: m.abudrais on September 25, 2021, 04:12:21 am ---try TImage
--- Code: Pascal  [+][-]window.onload = function(){var x1 = document.getElementById("main_content_section"); if (x1) { var x = document.getElementsByClassName("geshi");for (var i = 0; i < x.length; i++) { x[i].style.maxHeight='none'; x[i].style.height = Math.min(x[i].clientHeight+15,306)+'px'; x[i].style.resize = "vertical";}};} ---unit Unit1; {$mode objfpc}{$H+} interface uses  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, dateutils; type   { TForm1 }   TForm1 = class(TForm)    Button1: TButton;    Image1: TImage;    Timer1: TTimer;    procedure Button1Click(Sender: TObject);    procedure Timer1Timer(Sender: TObject);  private    LastTime: TDateTime;    TimeCounter: integer;    procedure UpdateImage;  public   end; var  Form1: TForm1; implementation {$R *.lfm} { TForm1 } procedure TForm1.Button1Click(Sender: TObject);begin  TimeCounter := 0;  UpdateImage;end; procedure TForm1.Timer1Timer(Sender: TObject);var  M: int64;begin  UpdateImage;  Inc(TimeCounter);  M := MilliSecondsBetween(LastTime, Now);  if M > 5000 then  begin    Form1.Caption := round(50 * 100 * TimeCounter / (M / 1000)).ToString();    LastTime := Now;  end;end; procedure TForm1.UpdateImage;var  k: integer;  m: integer;  c: TCanvas;  R: int64;begin  c := Image1.Canvas;  c.Brush.Color := clBlack;  c.FillRect(0, 0, Image1.Width, Image1.Height);  c.Brush.Color := clBlue;  for k := 0 to 50 do  begin    for m := 0 to 100 do    begin      R := Random(10);      if R > 5 then        c.Brush.Color := clBlue      else        c.Brush.Color := clGreen;      c.FillRect(m * 10, k * 10, m * 10 + 8, k * 10 + 8);    end;  end;end; end. if you need more performance you use other lib like https://wiki.freepascal.org/BGRABitmap

--- End quote ---

Navigation

[0] Message Index

[#] Next page

Go to full version