6 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
7 let sh = float state
.winh
/. sh in
8 let sh = max
sh (float conf
.scrollh
) in
10 let percent = float y
/. float maxy
in
11 let position = (float state
.winh
-. sh) *. percent in
14 if position +. sh > float state
.winh
15 then float state
.winh
-. sh
21 let isbirdseye = function
23 | Textentry _
| View
| LinkNav _
-> false
26 let istextentry = function
28 | Birdseye _
| View
| LinkNav _
-> false
32 if state
.uioh#alwaysscrolly
|| ((conf
.scrollb
land scrollbvv
!= 0)
33 && (state
.maxy
> state
.winh
))
41 else x
> state
.winw
- vscrollw ()
44 let firstof first active
=
45 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
46 then max
0 (active
- (fstate
.maxrows
/2))
50 let calcfirst first active
=
53 let rows = active
- first
in
54 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
59 let len = String.length state
.text
in
60 let x0 = if conf
.leftscroll
then vscrollw () else 0 in
64 | Textentry _
| View
| LinkNav _
->
65 let h, _
, _
= state
.uioh#scrollpw
in
71 x
(float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
72 (x
+.w
) (float (state
.winh
- hscrollh))
75 let w = float (state
.winw
- 1 - vscrollw ()) in
76 if state
.progress
>= 0.0 && state
.progress
< 1.0
78 GlDraw.color
(0.3, 0.3, 0.3);
79 let w1 = w *. state
.progress
in
81 GlDraw.color
(0.0, 0.0, 0.0);
82 rect (float x0+.w1) (float x0+.w-.w1)
85 GlDraw.color
(0.0, 0.0, 0.0);
89 GlDraw.color
(1.0, 1.0, 1.0);
92 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
93 (state
.winh
- hscrollh - 5) s
;
97 | Textentry
((prefix
, text
, _
, _
, _
, _
), _
) ->
100 then Printf.sprintf
"%s%s_ [%s]" prefix text state
.text
101 else Printf.sprintf
"%s%s_" prefix text
105 | Birdseye _
| View
| LinkNav _
-> state
.text
110 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
112 let s1 = "(press 'e' to review error messasges)" in
113 if nonemptystr
s then s ^
" " ^
s1 else s1
122 let textentrykeyboard
123 key mask
((c
, text
, opthist
, onkey
, ondone
, cancelonempty
), onleave
) =
126 state
.mode
<- Textentry
(te
, onleave
);
128 postRedisplay
"textentrykeyboard enttext";
133 | Some
(action
, _
) ->
134 state
.mode
<- Textentry
(
135 (c
, action cmd
, opthist
,
136 onkey
, ondone
, cancelonempty
),
138 postRedisplay
"textentry histaction"
141 let kt = Wsi.kc2kt key
in
142 match [@warning
"-4"] kt with
144 if emptystr text
&& cancelonempty
147 postRedisplay
"textentrykeyboard after cancel";
150 let s = withoutlastutf8 text
in
151 enttext (c
, s, opthist
, onkey
, ondone
, cancelonempty
)
156 postRedisplay
"textentrykeyboard after confirm"
158 | Up
-> histaction HCprev
159 | Down
-> histaction HCnext
160 | Home
-> histaction HCfirst
161 | End
-> histaction HClast
166 begin match opthist
with
168 | Some
(_
, onhistcancel
) -> onhistcancel
()
172 postRedisplay
"textentrykeyboard after cancel2"
174 else enttext (c
, E.s, opthist
, onkey
, ondone
, cancelonempty
)
178 | Insert
when Wsi.withshift mask
->
179 let s = getcmdoutput
(fun s ->
180 prerr_endline
("error pasting: " ^
s)) conf
.pastecmd
in
181 enttext (c
, s, opthist
, onkey
, ondone
, cancelonempty
)
183 | Code _
| Ascii _
->
184 begin match onkey text
kt with
188 postRedisplay
"textentrykeyboard after confirm2";
191 enttext (c
, text
, opthist
, onkey
, ondone
, cancelonempty
);
195 postRedisplay
"textentrykeyboard after cancel3";
198 state
.mode
<- Textentry
(te
, onleave
);
199 postRedisplay
"textentrykeyboard switch";
201 | _
-> vlog
"unhandled key"
204 class type lvsource
=
206 method getitemcount
: int
207 method getitem
: int -> (string * int)
208 method hasaction
: int -> bool
209 method exit
: uioh
:uioh
->
215 method getactive
: int
216 method getfirst
: int
218 method getminfo
: (int * int) array
221 class virtual lvsourcebase
=
223 val mutable m_active
= 0
224 val mutable m_first
= 0
225 val mutable m_pan
= 0
226 method getactive
= m_active
227 method getfirst
= m_first
228 method getpan
= m_pan
229 method getminfo
: (int * int) array
= E.a
232 let coe s = (s :> uioh
);;
234 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
236 val m_pan
= source#getpan
237 val m_first
= source#getfirst
238 val m_active
= source#getactive
240 val m_prev_uioh
= state
.uioh
242 method private elemunder y
=
246 let n = y
/ (fstate
.fontsize
+1) in
247 if m_first
+ n < source#getitemcount
249 if source#hasaction
(m_first
+ n)
250 then Some
(m_first
+ n)
257 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
258 GlDraw.color
(0., 0., 0.) ~alpha
:0.85;
259 filledrect
0. 0. (float state
.winw
) (float state
.winh
);
260 GlDraw.color
(1., 1., 1.);
261 Gl.enable `texture_2d
;
262 let fs = fstate
.fontsize
in
264 let hw = state
.winw
/3 in
265 let ww = fstate
.wwidth
in
266 let tabw = 17.0*.ww in
267 let itemcount = source#getitemcount
in
268 let minfo = source#getminfo
in
272 GlMat.translate ~x
:(float conf
.scrollbw
) ();
274 let x0 = 0.0 and x1
= float (state
.winw
- conf
.scrollbw
- 1) in
276 if not
((row
- m_first
) > fstate
.maxrows
)
278 if row
>= 0 && row
< itemcount
280 let (s, level
) = source#getitem row
in
281 let y = (row
- m_first
) * nfs in
282 let x = 5.0 +. (float (level
+ m_pan
)) *. ww in
285 (let c = if row
land 1 = 0 then 1.0 else 0.92 in (c,c,c));
289 Gl.disable `texture_2d
;
290 let alpha = if source#hasaction row
then 0.9 else 0.3 in
291 GlDraw.color
(1., 1., 1.) ~
alpha;
292 linerect
(x0 +. 1.) (float (y + 1)) (x1
) (float (y + fs + 3));
293 Gl.enable `texture_2d
;
296 if zebra
&& row
land 1 = 1
300 GlDraw.color
(c,c,c);
301 let drawtabularstring s =
303 let x'
= truncate
(x0 +. x) in
304 let s1, s2
= splitatchar
s '
\000'
in
306 then drawstring1
fs x'
(y+nfs) s
312 let s'
= withoutlastutf8
s in
313 let s = s' ^
Utf8syms.ellipsis
in
314 let w = measurestr
fs s in
315 if float x'
+. w +. ww < float (hw + x'
)
320 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
324 ignore
(drawstring1
fs x'
(y+nfs) s1);
325 drawstring1
fs (hw + x'
) (y+nfs) s2
329 let x = if helpmode
&& row
> 0 then x +. ww else x in
330 let s1, s2
= splitatchar
s '
\t'
in
333 let nx = drawstr x s1 in
335 let x = x +. (max
tabw sw) in
338 let len = String.length
s - 2 in
339 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
341 let s = String.sub
s 2 len in
342 let x = if not helpmode
then x +. ww else x in
343 GlDraw.color
(1.2, 1.2, 1.2);
344 let vinc = drawstring1
(fs+fs/4)
345 (truncate
(x -. ww)) (y+nfs) s in
346 GlDraw.color
(1., 1., 1.);
347 vinc +. (float fs *. 0.8)
351 ignore
(drawtabularstring s);
357 GlDraw.color
(1.0, 1.0, 1.0) ~
alpha:0.5;
360 if (row
- m_first
) <= fstate
.maxrows
362 if row
>= 0 && row
< itemcount
364 let (s, level
) = source#getitem row
in
365 let pos0 = Ne.index
s '
\000'
in
366 let y = (row
- m_first
) * nfs in
367 let x = float (level
+ m_pan
) *. ww in
368 let (first
, last
) = minfo.(row
) in
370 if pos0 > 0 && first
> pos0
371 then String.sub
s (pos0+1) (first
-pos0-1)
372 else String.sub
s 0 first
374 let suffix = String.sub
s first
(last
- first
) in
375 let w1 = measurestr fstate
.fontsize
prefix in
376 let w2 = measurestr fstate
.fontsize
suffix in
377 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
378 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
380 and y0
= float (y+2) in
382 and y1
= float (y+fs+3) in
383 filledrect
x0 y0
x1 y1
;
386 Gl.disable `texture_2d
;
387 if Array.length
minfo > 0 then loop m_first
;
392 method nextcurlevel incr
=
393 let len = source#getitemcount
in
395 if m_active
>= 0 && m_active
< len
396 then snd
(source#getitem m_active
)
400 if i
= len then i
-1 else if i
= -1 then 0 else
401 let _, l
= source#getitem i
in
402 if l
<= curlevel then i
else flow (i
+incr
)
404 let active = flow (m_active
+incr
) in
405 let first = calcfirst m_first
active in
406 postRedisplay
"outline nextcurlevel";
407 {< m_active
= active; m_first
= first >}
409 method updownlevel incr
=
410 let len = source#getitemcount
in
412 if m_active
>= 0 && m_active
< len
413 then snd
(source#getitem m_active
)
417 if i
= len then i
-1 else if i
= -1 then 0 else
418 let _, l
= source#getitem i
in
419 if l
!= curlevel then i
else flow (i
+incr
)
421 let active = flow m_active
in
422 let first = calcfirst m_first
active in
423 postRedisplay
"outline updownlevel";
424 {< m_active
= active; m_first
= first >}
426 method private key1 key mask
=
427 let set1 active first qsearch
=
428 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
430 let search active pattern incr
=
431 let active = if active = -1 then m_first
else active in
434 if n >= 0 && n < source#getitemcount
436 let s, _ = source#getitem
n in
437 match Str.search_forward re
s 0 with
438 | exception Not_found
-> loop (n + incr
)
445 let qpat = Str.quote pattern
in
446 match Str.regexp_case_fold
qpat with
449 dolog
"regexp_case_fold for `%S' failed: %S\n" qpat @@
450 Printexc.to_string exn
;
453 let itemcount = source#getitemcount
in
454 let find start incr
=
456 if i
= -1 || i
= itemcount
459 if source#hasaction i
466 let set active first =
467 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
469 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
472 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
474 let incr1 = if incr
> 0 then 1 else -1 in
475 if isvisible m_first m_active
478 let next = m_active
+ incr
in
480 if next < 0 || next >= itemcount
484 if abs
(m_active
- next) > fstate
.maxrows
490 let first = m_first
+ incr
in
491 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
493 let next = m_active
+ incr
in
494 let next = bound
next 0 (itemcount - 1) in
501 if isvisible first next
508 let first = min
next m_first
in
510 if abs
(next - first) > fstate
.maxrows
516 let first = m_first
+ incr
in
517 let first = bound
first 0 (itemcount - 1) in
519 let next = m_active
+ incr
in
520 let next = bound
next 0 (itemcount - 1) in
521 let next = find next incr1 in
523 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
525 let active = if m_active
= -1 then next else m_active
in
530 if isvisible first active
536 postRedisplay
"listview navigate";
540 let kt = Wsi.kc2kt key
in
541 match [@warning
"-4"] kt with
542 | Ascii
(('r'
|'
s'
) as c) when Wsi.withctrl mask
->
543 let incr = if c = 'r'
then -1 else 1 in
545 match search (m_active
+ incr) m_qsearch
incr with
547 state
.text
<- m_qsearch ^
" [not found]";
550 state
.text
<- m_qsearch
;
551 active, firstof m_first
active
553 postRedisplay
"listview ctrl-r/s";
554 set1 active first m_qsearch
;
556 | Insert
when Wsi.withctrl mask
->
557 if m_active
>= 0 && m_active
< source#getitemcount
559 let s, _ = source#getitem m_active
in
560 selstring conf
.selcmd
s;
565 if emptystr m_qsearch
568 let qsearch = withoutlastutf8 m_qsearch
in
572 postRedisplay
"listview empty qsearch";
573 set1 m_active m_first
E.s;
577 match search m_active
qsearch ~
-1 with
579 state
.text
<- qsearch ^
" [not found]";
582 state
.text
<- qsearch;
583 active, firstof m_first
active
585 postRedisplay
"listview backspace qsearch";
586 set1 active first qsearch
589 | Ascii
_ | Code
_ ->
591 match [@warning
"-8"] kt with
592 | Ascii
c -> String.make
1 c
593 | Code code
-> toutf8 code
595 let pattern = m_qsearch ^
utf8 in
597 match search m_active
pattern 1 with
599 state
.text
<- pattern ^
" [not found]";
602 state
.text
<- pattern;
603 active, firstof m_first
active
605 postRedisplay
"listview qsearch add";
606 set1 active first pattern;
610 if emptystr m_qsearch
612 postRedisplay
"list view escape";
614 let mx, my = state.mpos in
617 getoptdef m_prev_uioh
@@
618 source#exit ~uioh
:(coe self
) ~cancel
:true ~
active:m_active
619 ~
first:m_first ~pan
:m_pan
622 postRedisplay
"list view kill qsearch";
623 coe {< m_qsearch
= E.s >}
628 let self = {< m_qsearch
= E.s >} in
630 postRedisplay
"listview enter";
631 let cancel = not
(m_active
>= 0 && m_active
< source#getitemcount
) in
632 source#exit ~uioh
:(coe self) ~
cancel
633 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
635 getoptdef m_prev_uioh
opt
640 | Prior
-> navigate ~
-(fstate
.maxrows
)
641 | Next
-> navigate fstate
.maxrows
645 postRedisplay
"listview right";
646 coe {< m_pan
= m_pan
- 1 >}
650 postRedisplay
"listview left";
651 coe {< m_pan
= m_pan
+ 1 >}
654 let active = find 0 1 in
655 postRedisplay
"listview home";
659 let first = max
0 (itemcount - fstate
.maxrows
) in
660 let active = find (itemcount - 1) ~
-1 in
661 postRedisplay
"listview end";
666 method key key mask
=
667 match state
.mode
with
669 textentrykeyboard key mask te
;
671 | Birdseye
_ | View
| LinkNav
_ -> self#key1 key mask
673 method button button down
x y _ =
676 | 1 when vscrollhit x ->
677 postRedisplay
"listview scroll";
680 let _, position, sh = self#
scrollph in
681 if y > truncate
position && y < truncate
(position +. sh)
683 state
.mstate
<- Mscrolly
;
687 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
688 let first = truncate
(s *. float source#getitemcount
) in
689 let first = min source#getitemcount
first in
690 Some
(coe {< m_first
= first; m_active
= first >})
692 state
.mstate
<- Mnone
;
696 begin match self#elemunder
y with
698 postRedisplay
"listview click";
699 source#exit ~uioh
:(coe {< m_active
= n >})
700 ~
cancel:false ~
active:n ~
first:m_first ~pan
:m_pan
704 | n when (n == 4 || n == 5) && not down
->
705 let len = source#getitemcount
in
707 if n = 5 && m_first
+ fstate
.maxrows
>= len
710 let first = m_first
+ (if n == 4 then -1 else 1) in
711 bound
first 0 (len - 1)
713 postRedisplay
"listview wheel";
714 Some
(coe {< m_first
= first >})
715 | n when (n = 6 || n = 7) && not down
->
716 let inc = if n = 7 then -1 else 1 in
717 postRedisplay
"listview hwheel";
718 Some
(coe {< m_pan
= m_pan
+ inc >})
719 | _ -> Some
(coe self)
721 getoptdef m_prev_uioh
opt
723 method multiclick
_ x y = self#button
1 true x y
726 match state
.mstate
with
728 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
729 let first = truncate
(s *. float source#getitemcount
) in
730 let first = min source#getitemcount
first in
731 postRedisplay
"listview motion";
732 coe {< m_first
= first; m_active
= first >}
741 if x < state
.winw
- conf
.scrollbw
744 match self#elemunder
y with
745 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
746 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
750 then (postRedisplay
"listview pmotion"; {< m_active
= n >})
755 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
759 method infochanged
_ = ()
761 method scrollpw
= (0, 0.0, 0.0)
763 let nfs = fstate
.fontsize
+ 1 in
764 let y = m_first
* nfs in
765 let itemcount = source#getitemcount
in
766 let maxi = max
0 (itemcount - fstate
.maxrows
) in
767 let maxy = maxi * nfs in
768 let p, h = scrollph y maxy in
771 method modehash
= modehash
772 method eformsgs
= false
773 method alwaysscrolly
= true
776 if dy
!= 0 then begin
777 let len = source#getitemcount
in
779 if dy
> 0 && m_first
+ fstate
.maxrows
>= len
782 let first = m_first
+ dy
/ 10 in
783 bound
first 0 (len - 1)
785 postRedisplay
"listview wheel";
786 {< m_first
= first >}
792 method zoom
_ _ _ = ()