1-----------------------------------------------------------------------
2--          GtkAda - Ada95 binding for the Gimp Toolkit              --
3--                                                                   --
4--   Copyright (C) 1998-2000 E. Briot, J. Brobecker and A. Charlet   --
5--                Copyright (C) 2000-2003 ACT-Europe                 --
6--                                                                   --
7-- This library is free software; you can redistribute it and/or     --
8-- modify it under the terms of the GNU General Public               --
9-- License as published by the Free Software Foundation; either      --
10-- version 2 of the License, or (at your option) any later version.  --
11--                                                                   --
12-- This library is distributed in the hope that it will be useful,   --
13-- but WITHOUT ANY WARRANTY; without even the implied warranty of    --
14-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU --
15-- General Public License for more details.                          --
16--                                                                   --
17-- You should have received a copy of the GNU General Public         --
18-- License along with this library; if not, write to the             --
19-- Free Software Foundation, Inc., 59 Temple Place - Suite 330,      --
20-- Boston, MA 02111-1307, USA.                                       --
21--                                                                   --
22-- As a special exception, if other files instantiate generics from  --
23-- this unit, or you link this unit with other files to produce an   --
24-- executable, this  unit  does not  by itself cause  the resulting  --
25-- executable to be covered by the GNU General Public License. This  --
26-- exception does not however invalidate any other reasons why the   --
27-- executable file  might be covered by the  GNU Public License.     --
28-----------------------------------------------------------------------
29
30with Glib;                use Glib;
31with Gdk;                 use Gdk;
32with Gdk.Color;           use Gdk.Color;
33with Gdk.Pixmap;          use Gdk.Pixmap;
34with Gdk.Bitmap;          use Gdk.Bitmap;
35with Gtk;                 use Gtk;
36with Gtk.Box;             use Gtk.Box;
37with Gtk.Button;          use Gtk.Button;
38with Gtk.Check_Button;    use Gtk.Check_Button;
39with Gtk.Clist;           use Gtk.Clist;
40with Gtk.Enums;           use Gtk.Enums;
41with Gtk.Label;           use Gtk.Label;
42with Gtk.Option_Menu;     use Gtk.Option_Menu;
43with Gtk.Scrolled_Window; use Gtk.Scrolled_Window;
44with Gtk.Handlers;        use Gtk.Handlers;
45with Gtk.Style;           use Gtk.Style;
46with Gtk.Widget;          use Gtk.Widget;
47with Gtkada.Types;        use Gtkada.Types;
48with Pango.Font;          use Pango.Font;
49with Common;              use Common;
50with Interfaces.C.Strings;
51
52package body Create_Clist is
53   package IC renames Interfaces.C;
54   package ICS renames Interfaces.C.Strings;
55
56   package Clist_Cb is new Handlers.Callback (Gtk_Clist_Record);
57   package Check_Cb is new Handlers.User_Callback
58     (Gtk_Check_Button_Record, Gtk_Clist);
59
60   use type Interfaces.C.size_t;
61
62   Clist_Columns      : constant Interfaces.C.size_t := 12;
63   Clist_Rows         : Integer := 0;
64   Style1             : Gtk_Style;
65   Style2             : Gtk_Style;
66   Style3             : Gtk_Style;
67   Clist_Omenu_Group  : Widget_SList.GSlist;
68
69   Titles : constant Chars_Ptr_Array (1 .. Clist_Columns) :=
70     "Auto resize" +
71     "Not resizable" +
72     "Max width 100" +
73     "Min Width 50" +
74     "Hide column" +
75     "Title 5" +
76     "Title 6" +
77     "Title 7" +
78     "Title 8" +
79     "Title 9" +
80     "Title 10" +
81     "Title 11";
82   --  Put at the library level to avoid having to allocate/free the
83   --  memory each time "Run" is called...
84
85   Items : constant Chars_Ptr_Array :=
86     "Single" + "Browse" + "Multiple" + "Extended";
87
88   ----------
89   -- Help --
90   ----------
91
92   function Help return String is
93   begin
94      return "!!!! Consider using a @bGtk_Tree_View@B instead !!!!"
95        & ASCII.LF
96        & ASCII.LF
97        & "An @bGtk_Clist@B is like a @bGtk_List@B, except it shows the"
98        & " information on multiple columns. You can have as many columns"
99        & " as you want, each with its own information."
100        & ASCII.LF
101        & "Each line can have its own user_data, although the interface is"
102        & " different from the standard interface. Some specific functions"
103        & " are provided for this usage. The standard inheritance mechanism"
104        & " does not work for rows in a clist, altough of course it does"
105        & " work for the @bGtk_Clist@B itself.";
106   end Help;
107
108   ----------------
109   -- Clear_List --
110   ----------------
111
112   procedure Clear_List (List : access Gtk_Clist_Record'Class) is
113   begin
114      Clear (List);
115      Clist_Rows := 0;
116   end Clear_List;
117
118   ----------------------
119   -- Remove_Selection --
120   ----------------------
121
122   procedure Remove_Selection (List : access Gtk_Clist_Record'Class) is
123      use Gint_List;
124      I : Gint;
125   begin
126      Freeze (List);
127      loop
128         exit when Length (Get_Selection (List)) = 0;
129         Clist_Rows := Clist_Rows - 1;
130         I := Get_Data (First (Get_Selection (List)));
131         Remove (List, I);
132         exit when Get_Selection_Mode (List) = Selection_Browse;
133      end loop;
134
135      Thaw (List);
136   end Remove_Selection;
137
138   -------------------
139   -- Toggle_Titles --
140   -------------------
141
142   procedure Toggle_Titles (Button : access Gtk_Check_Button_Record'Class;
143                            List : in Gtk_Clist) is
144   begin
145      if Get_Active (Button) then
146         Column_Titles_Show (List);
147      else
148         Column_Titles_Hide (List);
149      end if;
150   end Toggle_Titles;
151
152   ------------------------
153   -- Toggle_Reorderable --
154   ------------------------
155
156   procedure Toggle_Reorderable (Button : access Gtk_Check_Button_Record'Class;
157                                 List : in Gtk_Clist) is
158   begin
159      Set_Reorderable (List, Get_Active (Button));
160   end Toggle_Reorderable;
161
162   -------------
163   -- Add1000 --
164   -------------
165
166   procedure Add1000 (List : access Gtk_Clist_Record'Class) is
167      Pixmap : Gdk.Gdk_Pixmap;
168      Mask   : Gdk.Gdk_Bitmap;
169      Texts  : Chars_Ptr_Array (0 .. Clist_Columns - 1);
170      Row    : Gint;
171      Style  : constant Gtk_Style := Get_Style (List);
172
173   begin
174      Create_From_Xpm_D (Pixmap, Get_Clist_Window (List),
175                         Mask, Get_White (Style),
176                         Gtk_Mini_Xpm);
177      for I in 4 .. Clist_Columns - 1 loop
178         Texts (I) := ICS.New_String ("Column" & IC.size_t'Image (I));
179      end loop;
180      Texts (0 .. 3) := Null_Ptr + "Right" + "Center" + Null_Ptr;
181      Freeze (List);
182
183      for I in 0 .. 999 loop
184         ICS.Free (Texts (0));
185         Texts (0) := ICS.New_String ("CListRow" & Integer'Image (I));
186         Row := Append (List, Texts);
187         Set_Pixtext (List, Row, 3, "gtk+", 5, Pixmap, Mask);
188      end loop;
189      Clist_Rows := Clist_Rows + 1000;
190
191      Free (Texts);
192
193      Thaw (List);
194      Gdk.Pixmap.Unref (Pixmap);
195      Gdk.Bitmap.Unref (Mask);
196   end Add1000;
197
198   --------------
199   -- Add10000 --
200   --------------
201
202   procedure Add10000 (List : access Gtk_Clist_Record'Class) is
203      Texts  : Chars_Ptr_Array (0 .. Clist_Columns - 1);
204      Row    : Gint;
205      pragma Unreferenced (Row);
206
207   begin
208      for I in 3 .. Clist_Columns - 1 loop
209         Texts (I) := ICS.New_String ("Column" & IC.size_t'Image (I));
210      end loop;
211
212      Texts (0 .. 2) := Null_Ptr + "Right" + "Center";
213      Freeze (List);
214
215      for I in 0 .. 9999 loop
216         ICS.Free (Texts (0));
217         Texts (0) := ICS.New_String ("Row" & Integer'Image (I));
218         Row := Append (List, Texts);
219      end loop;
220
221      Clist_Rows := Clist_Rows + 10000;
222      Free (Texts);
223      Thaw (List);
224   end Add10000;
225
226   ----------------
227   -- Insert_Row --
228   ----------------
229
230   procedure Insert_Row (List : access Gtk_Clist_Record'Class) is
231      Texts  : Chars_Ptr_Array (0 .. Clist_Columns - 1) :=
232        "This" + "is an" + "inserted" + "row" +
233        "This" + "is an" + "inserted" + "row" +
234        "This" + "is an" + "inserted" + "row";
235      Col1 : Gdk_Color;
236      Col2 : Gdk_Color;
237      Row  : Gint;
238      Style : constant Gtk_Style := Get_Style (List);
239
240   begin
241      Row := Prepend (List, Texts);
242      if Style1 = Null_Style then
243         Set_Rgb (Col1, 0, 56000, 0);
244         Set_Rgb (Col2, 32000, 0, 56000);
245
246         --  Note that the memory allocated here is never freed in this
247         --  small example!
248         Style1 := Copy (Style);
249         Set_Base (Style1, State_Normal, Col1);
250         Set_Base (Style1, State_Selected, Col2);
251
252         Style2 := Copy (Style);
253         Set_Foreground (Style2, State_Normal, Col1);
254         Set_Foreground (Style2, State_Selected, Col2);
255
256         Style3 := Copy (Style);
257         Set_Foreground (Style3, State_Normal, Col1);
258         Set_Base (Style3, State_Normal, Col2);
259
260         Set_Font_Description (Style3, From_String ("Courier 120"));
261      end if;
262
263      Set_Cell_Style (List, Row, 3, Style1);
264      Set_Cell_Style (List, Row, 4, Style2);
265      Set_Cell_Style (List, Row, 0, Style3);
266      Clist_Rows := Clist_Rows + 1;
267      Free (Texts);
268   end Insert_Row;
269
270   --------------------
271   -- Undo_Selection --
272   --------------------
273
274   procedure Undo_Selection (List : access Gtk_Clist_Record'Class) is
275   begin
276      Gtk.Clist.Undo_Selection (List);
277   end Undo_Selection;
278
279   ------------------
280   -- Click_Column --
281   ------------------
282
283   procedure Click_Column (List   : access Gtk_Clist_Record'Class;
284                           Column : Gint) is
285   begin
286      if Column = 4 then
287         Set_Column_Visibility (List, Column, False);
288      elsif Column = Get_Sort_Column (List) then
289         if Get_Sort_Type (List) = Ascending then
290            Set_Sort_Type (List, Descending);
291         else
292            Set_Sort_Type (List, Ascending);
293         end if;
294      else
295         Set_Sort_Column (List, Column);
296      end if;
297
298      Sort (List);
299   end Click_Column;
300
301   ---------
302   -- Run --
303   ---------
304
305   procedure Run (Frame : access Gtk.Frame.Gtk_Frame_Record'Class) is
306      Texts     : Chars_Ptr_Array (0 .. Clist_Columns - 1);
307      VBox, HBox : Gtk_Box;
308      Clist     : Gtk_Clist;
309      Button    : Gtk_Button;
310      Label     : Gtk_Label;
311      New_Row   : Gint;
312      Scrolled  : Gtk_Scrolled_Window;
313      Check     : Gtk_Check_Button;
314      Omenu     : Gtk_Option_Menu;
315      Col1      : Gdk_Color;
316      Col2      : Gdk_Color;
317      Style     : Gtk_Style;
318      pragma Unreferenced (New_Row);
319
320   begin
321
322      Clist_Rows := 0;
323      Set_Label (Frame, "Clist");
324
325      Gtk_New_Vbox (VBox, False, 0);
326      Add (Frame, VBox);
327
328      Gtk_New (Scrolled);
329      Set_Border_Width (Scrolled, 5);
330      Set_Policy (Scrolled, Policy_Automatic, Policy_Automatic);
331
332      Gtk_New (Clist, Gint (Clist_Columns), Titles);
333      Add (Scrolled, Clist);
334      --  TBD: Callback for click column
335
336      Gtk_New_Hbox (HBox, False, 5);
337      Set_Border_Width (HBox, 5);
338      Pack_Start (VBox, HBox, False, False, 0);
339
340      Clist_Cb.Connect (Clist, "click_column",
341                        Clist_Cb.To_Marshaller (Click_Column'Access));
342
343      Gtk_New (Button, "Insert Row");
344      Pack_Start (HBox, Button, True, True, 0);
345      Clist_Cb.Object_Connect (Button, "clicked",
346                               Clist_Cb.To_Marshaller (Insert_Row'Access),
347                               Slot_Object => Clist);
348
349      Gtk_New (Button, "Add 1000 Rows with Pixmaps");
350      Pack_Start (HBox, Button, True, True, 0);
351      Clist_Cb.Object_Connect (Button, "clicked",
352                               Clist_Cb.To_Marshaller (Add1000'Access),
353                               Slot_Object => Clist);
354
355      Gtk_New (Button, "Add 10000 Rows");
356      Pack_Start (HBox, Button, True, True, 0);
357      Clist_Cb.Object_Connect (Button, "clicked",
358                               Clist_Cb.To_Marshaller (Add10000'Access),
359                               Slot_Object => Clist);
360
361      --  Second layer of buttons
362      Gtk_New_Hbox (HBox, False, 5);
363      Set_Border_Width (HBox, 5);
364      Pack_Start (VBox, HBox, False, False, 0);
365
366      Gtk_New (Button, "Clear List");
367      Pack_Start (HBox, Button, True, True, 0);
368      Clist_Cb.Object_Connect (Button, "clicked",
369                               Clist_Cb.To_Marshaller (Clear_List'Access),
370                               Slot_Object => Clist);
371
372      Gtk_New (Button, "Remove Selection");
373      Pack_Start (HBox, Button, True, True, 0);
374      Clist_Cb.Object_Connect
375        (Button, "clicked",
376         Clist_Cb.To_Marshaller (Remove_Selection'Access),
377         Slot_Object => Clist);
378
379      Gtk_New (Button, "Undo Selection");
380      Pack_Start (HBox, Button, True, True, 0);
381      Clist_Cb.Object_Connect
382        (Button, "clicked",
383         Clist_Cb.To_Marshaller (Undo_Selection'Access),
384         Slot_Object => Clist);
385
386      --  TBD??? Warning tests button
387
388      --  Third layer of buttons
389      Gtk_New_Hbox (HBox, False, 5);
390      Set_Border_Width (HBox, 5);
391      Pack_Start (VBox, HBox, False, False, 0);
392
393      Gtk_New (Check, "Toggle title Buttons");
394      Pack_Start (HBox, Check, True, True, 0);
395      Check_Cb.Connect (Check, "clicked",
396                        Check_Cb.To_Marshaller (Toggle_Titles'Access),
397                        Clist);
398      Set_Active (Check, True);
399
400      Gtk_New (Check, "Reorderable");
401      Pack_Start (HBox, Check, True, True, 0);
402      Check_Cb.Connect
403        (Check, "clicked",
404         Check_Cb.To_Marshaller (Toggle_Reorderable'Access),
405         Clist);
406      Set_Active (Check, True);
407
408      Gtk_New (Label, "Selection_Mode :");
409      Pack_Start (HBox, Label, False, True, 0);
410
411      Clist_Omenu_Group := Widget_SList.Null_List;
412      Build_Option_Menu (Omenu, Clist_Omenu_Group, Items, 0, null);
413      --  FIXME: Add the missing callback (instead of null).
414      Pack_Start (HBox, Omenu, False, True, 0);
415
416      Pack_Start (VBox, Scrolled, True, True, 0);
417      Set_Row_Height (Clist, 18);
418      Set_USize (Clist, -1, 300);
419
420      for I in 0 .. Clist_Columns - 1 loop
421         Set_Column_Width (Clist, Gint (I), 80);
422      end loop;
423
424      Set_Column_Auto_Resize (Clist, 0, True);
425      Set_Column_Resizeable (Clist, 1, False);
426      Set_Column_Max_Width (Clist, 2, 100);
427      Set_Column_Min_Width (Clist, 3, 50);
428      Set_Selection_Mode (Clist, Selection_Multiple);
429      Set_Column_Justification (Clist, 1, Justify_Right);
430      Set_Column_Justification (Clist, 2, Justify_Center);
431
432      for I in 1 .. Clist_Columns - 1 loop
433            Texts (I) := ICS.New_String ("Columns " & IC.size_t'Image (I));
434      end loop;
435
436      Set_Rgb (Col1, 56000, 0, 0);
437      Set_Rgb (Col2, 0, 56000, 32000);
438
439      Gtk_New (Style);
440      Set_Foreground (Style, State_Normal, Col1);
441      Set_Base (Style, State_Normal, Col2);
442      Set_Font_Description (Style, From_String ("Helvetica Bold 14"));
443
444      for I in Gint'(0) .. 9 loop
445         Texts (0) :=
446           ICS.New_String ("ClistRow " & Integer'Image (Clist_Rows));
447         Clist_Rows := Clist_Rows + 1;
448         New_Row := Append (Clist, Texts);
449         ICS.Free (Texts (0));
450         if I mod 4 = 2 then
451            Set_Row_Style (Clist, I, Style);
452         else
453            Set_Cell_Style (Clist, I, I mod 4, Style);
454         end if;
455      end loop;
456
457      Show_All (Frame);
458   end Run;
459
460end Create_Clist;
461