diff options
Diffstat (limited to 'otherlibs/labltk/browser/jg_multibox.ml')
| -rw-r--r-- | otherlibs/labltk/browser/jg_multibox.ml | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml new file mode 100644 index 000000000..161e21534 --- /dev/null +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -0,0 +1,169 @@ +(* $Id$ *) + +let rec gen_list fun:f :len = + if len = 0 then [] else f () :: gen_list fun:f len:(len - 1) + +let rec make_list :len :fill = + if len = 0 then [] else fill :: make_list len:(len - 1) :fill + +(* By column version +let rec firsts :len l = + if len = 0 then ([],l) else + match l with + a::l -> + let (f,l) = firsts l len:(len - 1) in + (a::f,l) + | [] -> + (l,[]) + +let rec split :len = function + [] -> [] + | l -> + let (f,r) = firsts l :len in + let ret = split :len r in + f :: ret + +let extend l :len :fill = + if List.length l >= len then l + else l @ make_list :fill len:(len - List.length l) +*) + +(* By row version *) + +let rec first l :len = + if len = 0 then [], l else + match l with + [] -> make_list :len fill:"", [] + | a::l -> + let (l',r) = first len:(len - 1) l in a::l',r + +let rec split l :len = + if l = [] then make_list :len fill:[] else + let (cars,r) = first l :len in + let cdrs = split r :len in + List.map2 cars cdrs fun:(fun a l -> a::l) + + +open Tk + +class c :parent :cols :texts ?:maxheight ?:width () = object (self) + val parent' = coe parent + val length = List.length texts + val boxes = + let height = (List.length texts - 1) / cols + 1 in + let height = + match maxheight with None -> height + | Some max -> min max height + in + gen_list len:cols fun: + begin fun () -> + Listbox.create :parent :height ?:width + highlightthickness:(`Pix 0) + borderwidth:(`Pix 1) () + end + val mutable current = 0 + method cols = cols + method texts = texts + method parent = parent' + method boxes = boxes + method current = current + method recenter?:aligntop{=false} n = + current <- + if n < 0 then 0 else + if n < length then n else length - 1; + (* Activate it, to keep consistent with Up/Down. + You have to be in Extended or Browse mode *) + let box = List.nth boxes pos:(current mod cols) + and index = `Num (current / cols) in + List.iter boxes fun: + begin fun box -> + Listbox.selection_clear box first:(`Num 0) last:`End; + Listbox.selection_anchor box :index; + Listbox.activate box :index + end; + Focus.set box; + if aligntop then Listbox.yview_index box :index + else Listbox.see box :index; + let (first,last) = Listbox.yview_get box in + List.iter boxes fun:(Listbox.yview scroll:(`Moveto first)) + method init = + let textl = split len:cols texts in + List.iter2 boxes textl fun: + begin fun box texts -> + Jg_bind.enter_focus box; + Listbox.insert box :texts index:`End + end; + pack boxes side:`Left expand:true fill:`Both; + self#bind_mouse events:[[],`ButtonPressDetail 1] + action:(fun _ index:n -> self#recenter n; break ()); + let current_height () = + let (top,bottom) = Listbox.yview_get (List.hd boxes) in + truncate ((bottom -. top) *. float (Listbox.size (List.hd boxes)) + +. 0.99) + in + List.iter + [ "Right", (fun n -> n+1); + "Left", (fun n -> n-1); + "Up", (fun n -> n-cols); + "Down", (fun n -> n+cols); + "Prior", (fun n -> n - current_height () * cols); + "Next", (fun n -> n + current_height () * cols); + "Home", (fun _ -> 0); + "End", (fun _ -> List.length texts) ] + fun:begin fun (key,f) -> + self#bind_kbd events:[[],`KeyPressDetail key] + action:(fun _ index:n -> self#recenter (f n); break ()) + end; + self#recenter 0 + method bind_mouse :events :action = + let i = ref 0 in + List.iter boxes fun: + begin fun box -> + let b = !i in + bind box :events + action:(`Setbreakable ([`MouseX;`MouseY], fun ev -> + let `Num n = Listbox.nearest box y:ev.ev_MouseY + in action ev index:(n * cols + b))); + incr i + end + method bind_kbd :events :action = + let i = ref 0 in + List.iter boxes fun: + begin fun box -> + let b = !i in + bind box :events + action:(`Setbreakable ([`Char], fun ev -> + let `Num n = Listbox.index box index:`Active in + action ev index:(n * cols + b))); + incr i + end +end + +let add_scrollbar (box : c) = + let boxes = box#boxes in + let sb = + Scrollbar.create parent:(box#parent) () + command:(fun :scroll -> List.iter boxes fun:(Listbox.yview :scroll)) in + List.iter boxes + fun:(fun lb -> Listbox.configure lb yscrollcommand:(Scrollbar.set sb)); + pack [sb] before:(List.hd boxes) side:`Right fill:`Y; + sb + +let add_completion ?:action ?:wait (box : c) = + let comp = new Jg_completion.timed (box#texts) ?:wait in + box#bind_kbd events:[[], `KeyPress] + action:(fun ev :index -> + (* consider only keys producing characters. The callback is called + * even if you press Shift. *) + if ev.ev_Char <> "" then + box#recenter (comp#add ev.ev_Char) aligntop:true); + match action with + Some action -> + box#bind_kbd events:[[], `KeyPressDetail "space"] + action:(fun ev :index -> action (box#current)); + box#bind_kbd events:[[], `KeyPressDetail "Return"] + action:(fun ev :index -> action (box#current)); + box#bind_mouse events:[[], `ButtonPressDetail 1] + action:(fun ev :index -> + box#recenter index; action (box#current); break ()) + | None -> () |