TVirtualStringTree - resetting non-visual nodes and memory consumption - delphi

I have an app that loads records from a binary log file and displays them in a virtual TListView. There are potentially millions of records in a file, and the display can be filtered by the user, so I do not load all of the records in memory at one time, and the ListView item indexes are not a 1-to-1 relation with the file record offsets (List item 1 may be file record 100, for instance). I use the ListView's OnDataHint event to load records for just the items the ListView is actually interested in. As the user scrolls around, the range specified by OnDataHint changes, allowing me to free records that are not in the new range, and allocate new records as needed.
This works fine, speed is tolerable, and the memory footprint is very low.
I am currently evaluating TVirtualStringTree as a replacement for the TListView, mainly because I want to add the ability to expand/collapse records that span multiple lines (I can fudge it with the TListView by incrementing/decrementing the item count dynamically, but this is not as straight forward as using a real tree).
For the most part, I have been able to port the TListView logic and have everything work as I need. I notice that TVirtualStringTree's virtual paradigm is vastly different, though. It does not have the same kind of OnDataHint functionality that TListView does (I can use the OnScroll event to fake it, which allows my memory buffer logic to continue working), and I can use the OnInitializeNode event to associate nodes with records that are allocated.
However, once a tree node is initialized, it sees that it remains initialized for the lifetime of the tree. That is not good for me. As the user scrolls around and I remove records from memory, I need to reset those non-visual nodes without removing them from the tree completely, or losing their expand/collapse states. When the user scrolls them back into view, I can re-allocate the records and re-initialize the nodes. Basically, I want to make TVirtualStringTree act as much like TListView as possible, as far as its virtualization is concerned.
I have seen that TVirtualStringTree has a ResetNode() method, but I encounter various errors whenever I try to use it. I must be using it wrong. I also thought of just storing a data pointer inside each node to my record buffers, and I allocate and free memory, update those pointers accordingly. The end effect does not work so well, either.
Worse, my largest test log file has ~5 million records in it. If I initialize the TVirtualStringTree with that many nodes at one time (when the log display is unfiltered), the tree's internal overhead for its nodes takes up a whopping 260MB of memory (without any records being allocated yet). Whereas with the TListView, loading the same log file and all the memory logic behind it, I can get away with using just a few MBs.
Any ideas?

You probably shouldn't switch to VST unless you have a use for at least some of the nice features of VST that a standard listbox / listview don't have. But there is of course a large memory overhead compared to a flat list of items.
I don't see a real benefit in using TVirtualStringTree only to be able to expand and collapse items that span multiple lines. You write
mainly because I want to add the ability to expand/collapse records that span multiple lines (I can fudge it with the TListView by incrementing/decrementing the item count dynamically, but this is not as straight forward as using a real tree).
but you can implement that easily without changing the item count. If you set the Style of the listbox to lbOwnerDrawVariable and implement the OnMeasureItem event you can adjust the height as required to draw either only the first or all lines. Drawing the expander triangle or the little plus symbol of a tree view manually should be easy. The Windows API functions DrawText() or DrawTextEx() can be used both to measure and draw the (optionally word-wrapped) text.
Edit:
Sorry, I completely missed the fact that you are using a listview right now, not a listbox. Indeed, there is no way to have rows with different heights in a listview, so that's no option. You could still use a listbox with a standard header control on top, but that may not support everything you are using now from listview functionality, and it may itself be as much or even more work to get right than dynamically showing and hiding listview rows to simulate collapsing and expanding.

If I understand it correctly, the memory requirement of TVirtualStringTree should be:
nodecount * (SizeOf(TVirtualNode) + YourNodeDataSize + DWORD-align-padding)
To minimize the memory footprint, you could perhaps initialize the nodes with only pointers to offsets to a memory-mapped file. Resetting nodes which have already been initialized doesn't seem necessary in this case - the memory footprint should be nodecount * (44 + 4 + 0) - for 5 million records, about 230 MB.
IMHO you can't get any better with the tree but using a memory-mapped file would allow you to read the data directly from the file without allocating even more memory and copying the data to it.
You could also consider using a tree structure instead of a flat view to present the data. That way you could initialize child nodes of a parent node on demand (when the parent node is expanded) and resetting the parent node when it's collapsed (therefore freeing all its child nodes). In other words, try not to have too many nodes at the same level.

