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
|
(* $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:(`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 (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 -> ()
|
