l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/browser/jg_multibox.ml

   1 (*************************************************************************)
   2 (*                                                                       *)
   3 (*                Objective Caml LablTk library                          *)
   4 (*                                                                       *)
   5 (*            Jacques Garrigue, Kyoto University RIMS                    *)
   6 (*                                                                       *)
   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.                                 *)
  12 (*                                                                       *)
  13 (*************************************************************************)
  14
  15 (* $Id: jg_multibox.ml 4144 2001-12-07 13:41:02Z xleroy $ *)
  16
  17 open StdLabels
  18
  19 let rec gen_list ~f:f ~len =
  20   if len = 0 then [] else f () :: gen_list ~f:f ~len:(len - 1)
  21
  22 let rec make_list ~len ~fill =
  23   if len = 0 then [] else fill :: make_list ~len:(len - 1) ~fill
  24
  25 (* By column version
  26 let rec firsts ~len l =
  27   if len = 0 then ([],l) else
  28   match l with
  29     a::l ->
  30       let (f,l) = firsts l len:(len - 1) in
  31       (a::f,l)
  32   | [] ->
  33       (l,[])
  34
  35 let rec split ~len = function
  36     [] -> []
  37   | l ->
  38       let (f,r) = firsts l ~len in
  39       let ret = split ~len r in
  40       f :: ret
  41
  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)
  45 *)
  46
  47 (* By row version *)
  48
  49 let rec first l ~len =
  50   if len = 0 then [], l else
  51   match l with
  52     [] -> make_list ~len ~fill:"", []
  53   | a::l ->
  54       let (l',r) = first ~len:(len - 1) l in a::l',r
  55
  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)
  61
  62
  63 open Tk
  64
  65 class c ~cols ~texts ?maxheight ?width parent = object (self)
  66   val parent' = coe parent
  67   val length = List.length texts
  68   val boxes =
  69     let height = (List.length texts - 1) / cols + 1 in
  70     let height =
  71       match maxheight with None -> height
  72       | Some max -> min max height
  73     in
  74     gen_list ~len:cols ~f:
  75       begin fun () ->
  76         Listbox.create parent ~height ?width
  77           ~highlightthickness:0
  78           ~borderwidth:1
  79       end
  80   val mutable current = 0
  81   method cols = cols
  82   method texts = texts
  83   method parent = parent'
  84   method boxes = boxes
  85   method current = current
  86   method recenter ?(aligntop=false) n =
  87     current <-
  88        if n < 0 then 0 else
  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
  94     List.iter boxes ~f:
  95       begin fun box ->
  96         Listbox.selection_clear box ~first:(`Num 0) ~last:`End;
  97         Listbox.selection_anchor box ~index;
  98         Listbox.activate box ~index
  99       end;
 100     Focus.set box;
 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))
 105   method init =
 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
 111       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))
 118                   +. 0.99)
 119     in
 120     List.iter
 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 ())
 132       end;
 133     self#recenter 0
 134   method bind_mouse ~events ~action =
 135     let i = ref 0 in
 136     List.iter boxes ~f:
 137       begin fun box ->
 138         let b = !i in
 139         bind box ~events ~breakable:true ~fields:[`MouseX;`MouseY]
 140           ~action:(fun ev ->
 141             let `Num n = Listbox.nearest box ~y:ev.ev_MouseY
 142             in action ev ~index:(n * cols + b));
 143         incr i
 144       end
 145   method bind_kbd ~events ~action =
 146     let i = ref 0 in
 147     List.iter boxes ~f:
 148       begin fun box ->
 149         let b = !i in
 150         bind box ~events ~breakable:true ~fields:[`Char]
 151           ~action:(fun ev ->
 152             let `Num n = Listbox.index box ~index:`Active in
 153             action ev ~index:(n * cols + b));
 154         incr i
 155       end
 156 end
 157
 158 let add_scrollbar (box : c) =
 159   let boxes = box#boxes in
 160   let sb =
 161     Scrollbar.create (box#parent)
 162       ~command:(fun ~scroll -> List.iter boxes ~f:(Listbox.yview ~scroll)) in
 163   List.iter boxes
 164     ~f:(fun lb -> Listbox.configure lb ~yscrollcommand:(Scrollbar.set sb));
 165   pack [sb] ~before:(List.hd boxes) ~side:`Right ~fill:`Y;
 166   sb
 167
 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);
 176   match action with
 177     Some action ->
 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 ())
 185   | None -> ()