To meet your requirement "to expand/collapse records that span multiple lines", I'd simply use a drawgrid. To check it out, drag a drawgrid onto a form, then plug in the following Delphi 6 code. You can collapse and expand 5,000,000 multiline records (or whatever quantity you want) with essentially no overhead. It's a simple technique, doesn't require much code, and works surprisingly well.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Grids, StdCtrls;
type
TForm1 = class(TForm)
DrawGrid1: TDrawGrid;
procedure DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
procedure DrawGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
procedure DrawGrid1TopLeftChanged(Sender: TObject);
procedure DrawGrid1DblClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
procedure AdjustGrid;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
// Display a large number of multi-line records that can be expanded or collapsed, using minimal overhead.
// LinesInThisRecord() and RecordContents() are faked; change them to return actual data.
const TOTALRECORDS = 5000000; // arbitrary; a production implementation would probably determine this at run time
// keep track of whether each record is expanded or collapsed
var isExpanded: packed array[1..TOTALRECORDS] of boolean; // initially all FALSE
function LinesInThisRecord(const RecNum: integer): integer;
begin // how many lines (rows) does the record need to display when expanded?
result := (RecNum mod 10) + 1; // make something up, so we don't have to use real data just for this demo
end;
function LinesDisplayedForRecord(const RecNum: integer): integer;
begin // how many lines (rows) of info are we currently displaying for the given record?
if isExpanded[RecNum] then result := LinesInThisRecord(RecNum) // all lines show when expanded
else result := 1; // show only 1 row when collapsed
end;
procedure GridRowToRecordAndLine(const RowNum: integer; var RecNum, LineNum: integer);
var LinesAbove: integer;
begin // for a given row number in the drawgrid, return the record and line numbers that appear in that row
RecNum := Form1.DrawGrid1.TopRow; // for simplicity, TopRow always displays the record with that same number
if RecNum > TOTALRECORDS then RecNum := 0; // avoid overflow
LinesAbove := 0;
while (RecNum > 0) and ((LinesDisplayedForRecord(RecNum) + LinesAbove) &lt (RowNum - Form1.DrawGrid1.TopRow + 1)) do
begin // accumulate the tally of lines in expanded or collapsed records until we reach the row of interest
inc(LinesAbove, LinesDisplayedForRecord(RecNum));
inc(RecNum); if RecNum > TOTALRECORDS then RecNum := 0; // avoid overflow
end;
LineNum := RowNum - Form1.DrawGrid1.TopRow + 1 - LinesAbove;
end;
function RecordContents(const RowNum: integer): string;
var RecNum, LineNum: integer;
begin // display the data that goes in the grid row. for now, fake it
GridRowToRecordAndLine(RowNum, RecNum, LineNum); // convert row number to record and line numbers
if RecNum = 0 then result := '' // out of range
else
begin
result := 'Record ' + IntToStr(RecNum);
if isExpanded[RecNum] then // show line counts too
result := result + ' line ' + IntToStr(LineNum) + ' of ' + IntToStr(LinesInThisRecord(RecNum));
end;
end;
procedure TForm1.AdjustGrid;
begin // don't allow scrolling past last record
if DrawGrid1.TopRow > TOTALRECORDS then DrawGrid1.TopRow := TOTALRECORDS;
if RecordContents(DrawGrid1.Selection.Top) = '' then // move selection back on to a valid cell
DrawGrid1.Selection := TGridRect(Rect(0, TOTALRECORDS, 0, TOTALRECORDS));
DrawGrid1.Refresh;
end;
procedure TForm1.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
var s: string;
begin // time to draw one of the grid cells
if ARow = 0 then s := 'Data' // we're in the top row, get the heading for the column
else s := RecordContents(ARow); // painting a record, get the data for this cell from the appropriate record
// draw the data in the cell
ExtTextOut(DrawGrid1.Canvas.Handle, Rect.Left, Rect.Top, ETO_CLIPPED or ETO_OPAQUE, #Rect, pchar(s), length(s), nil);
end;
procedure TForm1.DrawGrid1SelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean);
var RecNum, ignore: integer;
begin
GridRowToRecordAndLine(ARow, RecNum, ignore); // convert selected row number to record number
CanSelect := RecNum &lt> 0; // don't select unoccupied rows
end;
procedure TForm1.DrawGrid1TopLeftChanged(Sender: TObject);
begin
AdjustGrid; // keep last page looking good
end;
procedure TForm1.DrawGrid1DblClick(Sender: TObject);
var RecNum, ignore, delta: integer;
begin // expand or collapse the currently selected record
GridRowToRecordAndLine(DrawGrid1.Selection.Top, RecNum, ignore); // convert selected row number to record number
isExpanded[RecNum] := not isExpanded[RecNum]; // mark record as expanded or collapsed; subsequent records might change their position in the grid
delta := LinesInThisRecord(RecNum) - 1; // amount we grew or shrank (-1 since record already occupied 1 line)
if isExpanded[RecNum] then // just grew
else delta := -delta; // just shrank
DrawGrid1.RowCount := DrawGrid1.RowCount + delta; // keep rowcount in sync
AdjustGrid; // keep last page looking good
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Caption := FormatFloat('#,##0 records', TOTALRECORDS);
DrawGrid1.RowCount := TOTALRECORDS + 1; // +1 for column heading
DrawGrid1.ColCount := 1;
DrawGrid1.DefaultColWidth := 300; // arbitrary
DrawGrid1.DefaultRowHeight := 12; // arbitrary
DrawGrid1.Options := DrawGrid1.Options - [goVertLine, goHorzLine, goRangeSelect] + [goDrawFocusSelected, goThumbTracking]; // change some defaults
end;
end.

You shouldn't use ResetNode because this method invokes InvalidateNode and initializes node again, leading to opposite effect than expected.
I don't know if it's possible to induce VST to free memory size specified in NodeDataSize without actually removing node. But why not set NodeDataSize to size of Pointer ( Delphi, VirtualStringTree - classes (objects) instead of records ) and manage data yourself? Just an idea...

Give "DeleteChildren" a try. Here's what this procedure's comment says:
// Removes all children and their children from memory without changing the vsHasChildren style by default.
Never used it, but as I read it, you can use that in the OnCollapsed event to free the memory allocated to nodes that just became invisible. And then re-generate those nodes in OnExpading so the user never knows the node went away from memory.
But I can't be sure, I never had a need for such behaviour.

Related

How to search a FMX.TListView header as well as items

