paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-28 18:40:52 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: fixed sorted customlistbox

Browse Source 
git-svn-id: trunk@373 -
This commit is contained in:
lazarus 2001-10-31 10:38:26 +00:00
parent 00dc711489
commit 82aca78edd
3 changed files with 84 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
lcl/include/customlistbox.inc
View File

@ -1,10 +1,22 @@
// included by stdctrls.pp
{ if not HandleAllocated then
FItems contains a normal TStringList
else
FItems contains an interface specific TStrings descendent
}
{------------------------------------------------------------------------------}
{ procedure TCustomListBox.CreateHandle }
{------------------------------------------------------------------------------}
procedure TCustomListBox.CreateHandle;
var NewStrings : TStrings;
begin
//writeln('[TCustomListBox.CreateHandle] A ',FItems.ClassName);
inherited CreateHandle;
//writeln('[TCustomListBox.CreateHandle] B ',FItems.ClassName);
// create
NewStrings:= TStrings(Pointer(CNSendMessage(LM_GETITEMS, Self, nil)));
NewStrings.Assign(Items);
FItems.Free;
@ -12,6 +24,7 @@ begin
{ Sync other properties }
CNSendMessage(LM_SETBORDER, Self, nil);
UpdateSelectionMode;
//writeln('[TCustomListBox.CreateHandle] END ',FItems.ClassName);
end;
{------------------------------------------------------------------------------}
@ -20,11 +33,14 @@ end;
procedure TCustomListBox.DestroyHandle;
var NewStrings : TStrings;
begin
//writeln('[TCustomListBox.DestroyHandle] A ',FItems.ClassName);
NewStrings:= TStringList.Create;
NewStrings.Assign(Items);
FItems.Free;
FItems:= NewStrings;
//writeln('[TCustomListBox.DestroyHandle] B ',FItems.ClassName);
inherited DestroyHandle;
//writeln('[TCustomListBox.DestroyHandle] END ',FItems.ClassName);
end;
{------------------------------------------------------------------------------}
@ -77,7 +93,8 @@ end;
procedure TCustomListBox.SetSelected(Index : integer; Val : boolean);
var Message : TLMSetSel;
begin
if (Index < 0) or (Index >= Items.Count) then raise Exception.Create('List index out of bounds');
if (Index < 0) or (Index >= Items.Count) then
raise Exception.Create('List index out of bounds');
HandleNeeded;
Message.Index:= Index;
Message.Selected:= Val;
@ -89,7 +106,8 @@ end;
{------------------------------------------------------------------------------}
function TCustomListBox.GetSelected(Index : integer) : boolean;
begin
if (Index < 0) or (Index >= Items.Count) then raise Exception.Create('List index out of bound.');
if (Index < 0) or (Index >= Items.Count) then
raise Exception.Create('List index out of bound.');
Result:= (CNSendMessage(LM_GETSEL, Self, @Index) >= 0);
end;
@ -133,7 +151,8 @@ end;
{------------------------------------------------------------------------------}
procedure TCustomListBox.SetItems(Value : TStrings);
begin
if Value <> FItems then begin
if (Value <> FItems) then begin
//writeln('[TCustomListBox.SetItems] A FItems=',FItems.ClassName,' Value=',Value.ClassName);
FItems.Assign(Value);
end;
end;
@ -156,19 +175,23 @@ end;
{------------------------------------------------------------------------------}
destructor TCustomListBox.Destroy;
begin
if FItems <> nil then FItems.Free;
inherited Destroy;
FItems.Free;
end;
function TCustomListBox.GetItemIndex : integer;
begin
//writeln('[TCustomListBox.GetItemIndex] A ',FItems.ClassName);
Result:= CNSendMessage(LM_GETITEMINDEX, Self, nil);
//writeln('[TCustomListBox.GetItemIndex] END ');
end;
procedure TCustomListBox.SetItemIndex(Val : integer);
begin
if (Val < 0) or (Val >= FItems.Count) then raise Exception.Create('Out of bounds');
//writeln('[TCustomListBox.SetItemIndex] A ',FItems.ClassName,' ',Val);
CNSendMessage(LM_SETITEMINDEX, Self, Pointer(Val));
//writeln('[TCustomListBox.SetItemIndex] END ',FItems.ClassName);
end;
{------------------------------------------------------------------------------}
@ -180,3 +203,4 @@ begin
end;
// back to stdctrls.pp

54
lcl/interfaces/gtk/gtklistsl.inc
View File

