ocaml/otherlibs/labltk/browser/jg_multibox.ml

(*************************************************************************)
(*                                                                       *)
(*                Objective Caml LablTk library                          *)
(*                                                                       *)
(*            Jacques Garrigue, Kyoto University RIMS                    *)
(*                                                                       *)
(*   Copyright 1999 Institut National de Recherche en Informatique et    *)
(*   en Automatique and Kyoto University.  All rights reserved.          *)
(*   This file is distributed under the terms of the GNU Library         *)
(*   General Public License.                                             *)
(*                                                                       *)
(*************************************************************************)

(* $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 :cols :texts ?:maxheight ?:width parent = 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:0
          borderwidth: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 breakable:true fields:[`MouseX;`MouseY]
          action:(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 breakable:true fields:[`Char]
          action:(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 (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 -> ()