I have a LiveBindings databound FMX.TListView with the FieldName being Stage and the FillHeaderFieldName being Production. When the app is running, I see a list of Productions using the HeaderAppearance, and within each Production, there is a list of Stages using the ItemAppearance. I've turned on SearchVisible to get the components search panel to show at the top of the list.
Currently, typing into the search box only filters on the Stage, and not the Production.
I'd like to be able to do both, and I'd like to be able to do it without making another REST call with filter parameters. I understand I would probably need to write an event handler for the OnSearchChange event, and I have this bit of code to get the search text entered:
List := Sender as TListView;
for I := 0 to List.Controls.Count-1 do
if List.Controls[I].ClassType = TSearchBox then
begin
SearchBox := TSearchBox(List.Controls[I]);
break;
end;
And I think I need to set the Items.Filter property, and I used this bit of code:
Lower := LowerCase(SearchBox.Text.Trim);
List.Items.Filter :=
function(X: string): Boolean
begin
Result:= (Lower = EmptyStr) or LowerCase(X).Contains(Lower);
end;
One of the problems is that the ListView component is applying its filtering as soon as a character is typed, while the OnSearchChange event only fires when the searchbox loses focus.
The second problem is that, even after the event is fired and the new filter function set, nothing happens to the list.
I've confirmed that the List.Items collection in my "36" example does actually contain all 6 items - the 3 header items and the 3 detail items - so I'm unsure why the filter is not applying to the header items as it does the detail items.
I tried this out and found a solution. Keep in mind I don't have access to Delphi 10.3 Rio. I'm using 10.1 Berlin. Also keep in mind that what I usually do is bind in the code and not visually. But for this I stuck to visual binding.
As a dataset I have used a TFDMemoryTable (mt1) with 2 data fields (fmt1Prod and fmt1Stage) and 1 calculated field (fmt1Search). I have the following handler to calculate the Search field:
Procedure TForm2.mt1CalcFields(DataSet: TDataSet);
Begin
fmt1Search.AsString := fmt1Prod.AsString + '|' + fmt1Stage.AsString;
End;
I put some random data in the memory table OnFormCreate:
Procedure TForm2.FormCreate(Sender: TObject);
Var
i1, i2: Integer;
s1, s2: String;
Begin
mt1.CreateDataSet;
For i1 := 1 To 13 Do Begin
s1 := 'Prod' + FormatFloat('00', i1);
For i2 := Random(6) To Random(14) Do Begin
s2 := 'Stage' + FormatFloat('00', i2);
mt1.Append;
fmt1Prod.AsString := s1;
fmt1Stage.AsString := s2;
mt1.Post;
End;
End;
End;
I have put on Form2 a TGrid and a TListView. Both are bound to the dataset. Data and calculated fields show up properly in the TGrid (just to check).
The TListView is bound to the dataset as follows:
Synch <-> *
ItemHeader.Text <- Prod
ItemHeader.Break <- Prod
Item.Text <- Search
Item.Detail <- Stage
I did this because I cannot find a way to have the TListView searchbox work on anything but the Text of the items. Ok then... but this can be worked around though:
Set TListView.ItemAppeance to Custom
Find the TListView/ItemAppearance/Item/Text object in the structure and set Visible to False
Find the TListView/ItemAppearance/Item/Detail object in the structure and set Visible to True
I'm not sure all of the above is necessary, but it works. If your TListView is editable then you will probably need to fiddle with the ItemEditAppearance too.
Remember that with custom item appearance you can actually set the list view items to look just about anyway you want. You can add and remove labels, images and other things. It's not as powerful as designing a form, but you can do a lot with it. But all you really need here is to hide the search text and show the stage text somewhere in the item.
And... for more sophisticated item appearance you may have to do some code binding (non sure of this though).
If use bind visually and ItemAppearance (Dynamic Appearance) you can one column from data source assign to header and text item (visible = false). In this situation in header and item we have the same value and search work fine.

Fading values general function/procedure

