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 | Code _
| Ascii _
->
179 begin match onkey text
kt with
183 postRedisplay
"textentrykeyboard after confirm2";
186 enttext (c
, text
, opthist
, onkey
, ondone
, cancelonempty
);
190 postRedisplay
"textentrykeyboard after cancel3";
193 state
.mode
<- Textentry
(te
, onleave
);
194 postRedisplay
"textentrykeyboard switch";
196 | _
-> vlog
"unhandled key"
199 class type lvsource
=
201 method getitemcount
: int
202 method getitem
: int -> (string * int)
203 method hasaction
: int -> bool
204 method exit
: uioh
:uioh
->
210 method getactive
: int
211 method getfirst
: int
213 method getminfo
: (int * int) array
216 class virtual lvsourcebase
=
218 val mutable m_active
= 0
219 val mutable m_first
= 0
220 val mutable m_pan
= 0
221 method getactive
= m_active
222 method getfirst
= m_first
223 method getpan
= m_pan
224 method getminfo
: (int * int) array
= E.a
227 let coe s = (s :> uioh
);;
229 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
231 val m_pan
= source#getpan
232 val m_first
= source#getfirst
233 val m_active
= source#getactive
235 val m_prev_uioh
= state
.uioh
237 method private elemunder y
=
241 let n = y
/ (fstate
.fontsize
+1) in
242 if m_first
+ n < source#getitemcount
244 if source#hasaction
(m_first
+ n)
245 then Some
(m_first
+ n)
252 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
253 GlDraw.color
(0., 0., 0.) ~alpha
:0.85;
254 filledrect
0. 0. (float state
.winw
) (float state
.winh
);
255 GlDraw.color
(1., 1., 1.);
256 Gl.enable `texture_2d
;
257 let fs = fstate
.fontsize
in
259 let hw = state
.winw
/3 in
260 let ww = fstate
.wwidth
in
261 let tabw = 17.0*.ww in
262 let itemcount = source#getitemcount
in
263 let minfo = source#getminfo
in
267 GlMat.translate ~x
:(float conf
.scrollbw
) ();
269 let x0 = 0.0 and x1
= float (state
.winw
- conf
.scrollbw
- 1) in
271 if not
((row
- m_first
) > fstate
.maxrows
)
273 if row
>= 0 && row
< itemcount
275 let (s, level
) = source#getitem row
in
276 let y = (row
- m_first
) * nfs in
277 let x = 5.0 +. (float (level
+ m_pan
)) *. ww in
280 (let c = if row
land 1 = 0 then 1.0 else 0.92 in (c,c,c));
284 Gl.disable `texture_2d
;
285 let alpha = if source#hasaction row
then 0.9 else 0.3 in
286 GlDraw.color
(1., 1., 1.) ~
alpha;
287 linerect
(x0 +. 1.) (float (y + 1)) (x1
) (float (y + fs + 3));
288 Gl.enable `texture_2d
;
291 if zebra
&& row
land 1 = 1
295 GlDraw.color
(c,c,c);
296 let drawtabularstring s =
298 let x'
= truncate
(x0 +. x) in
299 let s1, s2
= splitatchar
s '
\000'
in
301 then drawstring1
fs x'
(y+nfs) s
307 let s'
= withoutlastutf8
s in
308 let s = s' ^
Utf8syms.ellipsis
in
309 let w = measurestr
fs s in
310 if float x'
+. w +. ww < float (hw + x'
)
315 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
319 ignore
(drawstring1
fs x'
(y+nfs) s1);
320 drawstring1
fs (hw + x'
) (y+nfs) s2
324 let x = if helpmode
&& row
> 0 then x +. ww else x in
325 let s1, s2
= splitatchar
s '
\t'
in
328 let nx = drawstr x s1 in
330 let x = x +. (max
tabw sw) in
333 let len = String.length
s - 2 in
334 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
336 let s = String.sub
s 2 len in
337 let x = if not helpmode
then x +. ww else x in
338 GlDraw.color
(1.2, 1.2, 1.2);
339 let vinc = drawstring1
(fs+fs/4)
340 (truncate
(x -. ww)) (y+nfs) s in
341 GlDraw.color
(1., 1., 1.);
342 vinc +. (float fs *. 0.8)
346 ignore
(drawtabularstring s);
352 GlDraw.color
(1.0, 1.0, 1.0) ~
alpha:0.5;
355 if (row
- m_first
) <= fstate
.maxrows
357 if row
>= 0 && row
< itemcount
359 let (s, level
) = source#getitem row
in
360 let pos0 = Ne.index
s '
\000'
in
361 let y = (row
- m_first
) * nfs in
362 let x = float (level
+ m_pan
) *. ww in
363 let (first
, last
) = minfo.(row
) in
365 if pos0 > 0 && first
> pos0
366 then String.sub
s (pos0+1) (first
-pos0-1)
367 else String.sub
s 0 first
369 let suffix = String.sub
s first
(last
- first
) in
370 let w1 = measurestr fstate
.fontsize
prefix in
371 let w2 = measurestr fstate
.fontsize
suffix in
372 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
373 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
375 and y0
= float (y+2) in
377 and y1
= float (y+fs+3) in
378 filledrect
x0 y0
x1 y1
;
381 Gl.disable `texture_2d
;
382 if Array.length
minfo > 0 then loop m_first
;
387 method updownlevel incr
=
388 let len = source#getitemcount
in
390 if m_active
>= 0 && m_active
< len
391 then snd
(source#getitem m_active
)
395 if i
= len then i
-1 else if i
= -1 then 0 else
396 let _, l
= source#getitem i
in
397 if l
!= curlevel then i
else flow (i
+incr
)
399 let active = flow m_active
in
400 let first = calcfirst m_first
active in
401 postRedisplay
"outline updownlevel";
402 {< m_active
= active; m_first
= first >}
404 method private key1 key mask
=
405 let set1 active first qsearch
=
406 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
408 let search active pattern incr
=
409 let active = if active = -1 then m_first
else active in
412 if n >= 0 && n < source#getitemcount
414 let s, _ = source#getitem
n in
415 match Str.search_forward re
s 0 with
416 | exception Not_found
-> loop (n + incr
)
423 let qpat = Str.quote pattern
in
424 match Str.regexp_case_fold
qpat with
427 dolog
"regexp_case_fold for `%S' failed: %S\n" qpat @@
428 Printexc.to_string exn
;
431 let itemcount = source#getitemcount
in
432 let find start incr
=
434 if i
= -1 || i
= itemcount
437 if source#hasaction i
444 let set active first =
445 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
447 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
450 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
452 let incr1 = if incr
> 0 then 1 else -1 in
453 if isvisible m_first m_active
456 let next = m_active
+ incr
in
458 if next < 0 || next >= itemcount
462 if abs
(m_active
- next) > fstate
.maxrows
468 let first = m_first
+ incr
in
469 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
471 let next = m_active
+ incr
in
472 let next = bound
next 0 (itemcount - 1) in
479 if isvisible first next
486 let first = min
next m_first
in
488 if abs
(next - first) > fstate
.maxrows
494 let first = m_first
+ incr
in
495 let first = bound
first 0 (itemcount - 1) in
497 let next = m_active
+ incr
in
498 let next = bound
next 0 (itemcount - 1) in
499 let next = find next incr1 in
501 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
503 let active = if m_active
= -1 then next else m_active
in
508 if isvisible first active
514 postRedisplay
"listview navigate";
518 let kt = Wsi.kc2kt key
in
519 match [@warning
"-4"] kt with
520 | Ascii
(('r'
|'
s'
) as c) when Wsi.withctrl mask
->
521 let incr = if c = 'r'
then -1 else 1 in
523 match search (m_active
+ incr) m_qsearch
incr with
525 state
.text
<- m_qsearch ^
" [not found]";
528 state
.text
<- m_qsearch
;
529 active, firstof m_first
active
531 postRedisplay
"listview ctrl-r/s";
532 set1 active first m_qsearch
;
534 | Insert
when Wsi.withctrl mask
->
535 if m_active
>= 0 && m_active
< source#getitemcount
537 let s, _ = source#getitem m_active
in
538 selstring conf
.selcmd
s;
543 if emptystr m_qsearch
546 let qsearch = withoutlastutf8 m_qsearch
in
550 postRedisplay
"listview empty qsearch";
551 set1 m_active m_first
E.s;
555 match search m_active
qsearch ~
-1 with
557 state
.text
<- qsearch ^
" [not found]";
560 state
.text
<- qsearch;
561 active, firstof m_first
active
563 postRedisplay
"listview backspace qsearch";
564 set1 active first qsearch
567 | Ascii
_ | Code
_ ->
569 match [@warning
"-8"] kt with
570 | Ascii
c -> String.make
1 c
571 | Code code
-> toutf8 code
573 let pattern = m_qsearch ^
utf8 in
575 match search m_active
pattern 1 with
577 state
.text
<- pattern ^
" [not found]";
580 state
.text
<- pattern;
581 active, firstof m_first
active
583 postRedisplay
"listview qsearch add";
584 set1 active first pattern;
588 if emptystr m_qsearch
590 postRedisplay
"list view escape";
592 let mx, my = state.mpos in
595 getoptdef m_prev_uioh
@@
596 source#exit ~uioh
:(coe self
) ~cancel
:true ~
active:m_active
597 ~
first:m_first ~pan
:m_pan
600 postRedisplay
"list view kill qsearch";
601 coe {< m_qsearch
= E.s >}
606 let self = {< m_qsearch
= E.s >} in
608 postRedisplay
"listview enter";
609 let cancel = not
(m_active
>= 0 && m_active
< source#getitemcount
) in
610 source#exit ~uioh
:(coe self) ~
cancel
611 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
613 getoptdef m_prev_uioh
opt
618 | Prior
-> navigate ~
-(fstate
.maxrows
)
619 | Next
-> navigate fstate
.maxrows
623 postRedisplay
"listview right";
624 coe {< m_pan
= m_pan
- 1 >}
628 postRedisplay
"listview left";
629 coe {< m_pan
= m_pan
+ 1 >}
632 let active = find 0 1 in
633 postRedisplay
"listview home";
637 let first = max
0 (itemcount - fstate
.maxrows
) in
638 let active = find (itemcount - 1) ~
-1 in
639 postRedisplay
"listview end";
644 method key key mask
=
645 match state
.mode
with
647 textentrykeyboard key mask te
;
649 | Birdseye
_ | View
| LinkNav
_ -> self#key1 key mask
651 method button button down
x y _ =
654 | 1 when vscrollhit x ->
655 postRedisplay
"listview scroll";
658 let _, position, sh = self#
scrollph in
659 if y > truncate
position && y < truncate
(position +. sh)
661 state
.mstate
<- Mscrolly
;
665 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
666 let first = truncate
(s *. float source#getitemcount
) in
667 let first = min source#getitemcount
first in
668 Some
(coe {< m_first
= first; m_active
= first >})
670 state
.mstate
<- Mnone
;
674 begin match self#elemunder
y with
676 postRedisplay
"listview click";
677 source#exit ~uioh
:(coe {< m_active
= n >})
678 ~
cancel:false ~
active:n ~
first:m_first ~pan
:m_pan
682 | n when (n == 4 || n == 5) && not down
->
683 let len = source#getitemcount
in
685 if n = 5 && m_first
+ fstate
.maxrows
>= len
688 let first = m_first
+ (if n == 4 then -1 else 1) in
689 bound
first 0 (len - 1)
691 postRedisplay
"listview wheel";
692 Some
(coe {< m_first
= first >})
693 | n when (n = 6 || n = 7) && not down
->
694 let inc = if n = 7 then -1 else 1 in
695 postRedisplay
"listview hwheel";
696 Some
(coe {< m_pan
= m_pan
+ inc >})
697 | _ -> Some
(coe self)
699 getoptdef m_prev_uioh
opt
701 method multiclick
_ x y = self#button
1 true x y
704 match state
.mstate
with
706 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
707 let first = truncate
(s *. float source#getitemcount
) in
708 let first = min source#getitemcount
first in
709 postRedisplay
"listview motion";
710 coe {< m_first
= first; m_active
= first >}
719 if x < state
.winw
- conf
.scrollbw
722 match self#elemunder
y with
723 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
724 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
728 then (postRedisplay
"listview pmotion"; {< m_active
= n >})
733 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
737 method infochanged
_ = ()
739 method scrollpw
= (0, 0.0, 0.0)
741 let nfs = fstate
.fontsize
+ 1 in
742 let y = m_first
* nfs in
743 let itemcount = source#getitemcount
in
744 let maxi = max
0 (itemcount - fstate
.maxrows
) in
745 let maxy = maxi * nfs in
746 let p, h = scrollph y maxy in
749 method modehash
= modehash
750 method eformsgs
= false
751 method alwaysscrolly
= true
754 if dy
!= 0 then begin
755 let len = source#getitemcount
in
757 if dy
> 0 && m_first
+ fstate
.maxrows
>= len
760 let first = m_first
+ dy
/ 10 in
761 bound
first 0 (len - 1)
763 postRedisplay
"listview wheel";
764 {< m_first
= first >}
770 method zoom
_ _ _ = ()