1 (*************************************************************************)
3 (* Objective Caml LablTk library *)
5 (* Jacques Garrigue, Kyoto University RIMS *)
7 (* Copyright 1999 Institut National de Recherche en Informatique et *)
8 (* en Automatique and Kyoto University. All rights reserved. *)
9 (* This file is distributed under the terms of the GNU Library *)
10 (* General Public License, with the special exception on linking *)
11 (* described in file ../../../LICENSE. *)
13 (*************************************************************************)
15 (* $Id: jg_multibox.ml 4144 2001-12-07 13:41:02Z xleroy $ *)
19 let rec gen_list ~f:f ~len =
20 if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1)
22 let rec make_list ~len ~fill =
23 if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill
26 let rec firsts ~len l =
27 if len = 0 then ([],l) else
30 let (f,l) = firsts l len:(len - 1) in
35 let rec split ~len = function
38 let (f,r) = firsts l ~len in
39 let ret = split ~len r in
42 let extend l ~len ~fill =
43 if List.length l >= len then l
44 else l @ make_list ~fill len:(len - List.length l)
49 let rec first l ~len =
50 if len = 0 then [], l else
52 [] -> make_list ~len ~fill:"", []
54 let (l',r) = first ~len:(len - 1) l in a::l',r
56 let rec split l ~len =
57 if l = [] then make_list ~len ~fill:[] else
58 let (cars,r) = first l ~len in
59 let cdrs = split r ~len in
60 List.map2 cars cdrs ~f:(fun a l -> a::l)
65 class c ~cols ~texts ?maxheight ?width parent = object (self)
66 val parent' = coe parent
67 val length = List.length texts
69 let height = (List.length texts - 1) / cols + 1 in
71 match maxheight with None -> height
72 | Some max -> min max height
74 gen_list ~len:cols ~f:
76 Listbox.create parent ~height ?width
80 val mutable current = 0
83 method parent = parent'
85 method current = current
86 method recenter ?(aligntop=false) n =
89 if n < length then n else length - 1;
90 (* Activate it, to keep consistent with Up/Down.
91 You have to be in Extended or Browse mode *)
92 let box = List.nth boxes (current mod cols)
93 and index = `Num (current / cols) in
96 Listbox.selection_clear box ~first:(`Num 0) ~last:`End;
97 Listbox.selection_anchor box ~index;
98 Listbox.activate box ~index
101 if aligntop then Listbox.yview_index box ~index
102 else Listbox.see box ~index;
103 let (first,last) = Listbox.yview_get box in
104 List.iter boxes ~f:(Listbox.yview ~scroll:(`Moveto first))
106 let textl = split ~len:cols texts in
107 List.iter2 boxes textl ~f:
108 begin fun box texts ->
109 Jg_bind.enter_focus box;
110 Listbox.insert box ~texts ~index:`End
112 pack boxes ~side:`Left ~expand:true ~fill:`Both;
113 self#bind_mouse ~events:[`ButtonPressDetail 1]
114 ~action:(fun _ ~index:n -> self#recenter n; break ());
115 let current_height () =
116 let (top,bottom) = Listbox.yview_get (List.hd boxes) in
117 truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes))
121 [ "Right", (fun n -> n+1);
122 "Left", (fun n -> n-1);
123 "Up", (fun n -> n-cols);
124 "Down", (fun n -> n+cols);
125 "Prior", (fun n -> n - current_height () * cols);
126 "Next", (fun n -> n + current_height () * cols);
127 "Home", (fun _ -> 0);
128 "End", (fun _ -> List.length texts) ]
129 ~f:begin fun (key,f) ->
130 self#bind_kbd ~events:[`KeyPressDetail key]
131 ~action:(fun _ ~index:n -> self#recenter (f n); break ())
134 method bind_mouse ~events ~action =
139 bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY]
141 let `Num n = Listbox.nearest box ~y:ev.ev_MouseY
142 in action ev ~index:(n * cols + b));
145 method bind_kbd ~events ~action =
150 bind box ~events ~breakable:true ~fields:[`Char]
152 let `Num n = Listbox.index box ~index:`Active in
153 action ev ~index:(n * cols + b));
158 let add_scrollbar (box : c) =
159 let boxes = box#boxes in
161 Scrollbar.create (box#parent)
162 ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in
164 ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb));
165 pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y;
168 let add_completion ?action ?wait (box : c) =
169 let comp = new Jg_completion.timed (box#texts) ?wait in
170 box#bind_kbd ~events:[`KeyPress]
171 ~action:(fun ev ~index ->
172 (* consider only keys producing characters. The callback is called
173 * even if you press Shift. *)
174 if ev.ev_Char <> "" then
175 box#recenter (comp#add ev.ev_Char) ~aligntop:true);
178 box#bind_kbd ~events:[`KeyPressDetail "space"]
179 ~action:(fun ev ~index -> action (box#current));
180 box#bind_kbd ~events:[`KeyPressDetail "Return"]
181 ~action:(fun ev ~index -> action (box#current));
182 box#bind_mouse ~events:[`ButtonPressDetail 1]
183 ~action:(fun ev ~index ->
184 box#recenter index; action (box#current); break ())