@ -20,11 +20,12 @@ var AStr, BStr : PChar;
begin
gtk_label_get(PGtkLabel(PGtkBin(a)^.child), @AStr);
gtk_label_get(PGtkLabel(PGtkBin(b)^.child), @BStr);
//writeln('DefaultCompareFunc "',AStr,'" "',BStr,'"');
Result:= strcomp(AStr, BStr);
end;
{*************************************************************}
{ TGtkListStringList methods }
{ TGtkListStringList methods }
{*************************************************************}
{------------------------------------------------------------------------------
@ -50,7 +51,7 @@ procedure TGtkListStringList.SetSorted(Val : boolean);
begin
if Val <> FSorted then begin
FSorted:= Val;
Sort;
if FSorted then Sort;
end;
end;
@ -61,8 +62,17 @@ end;
------------------------------------------------------------------------------}
procedure TGtkListStringList.Sort;
var sl: TStringList;
begin
FGtkList^.children:= g_list_sort(FGtkList^.children, @DefaultCompareFunc);
// sort internally (sorting in the widget would be slow and unpretty ;)
sl:=TStringList.Create;
sl.Assign(Self);
sl.Sort; // currently this is quicksort ->
// Disadvantages: - worst case on sorted list
// - not keeping order
// ToDo: replace by mergesort and add customsort
Assign(sl);
sl.Free;
end;
{------------------------------------------------------------------------------
@ -74,12 +84,15 @@ end;
procedure TGtkListStringList.Assign(Source : TPersistent);
var Counter : integer;
begin
if (Source=Self) or (Source=nil) then exit;
//writeln('[TGtkListStringList.Assign] A ',Source.Classname);
{ Do not call inherited Assign as it does things we do not want to happen }
if Source is TStrings then begin
Clear;
for Counter:= TStrings(Source).Count - 1 downto 0 do
Insert(0, TStrings(Source)[Counter]);
end else inherited Assign(Source);
//writeln('[TGtkListStringList.Assign] END ',Source.Classname);
end;
{------------------------------------------------------------------------------
@ -93,11 +106,17 @@ var Item : PChar;
ALabel : PGtkWidget;
ListItem : PGtkListItem;
begin
//writeln('[TGtkListStringList.Get] Index=',Index,' Count=',Count);
if (Index < 0) or (Index >= Count) then raise Exception.Create('Out of bounds.')
else begin
if FGtkList=nil then begin
Result:='';
exit;
end;
ListItem:= g_list_nth_data(FGtkList^.children, Index);
ALabel:= PGtkBin(ListItem)^.child;
if ALabel = nil then Result:= ''
if ALabel = nil then
Result:= ''
else begin
Item:=nil;
gtk_label_get (PGtkLabel(ALabel), @Item);
@ -148,13 +167,35 @@ end;
------------------------------------------------------------------------------}
procedure TGtkListStringList.Insert(Index : integer; const S : string);
var li : PGtkWidget;
l, m, r, cmp: integer;
begin
//writeln('[TGtkListStringList.Insert] Index=',Index,' Count=',Count,' ',S);
if FSorted then begin
l:=0;
r:=Count-1;
m:=l;
while (l<=r) do begin
m:=(l+r) shr 1;
cmp:=AnsiCompareText(S,Strings[m]);
if cmp<0 then
r:=m-1
else if cmp>0 then
l:=m+1
else
break;
end;
if (m<Count) and (AnsiCompareText(S,Strings[m])>0) then
inc(m);
Index:=m;
end;
if (Index < 0) or (Index > Count) then raise Exception.Create('Out of bounds.');
li:= gtk_list_item_new_with_label(PChar(S));
gtk_widget_show(li);
gtk_list_insert_items(FGtkList, g_list_append(nil, li), Index);
if FSorted then Sort;
end;
{*************************************************************}
{ TGtkCListStringList methods }
{*************************************************************}
@ -335,6 +376,9 @@ end;
{ =============================================================================
$Log$
Revision 1.3 2001/10/31 10:38:26 lazarus
MG: fixed sorted customlistbox
Revision 1.2 2001/09/30 08:34:52 lazarus
MG: fixed mem leaks and fixed range check errors

11
lcl/interfaces/gtk/gtklistslh.inc
View File

@ -18,15 +18,15 @@ type
protected
function Get(Index : Integer) : string; override;
function GetCount : integer; override;
procedure SetSorted(Val : boolean); virtual;
public
procedure SetSorted(Val : boolean); virtual;
public
constructor Create(List : PGtkList);
procedure Assign(Source : TPersistent); override;
procedure Clear; override;
procedure Delete(Index : integer); override;
procedure Insert(Index : integer; const S: string); override;
procedure Sort; virtual;
property Sorted : boolean read FSorted write SetSorted;
procedure Sort; virtual;
property Sorted : boolean read FSorted write SetSorted;
end;
TGtkCListStringList = class(TStrings)
@ -58,6 +58,9 @@ type
{ =============================================================================
$Log$
Revision 1.2 2001/10/31 10:38:26 lazarus
MG: fixed sorted customlistbox
Revision 1.1 2000/07/13 10:28:29 michael
+ Initial import