Forum > LCL
Drawing, shapes? Canvas? Disk Defrag map style
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.
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 ---
Tony Stone:
--- Quote from: jamie on September 25, 2021, 04:08:21 am ---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...
--- End quote ---
Yeah... spawned square fruit... slowly. lol
It did kind of "work" at least. I am looking at drawgrid now. I think I looked at it initially and stopped focusing on it as i believe its the control that looked like a spreadsheet type control...
Navigation
[0] Message Index
[#] Next page