6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external getmaxw
: unit -> float = "ml_getmaxw";;
16 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr
: int -> string -> float = "ml_measure_string";;
18 external postprocess
:
19 opaque
-> int -> int -> int -> (int * string * int) -> int
21 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel
: int -> unit = "ml_setaalevel";;
23 external realloctexts
: int -> bool = "ml_realloctexts";;
24 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
25 external getlink
: opaque
-> int -> under
= "ml_getlink";;
26 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
27 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
28 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
29 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
30 external freepbo
: opaque
-> unit = "ml_freepbo";;
31 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
32 external bousable
: unit -> bool = "ml_bo_usable";;
33 external unproject
: opaque
-> int -> int -> (int * int) option
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
40 external begintiles
: unit -> unit = "ml_begintiles";;
41 external endtiles
: unit -> unit = "ml_endtiles";;
42 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
43 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
44 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
45 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc
: string -> unit = "ml_savedoc";;
47 external getannotcontents
: opaque
-> slinkindex
-> string
48 = "ml_getannotcontents";;
49 external drawprect
: opaque
-> int -> int -> float array
-> unit =
51 external wcmd
: Unix.file_descr
-> bytes
-> int -> unit = "ml_wcmd";;
52 external rcmd
: Unix.file_descr
-> string = "ml_rcmd";;
54 let selfexec = ref E.s
;;
55 let opengl_has_pbo = ref false;;
57 let drawstring size x y s
=
59 Gl.enable `texture_2d
;
60 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
61 ignore
(drawstr size x y s
);
63 Gl.disable `texture_2d
;
66 let drawstring1 size x y s
=
70 let drawstring2 size x y fmt
=
71 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
75 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
76 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
77 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
78 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
79 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
80 dolog
" column %d" l
.pagecol
;
84 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
86 dolog
" x0,y0=(% f, % f)" x0 y0
;
87 dolog
" x1,y1=(% f, % f)" x1 y1
;
88 dolog
" x2,y2=(% f, % f)" x2 y2
;
89 dolog
" x3,y3=(% f, % f)" x3 y3
;
93 let isbirdseye = function
100 let istextentry = function
101 | Textentry _
-> true
107 let wtmode = ref false;;
108 let cxack = ref false;;
110 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
113 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
114 || (state
.x
= 0 && state
.w
<= state
.winw
)
120 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
121 || (state
.maxy
< state
.winh
)
129 else x
> state
.winw
- vscrollw ()
133 fstate
.fontsize
<- n
;
134 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
135 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
141 else Printf.kprintf ignore fmt
145 if emptystr conf
.pathlauncher
146 then dolog
"%s" state
.path
148 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
149 match spawn
command [] with
152 dolog
"failed to execute `%s': %s" command @@ exntos exn
158 let postRedisplay who
=
159 vlog "redisplay for [%S]" who
;
160 state
.redisplay
<- true;
164 let getopaque pageno
=
165 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
166 with Not_found
-> None
169 let pagetranslatepoint l x y
=
170 let dy = y
- l
.pagedispy
in
171 let y = dy + l
.pagey
in
172 let dx = x
- l
.pagedispx
in
173 let x = dx + l
.pagex
in
177 let onppundermouse g
x y d
=
180 begin match getopaque l
.pageno
with
182 let x0 = l
.pagedispx
in
183 let x1 = x0 + l
.pagevw
in
184 let y0 = l
.pagedispy
in
185 let y1 = y0 + l
.pagevh
in
186 if y >= y0 && y <= y1 && x >= x0 && x <= x1
188 let px, py
= pagetranslatepoint l
x y in
189 match g opaque l
px py
with
202 let g opaque l
px py
=
205 match rectofblock opaque
px py
with
206 | Some
[|x0;x1;y0;y1|] ->
207 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
208 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
209 state
.rects
<- [l
.pageno
, color, rect];
210 G.postRedisplay "getunder";
213 let under = whatsunder opaque
px py
in
214 if under = Unone
then None
else Some
under
216 onppundermouse g x y Unone
221 match unproject opaque
x y with
222 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
225 onppundermouse g x y None
;
229 state
.text
<- Printf.sprintf
"%c%s" c s
;
230 G.postRedisplay "showtext";
234 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
237 let pipesel opaque cmd
=
240 match Unix.pipe
() with
241 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
243 let doclose what fd
=
244 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
247 try spawn cmd
[r
, 0; w
, -1]
249 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
255 G.postRedisplay "pipesel";
257 else doclose "pipesel pipe/w" w
;
258 doclose "pipesel pipe/r" r
;
262 let g opaque l
px py
=
263 if markunder opaque
px py conf
.paxmark
266 match getopaque l
.pageno
with
268 | Some opaque
-> pipesel opaque conf
.paxcmd
273 G.postRedisplay "paxunder";
274 if conf
.paxmark
= Mark_page
277 match getopaque l
.pageno
with
279 | Some opaque
-> clearmark opaque
) state
.layout
;
280 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
284 match Unix.pipe
() with
285 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
288 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
291 try spawn conf
.selcmd
[r
, 0; w
, -1]
293 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
299 let l = String.length s
in
300 let bytes = Bytes.unsafe_of_string s
in
301 let n = tempfailureretry
(Unix.write w
bytes 0) l in
303 then impmsg "failed to write %d characters to sel pipe, wrote %d"
306 impmsg "failed to write to sel pipe: %s" @@ exntos exn
309 clo "selstring pipe/r" r
;
310 clo "selstring pipe/w" w
;
313 let undertext ?
(nopath
=false) = function
316 | Ulinkgoto
(pageno
, _
) ->
318 then "page " ^ string_of_int
(pageno
+1)
319 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
320 | Utext s
-> "font: " ^ s
321 | Uunexpected s
-> "unexpected: " ^ s
322 | Ulaunch s
-> "launch: " ^ s
323 | Unamed s
-> "named: " ^ s
324 | Uremote
(filename
, pageno
) ->
325 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
326 | Uremotedest
(filename
, destname
) ->
327 Printf.sprintf
"%s: destination %S" filename destname
328 | Uannotation
(opaque
, slinkindex
) ->
329 "annotation: " ^ getannotcontents opaque slinkindex
332 let updateunder x y =
333 match getunder x y with
334 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
336 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
337 Wsi.setcursor
Wsi.CURSOR_INFO
338 | Ulinkgoto
(pageno
, _
) ->
340 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
341 Wsi.setcursor
Wsi.CURSOR_INFO
343 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
344 Wsi.setcursor
Wsi.CURSOR_TEXT
346 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
347 Wsi.setcursor
Wsi.CURSOR_INHERIT
349 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
350 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
353 Wsi.setcursor
Wsi.CURSOR_INHERIT
354 | Uremote
(filename
, pageno
) ->
355 if conf
.underinfo
then showtext 'r'
356 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
357 Wsi.setcursor
Wsi.CURSOR_INFO
358 | Uremotedest
(filename
, destname
) ->
359 if conf
.underinfo
then showtext 'r'
360 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
361 Wsi.setcursor
Wsi.CURSOR_INFO
363 if conf
.underinfo
then showtext 'a'
"nnotation";
364 Wsi.setcursor
Wsi.CURSOR_INFO
367 let showlinktype under =
368 if conf
.underinfo
&& under != Unone
369 then showtext ' '
@@ undertext under
372 let intentry_with_suffix text key
=
374 if key
>= 32 && key
< 127
376 let c = Char.chr key
in
381 | 'k'
| 'm'
| '
g'
| 'K'
| 'M'
| 'G'
->
382 addchar
text @@ asciilower
c
384 state
.text <- Printf.sprintf
"invalid key (%d, `%c')" key
c;
387 state
.text <- Printf.sprintf
"invalid key %d" key
;
395 let b = Buffer.create
16 in
396 Buffer.add_string
b "llll";
399 let b = Buffer.to_bytes
b in
400 wcmd state
.ss
b @@ Bytes.length
b
404 let nogeomcmds cmds
=
406 | s
, [] -> emptystr s
410 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
411 let rec fold accu
n =
412 if n = Array.length
b
415 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
418 || n = state
.pagecount
- coverB
419 || (n - coverA
) mod columns
= columns
- 1)
425 let pagey = max
0 (y - vy
) in
426 let pagedispy = if pagey > 0 then 0 else vy
- y in
427 let pagedispx, pagex
=
429 if n = coverA
- 1 || n = state
.pagecount
- coverB
430 then x + (sw
- w
) / 2
438 let vw = sw
- pagedispx in
439 let pw = w
- pagex
in
442 let pagevh = min
(h
- pagey) (sh
- pagedispy) in
443 if pagevw > 0 && pagevh > 0
454 ; pagedispx = pagedispx
455 ; pagedispy = pagedispy
467 if Array.length
b = 0
469 else List.rev
(fold [] (page_of_y
y))
472 let layoutS (columns
, b) x y sw sh
=
473 let rec fold accu n =
474 if n = Array.length
b
477 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
485 let pagey = max
0 (y - vy
) in
486 let pagedispy = if pagey > 0 then 0 else vy
- y in
487 let pagedispx, pagex
=
501 let pagecolw = pagew
/columns
in
504 then pagedispx + ((sw
- pagecolw) / 2)
508 let vw = sw
- pagedispx in
509 let pw = pagew
- pagex
in
512 let pagevw = min
pagevw pagecolw in
513 let pagevh = min
(pageh
- pagey) (sh
- pagedispy) in
514 if pagevw > 0 && pagevh > 0
525 ; pagedispx = pagedispx
526 ; pagedispy = pagedispy
527 ; pagecol
= n mod columns
541 let layout x y sw sh
=
542 if nogeomcmds state
.geomcmds
544 match conf
.columns
with
545 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw sh
546 | Cmulti
c -> layoutN c x y sw sh
547 | Csplit s
-> layoutS s
x y sw sh
552 let y = state
.y + incr
in
554 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
559 let tilex = l.pagex
mod conf
.tilew
in
560 let tiley = l.pagey mod conf
.tileh
in
562 let col = l.pagex
/ conf
.tilew
in
563 let row = l.pagey / conf
.tileh
in
565 let rec rowloop row y0 dispy h
=
569 let dh = conf
.tileh
- y0 in
571 let rec colloop col x0 dispx w
=
575 let dw = conf
.tilew
- x0 in
577 f col row dispx dispy
x0 y0 dw dh;
578 colloop (col+1) 0 (dispx
+dw) (w
-dw)
581 colloop col tilex l.pagedispx l.pagevw;
582 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
585 if l.pagevw > 0 && l.pagevh > 0
586 then rowloop row tiley l.pagedispy l.pagevh;
589 let gettileopaque l col row =
591 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
593 try Some
(Hashtbl.find state
.tilemap
key)
594 with Not_found
-> None
597 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
598 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
599 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
602 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3
=
603 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x1; y1; x2
; y2
; x3
; y3
|];
604 GlArray.vertex `two state
.vraw
;
605 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
608 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
610 let filledrect x0 y0 x1 y1 =
611 GlArray.disable `texture_coord
;
612 filledrect1 x0 y0 x1 y1;
613 GlArray.enable `texture_coord
;
616 let linerect x0 y0 x1 y1 =
617 GlArray.disable `texture_coord
;
618 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
619 GlArray.vertex `two state
.vraw
;
620 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
621 GlArray.enable `texture_coord
;
624 let drawtiles l color =
627 let f col row x y tilex tiley w h
=
628 match gettileopaque l col row with
629 | Some
(opaque
, _
, t
) ->
630 let params = x, y, w
, h
, tilex, tiley in
632 then GlTex.env
(`mode `blend
);
633 drawtile
params opaque
;
635 then GlTex.env
(`mode `modulate
);
639 let s = Printf.sprintf
643 let w = measurestr fstate
.fontsize
s in
644 GlDraw.color (0.0, 0.0, 0.0);
645 filledrect (float (x-2))
648 (float (y + fstate
.fontsize
+ 2));
650 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
657 let lw = state
.winw
- x in
660 let lh = state
.winh
- y in
664 then GlTex.env
(`mode `blend
);
665 begin match state
.checkerstexid
with
667 Gl.enable `texture_2d
;
668 GlTex.bind_texture ~target
:`texture_2d id
;
672 and y1 = float (y+h
) in
674 let tw = float w /. 16.0
675 and th
= float h
/. 16.0 in
676 let tx0 = float tilex /. 16.0
677 and ty0
= float tiley /. 16.0 in
679 and ty1
= ty0
+. th
in
680 Raw.sets_float state
.vraw ~pos
:0
681 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
682 Raw.sets_float state
.traw ~pos
:0
683 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
684 GlArray.vertex `two state
.vraw
;
685 GlArray.tex_coord `two state
.traw
;
686 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
687 Gl.disable `texture_2d
;
690 GlDraw.color (1.0, 1.0, 1.0);
691 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
694 then GlTex.env
(`mode `modulate
);
695 if w > 128 && h
> fstate
.fontsize
+ 10
697 let c = if conf
.invert
then 1.0 else 0.0 in
698 GlDraw.color (c, c, c);
701 then (col*conf
.tilew
, row*conf
.tileh
)
704 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
713 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
715 let tilevisible1 l x y =
717 and ax1
= l.pagex
+ l.pagevw
719 and ay1
= l.pagey + l.pagevh in
723 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
724 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
726 let rx0 = max
ax0 bx0
727 and ry0
= max ay0 by0
728 and rx1
= min ax1
bx1
729 and ry1
= min ay1 by1
in
731 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
735 let tilevisible layout n x y =
736 let rec findpageinlayout m
= function
737 | l :: rest
when l.pageno
= n ->
738 tilevisible1 l x y || (
739 match conf
.columns
with
740 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
745 | _
:: rest
-> findpageinlayout 0 rest
748 findpageinlayout 0 layout;
751 let tileready l x y =
752 tilevisible1 l x y &&
753 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
756 let tilepage n p
layout =
757 let rec loop = function
761 let f col row _ _ _ _ _ _
=
762 if state
.currently
= Idle
764 match gettileopaque l col row with
767 let x = col*conf
.tilew
768 and y = row*conf
.tileh
in
770 let w = l.pagew
- x in
774 let h = l.pageh
- y in
779 then getpbo
w h conf
.colorspace
782 wcmd "tile %s %d %d %d %d %s"
783 (~
> p
) x y w h (~
> pbo);
786 l, p
, conf
.colorspace
, conf
.angle
,
787 state
.gen
, col, row, conf
.tilew
, conf
.tileh
796 if nogeomcmds state
.geomcmds
800 let preloadlayout x y sw sh
=
801 let y = if y < sh
then 0 else y - sh
in
802 let x = min
0 (x + sw
) in
810 if state
.currently
!= Idle
815 begin match getopaque l.pageno
with
817 wcmd "page %d %d" l.pageno
l.pagedimno
;
818 state
.currently
<- Loading
(l, state
.gen
);
820 tilepage l.pageno opaque pages
;
825 if nogeomcmds state
.geomcmds
831 if conf
.preload && state
.currently
= Idle
832 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
835 let layoutready layout =
836 let rec fold all ls
=
839 let seen = ref false in
840 let allvisible = ref true in
841 let foo col row _ _ _ _ _ _
=
843 allvisible := !allvisible &&
844 begin match gettileopaque l col row with
850 fold (!seen && !allvisible) rest
853 let alltilesvisible = fold true layout in
858 let y = bound
y 0 state
.maxy
in
859 let y, layout, proceed
=
860 match conf
.maxwait
with
861 | Some time
when state
.ghyll
== noghyll
->
862 begin match state
.throttle
with
864 let layout = layout x y state
.winw state
.winh
in
865 let ready = layoutready layout in
869 state
.throttle
<- Some
(layout, y, now
());
871 else G.postRedisplay "gotoxy showall (None)";
873 | Some
(_
, _
, started
) ->
874 let dt = now
() -. started
in
877 state
.throttle
<- None
;
878 let layout = layout x y state
.winw state
.winh
in
880 G.postRedisplay "maxwait";
887 let layout = layout x y state
.winw state
.winh
in
888 if not
!wtmode || layoutready layout
889 then G.postRedisplay "gotoxy ready";
896 state
.layout <- layout;
897 begin match state
.mode
with
900 | Ltexact
(pageno
, linkno
) ->
901 let rec loop = function
903 state
.mode
<- LinkNav
(Ltgendir
0)
904 | l :: _
when l.pageno
= pageno
->
905 begin match getopaque pageno
with
906 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
908 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
909 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
910 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
911 then state
.mode
<- LinkNav
(Ltgendir
0)
913 | _
:: rest
-> loop rest
916 | Ltnotready _
| Ltgendir _
-> ()
922 begin match state
.mode
with
923 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
924 if not
(pagevisible layout pageno
)
926 match state
.layout with
929 state
.mode
<- Birdseye
(
930 conf
, leftx
, l.pageno
, hooverpageno
, anchor
935 | Ltnotready
(_
, dir
)
938 let rec loop = function
941 match getopaque l.pageno
with
942 | None
-> Ltnotready
(l.pageno
, dir
)
947 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
949 if dir
> 0 then LDfirst
else LDlast
955 | Lnotfound
-> loop rest
957 showlinktype (getlink opaque
n);
958 Ltexact
(l.pageno
, n)
962 state
.mode
<- LinkNav
linknav
970 state
.ghyll
<- noghyll
;
973 let mx, my
= state
.mpos
in
978 let conttiling pageno opaque
=
979 tilepage pageno opaque
981 then preloadlayout state
.x state
.y state
.winw state
.winh
985 let gotoxy_and_clear_text x y =
986 if not conf
.verbose
then state
.text <- E.s;
990 let getanchory (n, top
, dtop
) =
991 let y, h = getpageyh
n in
994 let ips = calcips
h in
995 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
997 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1000 let gotoanchor anchor
=
1001 gotoxy state
.x (getanchory anchor
);
1005 cbput state
.hists
.nav
(getanchor
());
1009 let anchor = cbgetc state
.hists
.nav dir
in
1013 let gotoghyll1 single
y =
1014 let scroll f n a
b =
1015 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1017 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1019 then s (float f /. float a
)
1022 then 1.0 -. s ((float (f-b) /. float (n-b)))
1028 let ins = float a
*. 0.5
1029 and outs
= float (n-b) *. 0.5 in
1031 ins +. outs
+. float ones
1033 let rec set nab
y sy
=
1034 let (_N
, _A
, _B
), y =
1037 let scl = if y > sy
then 2 else -2 in
1038 let _N, _
, _
= nab
in
1039 (_N,0,_N), y+conf
.scrollstep
*scl
1041 let sum = summa
_N _A _B
in
1042 let dy = float (y - sy
) in
1046 then state
.ghyll
<- noghyll
1049 let s = scroll n _N _A _B
in
1050 let y1 = y1 +. ((s *. dy) /. sum) in
1051 gotoxy_and_clear_text state
.x (truncate
y1);
1052 state
.ghyll
<- gf (n+1) y1;
1056 | Some
y'
when single
-> set nab
y' state
.y
1057 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1059 gf 0 (float state
.y)
1062 match conf
.ghyllscroll
with
1063 | Some nab
when not conf
.presentation
->
1064 if state
.ghyll
== noghyll
1065 then set nab
y state
.y
1066 else state
.ghyll
(Some
y)
1068 gotoxy_and_clear_text state
.x y
1071 let gotoghyll = gotoghyll1 false;;
1073 let gotopage n top
=
1074 let y, h = getpageyh
n in
1075 let y = y + (truncate
(top
*. float h)) in
1079 let gotopage1 n top
=
1080 let y = getpagey
n in
1085 let invalidate s f =
1086 state
.redisplay
<- false;
1091 match state
.geomcmds
with
1092 | ps
, [] when emptystr ps
->
1094 state
.geomcmds
<- s, [];
1097 state
.geomcmds
<- ps
, [s, f];
1099 | ps
, (s'
, _
) :: rest
when s'
= s ->
1100 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1103 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1107 Hashtbl.iter
(fun _ opaque
->
1108 wcmd "freepage %s" (~
> opaque
);
1110 Hashtbl.clear state
.pagemap
;
1114 if not
(Queue.is_empty state
.tilelru
)
1116 Queue.iter
(fun (k
, p
, s) ->
1117 wcmd "freetile %s" (~
> p
);
1118 state
.memused
<- state
.memused
- s;
1119 Hashtbl.remove state
.tilemap k
;
1121 state
.uioh#infochanged Memused
;
1122 Queue.clear state
.tilelru
;
1128 let h = truncate
(float h*.conf
.zoom
) in
1129 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1133 let opendoc path password
=
1135 state
.password
<- password
;
1136 state
.gen
<- state
.gen
+ 1;
1137 state
.docinfo
<- [];
1138 state
.outlines
<- [||];
1141 setaalevel conf
.aalevel
;
1143 if emptystr state
.origin
1147 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1148 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1149 invalidate "reqlayout"
1151 wcmd "reqlayout %d %d %d %s\000"
1152 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1153 (stateh state
.winh
) state
.nameddest
1158 state
.anchor <- getanchor
();
1159 opendoc state
.path state
.password
;
1163 let c = c *. conf
.colorscale
in
1167 let scalecolor2 (r
, g, b) =
1168 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1171 let docolumns columns
=
1174 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1175 let rec loop pageno
pdimno pdim
y ph pdims
=
1176 if pageno
= state
.pagecount
1179 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1181 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1182 pdimno+1, pdim
, rest
1186 let x = max
0 (((state
.winw
- w) / 2) - xoff
) in
1188 (if conf
.presentation
1189 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1190 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1193 a.(pageno
) <- (pdimno, x, y, pdim
);
1194 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1196 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1197 conf
.columns
<- Csingle
a;
1199 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1200 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1201 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1202 let rec fixrow m
= if m
= pageno
then () else
1203 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1206 let y = y + (rowh
- h) / 2 in
1207 a.(m
) <- (pdimno, x, y, pdim
);
1211 if pageno
= state
.pagecount
1212 then fixrow (((pageno
- 1) / columns
) * columns
)
1214 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1216 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1217 pdimno+1, pdim
, rest
1222 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1224 let x = (state
.winw
- w) / 2 in
1226 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1227 x, y + ips + rowh
, h
1230 if (pageno
- coverA
) mod columns
= 0
1232 let x = max
0 (state
.winw
- state
.w) / 2 in
1234 if conf
.presentation
1236 let ips = calcips
h in
1237 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1239 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1243 else x, y, max rowh
h
1247 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1250 if pageno
= columns
&& conf
.presentation
1252 let ips = calcips rowh
in
1253 for i
= 0 to pred columns
1255 let (pdimno, x, y, pdim
) = a.(i
) in
1256 a.(i
) <- (pdimno, x, y+ips, pdim
)
1262 fixrow (pageno
- columns
);
1267 a.(pageno
) <- (pdimno, x, y, pdim
);
1268 let x = x + w + xoff
*2 + conf
.interpagespace
in
1269 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1271 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1272 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1275 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1276 let rec loop pageno
pdimno pdim
y pdims
=
1277 if pageno
= state
.pagecount
1280 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1282 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1283 pdimno+1, pdim
, rest
1288 let rec loop1 n x y =
1289 if n = c then y else (
1290 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1291 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1294 let y = loop1 0 0 y in
1295 loop (pageno
+1) pdimno pdim
y pdims
1297 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1298 conf
.columns
<- Csplit
(c, a);
1302 docolumns conf
.columns
;
1303 state
.maxy
<- calcheight
();
1304 if state
.reprf
== noreprf
1306 match state
.mode
with
1307 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1308 let y, h = getpageyh pageno
in
1309 let top = (state
.winh
- h) / 2 in
1310 gotoxy state
.x (max
0 (y - top))
1314 let y = getanchory state
.anchor in
1315 let y = min
y (state
.maxy
- state
.winh
) in
1320 state
.reprf
<- noreprf
;
1324 let reshape ?
(firsttime
=false) w h =
1325 GlDraw.viewport ~
x:0 ~
y:0 ~
w ~
h;
1326 if not firsttime
&& nogeomcmds state
.geomcmds
1327 then state
.anchor <- getanchor
();
1330 let w = truncate
(float w *. conf
.zoom
) in
1333 setfontsize fstate
.fontsize
;
1334 GlMat.mode `modelview
;
1335 GlMat.load_identity
();
1337 GlMat.mode `projection
;
1338 GlMat.load_identity
();
1339 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1340 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1341 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1346 else float state
.x /. float state
.w
1348 invalidate "geometry"
1352 then state
.x <- truncate
(relx *. float w);
1354 match conf
.columns
with
1356 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1357 | Csplit
(c, _
) -> w * c
1359 wcmd "geometry %d %d %d"
1360 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1365 let len = String.length state
.text in
1366 let x0 = if conf
.leftscroll
then vscrollw () else 0 in
1369 match state
.mode
with
1370 | Textentry _
| View
| LinkNav _
->
1371 let h, _
, _
= state
.uioh#scrollpw
in
1376 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1377 (x+.w) (float (state
.winh
- hscrollh))
1380 let w = float (state
.winw
- 1 - vscrollw ()) in
1381 if state
.progress
>= 0.0 && state
.progress
< 1.0
1383 GlDraw.color (0.3, 0.3, 0.3);
1384 let w1 = w *. state
.progress
in
1386 GlDraw.color (0.0, 0.0, 0.0);
1387 rect (float x0+.w1) (float x0+.w-.w1)
1390 GlDraw.color (0.0, 0.0, 0.0);
1394 GlDraw.color (1.0, 1.0, 1.0);
1395 drawstring fstate
.fontsize
1396 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1397 (state
.winh
- hscrollh - 5) s;
1400 match state
.mode
with
1401 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1405 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1407 Printf.sprintf
"%s%s_" prefix
text
1413 | LinkNav _
-> state
.text
1418 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1420 let s1 = "(press 'e' to review error messasges)" in
1421 if nonemptystr
s then s ^
" " ^
s1 else s1
1431 let len = Queue.length state
.tilelru
in
1433 match state
.throttle
with
1436 then preloadlayout state
.x state
.y state
.winw state
.winh
1438 | Some
(layout, _
, _
) ->
1442 if state
.memused
<= conf
.memlimit
1447 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1448 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1449 let (_
, pw, ph
, _
) = getpagedim
n in
1452 && colorspace
= conf
.colorspace
1453 && angle
= conf
.angle
1457 let x = col*conf
.tilew
1458 and y = row*conf
.tileh
in
1459 tilevisible (Lazy.force_val
layout) n x y
1461 then Queue.push lruitem state
.tilelru
1464 wcmd "freetile %s" (~
> p
);
1465 state
.memused
<- state
.memused
- s;
1466 state
.uioh#infochanged Memused
;
1467 Hashtbl.remove state
.tilemap k
;
1475 let onpagerect pageno
f =
1477 match conf
.columns
with
1478 | Cmulti
(_
, b) -> b
1480 | Csplit
(_
, b) -> b
1482 if pageno
>= 0 && pageno
< Array.length
b
1484 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1488 let gotopagexy1 wtmode pageno
x y =
1489 let _,w1,h1
,leftx
= getpagedim pageno
in
1490 let top = y /. (float h1
) in
1491 let left = x /. (float w1) in
1492 let py, w, h = getpageywh pageno
in
1493 let wh = state
.winh
in
1494 let x = left *. (float w) in
1495 let x = leftx
+ state
.x + truncate
x in
1497 if x < 0 || x >= state
.winw
1501 let pdy = truncate
(top *. float h) in
1502 let y'
= py + pdy in
1503 let dy = y'
- state
.y in
1505 if x != state
.x || not
(dy > 0 && dy < wh)
1507 if conf
.presentation
1509 if abs
(py - y'
) > wh
1516 if state
.x != sx || state
.y != sy
1521 let ww = state
.winw
in
1523 and qy
= pdy / wh in
1525 and y = py + qy
* wh in
1526 let x = if -x + ww > w1 then -(w1-ww) else x
1527 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1529 if conf
.presentation
1531 if abs
(py - y'
) > wh
1540 gotoxy_and_clear_text x y;
1542 else gotoxy_and_clear_text state
.x state
.y;
1545 let gotopagexy wtmode pageno
x y =
1546 match state
.mode
with
1547 | Birdseye
_ -> gotopage pageno
0.0
1550 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1553 let getpassword () =
1554 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1559 impmsg "error getting password: %s" s;
1560 dolog
"%s" s) passcmd;
1563 let pgoto opaque pageno
x y =
1564 let pdimno = getpdimno pageno
in
1565 let x, y = project opaque pageno
pdimno x y in
1566 gotopagexy false pageno
x y;
1570 (* dolog "%S" cmds; *)
1571 let spl = splitatspace cmds
in
1573 try Scanf.sscanf
s fmt
f
1575 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1578 let addoutline outline
=
1579 match state
.currently
with
1580 | Outlining outlines
->
1581 state
.currently
<- Outlining
(outline
:: outlines
)
1582 | Idle
-> state
.currently
<- Outlining
[outline
]
1585 dolog
"invalid outlining state";
1586 logcurrently state
.currently
1590 state
.uioh#infochanged Pdim
;
1593 | "clearrects", "" ->
1594 state
.rects
<- state
.rects1
;
1595 G.postRedisplay "clearrects";
1597 | "continue", args
->
1598 let n = scan args
"%u" (fun n -> n) in
1599 state
.pagecount
<- n;
1600 begin match state
.currently
with
1602 state
.currently
<- Idle
;
1603 state
.outlines
<- Array.of_list
(List.rev
l)
1609 let cur, cmds
= state
.geomcmds
in
1611 then failwith
"umpossible";
1613 begin match List.rev cmds
with
1615 state
.geomcmds
<- E.s, [];
1616 state
.throttle
<- None
;
1620 state
.geomcmds
<- s, List.rev rest
;
1622 if conf
.maxwait
= None
&& not
!wtmode
1623 then G.postRedisplay "continue";
1630 then showtext ' ' args
1633 Buffer.add_string state
.errmsgs args
;
1634 state
.newerrmsgs
<- true;
1635 G.postRedisplay "error message"
1637 | "progress", args
->
1638 let progress, text =
1641 f, String.sub args pos
(String.length args
- pos
))
1644 state
.progress <- progress;
1645 G.postRedisplay "progress"
1647 | "firstmatch", args
->
1648 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1649 scan args
"%u %d %f %f %f %f %f %f %f %f"
1650 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1651 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1653 let y = (getpagey
pageno) + truncate
y0 in
1661 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1662 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1665 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1666 scan args
"%u %d %f %f %f %f %f %f %f %f"
1667 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1668 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1670 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1672 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1675 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1676 let pageopaque = ~
< pageopaques in
1677 begin match state
.currently
with
1678 | Loading
(l, gen
) ->
1679 vlog "page %d took %f sec" l.pageno t
;
1680 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1681 begin match state
.throttle
with
1683 let preloadedpages =
1685 then preloadlayout state
.x state
.y state
.winw state
.winh
1690 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1691 IntSet.empty
preloadedpages
1694 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1695 if not
(IntSet.mem
pageno set)
1697 wcmd "freepage %s" (~
> opaque
);
1703 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1706 state
.currently
<- Idle
;
1709 tilepage l.pageno pageopaque state
.layout;
1711 load preloadedpages;
1712 let visible = pagevisible state
.layout l.pageno in
1715 match state
.mode
with
1716 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1717 if pageno = l.pageno
1722 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1724 if dir
> 0 then LDfirst
else LDlast
1727 findlink
pageopaque ld
1732 showlinktype (getlink
pageopaque n);
1733 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1735 | LinkNav
(Ltgendir
_)
1736 | LinkNav
(Ltexact
_)
1742 if visible && layoutready state
.layout
1744 G.postRedisplay "page";
1748 | Some
(layout, _, _) ->
1749 state
.currently
<- Idle
;
1750 tilepage l.pageno pageopaque layout;
1757 dolog
"Inconsistent loading state";
1758 logcurrently state
.currently
;
1763 let (x, y, opaques
, size
, t
) =
1764 scan args
"%u %u %s %u %f"
1765 (fun x y p size t
-> (x, y, p
, size
, t
))
1767 let opaque = ~
< opaques
in
1768 begin match state
.currently
with
1769 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1770 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1773 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1775 wcmd "freetile %s" (~
> opaque);
1776 state
.currently
<- Idle
;
1780 puttileopaque l col row gen cs angle
opaque size t
;
1781 state
.memused
<- state
.memused
+ size
;
1782 state
.uioh#infochanged Memused
;
1784 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1785 opaque, size
) state
.tilelru
;
1788 match state
.throttle
with
1789 | None
-> state
.layout
1790 | Some
(layout, _, _) -> layout
1793 state
.currently
<- Idle
;
1795 && conf
.colorspace
= cs
1796 && conf
.angle
= angle
1797 && tilevisible layout l.pageno x y
1798 then conttiling l.pageno pageopaque;
1800 begin match state
.throttle
with
1802 preload state
.layout;
1804 && conf
.colorspace
= cs
1805 && conf
.angle
= angle
1806 && tilevisible state
.layout l.pageno x y
1807 && (not
!wtmode || layoutready state
.layout)
1808 then G.postRedisplay "tile nothrottle";
1810 | Some
(layout, y, _) ->
1811 let ready = layoutready layout in
1815 state
.layout <- layout;
1816 state
.throttle
<- None
;
1817 G.postRedisplay "throttle";
1826 dolog
"Inconsistent tiling state";
1827 logcurrently state
.currently
;
1832 let (n, w, h, _) as pdim
=
1833 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1836 match conf
.fitmodel
with
1838 | FitPage
| FitProportional
->
1839 match conf
.columns
with
1840 | Csplit
_ -> (n, w, h, 0)
1841 | Csingle
_ | Cmulti
_ -> pdim
1843 state
.uioh#infochanged Pdim
;
1844 state
.pdims
<- pdim :: state
.pdims
1847 let (l, n, t
, h, pos
) =
1848 scan args
"%u %u %d %u %n"
1849 (fun l n t
h pos
-> l, n, t
, h, pos
)
1851 let s = String.sub args pos
(String.length args
- pos
) in
1852 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1855 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1856 let s = String.sub args pos
len in
1857 let pos2 = pos
+ len + 1 in
1858 let uri = String.sub args
pos2 (String.length args
- pos2) in
1859 addoutline (s, l, Ouri
uri)
1862 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1863 let s = String.sub args pos
(String.length args
- pos
) in
1864 addoutline (s, l, Onone
)
1868 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1870 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1873 let pos = nindex args '
\t'
in
1874 if pos >= 0 && String.sub args
0 pos = "Title"
1876 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1880 state
.docinfo
<- (1, args
) :: state
.docinfo
1883 state
.uioh#infochanged Docinfo
;
1884 state
.docinfo
<- List.rev state
.docinfo
1888 then Wsi.settitle
"Wrong password";
1889 let password = getpassword () in
1890 if emptystr
password
1891 then error
"document is password protected"
1892 else opendoc state
.path
password
1895 error
"unknown cmd `%S'" cmds
1900 let action = function
1901 | HCprev
-> cbget cb ~
-1
1902 | HCnext
-> cbget cb
1
1903 | HCfirst
-> cbget cb ~
-(cb
.rc)
1904 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1905 and cancel
() = cb
.rc <- rc
1909 let search pattern forward
=
1910 match conf
.columns
with
1911 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1914 if nonemptystr pattern
1917 match state
.layout with
1920 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1922 wcmd "search %d %d %d %d,%s\000"
1923 (btod conf
.icase
) pn py (btod forward
) pattern
;
1926 let intentry text key =
1928 if key >= 32 && key < 127
1930 let c = Char.chr
key in
1932 | '
0'
.. '
9'
-> addchar
text c
1934 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1937 state
.text <- Printf.sprintf
"invalid key (%d)" key;
1948 let l = String.length
s in
1949 let rec loop pos n = if pos = l then n else
1950 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1951 loop (pos+1) (n*26 + m)
1954 let rec loop n = function
1957 match getopaque l.pageno with
1958 | None
-> loop n rest
1960 let m = getlinkcount
opaque in
1963 let under = getlink
opaque n in
1966 else loop (n-m) rest
1968 loop n state
.layout;
1972 let linknentry text key =
1973 if key >= 32 && key < 127
1975 let text = addchar
text (Char.chr
key) in
1976 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
1979 state
.text <- Printf.sprintf
"invalid key %d" key;
1984 let textentry text key =
1985 if Wsi.isspecialkey
key
1987 else TEcont
(text ^ toutf8
key)
1990 let reqlayout angle fitmodel
=
1991 match state
.throttle
with
1993 if nogeomcmds state
.geomcmds
1994 then state
.anchor <- getanchor
();
1995 conf
.angle
<- angle
mod 360;
1998 match state
.mode
with
1999 | LinkNav
_ -> state
.mode
<- View
2004 conf
.fitmodel
<- fitmodel
;
2005 invalidate "reqlayout"
2007 wcmd "reqlayout %d %d %d"
2008 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2013 let settrim trimmargins trimfuzz
=
2014 if nogeomcmds state
.geomcmds
2015 then state
.anchor <- getanchor
();
2016 conf
.trimmargins
<- trimmargins
;
2017 conf
.trimfuzz
<- trimfuzz
;
2018 let x0, y0, x1, y1 = trimfuzz
in
2019 invalidate "settrim"
2021 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2026 match state
.throttle
with
2028 let zoom = max
0.0001 zoom in
2029 if zoom <> conf
.zoom
2031 state
.prevzoom
<- (conf
.zoom, state
.x);
2033 reshape state
.winw state
.winh
;
2034 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2037 | Some
(layout, y, started
) ->
2039 match conf
.maxwait
with
2043 let dt = now
() -. started
in
2051 let pivotzoom ?
(vw=state
.winw
)
2052 ?
(vh
=min
(state
.maxy
-state
.y) state
.winh
)
2053 ?
(x=vw/2) ?
(y=vh
/2) zoom =
2054 let w = float state
.w /. zoom in
2055 let hw = w /. 2.0 in
2056 let ratio = float vh
/. float vw in
2057 let hh = hw *. ratio in
2058 let x0 = float x -. hw in
2059 let y0 = float y -. hh in
2060 gotoxy (state
.x - truncate
x0) (state
.y + truncate
y0);
2064 let pivotzoom ?
vw ?vh ?
x ?
y zoom =
2065 if nogeomcmds state
.geomcmds
then pivotzoom ?
vw ?vh ?
x ?
y zoom
2068 let setcolumns mode columns coverA coverB
=
2069 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2073 then impmsg "split mode doesn't work in bird's eye"
2075 conf
.columns
<- Csplit
(-columns
, E.a);
2083 conf
.columns
<- Csingle
E.a;
2088 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2092 reshape state
.winw state
.winh
;
2095 let resetmstate () =
2096 state
.mstate
<- Mnone
;
2097 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2100 let enterbirdseye () =
2101 let zoom = float conf
.thumbw
/. float state
.winw
in
2102 let birdseyepageno =
2103 let cy = state
.winh
/ 2 in
2107 let rec fold best
= function
2110 let d = cy - (l.pagedispy + l.pagevh/2)
2111 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2112 if abs
d < abs dbest
2119 state
.mode
<- Birdseye
(
2120 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2124 conf
.presentation
<- false;
2125 conf
.interpagespace
<- 10;
2126 conf
.hlinks
<- false;
2127 conf
.fitmodel
<- FitPage
;
2129 conf
.maxwait
<- None
;
2131 match conf
.beyecolumns
with
2134 Cmulti
((c, 0, 0), E.a)
2135 | None
-> Csingle
E.a
2139 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2144 reshape state
.winw state
.winh
;
2147 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2149 conf
.zoom <- c.zoom;
2150 conf
.presentation
<- c.presentation
;
2151 conf
.interpagespace
<- c.interpagespace
;
2152 conf
.maxwait
<- c.maxwait
;
2153 conf
.hlinks
<- c.hlinks
;
2154 conf
.fitmodel
<- c.fitmodel
;
2155 conf
.beyecolumns
<- (
2156 match conf
.columns
with
2157 | Cmulti
((c, _, _), _) -> Some
c
2159 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2162 match c.columns
with
2163 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2164 | Csingle
_ -> Csingle
E.a
2165 | Csplit
(c, _) -> Csplit
(c, E.a)
2169 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2172 reshape state
.winw state
.winh
;
2173 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2177 let togglebirdseye () =
2178 match state
.mode
with
2179 | Birdseye vals
-> leavebirdseye vals
true
2180 | View
-> enterbirdseye ()
2185 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2186 let pageno = max
0 (pageno - incr
) in
2187 let rec loop = function
2188 | [] -> gotopage1 pageno 0
2189 | l :: _ when l.pageno = pageno ->
2190 if l.pagedispy >= 0 && l.pagey = 0
2191 then G.postRedisplay "upbirdseye"
2192 else gotopage1 pageno 0
2193 | _ :: rest
-> loop rest
2197 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2200 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2201 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2202 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2203 let rec loop = function
2205 let y, h = getpageyh
pageno in
2206 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2207 gotoxy state
.x (clamp dy)
2208 | l :: _ when l.pageno = pageno ->
2209 if l.pagevh != l.pageh
2210 then gotoxy state
.x (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2211 else G.postRedisplay "downbirdseye"
2212 | _ :: rest
-> loop rest
2218 let optentry mode
_ key =
2219 let btos b = if b then "on" else "off" in
2220 if key >= 32 && key < 127
2222 let c = Char.chr
key in
2226 try conf
.scrollstep
<- int_of_string
s with exn
->
2227 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2229 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2234 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2235 if state
.autoscroll
<> None
2236 then state
.autoscroll
<- Some conf
.autoscrollstep
2238 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2240 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2245 let n, a, b = multicolumns_of_string
s in
2246 setcolumns mode
n a b;
2248 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exn
2250 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2255 let zoom = float (int_of_string
s) /. 100.0 in
2258 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2260 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2265 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2267 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2268 begin match mode
with
2270 leavebirdseye beye
false;
2277 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2279 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2283 match int_of_string
s with
2284 | angle
-> reqlayout angle conf
.fitmodel
2287 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2289 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2292 conf
.icase
<- not conf
.icase
;
2293 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2296 conf
.preload <- not conf
.preload;
2297 gotoxy state
.x state
.y;
2298 TEdone
("preload " ^
(btos conf
.preload))
2301 conf
.verbose
<- not conf
.verbose
;
2302 TEdone
("verbose " ^
(btos conf
.verbose
))
2305 conf
.debug
<- not conf
.debug
;
2306 TEdone
("debug " ^
(btos conf
.debug
))
2309 conf
.maxhfit
<- not conf
.maxhfit
;
2310 state
.maxy
<- calcheight
();
2311 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2314 conf
.crophack
<- not conf
.crophack
;
2315 TEdone
("crophack " ^
btos conf
.crophack
)
2319 match conf
.maxwait
with
2321 conf
.maxwait
<- Some infinity
;
2322 "always wait for page to complete"
2324 conf
.maxwait
<- None
;
2325 "show placeholder if page is not ready"
2330 conf
.underinfo
<- not conf
.underinfo
;
2331 TEdone
("underinfo " ^
btos conf
.underinfo
)
2334 conf
.savebmarks
<- not conf
.savebmarks
;
2335 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2341 match state
.layout with
2346 conf
.interpagespace
<- int_of_string
s;
2347 docolumns conf
.columns
;
2348 state
.maxy
<- calcheight
();
2349 let y = getpagey
pageno in
2350 gotoxy state
.x (y + py)
2352 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2354 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2358 match conf
.fitmodel
with
2359 | FitProportional
-> FitWidth
2360 | FitWidth
| FitPage
-> FitProportional
2362 reqlayout conf
.angle
fm;
2363 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2366 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2367 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2370 conf
.invert
<- not conf
.invert
;
2371 TEdone
("invert colors " ^
btos conf
.invert
)
2375 cbput state
.hists
.sel
s;
2378 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2379 textentry, ondone, true)
2383 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2384 else conf
.pax
<- None
;
2385 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2388 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2394 class type lvsource
= object
2395 method getitemcount
: int
2396 method getitem
: int -> (string * int)
2397 method hasaction
: int -> bool
2405 method getactive
: int
2406 method getfirst
: int
2408 method getminfo
: (int * int) array
2411 class virtual lvsourcebase
= object
2412 val mutable m_active
= 0
2413 val mutable m_first
= 0
2414 val mutable m_pan
= 0
2415 method getactive
= m_active
2416 method getfirst
= m_first
2417 method getpan
= m_pan
2418 method getminfo
: (int * int) array
= E.a
2421 let textentrykeyboard
2422 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2424 let key = Wsi.keypadtodigitkey
key in
2426 state
.mode
<- Textentry
(te
, onleave
);
2428 G.postRedisplay "textentrykeyboard enttext";
2430 let histaction cmd
=
2433 | Some
(action, _) ->
2434 state
.mode
<- Textentry
(
2435 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2437 G.postRedisplay "textentry histaction"
2441 if emptystr
text && cancelonempty
2444 G.postRedisplay "textentrykeyboard after cancel";
2447 let s = withoutlastutf8
text in
2448 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2450 | @enter
| @kpenter
->
2453 G.postRedisplay "textentrykeyboard after confirm"
2455 | @up
| @kpup
-> histaction HCprev
2456 | @down
| @kpdown
-> histaction HCnext
2457 | @home
| @kphome
-> histaction HCfirst
2458 | @jend
| @kpend
-> histaction HClast
2463 begin match opthist
with
2465 | Some
(_, onhistcancel
) -> onhistcancel
()
2469 G.postRedisplay "textentrykeyboard after cancel2"
2472 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2475 | @delete
| @kpdelete
-> ()
2477 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2478 begin match onkey
text key with
2482 G.postRedisplay "textentrykeyboard after confirm2";
2485 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2489 G.postRedisplay "textentrykeyboard after cancel3"
2492 state
.mode
<- Textentry
(te
, onleave
);
2493 G.postRedisplay "textentrykeyboard switch";
2497 vlog "unhandled key %s" (Wsi.keyname
key)
2500 let firstof first active
=
2501 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2502 then max
0 (active
- (fstate
.maxrows
/2))
2506 let calcfirst first active
=
2509 let rows = active
- first
in
2510 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2514 let scrollph y maxy
=
2515 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2516 let sh = float state
.winh
/. sh in
2517 let sh = max
sh (float conf
.scrollh
) in
2519 let percent = float y /. float maxy
in
2520 let position = (float state
.winh
-. sh) *. percent in
2523 if position +. sh > float state
.winh
2524 then float state
.winh
-. sh
2530 let adderrmsg src msg
=
2531 Buffer.add_string state
.errmsgs msg
;
2532 state
.newerrmsgs
<- true;
2536 let adderrfmt src fmt
=
2537 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2540 let coe s = (s :> uioh
);;
2542 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2544 val m_pan
= source#getpan
2545 val m_first
= source#getfirst
2546 val m_active
= source#getactive
2548 val m_prev_uioh
= state
.uioh
2550 method private elemunder
y =
2554 let n = y / (fstate
.fontsize
+1) in
2555 if m_first
+ n < source#getitemcount
2557 if source#hasaction
(m_first
+ n)
2558 then Some
(m_first
+ n)
2565 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2566 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2567 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2568 GlDraw.color (1., 1., 1.);
2569 Gl.enable `texture_2d
;
2570 let fs = fstate
.fontsize
in
2572 let hw = state
.winw
/3 in
2573 let ww = fstate
.wwidth
in
2574 let tabw = 17.0*.ww in
2575 let itemcount = source#getitemcount
in
2576 let minfo = source#getminfo
in
2580 then float (state
.winw
- 1)
2581 else float (state
.winw
- conf
.scrollbw
- 1)
2584 if (row - m_first
) > fstate
.maxrows
2587 if row >= 0 && row < itemcount
2589 let (s, level
) = source#getitem
row in
2590 let y = (row - m_first
) * nfs in
2591 let x = 5.0 +. (float (level
+ m_pan
)) *. ww in
2594 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2598 Gl.disable `texture_2d
;
2599 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2600 GlDraw.color (1., 1., 1.) ~
alpha;
2601 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2602 Gl.enable `texture_2d
;
2605 if zebra
&& row land 1 = 1
2609 GlDraw.color (c,c,c);
2610 let drawtabularstring s =
2612 let x'
= truncate
(x0 +. x) in
2613 let pos = nindex
s '
\000'
in
2615 then drawstring1 fs x'
(y+nfs) s
2617 let s1 = String.sub
s 0 pos
2618 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2623 let s'
= withoutlastutf8
s in
2624 let s = s' ^
"@Uellipsis" in
2625 let w = measurestr
fs s in
2626 if float x'
+. w +. ww < float (hw + x'
)
2631 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2635 ignore
(drawstring1 fs x'
(y+nfs) s1);
2636 drawstring1 fs (hw + x'
) (y+nfs) s2
2640 let x = if helpmode
&& row > 0 then x +. ww else x in
2641 let tabpos = nindex
s '
\t'
in
2644 let len = String.length
s - tabpos - 1 in
2645 let s1 = String.sub
s 0 tabpos
2646 and s2
= String.sub
s (tabpos + 1) len in
2647 let nx = drawstr x s1 in
2649 let x = x +. (max
tabw sw) in
2652 let len = String.length
s - 2 in
2653 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2655 let s = String.sub
s 2 len in
2656 let x = if not helpmode
then x +. ww else x in
2657 GlDraw.color (1.2, 1.2, 1.2);
2658 let vinc = drawstring1 (fs+fs/4)
2659 (truncate
(x -. ww)) (y+nfs) s in
2660 GlDraw.color (1., 1., 1.);
2661 vinc +. (float fs *. 0.8)
2667 ignore
(drawtabularstring s);
2673 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2676 if (row - m_first
) > fstate
.maxrows
2679 if row >= 0 && row < itemcount
2681 let (s, level
) = source#getitem
row in
2682 let pos0 = nindex
s '
\000'
in
2683 let y = (row - m_first
) * nfs in
2684 let x = float (level
+ m_pan
) *. ww in
2685 let (first
, last
) = minfo.(row) in
2687 if pos0 > 0 && first
> pos0
2688 then String.sub
s (pos0+1) (first
-pos0-1)
2689 else String.sub
s 0 first
2691 let suffix = String.sub
s first
(last
- first
) in
2692 let w1 = measurestr fstate
.fontsize
prefix in
2693 let w2 = measurestr fstate
.fontsize
suffix in
2694 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2695 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2697 and y0 = float (y+2) in
2699 and y1 = float (y+fs+3) in
2700 filledrect x0 y0 x1 y1;
2705 Gl.disable `texture_2d
;
2706 if Array.length
minfo > 0 then loop m_first
;
2709 method updownlevel incr
=
2710 let len = source#getitemcount
in
2712 if m_active
>= 0 && m_active
< len
2713 then snd
(source#getitem m_active
)
2717 if i
= len then i
-1 else if i
= -1 then 0 else
2718 let _, l = source#getitem i
in
2719 if l != curlevel then i
else flow (i
+incr
)
2721 let active = flow m_active
in
2722 let first = calcfirst m_first
active in
2723 G.postRedisplay "outline updownlevel";
2724 {< m_active
= active; m_first
= first >}
2726 method private key1
key mask
=
2727 let set1 active first qsearch
=
2728 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2730 let search active pattern incr
=
2731 let active = if active = -1 then m_first
else active in
2734 if n >= 0 && n < source#getitemcount
2736 let s, _ = source#getitem
n in
2737 match Str.search_forward re
s 0 with
2738 | (exception Not_found
) -> loop (n + incr
)
2745 let qpat = Str.quote pattern
in
2746 match Str.regexp_case_fold
qpat with
2749 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2750 qpat @@ Printexc.to_string exn
;
2753 let itemcount = source#getitemcount
in
2754 let find start incr
=
2756 if i
= -1 || i
= itemcount
2759 if source#hasaction i
2761 else find (i
+ incr
)
2766 let set active first =
2767 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2769 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2772 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2774 let incr1 = if incr
> 0 then 1 else -1 in
2775 if isvisible m_first m_active
2778 let next = m_active
+ incr
in
2780 if next < 0 || next >= itemcount
2782 else find next incr1
2784 if abs
(m_active
- next) > fstate
.maxrows
2790 let first = m_first
+ incr
in
2791 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2793 let next = m_active
+ incr
in
2794 let next = bound
next 0 (itemcount - 1) in
2801 if isvisible first next
2808 let first = min
next m_first
in
2810 if abs
(next - first) > fstate
.maxrows
2816 let first = m_first
+ incr
in
2817 let first = bound
first 0 (itemcount - 1) in
2819 let next = m_active
+ incr
in
2820 let next = bound
next 0 (itemcount - 1) in
2821 let next = find next incr1 in
2823 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2825 let active = if m_active
= -1 then next else m_active
in
2830 if isvisible first active
2836 G.postRedisplay "listview navigate";
2840 | (@r
|@s) when Wsi.withctrl mask
->
2841 let incr = if key = @r
then -1 else 1 in
2843 match search (m_active
+ incr) m_qsearch
incr with
2845 state
.text <- m_qsearch ^
" [not found]";
2848 state
.text <- m_qsearch
;
2849 active, firstof m_first
active
2851 G.postRedisplay "listview ctrl-r/s";
2852 set1 active first m_qsearch
;
2854 | @insert
when Wsi.withctrl mask
->
2855 if m_active
>= 0 && m_active
< source#getitemcount
2857 let s, _ = source#getitem m_active
in
2863 if emptystr m_qsearch
2866 let qsearch = withoutlastutf8 m_qsearch
in
2870 G.postRedisplay "listview empty qsearch";
2871 set1 m_active m_first
E.s;
2875 match search m_active
qsearch ~
-1 with
2877 state
.text <- qsearch ^
" [not found]";
2880 state
.text <- qsearch;
2881 active, firstof m_first
active
2883 G.postRedisplay "listview backspace qsearch";
2884 set1 active first qsearch
2887 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2888 let pattern = m_qsearch ^ toutf8
key in
2890 match search m_active
pattern 1 with
2892 state
.text <- pattern ^
" [not found]";
2895 state
.text <- pattern;
2896 active, firstof m_first
active
2898 G.postRedisplay "listview qsearch add";
2899 set1 active first pattern;
2903 if emptystr m_qsearch
2905 G.postRedisplay "list view escape";
2906 let mx, my
= state
.mpos
in
2910 source#exit ~uioh
:(coe self
)
2911 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2913 | None
-> m_prev_uioh
2918 G.postRedisplay "list view kill qsearch";
2919 coe {< m_qsearch
= E.s >}
2922 | @enter
| @kpenter
->
2924 let self = {< m_qsearch
= E.s >} in
2926 G.postRedisplay "listview enter";
2927 if m_active
>= 0 && m_active
< source#getitemcount
2929 source#exit ~uioh
:(coe self) ~cancel
:false
2930 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2933 source#exit ~uioh
:(coe self) ~cancel
:true
2934 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2937 begin match opt with
2938 | None
-> m_prev_uioh
2942 | @delete
| @kpdelete
->
2945 | @up
| @kpup
-> navigate ~
-1
2946 | @down
| @kpdown
-> navigate 1
2947 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2948 | @next | @kpnext
-> navigate fstate
.maxrows
2950 | @right
| @kpright
->
2952 G.postRedisplay "listview right";
2953 coe {< m_pan
= m_pan
- 1 >}
2955 | @left | @kpleft
->
2957 G.postRedisplay "listview left";
2958 coe {< m_pan
= m_pan
+ 1 >}
2960 | @home
| @kphome
->
2961 let active = find 0 1 in
2962 G.postRedisplay "listview home";
2966 let first = max
0 (itemcount - fstate
.maxrows
) in
2967 let active = find (itemcount - 1) ~
-1 in
2968 G.postRedisplay "listview end";
2971 | key when (key = 0 || Wsi.isspecialkey
key) ->
2975 dolog
"listview unknown key %#x" key; coe self
2977 method key key mask
=
2978 match state
.mode
with
2979 | Textentry te
-> textentrykeyboard key mask te
; coe self
2982 | LinkNav
_ -> self#key1
key mask
2984 method button button down
x y _ =
2987 | 1 when vscrollhit x ->
2988 G.postRedisplay "listview scroll";
2991 let _, position, sh = self#
scrollph in
2992 if y > truncate
position && y < truncate
(position +. sh)
2994 state
.mstate
<- Mscrolly
;
2998 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
2999 let first = truncate
(s *. float source#getitemcount
) in
3000 let first = min source#getitemcount
first in
3001 Some
(coe {< m_first
= first; m_active
= first >})
3003 state
.mstate
<- Mnone
;
3007 begin match self#elemunder
y with
3009 G.postRedisplay "listview click";
3010 source#exit ~uioh
:(coe {< m_active
= n >})
3011 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3015 | n when (n == 4 || n == 5) && not down
->
3016 let len = source#getitemcount
in
3018 if n = 5 && m_first
+ fstate
.maxrows
>= len
3022 let first = m_first
+ (if n == 4 then -1 else 1) in
3023 bound
first 0 (len - 1)
3025 G.postRedisplay "listview wheel";
3026 Some
(coe {< m_first
= first >})
3027 | n when (n = 6 || n = 7) && not down
->
3028 let inc = if n = 7 then -1 else 1 in
3029 G.postRedisplay "listview hwheel";
3030 Some
(coe {< m_pan
= m_pan
+ inc >})
3035 | None
-> m_prev_uioh
3038 method multiclick
_ x y = self#button
1 true x y
3041 match state
.mstate
with
3043 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3044 let first = truncate
(s *. float source#getitemcount
) in
3045 let first = min source#getitemcount
first in
3046 G.postRedisplay "listview motion";
3047 coe {< m_first
= first; m_active
= first >}
3055 method pmotion
x y =
3056 if x < state
.winw
- conf
.scrollbw
3059 match self#elemunder
y with
3060 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3061 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3065 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3070 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3074 method infochanged
_ = ()
3076 method scrollpw
= (0, 0.0, 0.0)
3078 let nfs = fstate
.fontsize
+ 1 in
3079 let y = m_first
* nfs in
3080 let itemcount = source#getitemcount
in
3081 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3082 let maxy = maxi * nfs in
3083 let p, h = scrollph y maxy in
3086 method modehash
= modehash
3087 method eformsgs
= false
3088 method alwaysscrolly
= true
3091 class outlinelistview ~zebra ~source
=
3092 let settext autonarrow
s =
3095 let ss = source#statestr
in
3099 else "{" ^
ss ^
"} [" ^
s ^
"]"
3100 else state
.text <- s
3106 ~source
:(source
:> lvsource
)
3108 ~modehash
:(findkeyhash conf
"outline")
3111 val m_autonarrow
= false
3113 method! key key mask
=
3115 if emptystr state
.text
3117 else fstate
.maxrows - 2
3119 let calcfirst first active =
3122 let rows = active - first in
3123 if rows > maxrows then active - maxrows else first
3127 let active = m_active
+ incr in
3128 let active = bound
active 0 (source#getitemcount
- 1) in
3129 let first = calcfirst m_first
active in
3130 G.postRedisplay "outline navigate";
3131 coe {< m_active
= active; m_first
= first >}
3133 let navscroll first =
3135 let dist = m_active
- first in
3141 else first + maxrows
3144 G.postRedisplay "outline navscroll";
3145 coe {< m_first
= first; m_active
= active >}
3147 let ctrl = Wsi.withctrl mask
in
3152 then (source#denarrow
; E.s)
3154 let pattern = source#renarrow
in
3155 if nonemptystr m_qsearch
3156 then (source#narrow m_qsearch
; m_qsearch
)
3160 settext (not m_autonarrow
) text;
3161 G.postRedisplay "toggle auto narrowing";
3162 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3164 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3166 G.postRedisplay "toggle auto narrowing";
3167 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3170 source#narrow m_qsearch
;
3172 then source#add_narrow_pattern m_qsearch
;
3173 G.postRedisplay "outline ctrl-n";
3174 coe {< m_first
= 0; m_active
= 0 >}
3177 let active = source#calcactive
(getanchor
()) in
3178 let first = firstof m_first
active in
3179 G.postRedisplay "outline ctrl-s";
3180 coe {< m_first
= first; m_active
= active >}
3183 G.postRedisplay "outline ctrl-u";
3184 if m_autonarrow
&& nonemptystr m_qsearch
3186 ignore
(source#renarrow
);
3187 settext m_autonarrow
E.s;
3188 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3191 source#del_narrow_pattern
;
3192 let pattern = source#renarrow
in
3194 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3196 settext m_autonarrow
text;
3197 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3201 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3202 G.postRedisplay "outline ctrl-l";
3203 coe {< m_first
= first >}
3205 | @tab
when m_autonarrow
->
3206 if nonemptystr m_qsearch
3208 G.postRedisplay "outline list view tab";
3209 source#add_narrow_pattern m_qsearch
;
3211 coe {< m_qsearch
= E.s >}
3215 | @escape
when m_autonarrow
->
3216 if nonemptystr m_qsearch
3217 then source#add_narrow_pattern m_qsearch
;
3220 | @enter
| @kpenter
when m_autonarrow
->
3221 if nonemptystr m_qsearch
3222 then source#add_narrow_pattern m_qsearch
;
3225 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3226 let pattern = m_qsearch ^ toutf8
key in
3227 G.postRedisplay "outlinelistview autonarrow add";
3228 source#narrow
pattern;
3229 settext true pattern;
3230 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3232 | key when m_autonarrow
&& key = @backspace
->
3233 if emptystr m_qsearch
3236 let pattern = withoutlastutf8 m_qsearch
in
3237 G.postRedisplay "outlinelistview autonarrow backspace";
3238 ignore
(source#renarrow
);
3239 source#narrow
pattern;
3240 settext true pattern;
3241 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3243 | @up
| @kpup
when ctrl ->
3244 navscroll (max
0 (m_first
- 1))
3246 | @down
| @kpdown
when ctrl ->
3247 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3249 | @up
| @kpup
-> navigate ~
-1
3250 | @down
| @kpdown
-> navigate 1
3251 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3252 | @next | @kpnext
-> navigate fstate
.maxrows
3254 | @right
| @kpright
->
3258 G.postRedisplay "outline ctrl right";
3259 {< m_pan
= m_pan
+ 1 >}
3261 else self#updownlevel
1
3265 | @left | @kpleft
->
3269 G.postRedisplay "outline ctrl left";
3270 {< m_pan
= m_pan
- 1 >}
3272 else self#updownlevel ~
-1
3276 | @home
| @kphome
->
3277 G.postRedisplay "outline home";
3278 coe {< m_first
= 0; m_active
= 0 >}
3281 let active = source#getitemcount
- 1 in
3282 let first = max
0 (active - fstate
.maxrows) in
3283 G.postRedisplay "outline end";
3284 coe {< m_active
= active; m_first
= first >}
3286 | _ -> super#
key key mask
3289 let genhistoutlines () =
3291 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3292 compare c2
.lastvisit c1
.lastvisit
)
3294 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3295 let path = if nonemptystr origin
then origin
else path in
3296 let base = mbtoutf8
@@ Filename.basename
path in
3297 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3302 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3303 Config.save
leavebirdseye;
3304 state
.anchor <- anchor;
3305 state
.bookmarks
<- bookmarks
;
3306 state
.origin
<- origin
;
3309 let x0, y0, x1, y1 = conf
.trimfuzz
in
3310 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3311 reshape ~firsttime
:true state
.winw state
.winh
;
3312 opendoc path origin
;
3316 let makecheckers () =
3317 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3319 converted by Issac Trotts. July 25, 2002 *)
3320 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3321 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3322 let id = GlTex.gen_texture
() in
3323 GlTex.bind_texture ~target
:`texture_2d
id;
3324 GlPix.store
(`unpack_alignment
1);
3325 GlTex.image2d
image;
3326 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3327 [ `mag_filter `nearest
; `min_filter `nearest
];
3331 let setcheckers enabled
=
3332 match state
.checkerstexid
with
3334 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3336 | Some checkerstexid
->
3339 GlTex.delete_texture checkerstexid
;
3340 state
.checkerstexid
<- None
;
3344 let describe_location () =
3345 let fn = page_of_y state
.y in
3346 let ln = page_of_y
(state
.y + state
.winh
- 1) in
3347 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3351 else (100. *. (float state
.y /. float maxy))
3355 Printf.sprintf
"page %d of %d [%.2f%%]"
3356 (fn+1) state
.pagecount
percent
3359 "pages %d-%d of %d [%.2f%%]"
3360 (fn+1) (ln+1) state
.pagecount
percent
3363 let setpresentationmode v
=
3364 let n = page_of_y state
.y in
3365 state
.anchor <- (n, 0.0, 1.0);
3366 conf
.presentation
<- v
;
3367 if conf
.fitmodel
= FitPage
3368 then reqlayout conf
.angle conf
.fitmodel
;
3372 let setbgcol (r
, g, b) =
3374 let r = r *. 255.0 |> truncate
3375 and g = g *. 255.0 |> truncate
3376 and b = b *. 255.0 |> truncate
in
3377 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3379 Wsi.setwinbgcol
col;
3383 let btos b = if b then "@Uradical" else E.s in
3384 let showextended = ref false in
3385 let leave mode
_ = state
.mode
<- mode
in
3388 val mutable m_l
= []
3389 val mutable m_a
= E.a
3390 val mutable m_prev_uioh
= nouioh
3391 val mutable m_prev_mode
= View
3393 inherit lvsourcebase
3395 method reset prev_mode prev_uioh
=
3396 m_a
<- Array.of_list
(List.rev m_l
);
3398 m_prev_mode
<- prev_mode
;
3399 m_prev_uioh
<- prev_uioh
;
3401 method int name get
set =
3403 (name
, `
int get
, 1, Action
(
3406 try set (int_of_string
s)
3408 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3412 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3413 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3417 method int_with_suffix name get
set =
3419 (name
, `intws get
, 1, Action
(
3422 try set (int_of_string_with_suffix
s)
3424 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3429 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3431 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3435 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3437 (name
, `
bool (btos, get
), offset
, Action
(
3444 method color name get
set =
3446 (name
, `
color get
, 1, Action
(
3448 let invalid = (nan
, nan
, nan
) in
3451 try color_of_string
s
3453 state
.text <- Printf.sprintf
"bad color `%s': %s"
3460 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3461 state
.text <- color_to_string
(get
());
3462 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3466 method string name get
set =
3468 (name
, `
string get
, 1, Action
(
3470 let ondone s = set s in
3471 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3472 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3476 method colorspace name get
set =
3478 (name
, `
string get
, 1, Action
(
3482 inherit lvsourcebase
3485 m_active
<- CSTE.to_int conf
.colorspace
;
3488 method getitemcount
=
3489 Array.length
CSTE.names
3492 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3493 ignore
(uioh
, first, pan
);
3494 if not cancel
then set active;
3496 method hasaction
_ = true
3500 let modehash = findkeyhash conf
"info" in
3501 coe (new listview ~zebra
:false ~helpmode
:false
3502 ~
source ~trusted
:true ~
modehash)
3505 method paxmark name get
set =
3507 (name
, `
string get
, 1, Action
(
3511 inherit lvsourcebase
3514 m_active
<- MTE.to_int conf
.paxmark
;
3517 method getitemcount
= Array.length
MTE.names
3518 method getitem
n = (MTE.names
.(n), 0)
3519 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3520 ignore
(uioh
, first, pan
);
3521 if not cancel
then set active;
3523 method hasaction
_ = true
3527 let modehash = findkeyhash conf
"info" in
3528 coe (new listview ~zebra
:false ~helpmode
:false
3529 ~
source ~trusted
:true ~
modehash)
3532 method fitmodel name get
set =
3534 (name
, `
string get
, 1, Action
(
3538 inherit lvsourcebase
3541 m_active
<- FMTE.to_int conf
.fitmodel
;
3544 method getitemcount
= Array.length
FMTE.names
3545 method getitem
n = (FMTE.names
.(n), 0)
3546 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3547 ignore
(uioh
, first, pan
);
3548 if not cancel
then set active;
3550 method hasaction
_ = true
3554 let modehash = findkeyhash conf
"info" in
3555 coe (new listview ~zebra
:false ~helpmode
:false
3556 ~
source ~trusted
:true ~
modehash)
3559 method caption
s offset
=
3560 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3562 method caption2
s f offset
=
3563 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3565 method getitemcount
= Array.length m_a
3568 let tostr = function
3569 | `
int f -> string_of_int
(f ())
3570 | `intws
f -> string_with_suffix_of_int
(f ())
3572 | `
color f -> color_to_string
(f ())
3573 | `
bool (btos, f) -> btos (f ())
3576 let name, t
, offset
, _ = m_a
.(n) in
3577 ((let s = tostr t
in
3579 then Printf.sprintf
"%s\t%s" name s
3583 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3588 match m_a
.(active) with
3589 | _, _, _, Action
f -> f uioh
3590 | _, _, _, Noaction
-> uioh
3601 method hasaction
n =
3603 | _, _, _, Action
_ -> true
3604 | _, _, _, Noaction
-> false
3606 initializer m_active
<- 1
3609 let rec fillsrc prevmode prevuioh
=
3610 let sep () = src#caption
E.s 0 in
3611 let colorp name get
set =
3613 (fun () -> color_to_string
(get
()))
3616 let c = color_of_string
v in
3619 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3622 let oldmode = state
.mode
in
3623 let birdseye = isbirdseye state
.mode
in
3625 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3627 src#
bool "presentation mode"
3628 (fun () -> conf
.presentation
)
3629 (fun v -> setpresentationmode v);
3631 src#
bool "ignore case in searches"
3632 (fun () -> conf
.icase
)
3633 (fun v -> conf
.icase
<- v);
3636 (fun () -> conf
.preload)
3637 (fun v -> conf
.preload <- v);
3639 src#
bool "highlight links"
3640 (fun () -> conf
.hlinks
)
3641 (fun v -> conf
.hlinks
<- v);
3643 src#
bool "under info"
3644 (fun () -> conf
.underinfo
)
3645 (fun v -> conf
.underinfo
<- v);
3647 src#
bool "persistent bookmarks"
3648 (fun () -> conf
.savebmarks
)
3649 (fun v -> conf
.savebmarks
<- v);
3651 src#fitmodel
"fit model"
3652 (fun () -> FMTE.to_string conf
.fitmodel
)
3653 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3655 src#
bool "trim margins"
3656 (fun () -> conf
.trimmargins
)
3657 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3659 src#
bool "persistent location"
3660 (fun () -> conf
.jumpback
)
3661 (fun v -> conf
.jumpback
<- v);
3664 src#
int "inter-page space"
3665 (fun () -> conf
.interpagespace
)
3667 conf
.interpagespace
<- n;
3668 docolumns conf
.columns
;
3670 match state
.layout with
3675 state
.maxy <- calcheight
();
3676 let y = getpagey
pageno in
3677 gotoxy state
.x (y + py)
3681 (fun () -> conf
.pagebias
)
3682 (fun v -> conf
.pagebias
<- v);
3684 src#
int "scroll step"
3685 (fun () -> conf
.scrollstep
)
3686 (fun n -> conf
.scrollstep
<- n);
3688 src#
int "horizontal scroll step"
3689 (fun () -> conf
.hscrollstep
)
3690 (fun v -> conf
.hscrollstep
<- v);
3692 src#
int "auto scroll step"
3694 match state
.autoscroll
with
3696 | _ -> conf
.autoscrollstep
)
3698 let n = boundastep state
.winh
n in
3699 if state
.autoscroll
<> None
3700 then state
.autoscroll
<- Some
n;
3701 conf
.autoscrollstep
<- n);
3704 (fun () -> truncate
(conf
.zoom *. 100.))
3705 (fun v -> pivotzoom ((float v) /. 100.));
3708 (fun () -> conf
.angle
)
3709 (fun v -> reqlayout v conf
.fitmodel
);
3711 src#
int "scroll bar width"
3712 (fun () -> conf
.scrollbw
)
3715 reshape state
.winw state
.winh
;
3718 src#
int "scroll handle height"
3719 (fun () -> conf
.scrollh
)
3720 (fun v -> conf
.scrollh
<- v;);
3722 src#
int "thumbnail width"
3723 (fun () -> conf
.thumbw
)
3725 conf
.thumbw
<- min
4096 v;
3728 leavebirdseye beye
false;
3735 let mode = state
.mode in
3736 src#
string "columns"
3738 match conf
.columns
with
3740 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3741 | Csplit
(count
, _) -> "-" ^ string_of_int count
3744 let n, a, b = multicolumns_of_string
v in
3745 setcolumns mode n a b);
3748 src#caption
"Pixmap cache" 0;
3749 src#int_with_suffix
"size (advisory)"
3750 (fun () -> conf
.memlimit
)
3751 (fun v -> conf
.memlimit
<- v);
3754 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3755 (string_with_suffix_of_int state
.memused
)
3756 (Hashtbl.length state
.tilemap
)) 1;
3759 src#caption
"Layout" 0;
3760 src#caption2
"Dimension"
3762 Printf.sprintf
"%dx%d (virtual %dx%d)"
3763 state
.winw state
.winh
3768 src#caption2
"Position" (fun () ->
3769 Printf.sprintf
"%dx%d" state
.x state
.y
3772 src#caption2
"Position" (fun () -> describe_location ()) 1
3776 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3777 "Save these parameters as global defaults at exit"
3778 (fun () -> conf
.bedefault
)
3779 (fun v -> conf
.bedefault
<- v)
3783 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3784 src#
bool ~offset
:0 ~
btos "Extended parameters"
3785 (fun () -> !showextended)
3786 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3790 (fun () -> conf
.checkers
)
3791 (fun v -> conf
.checkers
<- v; setcheckers v);
3792 src#
bool "update cursor"
3793 (fun () -> conf
.updatecurs
)
3794 (fun v -> conf
.updatecurs
<- v);
3795 src#
bool "scroll-bar on the left"
3796 (fun () -> conf
.leftscroll
)
3797 (fun v -> conf
.leftscroll
<- v);
3799 (fun () -> conf
.verbose
)
3800 (fun v -> conf
.verbose
<- v);
3801 src#
bool "invert colors"
3802 (fun () -> conf
.invert
)
3803 (fun v -> conf
.invert
<- v);
3805 (fun () -> conf
.maxhfit
)
3806 (fun v -> conf
.maxhfit
<- v);
3808 (fun () -> conf
.pax
!= None
)
3811 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3812 else conf
.pax
<- None
);
3813 src#
string "uri launcher"
3814 (fun () -> conf
.urilauncher
)
3815 (fun v -> conf
.urilauncher
<- v);
3816 src#
string "path launcher"
3817 (fun () -> conf
.pathlauncher
)
3818 (fun v -> conf
.pathlauncher
<- v);
3819 src#
string "tile size"
3820 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3823 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3824 conf
.tilew
<- max
64 w;
3825 conf
.tileh
<- max
64 h;
3828 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3831 src#
int "texture count"
3832 (fun () -> conf
.texcount
)
3835 then conf
.texcount
<- v
3836 else impmsg "failed to set texture count please retry later"
3838 src#
int "slice height"
3839 (fun () -> conf
.sliceheight
)
3841 conf
.sliceheight
<- v;
3842 wcmd "sliceh %d" conf
.sliceheight
;
3844 src#
int "anti-aliasing level"
3845 (fun () -> conf
.aalevel
)
3847 conf
.aalevel
<- bound
v 0 8;
3848 state
.anchor <- getanchor
();
3849 opendoc state
.path state
.password;
3851 src#
string "page scroll scaling factor"
3852 (fun () -> string_of_float conf
.pgscale)
3855 let s = float_of_string
v in
3858 state
.text <- Printf.sprintf
3859 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3862 src#
int "ui font size"
3863 (fun () -> fstate
.fontsize
)
3864 (fun v -> setfontsize (bound
v 5 100));
3865 src#
int "hint font size"
3866 (fun () -> conf
.hfsize
)
3867 (fun v -> conf
.hfsize
<- bound
v 5 100);
3868 colorp "background color"
3869 (fun () -> conf
.bgcolor
)
3870 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3871 src#
bool "crop hack"
3872 (fun () -> conf
.crophack
)
3873 (fun v -> conf
.crophack
<- v);
3874 src#
string "trim fuzz"
3875 (fun () -> irect_to_string conf
.trimfuzz
)
3878 conf
.trimfuzz
<- irect_of_string
v;
3880 then settrim true conf
.trimfuzz
;
3882 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3884 src#
string "throttle"
3886 match conf
.maxwait
with
3887 | None
-> "show place holder if page is not ready"
3890 then "wait for page to fully render"
3892 "wait " ^ string_of_float
time
3893 ^
" seconds before showing placeholder"
3897 let f = float_of_string
v in
3899 then conf
.maxwait
<- None
3900 else conf
.maxwait
<- Some
f
3902 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3904 src#
string "ghyll scroll"
3906 match conf
.ghyllscroll
with
3908 | Some nab
-> ghyllscroll_to_string nab
3911 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3914 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3916 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3918 src#
string "selection command"
3919 (fun () -> conf
.selcmd
)
3920 (fun v -> conf
.selcmd
<- v);
3921 src#
string "synctex command"
3922 (fun () -> conf
.stcmd
)
3923 (fun v -> conf
.stcmd
<- v);
3924 src#
string "pax command"
3925 (fun () -> conf
.paxcmd
)
3926 (fun v -> conf
.paxcmd
<- v);
3927 src#
string "ask password command"
3928 (fun () -> conf
.passcmd)
3929 (fun v -> conf
.passcmd <- v);
3930 src#
string "save path command"
3931 (fun () -> conf
.savecmd
)
3932 (fun v -> conf
.savecmd
<- v);
3933 src#colorspace
"color space"
3934 (fun () -> CSTE.to_string conf
.colorspace
)
3936 conf
.colorspace
<- CSTE.of_int
v;
3940 src#paxmark
"pax mark method"
3941 (fun () -> MTE.to_string conf
.paxmark
)
3942 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3943 if bousable
() && !opengl_has_pbo
3946 (fun () -> conf
.usepbo
)
3947 (fun v -> conf
.usepbo
<- v);
3948 src#
bool "mouse wheel scrolls pages"
3949 (fun () -> conf
.wheelbypage
)
3950 (fun v -> conf
.wheelbypage
<- v);
3951 src#
bool "open remote links in a new instance"
3952 (fun () -> conf
.riani
)
3953 (fun v -> conf
.riani
<- v);
3954 src#
bool "edit annotations inline"
3955 (fun () -> conf
.annotinline
)
3956 (fun v -> conf
.annotinline
<- v);
3957 src#
bool "coarse positioning in presentation mode"
3958 (fun () -> conf
.coarseprespos
)
3959 (fun v -> conf
.coarseprespos
<- v);
3963 src#caption
"Document" 0;
3964 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3965 src#caption2
"Pages"
3966 (fun () -> string_of_int state
.pagecount
) 1;
3967 src#caption2
"Dimensions"
3968 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3972 src#caption
"Trimmed margins" 0;
3973 src#caption2
"Dimensions"
3974 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3978 src#caption
"OpenGL" 0;
3979 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3980 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3983 src#caption
"Location" 0;
3984 if nonemptystr state
.origin
3985 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3986 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3988 src#reset prevmode prevuioh
;
3993 let prevmode = state
.mode
3994 and prevuioh
= state
.uioh in
3995 fillsrc prevmode prevuioh
;
3996 let source = (src :> lvsource
) in
3997 let modehash = findkeyhash conf
"info" in
3998 state
.uioh <- coe (object (self)
3999 inherit listview ~zebra
:false ~helpmode
:false
4000 ~
source ~trusted
:true ~
modehash as super
4001 val mutable m_prevmemused
= 0
4002 method! infochanged
= function
4004 if m_prevmemused
!= state
.memused
4006 m_prevmemused
<- state
.memused
;
4007 G.postRedisplay "memusedchanged";
4009 | Pdim
-> G.postRedisplay "pdimchanged"
4010 | Docinfo
-> fillsrc prevmode prevuioh
4012 method! key key mask
=
4013 if not
(Wsi.withctrl mask
)
4016 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4017 | @right
| @kpright
-> coe (self#updownlevel
1)
4018 | _ -> super#
key key mask
4019 else super#
key key mask
4021 G.postRedisplay "info";
4027 inherit lvsourcebase
4028 method getitemcount
= Array.length state
.help
4030 let s, l, _ = state
.help
.(n) in
4033 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4037 match state
.help
.(active) with
4038 | _, _, Action
f -> Some
(f uioh)
4039 | _, _, Noaction
-> Some
uioh
4048 method hasaction
n =
4049 match state
.help
.(n) with
4050 | _, _, Action
_ -> true
4051 | _, _, Noaction
-> false
4057 let modehash = findkeyhash conf
"help" in
4059 state
.uioh <- coe (new listview
4060 ~zebra
:false ~helpmode
:true
4061 ~
source ~trusted
:true ~
modehash);
4062 G.postRedisplay "help";
4068 inherit lvsourcebase
4069 val mutable m_items
= E.a
4071 method getitemcount
= 1 + Array.length m_items
4076 else m_items
.(n-1), 0
4078 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4083 then Buffer.clear state
.errmsgs
;
4090 method hasaction
n =
4094 state
.newerrmsgs
<- false;
4095 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4096 m_items
<- Array.of_list
l
4105 let source = (msgsource :> lvsource
) in
4106 let modehash = findkeyhash conf
"listview" in
4107 state
.uioh <- coe (object
4108 inherit listview ~zebra
:false ~helpmode
:false
4109 ~
source ~trusted
:false ~
modehash as super
4112 then msgsource#reset
;
4115 G.postRedisplay "msgs";
4119 let editor = getenvwithdef
"EDITOR" E.s in
4123 let tmppath = Filename.temp_file
"llpp" "note" in
4126 let oc = open_out
tmppath in
4130 let execstr = editor ^
" " ^
tmppath in
4132 match spawn
execstr [] with
4133 | (exception exn
) ->
4134 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4137 match Unix.waitpid
[] pid with
4138 | (exception exn
) ->
4139 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4143 | Unix.WEXITED
0 -> filecontents
tmppath
4145 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4147 | Unix.WSIGNALED
n ->
4148 impmsg "editor process(%s) was killed by signal %d" execstr n;
4150 | Unix.WSTOPPED
n ->
4151 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4154 match Unix.unlink
tmppath with
4155 | (exception exn
) ->
4156 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4161 let enterannotmode opaque slinkindex
=
4164 inherit lvsourcebase
4165 val mutable m_text
= E.s
4166 val mutable m_items
= E.a
4168 method getitemcount
= Array.length m_items
4171 let label, _func
= m_items
.(n) in
4174 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4175 ignore
(uioh, first, pan
);
4178 let _label, func
= m_items
.(active) in
4183 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4186 let rec split accu b i
=
4188 if p = String.length
s
4189 then (String.sub
s b (p-b), unit) :: accu
4191 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4193 let ss = if i
= 0 then E.s else String.sub
s b i
in
4194 split ((ss, unit)::accu) (p+1) 0
4199 wcmd "freepage %s" (~
> opaque);
4201 Hashtbl.fold (fun key opaque'
accu ->
4202 if opaque'
= opaque'
4203 then key :: accu else accu) state
.pagemap
[]
4205 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4207 gotoxy state
.x state
.y
4210 delannot
opaque slinkindex
;
4213 let edit inline
() =
4218 modannot
opaque slinkindex
s;
4224 let mode = state
.mode in
4227 ("annotation: ", m_text
, None
, textentry, update, true),
4228 fun _ -> state
.mode <- mode);
4232 let s = getusertext m_text
in
4237 ( "[Copy]", fun () -> selstring m_text
)
4238 :: ("[Delete]", dele)
4239 :: ("[Edit]", edit conf
.annotinline
)
4241 :: split [] 0 0 |> List.rev
|> Array.of_list
4248 let s = getannotcontents
opaque slinkindex
in
4251 let source = (msgsource :> lvsource
) in
4252 let modehash = findkeyhash conf
"listview" in
4253 state
.uioh <- coe (object
4254 inherit listview ~zebra
:false ~helpmode
:false
4255 ~
source ~trusted
:false ~
modehash
4257 G.postRedisplay "enterannotmode";
4260 let gotounder under =
4261 let getpath filename
=
4263 if nonemptystr filename
4265 if Filename.is_relative filename
4267 let dir = Filename.dirname state
.path in
4269 if Filename.is_implicit
dir
4270 then Filename.concat
(Sys.getcwd
()) dir
4273 Filename.concat
dir filename
4277 if Sys.file_exists
path
4282 | Ulinkgoto
(pageno, top) ->
4287 if conf
.presentation
&& conf
.coarseprespos
4291 gotopage1 pageno top;
4294 | Ulinkuri
s -> gotouri
s
4296 | Uremote
(filename
, pageno) ->
4297 let path = getpath filename
in
4302 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4303 match spawn
command [] with
4305 | (exception exn
) ->
4306 dolog
"failed to execute `%s': %s" command @@ exntos exn
4308 let anchor = getanchor
() in
4309 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4310 state
.origin
<- E.s;
4311 state
.anchor <- (pageno, 0.0, 0.0);
4312 state
.ranchors
<- ranchor :: state
.ranchors
;
4315 else impmsg "cannot find %s" filename
4317 | Uremotedest
(filename
, destname
) ->
4318 let path = getpath filename
in
4323 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4324 match spawn
command [] with
4325 | (exception exn
) ->
4326 dolog
"failed to execute `%s': %s" command @@ exntos exn
4329 let anchor = getanchor
() in
4330 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4331 state
.origin
<- E.s;
4332 state
.nameddest
<- destname
;
4333 state
.ranchors
<- ranchor :: state
.ranchors
;
4336 else impmsg "cannot find %s" filename
4338 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4339 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4342 let gotooutline (_, _, kind
) =
4346 let (pageno, y, _) = anchor in
4348 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4352 | Ouri
uri -> gotounder (Ulinkuri
uri)
4353 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4354 | Oremote remote
-> gotounder (Uremote remote
)
4355 | Ohistory hist
-> gotohist hist
4356 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4359 class outlinesoucebase fetchoutlines
= object (self)
4360 inherit lvsourcebase
4361 val mutable m_items
= E.a
4362 val mutable m_minfo
= E.a
4363 val mutable m_orig_items
= E.a
4364 val mutable m_orig_minfo
= E.a
4365 val mutable m_narrow_patterns
= []
4366 val mutable m_gen
= -1
4368 method getitemcount
= Array.length m_items
4371 let s, n, _ = m_items
.(n) in
4374 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4376 ignore
(uioh, first);
4378 if m_narrow_patterns
= []
4379 then m_orig_items
, m_orig_minfo
4380 else m_items
, m_minfo
4387 gotooutline m_items
.(active);
4395 method hasaction
(_:int) = true
4398 if Array.length m_items
!= Array.length m_orig_items
4401 match m_narrow_patterns
with
4403 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4405 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4409 match m_narrow_patterns
with
4412 | head
:: _ -> "@Uellipsis" ^ head
4414 method narrow
pattern =
4415 match Str.regexp_case_fold
pattern with
4416 | (exception _) -> ()
4418 let rec loop accu minfo n =
4421 m_items
<- Array.of_list
accu;
4422 m_minfo
<- Array.of_list
minfo;
4425 let (s, _, _) as o = m_items
.(n) in
4427 match Str.search_forward re
s 0 with
4428 | (exception Not_found
) -> accu, minfo
4429 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4431 loop accu minfo (n-1)
4433 loop [] [] (Array.length m_items
- 1)
4435 method! getminfo
= m_minfo
4438 m_orig_items
<- fetchoutlines
();
4439 m_minfo
<- m_orig_minfo
;
4440 m_items
<- m_orig_items
4442 method add_narrow_pattern
pattern =
4443 m_narrow_patterns
<- pattern :: m_narrow_patterns
4445 method del_narrow_pattern
=
4446 match m_narrow_patterns
with
4447 | _ :: rest
-> m_narrow_patterns
<- rest
4452 match m_narrow_patterns
with
4453 | pattern :: [] -> self#narrow
pattern; pattern
4455 List.fold_left
(fun accu pattern ->
4456 self#narrow
pattern;
4457 pattern ^
"@Uellipsis" ^
accu) E.s list
4459 method calcactive
(_:anchor) = 0
4461 method reset
anchor items =
4462 if state
.gen
!= m_gen
4464 m_orig_items
<- items;
4466 m_narrow_patterns
<- [];
4468 m_orig_minfo
<- E.a;
4472 if items != m_orig_items
4474 m_orig_items
<- items;
4475 if m_narrow_patterns
== []
4476 then m_items
<- items;
4479 let active = self#calcactive
anchor in
4481 m_first
<- firstof m_first
active
4485 let outlinesource fetchoutlines
=
4487 inherit outlinesoucebase fetchoutlines
4488 method! calcactive
anchor =
4489 let rely = getanchory anchor in
4490 let rec loop n best bestd
=
4491 if n = Array.length m_items
4494 let _, _, kind
= m_items
.(n) in
4497 let orely = getanchory anchor in
4498 let d = abs
(orely - rely) in
4501 else loop (n+1) best bestd
4502 | Onone
| Oremote
_ | Olaunch
_
4503 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4504 loop (n+1) best bestd
4510 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4511 let mkselector sourcetype
=
4512 let fetchoutlines () =
4513 match sourcetype
with
4514 | `bookmarks
-> Array.of_list state
.bookmarks
4515 | `outlines
-> state
.outlines
4516 | `history
-> genhistoutlines ()
4519 if sourcetype
= `history
4520 then new outlinesoucebase
fetchoutlines
4521 else outlinesource fetchoutlines
4524 let outlines = fetchoutlines () in
4525 if Array.length
outlines = 0
4527 showtext ' ' errmsg
;
4531 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4532 let anchor = getanchor
() in
4533 source#reset
anchor outlines;
4534 state
.text <- source#greetmsg
;
4536 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4537 G.postRedisplay "enter selector";
4540 let mkenter sourcetype errmsg
=
4541 let enter = mkselector sourcetype
in
4542 fun () -> enter errmsg
4544 (**)mkenter `
outlines "document has no outline"
4545 , mkenter `bookmarks
"document has no bookmarks (yet)"
4546 , mkenter `history
"history is empty"
4549 let quickbookmark ?title
() =
4550 match state
.layout with
4556 let tm = Unix.localtime
(now
()) in
4558 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4562 (tm.Unix.tm_year
+ 1900)
4565 | Some
title -> title
4567 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4570 let setautoscrollspeed step goingdown
=
4571 let incr = max
1 ((abs step
) / 2) in
4572 let incr = if goingdown
then incr else -incr in
4573 let astep = boundastep state
.winh
(step
+ incr) in
4574 state
.autoscroll
<- Some
astep;
4578 match conf
.columns
with
4580 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4583 let panbound x = bound
x (-state
.w) state
.winw
;;
4585 let existsinrow pageno (columns
, coverA
, coverB
) p =
4586 let last = ((pageno - coverA
) mod columns
) + columns
in
4587 let rec any = function
4590 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4594 then (if l.pageno = last then false else any rest
)
4602 match state
.layout with
4604 let pageno = page_of_y state
.y in
4605 gotoghyll (getpagey
(pageno+1))
4607 match conf
.columns
with
4609 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4611 let y = clamp (pgscale state
.winh
) in
4614 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4615 gotoghyll (getpagey
pageno)
4616 | Cmulti
((c, _, _) as cl
, _) ->
4617 if conf
.presentation
4618 && (existsinrow l.pageno cl
4619 (fun l -> l.pageh
> l.pagey + l.pagevh))
4621 let y = clamp (pgscale state
.winh
) in
4624 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4625 gotoghyll (getpagey
pageno)
4627 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4629 let pagey, pageh
= getpageyh
l.pageno in
4630 let pagey = pagey + pageh
* l.pagecol
in
4631 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4632 gotoghyll (pagey + pageh
+ ips)
4636 match state
.layout with
4638 let pageno = page_of_y state
.y in
4639 gotoghyll (getpagey
(pageno-1))
4641 match conf
.columns
with
4643 if conf
.presentation
&& l.pagey != 0
4645 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4647 let pageno = max
0 (l.pageno-1) in
4648 gotoghyll (getpagey
pageno)
4649 | Cmulti
((c, _, coverB
) as cl
, _) ->
4650 if conf
.presentation
&&
4651 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4653 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4656 if l.pageno = state
.pagecount
- coverB
4660 let pageno = max
0 (l.pageno-decr) in
4661 gotoghyll (getpagey
pageno)
4669 let pageno = max
0 (l.pageno-1) in
4670 let pagey, pageh
= getpageyh
pageno in
4673 let pagey, pageh
= getpageyh
l.pageno in
4674 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4680 if emptystr conf
.savecmd
4681 then error
"don't know where to save modified document"
4683 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4686 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4691 let tmp = path ^
".tmp" in
4693 Unix.rename
tmp path;
4696 let viewkeyboard key mask
=
4698 let mode = state
.mode in
4699 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4702 G.postRedisplay "view:enttext"
4704 let ctrl = Wsi.withctrl mask
in
4705 let key = Wsi.keypadtodigitkey
key in
4710 if hasunsavedchanges
()
4714 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4716 state
.mode <- LinkNav
(Ltgendir
0);
4717 gotoxy state
.x state
.y;
4719 else impmsg "keyboard link navigation does not work under rotation"
4722 begin match state
.mstate
with
4725 G.postRedisplay "kill rect";
4728 | Mscrolly
| Mscrollx
4731 begin match state
.mode with
4734 G.postRedisplay "esc leave linknav"
4738 match state
.ranchors
with
4740 | (path, password, anchor, origin
) :: rest
->
4741 state
.ranchors
<- rest
;
4742 state
.anchor <- anchor;
4743 state
.origin
<- origin
;
4744 state
.nameddest
<- E.s;
4745 opendoc path password
4750 gotoghyll (getnav ~
-1)
4761 Hashtbl.iter
(fun _ opaque ->
4763 Hashtbl.clear state
.prects
) state
.pagemap
;
4764 G.postRedisplay "dehighlight";
4766 | @slash
| @question
->
4767 let ondone isforw
s =
4768 cbput state
.hists
.pat
s;
4769 state
.searchpattern
<- s;
4772 let s = String.make
1 (Char.chr
key) in
4773 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4774 textentry, ondone (key = @slash
), true)
4776 | @plus
| @kpplus
| @equals
when ctrl ->
4777 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4778 pivotzoom (conf
.zoom +. incr)
4780 | @plus
| @kpplus
->
4783 try int_of_string
s with exn
->
4784 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4790 state
.text <- "page bias is now " ^ string_of_int
n;
4793 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4795 | @minus
| @kpminus
when ctrl ->
4796 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4797 pivotzoom (max
0.01 (conf
.zoom -. decr))
4799 | @minus
| @kpminus
->
4800 let ondone msg
= state
.text <- msg
in
4802 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4803 optentry state
.mode, ondone, true
4808 then gotoxy 0 state
.y
4811 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4813 match conf
.columns
with
4814 | Csingle
_ | Cmulti
_ -> 1
4815 | Csplit
(n, _) -> n
4817 let h = state
.winh
-
4818 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4820 let zoom = zoomforh state
.winw
h 0 cols in
4821 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4826 match conf
.fitmodel
with
4827 | FitWidth
-> FitProportional
4828 | FitProportional
-> FitPage
4829 | FitPage
-> FitWidth
4831 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4832 reqlayout conf
.angle
fm
4834 | @4 when ctrl -> (* ctrl-4 *)
4835 let zoom = getmaxw
() /. float state
.winw
in
4836 if zoom > 0.0 then setzoom zoom
4844 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4845 when not
ctrl -> (* 0..9 *)
4848 try int_of_string
s with exn
->
4849 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4855 cbput state
.hists
.pag
(string_of_int
n);
4856 gotopage1 (n + conf
.pagebias
- 1) 0;
4859 let pageentry text key =
4860 match Char.unsafe_chr
key with
4861 | '
g'
-> TEdone
text
4862 | _ -> intentry text key
4864 let text = String.make
1 (Char.chr
key) in
4865 enttext (":", text, Some
(onhist state
.hists
.pag
),
4866 pageentry, ondone, true)
4869 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4870 reshape state
.winw state
.winh
;
4873 state
.bzoom
<- not state
.bzoom
;
4875 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4878 conf
.hlinks
<- not conf
.hlinks
;
4879 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4880 G.postRedisplay "toggle highlightlinks";
4883 if conf
.angle
mod 360 = 0
4885 state
.glinks
<- true;
4886 let mode = state
.mode in
4889 (":", E.s, None
, linknentry, linknact gotounder, false),
4891 state
.glinks
<- false;
4895 G.postRedisplay "view:linkent(F)"
4897 else impmsg "hint mode does not work under rotation"
4900 state
.glinks
<- true;
4901 let mode = state
.mode in
4902 state
.mode <- Textentry
(
4904 ":", E.s, None
, linknentry, linknact (fun under ->
4905 selstring (undertext under);
4909 state
.glinks
<- false;
4913 G.postRedisplay "view:linkent"
4916 begin match state
.autoscroll
with
4918 conf
.autoscrollstep
<- step
;
4919 state
.autoscroll
<- None
4921 if conf
.autoscrollstep
= 0
4922 then state
.autoscroll
<- Some
1
4923 else state
.autoscroll
<- Some conf
.autoscrollstep
4927 launchpath () (* XXX where do error messages go? *)
4930 setpresentationmode (not conf
.presentation
);
4931 showtext ' '
("presentation mode " ^
4932 if conf
.presentation
then "on" else "off");
4935 if List.mem
Wsi.Fullscreen state
.winstate
4936 then Wsi.reshape conf
.cwinw conf
.cwinh
4937 else Wsi.fullscreen
()
4940 search state
.searchpattern
false
4943 search state
.searchpattern
true
4946 begin match state
.layout with
4949 gotoghyll (getpagey
l.pageno)
4955 | @delete
| @kpdelete
-> (* delete *)
4959 showtext ' '
(describe_location ());
4962 begin match state
.layout with
4965 Wsi.reshape l.pagew
l.pageh
;
4970 enterbookmarkmode
()
4978 | @e when Buffer.length state
.errmsgs
> 0 ->
4983 match state
.layout with
4988 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4991 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4995 showtext ' '
"Quick bookmark added";
4998 begin match state
.layout with
5000 let rect = getpdimrect
l.pagedimno
in
5004 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5005 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5007 (truncate
(rect.(1) -. rect.(0)),
5008 truncate
(rect.(3) -. rect.(0)))
5010 let w = truncate
((float w)*.conf
.zoom)
5011 and h = truncate
((float h)*.conf
.zoom) in
5014 state
.anchor <- getanchor
();
5015 Wsi.reshape w (h + conf
.interpagespace
)
5017 G.postRedisplay "z";
5022 | @x -> state
.roam
()
5025 reqlayout (conf
.angle
+
5026 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5030 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5032 G.postRedisplay "brightness";
5034 | @c when state
.mode = View
->
5039 let m = (state
.winw
- state
.w) / 2 in
5040 gotoxy_and_clear_text m state
.y
5044 match state
.prevcolumns
with
5045 | None
-> (1, 0, 0), 1.0
5046 | Some
(columns
, z
) ->
5049 | Csplit
(c, _) -> -c, 0, 0
5050 | Cmulti
((c, a, b), _) -> c, a, b
5051 | Csingle
_ -> 1, 0, 0
5055 setcolumns View
c a b;
5058 | @down
| @up
when ctrl && Wsi.withshift mask
->
5059 let zoom, x = state
.prevzoom
in
5063 | @k
| @up
| @kpup
->
5064 begin match state
.autoscroll
with
5066 begin match state
.mode with
5067 | Birdseye beye
-> upbirdseye 1 beye
5072 then gotoxy_and_clear_text state
.x (clamp ~
-(state
.winh
/2))
5074 if not
(Wsi.withshift mask
) && conf
.presentation
5076 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5080 setautoscrollspeed n false
5083 | @j
| @down
| @kpdown
->
5084 begin match state
.autoscroll
with
5086 begin match state
.mode with
5087 | Birdseye beye
-> downbirdseye 1 beye
5092 then gotoxy_and_clear_text state
.x (clamp (state
.winh
/2))
5094 if not
(Wsi.withshift mask
) && conf
.presentation
5096 else gotoghyll1 true (clamp (conf
.scrollstep
))
5100 setautoscrollspeed n true
5103 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5109 else conf
.hscrollstep
5111 let dx = if key = @left || key = @kpleft
then dx else -dx in
5112 gotoxy_and_clear_text (panbound (state
.x + dx)) state
.y
5115 G.postRedisplay "left/right"
5118 | @prior
| @kpprior
->
5122 match state
.layout with
5124 | l :: _ -> state
.y - l.pagey
5126 clamp (pgscale (-state
.winh
))
5130 | @next | @kpnext
->
5134 match List.rev state
.layout with
5136 | l :: _ -> getpagey
l.pageno
5138 clamp (pgscale state
.winh
)
5142 | @g | @home
| @kphome
->
5145 | @G
| @jend
| @kpend
->
5147 gotoghyll (clamp state
.maxy)
5149 | @right
| @kpright
when Wsi.withalt mask
->
5150 gotoghyll (getnav 1)
5151 | @left | @kpleft
when Wsi.withalt mask
->
5152 gotoghyll (getnav ~
-1)
5157 | @v when conf
.debug
->
5160 match getopaque l.pageno with
5163 let x0, y0, x1, y1 = pagebbox
opaque in
5164 let rect = (float x0, float y0,
5167 float x0, float y1) in
5169 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5170 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5172 G.postRedisplay "v";
5175 let mode = state
.mode in
5176 let cmd = ref E.s in
5177 let onleave = function
5178 | Cancel
-> state
.mode <- mode
5181 match getopaque l.pageno with
5182 | Some
opaque -> pipesel opaque !cmd
5183 | None
-> ()) state
.layout;
5187 cbput state
.hists
.sel
s;
5191 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5193 G.postRedisplay "|";
5194 state
.mode <- Textentry
(te, onleave);
5197 vlog "huh? %s" (Wsi.keyname
key)
5200 let linknavkeyboard key mask
linknav =
5201 let getpage pageno =
5202 let rec loop = function
5204 | l :: _ when l.pageno = pageno -> Some
l
5205 | _ :: rest
-> loop rest
5206 in loop state
.layout
5208 let doexact (pageno, n) =
5209 match getopaque pageno, getpage pageno with
5210 | Some
opaque, Some
l ->
5211 if key = @enter || key = @kpenter
5213 let under = getlink
opaque n in
5214 G.postRedisplay "link gotounder";
5221 Some
(findlink
opaque LDfirst
), -1
5224 Some
(findlink
opaque LDlast
), 1
5227 Some
(findlink
opaque (LDleft
n)), -1
5230 Some
(findlink
opaque (LDright
n)), 1
5233 Some
(findlink
opaque (LDup
n)), -1
5236 Some
(findlink
opaque (LDdown
n)), 1
5241 begin match findpwl
l.pageno dir with
5245 state
.mode <- LinkNav
(Ltgendir
dir);
5246 let y, h = getpageyh
pageno in
5249 then y + h - state
.winh
5254 begin match getopaque pageno, getpage pageno with
5255 | Some
opaque, Some
_ ->
5257 let ld = if dir > 0 then LDfirst
else LDlast
in
5260 begin match link with
5262 showlinktype (getlink
opaque m);
5263 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5264 G.postRedisplay "linknav jpage";
5265 | Lnotfound
-> notfound dir
5271 begin match opt with
5272 | Some Lnotfound
-> pwl l dir;
5273 | Some
(Lfound
m) ->
5277 let _, y0, _, y1 = getlinkrect
opaque m in
5279 then gotopage1 l.pageno y0
5281 let d = fstate
.fontsize
+ 1 in
5282 if y1 - l.pagey > l.pagevh - d
5283 then gotopage1 l.pageno (y1 - state
.winh
+ d)
5284 else G.postRedisplay "linknav";
5286 showlinktype (getlink
opaque m);
5287 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5290 | None
-> viewkeyboard key mask
5292 | _ -> viewkeyboard key mask
5297 G.postRedisplay "leave linknav"
5301 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5302 | Ltexact exact
-> doexact exact
5305 let keyboard key mask
=
5306 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5307 then wcmd "interrupt"
5308 else state
.uioh <- state
.uioh#
key key mask
5311 let birdseyekeyboard key mask
5312 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5314 match conf
.columns
with
5316 | Cmulti
((c, _, _), _) -> c
5317 | Csplit
_ -> failwith
"bird's eye split mode"
5319 let pgh layout = List.fold_left
5320 (fun m l -> max
l.pageh
m) state
.winh
layout in
5322 | @l when Wsi.withctrl mask
->
5323 let y, h = getpageyh
pageno in
5324 let top = (state
.winh
- h) / 2 in
5325 gotoxy state
.x (max
0 (y - top))
5326 | @enter | @kpenter
-> leavebirdseye beye
false
5327 | @escape
-> leavebirdseye beye
true
5328 | @up
-> upbirdseye incr beye
5329 | @down
-> downbirdseye incr beye
5330 | @left -> upbirdseye 1 beye
5331 | @right
-> downbirdseye 1 beye
5334 begin match state
.layout with
5338 state
.mode <- Birdseye
(
5339 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5341 gotopage1 l.pageno 0;
5344 let layout = layout state
.x (state
.y-state
.winh
)
5346 (pgh state
.layout) in
5348 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5350 state
.mode <- Birdseye
(
5351 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5353 gotopage1 l.pageno 0
5356 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5360 begin match List.rev state
.layout with
5362 let layout = layout state
.x
5363 (state
.y + (pgh state
.layout))
5364 state
.winw state
.winh
in
5365 begin match layout with
5367 let incr = l.pageh
- l.pagevh in
5372 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5374 G.postRedisplay "birdseye pagedown";
5376 else gotoxy state
.x (clamp (incr + conf
.interpagespace
*2));
5380 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5381 gotopage1 l.pageno 0;
5384 | [] -> gotoxy state
.x (clamp state
.winh
)
5388 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5392 let pageno = state
.pagecount
- 1 in
5393 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5394 if not
(pagevisible state
.layout pageno)
5397 match List.rev state
.pdims
with
5399 | (_, _, h, _) :: _ -> h
5403 (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5404 else G.postRedisplay "birdseye end";
5406 | _ -> viewkeyboard key mask
5411 match state
.mode with
5412 | Textentry
_ -> scalecolor 0.4
5414 | View
-> scalecolor 1.0
5415 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5416 if l.pageno = hooverpageno
5419 if l.pageno = pageno
5421 let c = scalecolor 1.0 in
5423 GlDraw.line_width
3.0;
5424 let dispx = l.pagedispx in
5426 (float (dispx-1)) (float (l.pagedispy-1))
5427 (float (dispx+l.pagevw+1))
5428 (float (l.pagedispy+l.pagevh+1))
5430 GlDraw.line_width
1.0;
5439 let postdrawpage l linkindexbase
=
5440 match getopaque l.pageno with
5442 if tileready l l.pagex
l.pagey
5444 let x = l.pagedispx - l.pagex
5445 and y = l.pagedispy - l.pagey in
5447 match conf
.columns
with
5448 | Csingle
_ | Cmulti
_ ->
5449 (if conf
.hlinks
then 1 else 0)
5451 && not
(isbirdseye state
.mode) then 2 else 0)
5455 match state
.mode with
5456 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5462 Hashtbl.find_all state
.prects
l.pageno |>
5463 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5464 let n = postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
) in
5466 then (state
.redisplay
<- true; 0)
5472 let scrollindicator () =
5473 let sbw, ph
, sh = state
.uioh#
scrollph in
5474 let sbh, pw, sw = state
.uioh#scrollpw
in
5479 else ((state
.winw
- sbw), state
.winw
, 0)
5483 GlDraw.color (0.64, 0.64, 0.64) ~
alpha:0.7;
5484 filledrect (float x0) 0. (float x1) (float state
.winh
);
5486 (float hx0
) (float (state
.winh
- sbh))
5487 (float (hx0
+ state
.winw
)) (float state
.winh
)
5489 GlDraw.color (0.0, 0.0, 0.0) ~
alpha:0.7;
5491 filledrect (float x0) ph
(float x1) (ph
+. sh);
5492 let pw = pw +. float hx0
in
5493 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5498 match state
.mstate
with
5499 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5502 | Msel
((x0, y0), (x1, y1)) ->
5503 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5504 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5505 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5506 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5509 let showrects = function [] -> () | rects
->
5511 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5512 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5514 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5516 if l.pageno = pageno
5518 let dx = float (l.pagedispx - l.pagex
) in
5519 let dy = float (l.pagedispy - l.pagey) in
5520 let r, g, b, alpha = c in
5521 GlDraw.color (r, g, b) ~
alpha;
5522 filledrect2 (x0+.dx) (y0+.dy)
5534 begin match conf
.columns
, state
.layout with
5535 | Csingle
_, _ :: _ ->
5536 GlDraw.color (scalecolor2 conf
.bgcolor
);
5538 List.fold_left
(fun y l ->
5541 let x1 = l.pagedispx in
5542 let y1 = (l.pagedispy + l.pagevh) in
5543 filledrect (float x0) (float y0) (float x1) (float y1);
5544 let x0 = x1 + l.pagevw in
5545 let x1 = state
.winw
in
5546 filledrect1 (float x0) (float y0) (float x1) (float y1);
5550 and x1 = state
.winw
in
5552 and y1 = l.pagedispy in
5553 filledrect1 (float x0) (float y0) (float x1) (float y1);
5555 l.pagedispy + l.pagevh) 0 state
.layout
5558 and x1 = state
.winw
in
5560 and y1 = state
.winh
in
5561 filledrect1 (float x0) (float y0) (float x1) (float y1)
5562 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5563 GlClear.color (scalecolor2 conf
.bgcolor
);
5564 GlClear.clear
[`
color];
5566 List.iter
drawpage state
.layout;
5568 match state
.mode with
5569 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5570 begin match getopaque pageno with
5572 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5573 let color = (0.0, 0.0, 0.5, 0.5) in
5580 | None
-> state
.rects
5582 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5585 | View
-> state
.rects
5588 let rec postloop linkindexbase
= function
5590 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5591 postloop linkindexbase rest
5595 postloop 0 state
.layout;
5597 begin match state
.mstate
with
5598 | Mzoomrect
((x0, y0), (x1, y1)) ->
5600 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5601 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5602 filledrect (float x0) (float y0) (float x1) (float y1);
5606 | Mscrolly
| Mscrollx
5615 let zoomrect x y x1 y1 =
5618 and y0 = min
y y1 in
5619 let zoom = (float state
.w) /. float (x1 - x0) in
5621 let simple () = if state
.w < state
.winw
then state
.w / 2 else 0 in
5622 match conf
.fitmodel
with
5623 | FitWidth
| FitProportional
-> simple ()
5625 match conf
.columns
with
5627 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5628 | Cmulti
_ | Csingle
_ -> simple ()
5630 gotoxy ((state
.x + margin) - x0) (state
.y + y0);
5631 state
.anchor <- getanchor
();
5636 let annot inline
x y =
5637 match unproject x y with
5638 | Some
(opaque, n, ux
, uy
) ->
5640 addannot
opaque ux uy
text;
5641 wcmd "freepage %s" (~
> opaque);
5642 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5644 gotoxy state
.x state
.y
5648 let ondone s = add s in
5649 let mode = state
.mode in
5650 state
.mode <- Textentry
(
5651 ("annotation: ", E.s, None
, textentry, ondone, true),
5652 fun _ -> state
.mode <- mode);
5655 G.postRedisplay "annot"
5657 add @@ getusertext E.s
5662 let g opaque l px py =
5663 match rectofblock
opaque px py with
5665 let x0 = a.(0) -. 20. in
5666 let x1 = a.(1) +. 20. in
5667 let y0 = a.(2) -. 20. in
5668 let zoom = (float state
.w) /. (x1 -. x0) in
5669 let pagey = getpagey
l.pageno in
5670 let margin = (state
.w - l.pagew
)/2 in
5671 let nx = -truncate
x0 - margin in
5672 gotoxy_and_clear_text nx (pagey + truncate
y0);
5673 state
.anchor <- getanchor
();
5678 match conf
.columns
with
5680 impmsg "block zooming does not work properly in split columns mode"
5681 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5685 let winw = state
.winw - 1 in
5686 let s = float x /. float winw in
5687 let destx = truncate
(float (state
.w + winw) *. s) in
5688 gotoxy_and_clear_text (winw - destx) state
.y;
5689 state
.mstate
<- Mscrollx
;
5693 let s = float y /. float state
.winh
in
5694 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5695 gotoxy_and_clear_text state
.x desty;
5696 state
.mstate
<- Mscrolly
;
5699 let viewmulticlick clicks
x y mask
=
5700 let g opaque l px py =
5708 if markunder
opaque px py mark
5712 match getopaque l.pageno with
5714 | Some
opaque -> pipesel opaque cmd
5716 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5717 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5722 G.postRedisplay "viewmulticlick";
5723 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5727 match conf
.columns
with
5729 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5732 let viewmouse button down
x y mask
=
5734 | n when (n == 4 || n == 5) && not down
->
5735 if Wsi.withctrl mask
5737 match state
.mstate
with
5738 | Mzoom
(oldn
, i
) ->
5746 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5748 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5750 let zoom = conf
.zoom -. incr in
5751 pivotzoom ~
x ~
y zoom;
5752 state
.mstate
<- Mzoom
(n, 0);
5754 state
.mstate
<- Mzoom
(n, i
+1);
5756 else state
.mstate
<- Mzoom
(n, 0)
5760 | Mscrolly
| Mscrollx
5762 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5765 match state
.autoscroll
with
5766 | Some step
-> setautoscrollspeed step
(n=4)
5768 if conf
.wheelbypage
|| conf
.presentation
5777 then -conf
.scrollstep
5778 else conf
.scrollstep
5780 let incr = incr * 2 in
5781 let y = clamp incr in
5782 gotoxy_and_clear_text state
.x y
5785 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5787 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
) in
5788 gotoxy_and_clear_text x state
.y
5790 | 1 when Wsi.withshift mask
->
5791 state
.mstate
<- Mnone
;
5794 match unproject x y with
5796 | Some
(_, pageno, ux
, uy
) ->
5797 let cmd = Printf.sprintf
5799 conf
.stcmd state
.path pageno ux uy
5801 match spawn
cmd [] with
5802 | (exception exn
) ->
5803 impmsg "execution of synctex command(%S) failed: %S"
5804 conf
.stcmd
@@ exntos exn
5808 | 1 when Wsi.withctrl mask
->
5811 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5812 state
.mstate
<- Mpan
(x, y)
5815 state
.mstate
<- Mnone
5820 if Wsi.withshift mask
5822 annot conf
.annotinline
x y;
5823 G.postRedisplay "addannot"
5827 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5828 state
.mstate
<- Mzoomrect
(p, p)
5831 match state
.mstate
with
5832 | Mzoomrect
((x0, y0), _) ->
5833 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5834 then zoomrect x0 y0 x y
5837 G.postRedisplay "kill accidental zoom rect";
5841 | Mscrolly
| Mscrollx
5847 | 1 when vscrollhit x ->
5850 let _, position, sh = state
.uioh#
scrollph in
5851 if y > truncate
position && y < truncate
(position +. sh)
5852 then state
.mstate
<- Mscrolly
5855 state
.mstate
<- Mnone
5857 | 1 when y > state
.winh
- hscrollh () ->
5860 let _, position, sw = state
.uioh#scrollpw
in
5861 if x > truncate
position && x < truncate
(position +. sw)
5862 then state
.mstate
<- Mscrollx
5865 state
.mstate
<- Mnone
5867 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5870 let dest = if down
then getunder x y else Unone
in
5871 begin match dest with
5874 | Uremote
_ | Uremotedest
_
5875 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5878 | Unone
when down
->
5879 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5880 state
.mstate
<- Mpan
(x, y);
5882 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5884 | Unone
| Utext
_ ->
5889 state
.mstate
<- Msel
((x, y), (x, y));
5890 G.postRedisplay "mouse select";
5894 match state
.mstate
with
5897 | Mzoom
_ | Mscrollx
| Mscrolly
->
5898 state
.mstate
<- Mnone
5900 | Mzoomrect
((x0, y0), _) ->
5904 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5905 state
.mstate
<- Mnone
5907 | Msel
((x0, y0), (x1, y1)) ->
5908 let rec loop = function
5912 let a0 = l.pagedispy in
5913 let a1 = a0 + l.pagevh in
5914 let b0 = l.pagedispx in
5915 let b1 = b0 + l.pagevw in
5916 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5917 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5921 match getopaque l.pageno with
5924 match Unix.pipe
() with
5925 | (exception exn
) ->
5926 impmsg "cannot create sel pipe: %s" @@
5930 Ne.clo fd
(fun msg
->
5931 dolog
"%s close failed: %s" what msg
)
5934 try spawn
cmd [r, 0; w, -1]
5936 dolog
"cannot execute %S: %s"
5943 G.postRedisplay "copysel";
5945 else clo "Msel pipe/w" w;
5946 clo "Msel pipe/r" r;
5948 dosel conf
.selcmd
();
5949 state
.roam
<- dosel conf
.paxcmd
;
5961 let birdseyemouse button down
x y mask
5962 (conf
, leftx
, _, hooverpageno
, anchor) =
5965 let rec loop = function
5968 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5969 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5971 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5977 | _ -> viewmouse button down
x y mask
5983 method key key mask
=
5984 begin match state
.mode with
5985 | Textentry
textentry -> textentrykeyboard key mask
textentry
5986 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5987 | View
-> viewkeyboard key mask
5988 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5992 method button button bstate
x y mask
=
5993 begin match state
.mode with
5995 | View
-> viewmouse button bstate
x y mask
5996 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6001 method multiclick clicks
x y mask
=
6002 begin match state
.mode with
6004 | View
-> viewmulticlick clicks
x y mask
6011 begin match state
.mode with
6013 | View
| Birdseye
_ | LinkNav
_ ->
6014 match state
.mstate
with
6015 | Mzoom
_ | Mnone
-> ()
6020 state
.mstate
<- Mpan
(x, y);
6021 let x = if canpan () then panbound (state
.x + dx) else state
.x in
6023 gotoxy_and_clear_text x y
6026 state
.mstate
<- Msel
(a, (x, y));
6027 G.postRedisplay "motion select";
6030 let y = min state
.winh
(max
0 y) in
6034 let x = min state
.winw (max
0 x) in
6037 | Mzoomrect
(p0
, _) ->
6038 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6039 G.postRedisplay "motion zoomrect";
6043 method pmotion
x y =
6044 begin match state
.mode with
6045 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6046 let rec loop = function
6048 if hooverpageno
!= -1
6050 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6051 G.postRedisplay "pmotion birdseye no hoover";
6054 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6055 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6057 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6058 G.postRedisplay "pmotion birdseye hoover";
6068 match state
.mstate
with
6069 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6077 let past, _, _ = !r in
6079 let delta = now -. past in
6082 else r := (now, x, y)
6086 method infochanged
_ = ()
6089 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6092 then 0.0, float state
.winh
6093 else scrollph state
.y maxy
6098 let fwinw = float state
.winw in
6100 let sw = fwinw /. float state
.w in
6101 let sw = fwinw *. sw in
6102 max
sw (float conf
.scrollh
)
6105 let maxx = state
.w + state
.winw in
6106 let x = state
.winw - state
.x in
6107 let percent = float x /. float maxx in
6108 (fwinw -. sw) *. percent
6110 hscrollh (), position, sw
6114 match state
.mode with
6115 | LinkNav
_ -> "links"
6116 | Textentry
_ -> "textentry"
6117 | Birdseye
_ -> "birdseye"
6120 findkeyhash conf
modename
6122 method eformsgs
= true
6123 method alwaysscrolly
= false
6126 let addrect pageno r g b a x0 y0 x1 y1 =
6127 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6131 let cl = splitatspace cmds
in
6133 try Scanf.sscanf
s fmt
f
6135 adderrfmt "remote exec"
6136 "error processing '%S': %s\n" cmds
@@ exntos exn
6138 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6139 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6140 s pageno r g b a x0 y0 x1 y1;
6144 let _,w1,h1
,_ = getpagedim
pageno in
6145 let sw = float w1 /. float w
6146 and sh = float h1
/. float h in
6150 and y1s
= y1 *. sh in
6151 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6152 let color = (r, g, b, a) in
6153 if conf
.verbose
then debugrect rect;
6154 state
.rects <- (pageno, color, rect) :: state
.rects;
6159 | "reload", "" -> reload ()
6161 scan args
"%u %f %f"
6163 let cmd, _ = state
.geomcmds
in
6165 then gotopagexy !wtmode pageno x y
6168 gotopagexy !wtmode pageno x y;
6171 state
.reprf
<- f state
.reprf
6173 | "goto1", args
-> scan args
"%u %f" gotopage
6176 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6179 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6181 scan args
"%u %u %f %f %f %f"
6182 (fun pageno c x0 y0 x1 y1 ->
6183 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6184 rectx "rect" pageno color x0 y0 x1 y1;
6187 scan args
"%u %f %f %f %f %f %f %f %f"
6188 (fun pageno r g b alpha x0 y0 x1 y1 ->
6189 addrect pageno r g b alpha x0 y0 x1 y1;
6190 G.postRedisplay "prect"
6193 scan args
"%u %f %f"
6196 match getopaque pageno with
6197 | Some
opaque -> opaque
6200 pgoto optopaque pageno x y;
6201 let rec fixx = function
6204 if l.pageno = pageno
6205 then gotoxy (state
.x - l.pagedispx) state
.y
6210 match conf
.columns
with
6211 | Csingle
_ | Csplit
_ -> 1
6212 | Cmulti
((n, _, _), _) -> n
6214 layout 0 state
.y (state
.winw * mult) state
.winh
6218 | "activatewin", "" -> Wsi.activatewin
()
6219 | "quit", "" -> raise Quit
6222 let l = Config.keys_of_string
keys in
6223 List.iter
(fun (k
, m) -> keyboard k
m) l
6225 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6227 | "clearrects", "" ->
6228 Hashtbl.clear state
.prects
;
6229 G.postRedisplay "clearrects"
6231 adderrfmt "remote command"
6232 "error processing remote command: %S\n" cmds
;
6236 let scratch = Bytes.create
80 in
6237 let buf = Buffer.create
80 in
6239 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6240 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6243 if Buffer.length
buf > 0
6245 let s = Buffer.contents
buf in
6253 match Bytes.index_from
scratch ppos '
\n'
with
6254 | pos -> if pos >= n then -1 else pos
6255 | (exception Not_found
) -> -1
6259 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6260 let s = Buffer.contents
buf in
6266 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6272 let remoteopen path =
6273 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6275 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6280 let gcconfig = ref E.s in
6281 let trimcachepath = ref E.s in
6282 let rcmdpath = ref E.s in
6283 let pageno = ref None
in
6284 let rootwid = ref 0 in
6285 let openlast = ref false in
6286 let nofc = ref false in
6287 let doreap = ref false in
6288 selfexec := Sys.executable_name
;
6291 [("-p", Arg.String
(fun s -> state
.password <- s),
6292 "<password> Set password");
6296 Config.fontpath
:= s;
6297 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6299 "<path> Set path to the user interface font");
6303 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6304 Config.confpath
:= s),
6305 "<path> Set path to the configuration file");
6307 ("-last", Arg.Set
openlast, " Open last document");
6309 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6310 "<page-number> Jump to page");
6312 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6313 "<path> Set path to the trim cache file");
6315 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6316 "<named-destination> Set named destination");
6318 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6319 ("-cxack", Arg.Set
cxack, " Cut corners");
6321 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6322 "<path> Set path to the remote commands source");
6324 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6325 "<original-path> Set original path");
6327 ("-gc", Arg.Set_string
gcconfig,
6328 "<script-path> Collect garbage with the help of a script");
6330 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6332 ("-v", Arg.Unit
(fun () ->
6334 "%s\nconfiguration path: %s\n"
6338 exit
0), " Print version and exit");
6340 ("-embed", Arg.Set_int
rootwid,
6341 "<window-id> Embed into window")
6344 (fun s -> state
.path <- s)
6345 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6348 then selfexec := !selfexec ^
" -wtmode";
6350 let histmode = emptystr state
.path && not
!openlast in
6352 if not
(Config.load !openlast)
6353 then dolog
"failed to load configuration";
6355 begin match !pageno with
6356 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6360 if nonemptystr
!gcconfig
6363 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6364 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6367 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6368 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6370 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6375 let wsfd, winw, winh
= Wsi.init
(object (self)
6376 val mutable m_clicks
= 0
6377 val mutable m_click_x
= 0
6378 val mutable m_click_y
= 0
6379 val mutable m_lastclicktime
= infinity
6381 method private cleanup =
6382 state
.roam
<- noroam
;
6383 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6384 method expose
= G.postRedisplay "expose"
6388 | Wsi.Unobscured
-> "unobscured"
6389 | Wsi.PartiallyObscured
-> "partiallyobscured"
6390 | Wsi.FullyObscured
-> "fullyobscured"
6392 vlog "visibility change %s" name
6393 method display = display ()
6394 method map mapped
= vlog "mapped %b" mapped
6395 method reshape w h =
6398 method mouse
b d x y m =
6399 if d && canselect ()
6401 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6407 if abs
x - m_click_x
> 10
6408 || abs
y - m_click_y
> 10
6409 || abs_float
(t -. m_lastclicktime
) > 0.3
6411 m_clicks
<- m_clicks
+ 1;
6412 m_lastclicktime
<- t;
6416 G.postRedisplay "cleanup";
6417 state
.uioh <- state
.uioh#button
b d x y m;
6419 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6424 m_lastclicktime
<- infinity
;
6425 state
.uioh <- state
.uioh#button
b d x y m
6429 state
.uioh <- state
.uioh#button
b d x y m
6432 state
.mpos
<- (x, y);
6433 state
.uioh <- state
.uioh#motion
x y
6434 method pmotion
x y =
6435 state
.mpos
<- (x, y);
6436 state
.uioh <- state
.uioh#pmotion
x y
6438 let mascm = m land (
6439 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6442 let x = state
.x and y = state
.y in
6444 if x != state
.x || y != state
.y then self#
cleanup
6446 match state
.keystate
with
6448 let km = k
, mascm in
6451 let modehash = state
.uioh#
modehash in
6452 try Hashtbl.find modehash km
6454 try Hashtbl.find (findkeyhash conf
"global") km
6455 with Not_found
-> KMinsrt
(k
, m)
6457 | KMinsrt
(k
, m) -> keyboard k
m
6458 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6459 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6461 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6462 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6463 state
.keystate
<- KSnone
6464 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6465 state
.keystate
<- KSinto
(keys, insrt
)
6466 | KSinto
_ -> state
.keystate
<- KSnone
6469 state
.mpos
<- (x, y);
6470 state
.uioh <- state
.uioh#pmotion
x y
6471 method leave = state
.mpos
<- (-1, -1)
6472 method winstate wsl
= state
.winstate
<- wsl
6473 method quit
= raise Quit
6474 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6476 setbgcol conf
.bgcolor
;
6480 List.exists
GlMisc.check_extension
6481 [ "GL_ARB_texture_rectangle"
6482 ; "GL_EXT_texture_recangle"
6483 ; "GL_NV_texture_rectangle" ]
6485 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6488 let r = GlMisc.get_string `renderer
in
6489 let p = "Mesa DRI Intel(" in
6490 let l = String.length
p in
6491 String.length
r > l && String.sub
r 0 l = p
6494 defconf
.sliceheight
<- 1024;
6495 defconf
.texcount
<- 32;
6496 defconf
.usepbo
<- true;
6500 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6501 | (exception exn
) ->
6502 dolog
"socketpair failed: %s" @@ exntos exn
;
6510 setcheckers conf
.checkers
;
6512 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6515 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6516 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6517 !Config.fontpath
, !trimcachepath,
6521 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6523 reshape ~firsttime
:true winw winh
;
6527 Wsi.settitle
"llpp (history)";
6531 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6532 opendoc state
.path state
.password;
6536 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6537 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6540 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6541 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6542 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6544 | _pid
, _status
-> reap ()
6546 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6550 if nonemptystr
!rcmdpath
6551 then remoteopen !rcmdpath
6556 let rec loop deadline
=
6562 let r = [state
.ss; state
.wsfd] in
6566 | Some fd
-> fd
:: r
6570 state
.redisplay
<- false;
6577 if deadline
= infinity
6579 else max
0.0 (deadline
-. now)
6584 try Unix.select
r [] [] timeout
6585 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6591 if state
.ghyll
== noghyll
6593 match state
.autoscroll
with
6594 | Some step
when step
!= 0 ->
6595 let y = state
.y + step
in
6596 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6599 then state
.maxy - fy
6600 else if y >= state
.maxy - fy then 0 else y
6602 if state
.mode = View
6603 then gotoxy_and_clear_text state
.x y
6604 else gotoxy state
.x y;
6607 else deadline
+. 0.01
6612 let rec checkfds = function
6614 | fd
:: rest
when fd
= state
.ss ->
6615 let cmd = rcmd state
.ss in
6619 | fd
:: rest
when fd
= state
.wsfd ->
6623 | fd
:: rest
when Some fd
= !optrfd ->
6624 begin match remote fd
with
6625 | None
-> optrfd := remoteopen !rcmdpath;
6626 | opt -> optrfd := opt
6631 dolog
"select returned unknown descriptor";
6637 if deadline
= infinity
6641 match state
.autoscroll
with
6642 | Some step
when step
!= 0 -> deadline1
6643 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6651 Config.save leavebirdseye;
6652 if hasunsavedchanges
()