1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
|
(*************************************************************************)
(* *)
(* 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 ~f:f ~len =
if len = 0 then [] else f () :: gen_list ~f: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 ~f:(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 ~f:
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 (current mod cols)
and index = `Num (current / cols) in
List.iter boxes ~f:
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 ~f:(Listbox.yview ~scroll:(`Moveto first))
method init =
let textl = split ~len:cols texts in
List.iter2 boxes textl ~f:
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) ]
~f: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 ~f:
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 ~f:
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 ~f:(Listbox.yview ~scroll)) in
List.iter boxes
~f:(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 -> ()
|