I am after a general function/procedure that would calculate me fade times and values based on data provided, something like this:
I have byte values saved in a byte array: these are the start values. Then I have some memorized values in some other array: these are to be the new values. Then I have time to be provided, which is time needed a start value to get to new value.
I need to get updates on the values each time they change (up to 0.1 seconds accurate). I know that if value A changes for 10 and value B changes for 100 in the same time, let's say 1 second, I'll get value A updated 10 times, while value B will be updated 100 times.
So far I have been planning on using a timer, with interval let's say 50ms, which would constantly be calculating the difference based on the value of the change and the time needed, something like: change step := (Difference between start and new value / {divided by} (fade time / timer interval) ).
But given the fact that value changes are different, fade times as well, and that I could execute another value fading before the first fading has ended, is making all of this confusing and difficult for me.
So, what I would need is an option to, let's say, given values at index 1, 2, 3, 4, 5, 6 and 7 to be changed to their new values in 30 seconds, then at some point somewhere in between I could order the values at index 11, 13 and 17 to change to their new values in 9 seconds, etc...
Also, in case that value A would have a fading towards value B in progress, and another fade from A to C would be ordered, I would like it to be added to a queue list, to be executed right after the first fade is finished. And at that time, the B value from the first command would become the A value in the second command. This is due to these facts: The A in the example above should always be read at the very moment of the fade start. This way, it is a starting value no matter what was done before the fade or between the fade command and fade execution. Therefore, I could set Fade1 to Current -> B # 10s and queue a Fade2 for Current -> C # 10s, whereas the Current in the second case is actually value otherwise saved as B, and let's assume the Current in Fade1 is same as value saved as C. This way the value would be in a loopback, changing every 10 seconds. So basically, the command for adding a fade should only have something like SetNewFade: Dest:=B; Time:=10;.
So I could add ->B#10s, ->C#10s, ->B#10s, ->C#10s, and it would just loop from B to C and backwards until queue list is empty. I hope I managed to make this clear enough for you to understand. I really can't describe better what I need to achieve.
Also, as all of the fades would be provided in a Listbox, I would like to be able to delete fades in the queue as desired. But, if the currently running fade is deleted, the value should jump to a new value as if the fade would be already completed, and normally then start the new fade in queue list, if there's any.
How would that be the easiest to create? Is using Timer with fixed interval a good idea? Would it cause any delays if a lot of values would be pending for fade? Is using dynamic arrays for values and times (and populating them on StartFade event and release them after fading is complete) a shot in the dark or a good guess?
Here an example which I hope makes it clearer:
A: array [0..20] of Byte;
B: array [0..20] of Byte;
C: array [0..20] of Byte;
Current: array [0..20] of Byte;
Button1 applies the A values to the Current values, Button2 applies the B values, and Button3 applies the C values, and so on...
So I set time in an Edit box, let's say 5 seconds, and click on Button1. With that, I added the fade from Current towards values in array A with time 5 seconds. Since it's the first in queue, it starts to execute immediately. Before the fade is actually completed, I set time 20 seconds and press Button2. So I just added another fade in a queue list: from Current towards the values in array B. Since I'm changing the same values (index 0..20), this is starting to be executed right after the first fade completes. Note: the fading process is constantly updating the Current array, until it has the same values as the fade command's array! Therefore, the second fade will fade again from Current to B, with Current actually being same as A.
Now where things gets even more complicated is when I actually set just values indexed 0, 1, 2, 3 and 4 from the arrays to be faded #5sec to A, and then I apply the values indexed 5, 6, 7, 8 and 9 to be faded #10sec to B values: in that case, since the indexes I am fading are different ones, both fade commands should execute right away.
In case one value is in both fades (such as if I'd add value indexed 4 to the second fade), only this value would need to be added to a queue list. So the other fades right away, while the one that is already fading in the first fade, waits for it to finish, and then starts to fade as per the second command.
Some additional information:
Lengths of the arrays are not fixed at the moment, but could be set fixed if this is important. It is for sure a multiplier of 512 with a maximum of 2047.
The number of arrays is unknown and is to be modified in runtime as needed. They will probably be stored as records, (such as StoredVals: array of record;, Index: array of Integer (index of the values; this is to tell which values are stored in this record), and Value: array of Byte; (these are actual values that are faded, based on Current[StoredVals[0].Index[0]] for example. Current is keeping data of all values, meanwhile the records of A, B, C etc... keeps only the values of those which are indexed inside that record).
The lengths of the arrays are, based on the description above, not always equal since they aren't always changing the same amount of values.
The arrays are filled from the database at initialization. Since they can be created on runtime, they are filled from the Current values and stored as new array as well. But this is always also written in a database as well then. They are kind of memorized values, so that I can recall them with buttons. For that matter, I would like to have an option to recall those values immediately (as I do now already) or via the fading option. Now, to avoid the issues for a value in the queue, I was thinking of sending that immediate change through the fading process as well, only with time 0 seconds. That way, the values which are not in queue would be applied immediately, while if some value is currently fading, it will be applied after that fade is complete. That said, this fade process would be in the command flow all the time.
If there's any other extra clarification needed, please don't hesitate to ask!
I know this is really complicated, and that's why I'm looking for your help. Any partial help or suggestions would be appreciated.
I'm after a general function/procedure...
Actually, you seem to be after a complete program. You are thinking about solving it as a whole, and that's clouding, which is why you have so many questions. You need to learn breaking this task up in smaller parts, and to summarize the requirements more clearly. The question in its current form is close to being off-topic, and it probably would fit better at SE Programmers. But since this fits right up my alley, I would like to step you through.
Requirements
There is a set of values X of length N.
One or more values in this set can be assigned a new value.
The modification from an old value to the new value should be performed in steps within a specific duration.
This results in intermediate values during this transition.
This transition is value/index specific, i.e. the duration for X[0] could differ from that for X[1].
A transition has to be entirely completed before another new value can be assigned.
New values may be requested for assignment while a transition is in progress.
This concludes that new requests should be stored in a queue, such that when a transition is completed, en new value request can be pulled from the queue resulting in a new transition.
I am pretty sure this is a correct summary of your question.
Transitions
Your proposal to use a Timer to perform a piece of the total transition on every interval is sound. Now, there are two ways to calculate those pieces:
Divide the total transition into a fixed number of small transitions, set the Timer's interval to the total duration divided by that number and handle the sum of all processed smaller transitions on every interval. This is what you propose in the calculation of the change step. The drawback with this method is a twofold:
A Timer's interval is an approximation and will not be exact because of various reasons, one of them being dependend on the Windows messaging model which' timing is affected by many processes, including yours,
A possible rough or unsmooth progress because of it.
Recalculate the part of the processed transition at every interval. That way the progress will always be smooth, whether the next interval takes two times more or not.
The second solution is preferred, and this translates into the following general routine you are looking for. Let's start simple by assuming a single item:
function InBetweenValue(BeginValue, EndValue: Byte; Duration,
StartTick: Cardinal): Byte
var
Done: Single;
begin
Done := (GetTickCount - StartTick) / Duration;
if Done >= 1.0 then
Result := EndValue
else
Result := Round(BeginValue + (EndValue - BeginValue) * Done);
end;
Is using a Timer with fixed interval a good idea?
With this approach, the Timer's interval does not affect the calculation: at any given time the result of InBetweenValue will be correct. The only thing the Timer is needed for is driving the progress. If you want a 67 Hz refresh rate then set its interval to 15 milliseconds. If you want a refresh rate of 20 Hz, then set the interval to 50 milliseconds.
Performance
Would it cause any delays if a lot of values would be pending for fade?
No, not for the implied reason. The time needed for all calculations may depend on the size of the queue, but that will for sure not be a significant factor. (If so, then you have problems of a much more troubling caliber). Possible "delays" will be manifested in a a lesser refresh rate due to missed or merged Windows Timer messages, depending on how busy the computer is with everything it's doing.
Data storage
Is using dynamic arrays for values and times (and populating them on "StartFade" event and release them after fading is complete) a shot in the dark or a good guess?
Let's first analyze what data needs to be handled. There is a single set of in-between current values of arbitrary length, and each value has its own four attributes: begin value, end value, transition duration and transition start time. So you have the choice between:
Storing 5 sets: one set of current values and four sets of attributes, or
Storing 1 set: a single set of current values wherein each value has four attribute members.
The first solution requires trouble with keeping all five sets synchronized. The second requires another dimension. I would prefer the latter.
Whether you use arrays or something else is up to you. Choose what you are most comfortable with, what fits the purpose or what matches the input or required output best. Whether you choose static of dynamic arrays depends on the variability of the input and makes no measurable difference in performance. Dynamic arrays require runtime length management, where static arrays do not.
But since you need a dynamic solution anyway, then I suggest thinking outside the box. For example, the RTL offers no default built-in management tools for arrays, but it does have collection classes that do, e.g. TList.
For the rest of this answer, I will assume the decision of using an Object for an element and a List for keeping track of them.
Design
Now that the two most pressing points have been addressed, the design can be worked out.
There is a List with items, and each item has its current value and four attributes: begin, end, duration and start time. Each item must be capable of getting new attribute values. There is a formula for calculating the current value, based on the attributes. And there is a Timer which should automate a multiple of these calculations.
Furthermore, a multiple of transition commands should be stored for an Item. Since we have an Item with members already, let's add those commands as member of the Item too.
Something missing? No. Let's go.
Implementation
We need:
A type for a Transition with two members: end value and duration,
A type for a multiple of these transitions, preferably with queue characteristics,
A type for an Item with six members: begin value, end value, duration, start time, current value and transitions,
A type for a List of such Items,
A routine for calculating the current value of an Item,
A routine for popping up a new transition when the current value reached the end value,
A routine for doing this calculation and popping on all Items,
A Timer to drive this over-all routine,
A routine for updating an Item's attributes. Recapitulate. Do we need the ability to set all the attributes? Doesn't a transition have all the settings needed?
A type for an Object holding this all together.
This should help you set up the interface part of the code. Linger, and contain eagerness to start coding the implementation.
Hereby my try-out, originated as described above:
unit Modulation;
interface
uses
System.SysUtils, System.Classes, System.Generics.Collections, WinAPI.Windows,
VCL.ExtCtrls;
type
TTransition = record
EndValue: Byte;
Duration: Cardinal;
end;
TTransitions = class(TQueue<TTransition>);
TByte = class(TObject)
private
FBeginValue: Byte;
FCurrentValue: Byte;
FEndValue: Byte;
FDuration: Cardinal;
FStartTick: Cardinal;
FTransitions: TTransitions;
procedure PopTransition;
public
procedure AddTransition(ATransition: TTransition);
constructor Create;
destructor Destroy; override;
function HasTransition: Boolean;
function InTransition: Boolean;
procedure Recalculate;
property CurrentValue: Byte read FCurrentValue;
end;
TBytes = class(TObjectList<TByte>);
TByteModulator = class(TObject)
private
FItems: TBytes;
FOnProgress: TNotifyEvent;
FTimer: TTimer;
function Finished: Boolean;
function GetCurrentValue(Index: Integer): Byte;
function GetItemCount: Integer;
procedure SetItemCount(Value: Integer);
procedure Proceed(Sender: TObject);
protected
procedure DoProgress;
public
procedure AddTransition(Index: Integer; ATransition: TTransition);
constructor Create;
destructor Destroy; override;
property CurrentValues[Index: Integer]: Byte read GetCurrentValue; default;
property ItemCount: Integer read GetItemCount write SetItemCount;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
end;
implementation
{ TByte }
procedure TByte.AddTransition(ATransition: TTransition);
begin
if ATransition.Duration < 1 then
ATransition.Duration := 1;
FTransitions.Enqueue(ATransition);
Recalculate;
end;
constructor TByte.Create;
begin
inherited Create;
FTransitions := TTransitions.Create;
FDuration := 1;
end;
destructor TByte.Destroy;
begin
FTransitions.Free;
inherited Destroy;
end;
function TByte.HasTransition: Boolean;
begin
Result := FTransitions.Count > 0;
end;
function TByte.InTransition: Boolean;
begin
Result := FCurrentValue <> FEndValue;
end;
procedure TByte.PopTransition;
var
Transition: TTransition;
begin
Transition := FTransitions.Dequeue;
FBeginValue := FCurrentValue;
FEndValue := Transition.EndValue;
FDuration := Transition.Duration;
FStartTick := GetTickCount;
end;
procedure TByte.Recalculate;
var
Done: Single;
begin
Done := (GetTickCount - FStartTick) / FDuration;
if Done >= 1.0 then
begin
FCurrentValue := FEndValue;
if HasTransition then
PopTransition;
end
else
FCurrentValue := Round(FBeginValue + (FEndValue - FBeginValue) * Done);
end;
{ TByteModulator }
const
RefreshFrequency = 25;
procedure TByteModulator.AddTransition(Index: Integer;
ATransition: TTransition);
begin
FItems[Index].AddTransition(ATransition);
FTimer.Enabled := True;
end;
constructor TByteModulator.Create;
begin
inherited Create;
FItems := TBytes.Create(True);
FTimer := TTimer.Create(nil);
FTimer.Enabled := False;
FTimer.Interval := MSecsPerSec div RefreshFrequency;
FTimer.OnTimer := Proceed;
end;
destructor TByteModulator.Destroy;
begin
FTimer.Free;
FItems.Free;
inherited Destroy;
end;
procedure TByteModulator.DoProgress;
begin
if Assigned(FOnProgress) then
FOnProgress(Self);
end;
function TByteModulator.Finished: Boolean;
var
Item: TByte;
begin
Result := True;
for Item in FItems do
if Item.InTransition or Item.HasTransition then
begin
Result := False;
Break;
end;
end;
function TByteModulator.GetCurrentValue(Index: Integer): Byte;
begin
Result := FItems[Index].CurrentValue;
end;
function TByteModulator.GetItemCount: Integer;
begin
Result := FItems.Count;
end;
procedure TByteModulator.Proceed(Sender: TObject);
var
Item: TByte;
begin
for Item in FItems do
Item.Recalculate;
DoProgress;
FTimer.Enabled := not Finished;
end;
procedure TByteModulator.SetItemCount(Value: Integer);
var
I: Integer;
begin
for I := FItems.Count to Value - 1 do
FItems.Add(TByte.Create);
FItems.DeleteRange(Value, FItems.Count - Value);
end;
end.
And a tiny plug-and-play demonstration program (note that the labels only show the last request):
unit Unit2;
interface
uses
System.SysUtils, System.Classes, Vcl.Controls, Vcl.Forms,
VCL.ComCtrls, VCL.StdCtrls, Modulation;
type
TForm2 = class(TForm)
private
FBars: array of TProgressBar;
FLabels: array of TLabel;
FByteModulator: TByteModulator;
procedure FormClick(Sender: TObject);
procedure Progress(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
{ TForm2 }
const
Count = 10;
constructor TForm2.Create(AOwner: TComponent);
var
I: Integer;
begin
inherited Create(AOwner);
FByteModulator := TByteModulator.Create;
FByteModulator.ItemCount := Count;
FByteModulator.OnProgress := Progress;
SetLength(FBars, Count);
SetLength(FLabels, Count);
for I := 0 to Count - 1 do
begin
FBars[I] := TProgressBar.Create(Self);
FBars[I].SetBounds(10, 10 + 30 * I, 250, 25);
FBars[I].Smooth := True;
FBars[I].Max := High(Byte);
FBars[I].Parent := Self;
FLabels[I] := TLabel.Create(Self);
FLabels[I].SetBounds(270, 15 + 30 * I, 50, 25);
FLabels[I].Parent := Self;
end;
OnClick := FormClick;
end;
destructor TForm2.Destroy;
begin
FByteModulator.Free;
inherited Destroy;
end;
procedure TForm2.FormClick(Sender: TObject);
var
Transition: TTransition;
Index: Integer;
begin
Transition.EndValue := Random(High(Byte) + 1);
Transition.Duration := Random(3000);
Index := Random(Count);
FLabels[Index].Caption := Format('%d > %d # %f',
[FByteModulator.CurrentValues[Index], Transition.EndValue,
Transition.Duration / MSecsPerSec]);
FByteModulator.AddTransition(Index, Transition);
end;
procedure TForm2.Progress(Sender: TObject);
var
I: Integer;
begin
for I := 0 to Count - 1 do
FBars[I].Position := FByteModulator.CurrentValues[I];
end;
initialization
Randomize;
end.
Succes.

DBGrid stop current Row moving

Using d5, TDBGrid, SQLite3 and ZEOS. Database has 2000 items, one Column is an "Active" as Boolean, a second Column is "ItemName" as Text, and IndexFiledNames is "ItemName'
OnDblclick toggles "Active" On/Off and all works as expected for the Data. Active changes from True to False and back again.
But, if I double-click on the last visible Row of the DBGrid, to toggle the Active state -- after the toggle, the DBGrid moves that item Row to the vertical center Row-position of the grid. This is very confusing to a user with the Row they just double-clicked jumping around.
How can I stop the grid from moving that Row to the middle? This happens with all items that are on the last visible Row of the DGBGrid.
{EDIT} The remmed out items are attempts at reducing the issue - didn't work.
procedure TfrmMain.dbgridItemsDblClick(Sender: TObject);
begin
puItemsSelectedClick(Self);
end;
procedure TfrmMain.puItemsSelectedClick(Sender: TObject);
//var
// CurrItem : String;
// CurrIndx : String;
begin
if dm.tblItems.RecordCount = 0 then
begin
myShowMsg('There are no Items in the Items List');
Exit;
end;
// CurrItem:=dm.tblItems.FieldByName(fldItemGroupShop).AsString;
// CurrIndx:=dm.tblItems.IndexFieldNames;
dm.tblItems.DisableControls;
try
// dm.tblItems.IndexFieldNames:='';
dm.tblItems.Edit;
dm.tblItems.FieldByName(fldSelected).AsBoolean:=
not(dm.tblItems.FieldByName(fldSelected).AsBoolean);
dm.tblItems.Post;
// dm.tblItems.IndexFieldNames:=CurrIndx;
// dm.tblItems.Locate(fldItemGroupShop,CurrItem,[]);
finally
dm.tblItems.EnableControls;
end;
end;
The current row number and number of display rows of a DBGrid are protected properties,
so you need a "class cracker" type declaration in your code, like so:
type
TMyDBGrid = Class(TDBGrid);
function TForm1.GetGridRow: Integer;
begin
Result := TmyDBGrid(DBGrid1).Row;
end;
function TForm1.GridRowCount : Integer;
begin
Result := TmyDBGrid(DBGrid1).RowCount;
end;
Having done that, place a TEdit and TButton on your form to input a new grid row number that's less than the current one. Then try out the following routine:
procedure TForm1.SetGridRow(NewRow : Integer);
var
GridRows,
OldRow,
MoveDataSetBy,
MovedBy : Integer;
DataSet : TDataSet;
Possible : Boolean;
ScrollUp : Boolean;
begin
OldRow := GetGridRow;
if NewRow = OldRow then
Exit;
ScrollUp := NewRow < OldRow;
DataSet := dBGrid1.DataSource.DataSet;
GridRows := TmyDBGrid(DBGrid1).RowCount;
{ TODO : Test the case where the DataSet doesn't have enough rows to fill the grid}
{ TODO : Check why grid reports one more row than it displays.
Meanwhile ... }
GridRows := GridRows - 1;
// First check whether the NewRow value is sensible
Possible := (NewRow >= 1) and (NewRow <= GridRows);
if not Possible then exit;
try
if ScrollUp then begin
// First scroll the dataset forwards enough to bring
// a number of new records into view
MoveDataSetBy := GridRows - NewRow;
MovedBy := DataSet.MoveBy(MoveDataSetBy);
Shortfall := MoveDataSetBy - MovedBy;
if Shortfall = 0 then begin
// Now scroll the dataset backwards to get back
// to the record we were on
MoveDataSetBy := -GridRows + NewRow;
MovedBy := DataSet.MoveBy(MoveDataSetBy);
end
else
MovedBy := DataSet.MoveBy(-MovedBy);
end
else begin
MoveDataSetBy := -(NewRow - 1);
MovedBy := DataSet.MoveBy(MoveDataSetBy);
// We need to know if the DS cursor was able to move far enough
// back as we've asked or was prevented by reaching BOF
Shortfall := MoveDataSetBy - MovedBy;
if Shortfall = 0 then begin
// The DS cursor succeeded on moving the requested distance
MoveDataSetBy := NewRow - 1;
MovedBy := DataSet.MoveBy(MoveDataSetBy);
end
else
// it failed, so we need to return to the record we started on
// but this won't necessarily return us the same grid row number
MovedBy := DataSet.MoveBy(-MovedBy);
finally
DBGrid1.Invalidate;
end;
My earlier suggestion, to do a direct assignment to the grid row by "TmyDBGrid(DBGrid1).Row := NewRow;" was based on a mis-recollection, because in fact that seems to do nothing very useful.
The algorithm following "if ScrollUp" is made complicated by the fact that we're not depending on a meaningful RecNo. What this involves is checking whether the dataset cursor can be moved by a sufficient amount in the direction opposite the one we want to move the grid row in, to scroll the DS cursor relative to the rows in the grid, without hitting EOF or BOF - if either of thiose happens, we just move the DS cursor back to where it was and give up trying to scroll the grid.
For ScrollUp, the logic is:
First move the dataset cursor to the last row in the grid
Then move it forwards some more, by the difference between the old and new Row values.
Then move it back by an amount equal to the number of rows in the grid less the new row value.
If all that succeeds, the current row will move to the grid position requested by the NewRow value.
Of course, the code combines the first two of these steps. At first, I thought this code was nonsense, because the algebraic sum of the values used for the DataSet.MoveBy()s is zero. In fact,
it's not nonsense, just a bit counter-intuitive. Of course the distances add up do zero, because we want to get back to the record we were one; the point of doing the DataSet.MoveBy()s at all is to shake loose, as it were, the grid's grip on the current record and then return to it. This is incidentally why there's no point in doing what I usually when moving off the current record and then returning to it, namely DataSet.GetBookmark/GotBookmark/FreeBookmark and indeed using those will defeat the code's intended effect.
I'm using a ClientDataSet, btw, not a ZEOS one, but that shouldn't make any difference.
Btw, the local DataSet variable is to access the grid's dataset without using Delphi's infernal "With ..." construct.
Incidentally, your comment about "Rows div 2" reminded me: I don't think it's the grid that tells the dataset, ISTR it's the Datalink associated with the grid which tells the dataset how many records it should allocate buffers for. Then, in TDataSet.Resync, you'll notice
if rmCenter in Mode then
Count := (FBufferCount - 1) div 2 else
Count := FActiveRecord;
and then take a look how Count is used later in the routine; your theory may be spot on. Maybe put a breakpoint on "if cmCenter in Mode" and see if it gets called from where your grid acts up.
Btw#2, even if this code hasn't helped, this article might http://delphi.about.com/od/usedbvcl/l/aa011004a.htm
I am not sure that my situation is like yours, but if you want to fix annoying grid centering (for example, if you react on user click and need to get to the record before or record below and then correctly get back), use this:
var oldActiverecord:=FDataLink.ActiveRecord;
DataSet.DisableControls;
oldrecno:=Dataset.RecNo;//remember current recno
Dataset.RecNo:=SomeAnotherRecNoWhichYouNeedToGoTo;
//do what you like with this record
...
//then return to current
Dataset.RecNo:=oldrecno;//in this moment grid will center
var MoveDataSetBy:=oldActiverecord-FDataLink.ActiveRecord;//how much?
if MoveDataSetBy<>0 then begin
DataSet.MoveBy(-MoveDataSetBy); //get back
DataSet.Resync([rmCenter]); //center there
DataSet.MoveBy(+MoveDataSetBy);//move cursor where we was initially
end;
DataSet.EnableControls;

Emptying string grid in Delphi

In Delphi, is there a fast way of emptying a TStringgrid (containing in excess of 5000 rows) that will also free the memory?
Setting the rowcount to 1, empties the grid but does not free the memory.
Thanks in advance,
Paul
This should uninitialize the allocated strings (from the string list where the row texts are stored). Cleaning is done by columns since you have a lot of rows.
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
begin
for I := 0 to StringGrid1.ColCount - 1 do
StringGrid1.Cols[I].Clear;
StringGrid1.RowCount := 1;
end;
By "does not free the memory", do you mean that if you set RowCount := 1, and then set the RowCount := 10' you can still see the old content of theCells`?
If so, this is an old issue and has nothing to do with the memory not being freed; it's simply because you just happen to see the previous content of the memory when it's allocated again, because memory isn't zero'd out.
I have a pretty standard routine in a utility unit that deals with this visual glitch, and unless the grid is huge works fast enough. Just pass the TStringGrid before you change the RowCount or ColCount to a lower value.
procedure ClearStringGrid(const Grid: TStringGrid);
var
c, r: Integer;
begin
for c := 0 to Pred(Grid.ColCount) do
for r := 0 to Pred(Grid.RowCount) do
Grid.Cells[c, r] := '';
end;
Use it like this:
ClearStringGrid(StringGrid1);
StringGrid1.RowCount := 1;
I would suggest storing your string values in your own memory that you have full control over, and then use a TDrawGrid, or better a virtual TListView, to display the contents of that memory as needed.
The fastest way to use a TStringGrid is using OnGetValue/OnSetValue.
This way only the text of visible cells are requested dynamically.
Adding and removing rows is then lighting fast, otherwise TStringgrid is
very slooow when you have more than 5000 records.
This way I can fill and clear a grid with 700.000 records within a second!
When memory usage is the critical argument, consider using another grid. For example, NLDStringGrid that is (re)written by myself, and which has an additional property called MemoryOptions. It controls whether data can be stored beyond ColCount * RowCount, whether the storage is proportional (less memory usage for partially filled rows and columns), whether to store the Cols and Rows property results and whether the data is stored in sparse manner.
To clear such grid that has moBeyondGrid excluded from the memory options, setting RowCount to FixedRows suffices.
It's open source and downloadable from here.

Delphi: Problems with TList of Frames

I'm having a problem with an interface that consists of a number of frames (normally 25) within a TScrollBox.
There are 2 problems, and I am hoping that one is a consequence of the other...
Background:
When the application starts up, I create 25 frames, each containing approx. 20 controls, which are then populated with the default information. The user can then click on a control to limit the search to a subset of information at which point I free and recreate my frames (as the search may return < 25 records)
The problem:
If I quit the application after the initial search then it takes approx. 5 seconds to return to Delphi. After the 2nd search (and dispose / recreate of frames) it takes approx. 20 seconds)
Whilst I could rewrite the application to only create the frames once, I would like to understand what is going on.
Here is my create routine:
procedure TMF.CreateFrame(i: Integer; var FrameBottom: Integer);
var
NewFrame: TSF;
begin
NewFrame := TSF.Create(Self);
NewFrame.Name := 'SF' + IntToStr(i);
if i = 0 then
NewSF.Top := 8
else
NewSF.Top := FrameBottom + 8;
FrameBottom := NewFrame.Top + NewFrame.Height;
NewFrame.Parent := ScrollBox1;
FrameList.Add(NewFrame);
end;
And here is my delete routine:
procedure TMF.ClearFrames;
var
i: Integer;
SF: TSF;
begin
for i := 0 to MF.FrameList.Count -1 do
begin
SF := FrameList[i];
SF.Free;
end;
FrameList.Clear;
end;
What am I missing?
As you are taking control over the memory allocation of the Frames you are creating by Free'ing them, so there's no need to provide Self as the owner parameter in the create constructor. Pass nil instead to prevent the owner trying to free the frame.
Also, don't like the look of your ClearFrames routine. Try this instead:
while FrameList.count > 0 do
begin
TSF(Framelist[0]).free;
Framelist.delete(0);
end;
Framelist.clear;
If you want to know why your app is taking so long to do something, try profiling it. Try running Sampling Profiler against your program. The helpfile explains how to limit the profiling to only a specific section of your app, which you could use to only get sampling results on the clearing or creating parts. This should show you where you're actually spending most of your time and take a lot of the guesswork out of it.

Resources