From 82aca78edd32579e3ea460bf00932ea36f7e2a14 Mon Sep 17 00:00:00 2001 From: lazarus Date: Wed, 31 Oct 2001 10:38:26 +0000 Subject: [PATCH] MG: fixed sorted customlistbox git-svn-id: trunk@373 - --- lcl/include/customlistbox.inc | 32 +++++++++++++++--- lcl/interfaces/gtk/gtklistsl.inc | 54 ++++++++++++++++++++++++++++--- lcl/interfaces/gtk/gtklistslh.inc | 11 ++++--- 3 files changed, 84 insertions(+), 13 deletions(-) diff --git a/lcl/include/customlistbox.inc b/lcl/include/customlistbox.inc index ade960d24b..19a064f1d2 100644 --- a/lcl/include/customlistbox.inc +++ b/lcl/include/customlistbox.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtklistsl.inc b/lcl/interfaces/gtk/gtklistsl.inc index 9c65bc1cd0..ad2ba60982 100644 --- a/lcl/interfaces/gtk/gtklistsl.inc +++ b/lcl/interfaces/gtk/gtklistsl.inc @@ -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 (m0) 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 diff --git a/lcl/interfaces/gtk/gtklistslh.inc b/lcl/interfaces/gtk/gtklistslh.inc index 9f450c7be8..0aa6e50f84 100644 --- a/lcl/interfaces/gtk/gtklistslh.inc +++ b/lcl/interfaces/gtk/gtklistslh.inc @@ -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