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 pbousable
: unit -> bool = "ml_pbo_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 =
52 let selfexec = ref E.s
;;
54 let drawstring size x y s
=
56 Gl.enable `texture_2d
;
57 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
58 ignore
(drawstr size x y s
);
60 Gl.disable `texture_2d
;
63 let drawstring1 size x y s
=
67 let drawstring2 size x y fmt
=
68 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
72 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
73 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
74 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
75 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
76 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
77 dolog
" column %d" l
.pagecol
;
81 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
83 dolog
" x0,y0=(% f, % f)" x0 y0
;
84 dolog
" x1,y1=(% f, % f)" x1 y1
;
85 dolog
" x2,y2=(% f, % f)" x2 y2
;
86 dolog
" x3,y3=(% f, % f)" x3 y3
;
90 let isbirdseye = function
97 let istextentry = function
104 let wtmode = ref false;;
105 let cxack = ref false;;
107 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
110 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
111 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
117 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
125 else x
> state
.winw
- vscrollw ()
128 let wadjsb () = -vscrollw ();;
129 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
132 fstate
.fontsize
<- n
;
133 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
134 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
140 else Printf.kprintf ignore fmt
144 if emptystr conf
.pathlauncher
145 then dolog
"%s" state
.path
147 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
148 match spawn
command [] with
151 dolog
"failed to execute `%s': %s" command @@ exntos exn
157 let postRedisplay who
=
158 vlog "redisplay for [%S]" who
;
159 state
.redisplay
<- true;
163 let getopaque pageno
=
164 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
165 with Not_found
-> None
168 let pagetranslatepoint l x y
=
169 let dy = y
- l
.pagedispy
in
170 let y = dy + l
.pagey
in
171 let dx = x
- l
.pagedispx
in
172 let x = dx + l
.pagex
in
176 let onppundermouse g
x y d
=
179 begin match getopaque l
.pageno
with
181 let x0 = l
.pagedispx
in
182 let x1 = x0 + l
.pagevw
in
183 let y0 = l
.pagedispy
in
184 let y1 = y0 + l
.pagevh
in
185 if y >= y0 && y <= y1 && x >= x0 && x <= x1
187 let px, py
= pagetranslatepoint l
x y in
188 match g opaque l
px py
with
201 let g opaque l
px py
=
204 match rectofblock opaque
px py
with
205 | Some
[|x0;x1;y0;y1|] ->
206 let ox = xadjsb () |> float in
207 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, 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
378 match Char.lowercase
c with
380 let text = addchar
text c in
384 let text = addchar
text c in
388 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
393 let s = Bytes.create
4 in
394 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
395 if n != 4 then error
"incomplete read(len) = %d" n;
396 let len = (Char.code
(Bytes.get
s 0) lsl 24)
397 lor (Char.code
(Bytes.get
s 1) lsl 16)
398 lor (Char.code
(Bytes.get
s 2) lsl 8)
399 lor (Char.code
(Bytes.get
s 3))
401 let s = Bytes.create
len in
402 let n = tempfailureretry
(Unix.read fd
s 0) len in
403 if n != len then error
"incomplete read(data) %d vs %d" n len;
408 let b = Buffer.create
16 in
409 Buffer.add_string
b "llll";
412 let s = Buffer.to_bytes
b in
413 let n = Bytes.length
s in
415 (* dolog "wcmd %S" (String.sub s 4 len); *)
416 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
417 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
418 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
419 Bytes.set
s 3 (Char.chr
(len land 0xff));
420 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
421 if n'
!= n then error
"write failed %d vs %d" n'
n;
425 let nogeomcmds cmds
=
427 | s, [] -> emptystr
s
431 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
432 let sh = sh - (hscrollh ()) in
433 let wadj = wadjsb () in
434 let rec fold accu
n =
435 if n = Array.length
b
438 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
441 || n = state
.pagecount
- coverB
442 || (n - coverA
) mod columns
= columns
- 1)
448 let pagey = max
0 (y - vy
) in
449 let pagedispy = if pagey > 0 then 0 else vy
- y in
450 let pagedispx, pagex
=
452 if n = coverA
- 1 || n = state
.pagecount
- coverB
453 then x + (wadj + sw
- w
) / 2
461 let vw = wadj + sw
- pagedispx in
462 let pw = w
- pagex
in
465 let pagevh = min
(h
- pagey) (sh - pagedispy) in
466 if pagevw > 0 && pagevh > 0
477 ; pagedispx = pagedispx
478 ; pagedispy = pagedispy
490 if Array.length
b = 0
492 else List.rev
(fold [] (page_of_y
y))
495 let layoutS (columns
, b) x y sw
sh =
496 let sh = sh - hscrollh () in
497 let wadj = wadjsb () in
498 let rec fold accu n =
499 if n = Array.length
b
502 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
510 let pagey = max
0 (y - vy
) in
511 let pagedispy = if pagey > 0 then 0 else vy
- y in
512 let pagedispx, pagex
=
526 let pagecolw = pagew
/columns
in
529 then pagedispx + ((wadj + sw
- pagecolw) / 2)
533 let vw = wadj + sw
- pagedispx in
534 let pw = pagew
- pagex
in
537 let pagevw = min
pagevw pagecolw in
538 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
539 if pagevw > 0 && pagevh > 0
550 ; pagedispx = pagedispx
551 ; pagedispy = pagedispy
552 ; pagecol
= n mod columns
566 let layout x y sw
sh =
567 if nogeomcmds state
.geomcmds
569 match conf
.columns
with
570 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw
sh
571 | Cmulti
c -> layoutN c x y sw
sh
572 | Csplit
s -> layoutS s x y sw
sh
577 let y = state
.y + incr
in
579 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
584 let tilex = l.pagex
mod conf
.tilew
in
585 let tiley = l.pagey mod conf
.tileh
in
587 let col = l.pagex
/ conf
.tilew
in
588 let row = l.pagey / conf
.tileh
in
590 let xadj = xadjsb () in
591 let rec rowloop row y0 dispy h
=
595 let dh = conf
.tileh
- y0 in
597 let rec colloop col x0 dispx w
=
601 let dw = conf
.tilew
- x0 in
603 let dispx'
= xadj + dispx in
604 f col row dispx' dispy
x0 y0 dw dh;
605 colloop (col+1) 0 (dispx+dw) (w
-dw)
608 colloop col tilex l.pagedispx l.pagevw;
609 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
612 if l.pagevw > 0 && l.pagevh > 0
613 then rowloop row tiley l.pagedispy l.pagevh;
616 let gettileopaque l col row =
618 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
620 try Some
(Hashtbl.find state
.tilemap
key)
621 with Not_found
-> None
624 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
625 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
626 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
629 let filledrect x0 y0 x1 y1 =
630 GlArray.disable `texture_coord
;
631 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
632 GlArray.vertex `two state
.vraw
;
633 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
634 GlArray.enable `texture_coord
;
637 let linerect x0 y0 x1 y1 =
638 GlArray.disable `texture_coord
;
639 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
640 GlArray.vertex `two state
.vraw
;
641 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
642 GlArray.enable `texture_coord
;
645 let drawtiles l color =
647 let wadj = wadjsb () in
649 let f col row x y tilex tiley w h
=
650 match gettileopaque l col row with
651 | Some
(opaque
, _
, t
) ->
652 let params = x, y, w
, h
, tilex, tiley in
654 then GlTex.env
(`mode `blend
);
655 drawtile
params opaque
;
657 then GlTex.env
(`mode `modulate
);
661 let s = Printf.sprintf
665 let w = measurestr fstate
.fontsize
s in
666 GlDraw.color (0.0, 0.0, 0.0);
667 filledrect (float (x-2))
670 (float (y + fstate
.fontsize
+ 2));
671 GlDraw.color (1.0, 1.0, 1.0);
672 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
682 let lw = wadj + state
.winw
- x in
685 let lh = state
.winh
- y in
689 then GlTex.env
(`mode `blend
);
690 begin match state
.checkerstexid
with
692 Gl.enable `texture_2d
;
693 GlTex.bind_texture ~target
:`texture_2d id
;
697 and y1 = float (y+h
) in
699 let tw = float w /. 16.0
700 and th
= float h
/. 16.0 in
701 let tx0 = float tilex /. 16.0
702 and ty0
= float tiley /. 16.0 in
704 and ty1
= ty0
+. th
in
705 Raw.sets_float state
.vraw ~pos
:0
706 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
707 Raw.sets_float state
.traw ~pos
:0
708 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
709 GlArray.vertex `two state
.vraw
;
710 GlArray.tex_coord `two state
.traw
;
711 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
712 Gl.disable `texture_2d
;
715 GlDraw.color (1.0, 1.0, 1.0);
716 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
719 then GlTex.env
(`mode `modulate
);
720 if w > 128 && h
> fstate
.fontsize
+ 10
722 let c = if conf
.invert
then 1.0 else 0.0 in
723 GlDraw.color (c, c, c);
726 then (col*conf
.tilew
, row*conf
.tileh
)
729 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
738 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
740 let tilevisible1 l x y =
742 and ax1
= l.pagex
+ l.pagevw
744 and ay1
= l.pagey + l.pagevh in
748 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
749 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
751 let rx0 = max
ax0 bx0
752 and ry0
= max ay0 by0
753 and rx1
= min ax1
bx1
754 and ry1
= min ay1 by1
in
756 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
760 let tilevisible layout n x y =
761 let rec findpageinlayout m
= function
762 | l :: rest
when l.pageno
= n ->
763 tilevisible1 l x y || (
764 match conf
.columns
with
765 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
770 | _
:: rest
-> findpageinlayout 0 rest
773 findpageinlayout 0 layout;
776 let tileready l x y =
777 tilevisible1 l x y &&
778 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
781 let tilepage n p
layout =
782 let rec loop = function
786 let f col row _ _ _ _ _ _
=
787 if state
.currently
= Idle
789 match gettileopaque l col row with
792 let x = col*conf
.tilew
793 and y = row*conf
.tileh
in
795 let w = l.pagew
- x in
799 let h = l.pageh
- y in
804 then getpbo
w h conf
.colorspace
807 wcmd "tile %s %d %d %d %d %s"
808 (~
> p
) x y w h (~
> pbo);
811 l, p
, conf
.colorspace
, conf
.angle
,
812 state
.gen
, col, row, conf
.tilew
, conf
.tileh
821 if nogeomcmds state
.geomcmds
825 let preloadlayout x y sw
sh =
826 let y = if y < sh then 0 else y - sh in
833 if state
.currently
!= Idle
838 begin match getopaque l.pageno
with
840 wcmd "page %d %d" l.pageno
l.pagedimno
;
841 state
.currently
<- Loading
(l, state
.gen
);
843 tilepage l.pageno opaque pages
;
848 if nogeomcmds state
.geomcmds
854 if conf
.preload && state
.currently
= Idle
855 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
858 let layoutready layout =
859 let rec fold all ls
=
862 let seen = ref false in
863 let allvisible = ref true in
864 let foo col row _ _ _ _ _ _
=
866 allvisible := !allvisible &&
867 begin match gettileopaque l col row with
873 fold (!seen && !allvisible) rest
876 let alltilesvisible = fold true layout in
881 let y = bound
y 0 state
.maxy
in
882 let y, layout, proceed
=
883 match conf
.maxwait
with
884 | Some time
when state
.ghyll
== noghyll
->
885 begin match state
.throttle
with
887 let layout = layout state
.x y state
.winw state
.winh
in
888 let ready = layoutready layout in
892 state
.throttle
<- Some
(layout, y, now
());
894 else G.postRedisplay "gotoy showall (None)";
896 | Some
(_
, _
, started
) ->
897 let dt = now
() -. started
in
900 state
.throttle
<- None
;
901 let layout = layout state
.x y state
.winw state
.winh
in
903 G.postRedisplay "maxwait";
910 let layout = layout state
.x y state
.winw state
.winh
in
911 if not
!wtmode || layoutready layout
912 then G.postRedisplay "gotoy ready";
918 state
.layout <- layout;
919 begin match state
.mode
with
922 | Ltexact
(pageno
, linkno
) ->
923 let rec loop = function
925 state
.mode
<- LinkNav
(Ltgendir
0)
926 | l :: _
when l.pageno
= pageno
->
927 begin match getopaque pageno
with
928 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
930 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
931 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
932 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
933 then state
.mode
<- LinkNav
(Ltgendir
0)
935 | _
:: rest
-> loop rest
938 | Ltnotready _
| Ltgendir _
-> ()
944 begin match state
.mode
with
945 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
946 if not
(pagevisible layout pageno
)
948 match state
.layout with
951 state
.mode
<- Birdseye
(
952 conf
, leftx
, l.pageno
, hooverpageno
, anchor
957 | Ltnotready
(_
, dir
)
960 let rec loop = function
963 match getopaque l.pageno
with
964 | None
-> Ltnotready
(l.pageno
, dir
)
969 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
971 if dir
> 0 then LDfirst
else LDlast
977 | Lnotfound
-> loop rest
979 showlinktype (getlink opaque
n);
980 Ltexact
(l.pageno
, n)
984 state
.mode
<- LinkNav
linknav
992 state
.ghyll
<- noghyll
;
995 let mx, my
= state
.mpos
in
1000 let conttiling pageno opaque
=
1001 tilepage pageno opaque
1003 then preloadlayout state
.x state
.y state
.winw state
.winh
1007 let gotoy_and_clear_text y =
1008 if not conf
.verbose
then state
.text <- E.s;
1012 let getanchory (n, top
, dtop
) =
1013 let y, h = getpageyh
n in
1014 if conf
.presentation
1016 let ips = calcips
h in
1017 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1019 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1022 let gotoanchor anchor
=
1023 gotoy (getanchory anchor
);
1027 cbput state
.hists
.nav
(getanchor
());
1031 let anchor = cbgetc state
.hists
.nav dir
in
1035 let gotoghyll1 single
y =
1036 let scroll f n a
b =
1037 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1039 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1041 then s (float f /. float a
)
1044 then 1.0 -. s ((float (f-b) /. float (n-b)))
1050 let ins = float a
*. 0.5
1051 and outs
= float (n-b) *. 0.5 in
1053 ins +. outs
+. float ones
1055 let rec set nab
y sy
=
1056 let (_N
, _A
, _B
), y =
1059 let scl = if y > sy
then 2 else -2 in
1060 let _N, _
, _
= nab
in
1061 (_N,0,_N), y+conf
.scrollstep
*scl
1063 let sum = summa
_N _A _B
in
1064 let dy = float (y - sy
) in
1068 then state
.ghyll
<- noghyll
1071 let s = scroll n _N _A _B
in
1072 let y1 = y1 +. ((s *. dy) /. sum) in
1073 gotoy_and_clear_text (truncate
y1);
1074 state
.ghyll
<- gf (n+1) y1;
1078 | Some
y'
when single
-> set nab
y' state
.y
1079 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1081 gf 0 (float state
.y)
1084 match conf
.ghyllscroll
with
1085 | Some nab
when not conf
.presentation
->
1086 if state
.ghyll
== noghyll
1087 then set nab
y state
.y
1088 else state
.ghyll
(Some
y)
1090 gotoy_and_clear_text y
1093 let gotoghyll = gotoghyll1 false;;
1095 let gotopage n top
=
1096 let y, h = getpageyh
n in
1097 let y = y + (truncate
(top
*. float h)) in
1101 let gotopage1 n top
=
1102 let y = getpagey
n in
1107 let invalidate s f =
1112 match state
.geomcmds
with
1113 | ps
, [] when emptystr ps
->
1115 state
.geomcmds
<- s, [];
1118 state
.geomcmds
<- ps
, [s, f];
1120 | ps
, (s'
, _
) :: rest
when s'
= s ->
1121 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1124 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1128 Hashtbl.iter
(fun _ opaque
->
1129 wcmd "freepage %s" (~
> opaque
);
1131 Hashtbl.clear state
.pagemap
;
1135 if not
(Queue.is_empty state
.tilelru
)
1137 Queue.iter
(fun (k
, p
, s) ->
1138 wcmd "freetile %s" (~
> p
);
1139 state
.memused
<- state
.memused
- s;
1140 Hashtbl.remove state
.tilemap k
;
1142 state
.uioh#infochanged Memused
;
1143 Queue.clear state
.tilelru
;
1149 let h = truncate
(float h*.conf
.zoom
) in
1150 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1154 let opendoc path password
=
1156 state
.password
<- password
;
1157 state
.gen
<- state
.gen
+ 1;
1158 state
.docinfo
<- [];
1159 state
.outlines
<- [||];
1162 setaalevel conf
.aalevel
;
1164 if emptystr state
.origin
1168 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1169 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1170 invalidate "reqlayout"
1172 wcmd "reqlayout %d %d %d %s\000"
1173 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1174 (stateh state
.winh
) state
.nameddest
1179 state
.anchor <- getanchor
();
1180 opendoc state
.path state
.password
;
1184 let c = c *. conf
.colorscale
in
1188 let scalecolor2 (r
, g, b) =
1189 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1192 let docolumns columns
=
1193 let wadj = wadjsb () in
1196 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1197 let wadj = wadjsb () in
1198 let rec loop pageno
pdimno pdim
y ph pdims
=
1199 if pageno
= state
.pagecount
1202 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1204 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1205 pdimno+1, pdim
, rest
1209 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1211 (if conf
.presentation
1212 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1213 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1216 a.(pageno
) <- (pdimno, x, y, pdim
);
1217 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1219 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1220 conf
.columns
<- Csingle
a;
1222 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1223 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1224 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1225 let rec fixrow m
= if m
= pageno
then () else
1226 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1229 let y = y + (rowh
- h) / 2 in
1230 a.(m
) <- (pdimno, x, y, pdim
);
1234 if pageno
= state
.pagecount
1235 then fixrow (((pageno
- 1) / columns
) * columns
)
1237 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1239 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1240 pdimno+1, pdim
, rest
1245 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1247 let x = (wadj + state
.winw
- w) / 2 in
1249 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1250 x, y + ips + rowh
, h
1253 if (pageno
- coverA
) mod columns
= 0
1255 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1257 if conf
.presentation
1259 let ips = calcips
h in
1260 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1262 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1266 else x, y, max rowh
h
1270 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1273 if pageno
= columns
&& conf
.presentation
1275 let ips = calcips rowh
in
1276 for i
= 0 to pred columns
1278 let (pdimno, x, y, pdim
) = a.(i
) in
1279 a.(i
) <- (pdimno, x, y+ips, pdim
)
1285 fixrow (pageno
- columns
);
1290 a.(pageno
) <- (pdimno, x, y, pdim
);
1291 let x = x + w + xoff
*2 + conf
.interpagespace
in
1292 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1294 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1295 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1298 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1299 let rec loop pageno
pdimno pdim
y pdims
=
1300 if pageno
= state
.pagecount
1303 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1305 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1306 pdimno+1, pdim
, rest
1311 let rec loop1 n x y =
1312 if n = c then y else (
1313 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1314 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1317 let y = loop1 0 0 y in
1318 loop (pageno
+1) pdimno pdim
y pdims
1320 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1321 conf
.columns
<- Csplit
(c, a);
1325 docolumns conf
.columns
;
1326 state
.maxy
<- calcheight
();
1327 if state
.reprf
== noreprf
1329 match state
.mode
with
1330 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1331 let y, h = getpageyh pageno
in
1332 let top = (state
.winh
- h) / 2 in
1333 gotoy (max
0 (y - top))
1337 let y = getanchory state
.anchor in
1338 let y = min
y (state
.maxy
- state
.winw
- hscrollh ()) in
1343 state
.reprf
<- noreprf
;
1347 let reshape ?
(firsttime
=false) w h =
1348 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1349 if not firsttime
&& nogeomcmds state
.geomcmds
1350 then state
.anchor <- getanchor
();
1353 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1356 setfontsize fstate
.fontsize
;
1357 GlMat.mode `modelview
;
1358 GlMat.load_identity
();
1360 GlMat.mode `projection
;
1361 GlMat.load_identity
();
1362 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1363 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1364 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1369 else float state
.x /. float state
.w
1371 invalidate "geometry"
1375 then state
.x <- truncate
(relx *. float w);
1377 match conf
.columns
with
1379 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1380 | Csplit
(c, _
) -> w * c
1382 wcmd "geometry %d %d %d"
1383 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1388 let len = String.length state
.text in
1389 let x0 = xadjsb () in
1392 match state
.mode
with
1393 | Textentry _
| View
| LinkNav _
->
1394 let h, _
, _
= state
.uioh#scrollpw
in
1399 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1400 (x+.w) (float (state
.winh
- hscrollh))
1403 let w = float (wadjsb () + state
.winw
- 1) in
1404 if state
.progress
>= 0.0 && state
.progress
< 1.0
1406 GlDraw.color (0.3, 0.3, 0.3);
1407 let w1 = w *. state
.progress
in
1409 GlDraw.color (0.0, 0.0, 0.0);
1410 rect (float x0+.w1) (float x0+.w-.w1)
1413 GlDraw.color (0.0, 0.0, 0.0);
1417 GlDraw.color (1.0, 1.0, 1.0);
1418 drawstring fstate
.fontsize
1419 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1420 (state
.winh
- hscrollh - 5) s;
1423 match state
.mode
with
1424 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1428 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1430 Printf.sprintf
"%s%s_" prefix
text
1436 | LinkNav _
-> state
.text
1441 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1443 let s1 = "(press 'e' to review error messasges)" in
1444 if nonemptystr
s then s ^
" " ^
s1 else s1
1454 let len = Queue.length state
.tilelru
in
1456 match state
.throttle
with
1459 then preloadlayout state
.x state
.y state
.winw state
.winh
1461 | Some
(layout, _
, _
) ->
1465 if state
.memused
<= conf
.memlimit
1470 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1471 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1472 let (_
, pw, ph
, _
) = getpagedim
n in
1475 && colorspace
= conf
.colorspace
1476 && angle
= conf
.angle
1480 let x = col*conf
.tilew
1481 and y = row*conf
.tileh
in
1482 tilevisible (Lazy.force_val
layout) n x y
1484 then Queue.push lruitem state
.tilelru
1487 wcmd "freetile %s" (~
> p
);
1488 state
.memused
<- state
.memused
- s;
1489 state
.uioh#infochanged Memused
;
1490 Hashtbl.remove state
.tilemap k
;
1498 let onpagerect pageno
f =
1500 match conf
.columns
with
1501 | Cmulti
(_
, b) -> b
1503 | Csplit
(_
, b) -> b
1505 if pageno
>= 0 && pageno
< Array.length
b
1507 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1511 let gotopagexy1 pageno
x y =
1512 let _,w1,h1
,leftx
= getpagedim pageno
in
1513 let top = y /. (float h1
) in
1514 let left = x /. (float w1) in
1515 let py, w, h = getpageywh pageno
in
1516 let wh = state
.winh
- hscrollh () in
1517 let x = left *. (float w) in
1518 let x = leftx
+ state
.x + truncate
x in
1519 let wadj = wadjsb () in
1521 if x < 0 || x >= wadj + state
.winw
1525 let pdy = truncate
(top *. float h) in
1526 let y'
= py + pdy in
1527 let dy = y'
- state
.y in
1529 if x != state
.x || not
(dy > 0 && dy < wh)
1531 if conf
.presentation
1533 if abs
(py - y'
) > wh
1540 if state
.x != sx || state
.y != sy
1545 let ww = wadj + state
.winw
in
1547 and qy
= pdy / wh in
1549 and y = py + qy
* wh in
1550 let x = if -x + ww > w1 then -(w1-ww) else x
1551 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1553 if conf
.presentation
1555 if abs
(py - y'
) > wh
1565 gotoy_and_clear_text y;
1567 else gotoy_and_clear_text state
.y;
1570 let gotopagexy pageno
x y =
1571 match state
.mode
with
1572 | Birdseye
_ -> gotopage pageno
0.0
1575 | LinkNav
_ -> gotopagexy1 pageno
x y
1578 let getpassword () =
1579 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1584 impmsg "error getting password: %s" s;
1585 dolog
"%s" s) passcmd;
1588 let pgoto opaque pageno
x y =
1589 let pdimno = getpdimno pageno
in
1590 let x, y = project opaque pageno
pdimno x y in
1591 gotopagexy pageno
x y;
1595 (* dolog "%S" cmds; *)
1596 let cl = splitatspace cmds
in
1598 try Scanf.sscanf
s fmt
f
1600 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1603 let addoutline outline
=
1604 match state
.currently
with
1605 | Outlining outlines
->
1606 state
.currently
<- Outlining
(outline
:: outlines
)
1607 | Idle
-> state
.currently
<- Outlining
[outline
]
1610 dolog
"invalid outlining state";
1611 logcurrently state
.currently
1615 state
.uioh#infochanged Pdim
;
1618 | "clearrects" :: [] ->
1619 state
.rects
<- state
.rects1
;
1620 G.postRedisplay "clearrects";
1622 | "continue" :: args
:: [] ->
1623 let n = scan args
"%u" (fun n -> n) in
1624 state
.pagecount
<- n;
1625 begin match state
.currently
with
1627 state
.currently
<- Idle
;
1628 state
.outlines
<- Array.of_list
(List.rev
l)
1634 let cur, cmds
= state
.geomcmds
in
1636 then failwith
"umpossible";
1638 begin match List.rev cmds
with
1640 state
.geomcmds
<- E.s, [];
1641 state
.throttle
<- None
;
1645 state
.geomcmds
<- s, List.rev rest
;
1647 if conf
.maxwait
= None
&& not
!wtmode
1648 then G.postRedisplay "continue";
1650 | "msg" :: args
:: [] ->
1653 | "vmsg" :: args
:: [] ->
1655 then showtext ' ' args
1657 | "emsg" :: args
:: [] ->
1658 Buffer.add_string state
.errmsgs args
;
1659 state
.newerrmsgs
<- true;
1660 G.postRedisplay "error message"
1662 | "progress" :: args
:: [] ->
1663 let progress, text =
1666 f, String.sub args pos
(String.length args
- pos
))
1669 state
.progress <- progress;
1670 G.postRedisplay "progress"
1672 | "firstmatch" :: args
:: [] ->
1673 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1674 scan args
"%u %d %f %f %f %f %f %f %f %f"
1675 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1676 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1678 let xoff = float (xadjsb ()) in
1682 and x3
= x3
+. xoff in
1683 let y = (getpagey
pageno) + truncate
y0 in
1685 then state
.x <- truncate
(xoff -. x0) + state
.winw
/2;
1688 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1689 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1691 | "match" :: args
:: [] ->
1692 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1693 scan args
"%u %d %f %f %f %f %f %f %f %f"
1694 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1695 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1697 let xoff = float (xadjsb ()) in
1701 and x3
= x3
+. xoff in
1702 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1704 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1706 | "page" :: args
:: [] ->
1707 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1708 let pageopaque = ~
< pageopaques in
1709 begin match state
.currently
with
1710 | Loading
(l, gen
) ->
1711 vlog "page %d took %f sec" l.pageno t
;
1712 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1713 begin match state
.throttle
with
1715 let preloadedpages =
1717 then preloadlayout state
.x state
.y state
.winw state
.winh
1722 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1723 IntSet.empty
preloadedpages
1726 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1727 if not
(IntSet.mem
pageno set)
1729 wcmd "freepage %s" (~
> opaque
);
1735 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1738 state
.currently
<- Idle
;
1741 tilepage l.pageno pageopaque state
.layout;
1743 load preloadedpages;
1744 let visible = pagevisible state
.layout l.pageno in
1747 match state
.mode
with
1748 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1749 if pageno = l.pageno
1754 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1756 if dir
> 0 then LDfirst
else LDlast
1759 findlink
pageopaque ld
1764 showlinktype (getlink
pageopaque n);
1765 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1767 | LinkNav
(Ltgendir
_)
1768 | LinkNav
(Ltexact
_)
1774 if visible && layoutready state
.layout
1776 G.postRedisplay "page";
1780 | Some
(layout, _, _) ->
1781 state
.currently
<- Idle
;
1782 tilepage l.pageno pageopaque layout;
1789 dolog
"Inconsistent loading state";
1790 logcurrently state
.currently
;
1794 | "tile" :: args
:: [] ->
1795 let (x, y, opaques
, size
, t
) =
1796 scan args
"%u %u %s %u %f"
1797 (fun x y p size t
-> (x, y, p
, size
, t
))
1799 let opaque = ~
< opaques
in
1800 begin match state
.currently
with
1801 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1802 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1805 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1807 wcmd "freetile %s" (~
> opaque);
1808 state
.currently
<- Idle
;
1812 puttileopaque l col row gen cs angle
opaque size t
;
1813 state
.memused
<- state
.memused
+ size
;
1814 state
.uioh#infochanged Memused
;
1816 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1817 opaque, size
) state
.tilelru
;
1820 match state
.throttle
with
1821 | None
-> state
.layout
1822 | Some
(layout, _, _) -> layout
1825 state
.currently
<- Idle
;
1827 && conf
.colorspace
= cs
1828 && conf
.angle
= angle
1829 && tilevisible layout l.pageno x y
1830 then conttiling l.pageno pageopaque;
1832 begin match state
.throttle
with
1834 preload state
.layout;
1836 && conf
.colorspace
= cs
1837 && conf
.angle
= angle
1838 && tilevisible state
.layout l.pageno x y
1839 && (not
!wtmode || layoutready state
.layout)
1840 then G.postRedisplay "tile nothrottle";
1842 | Some
(layout, y, _) ->
1843 let ready = layoutready layout in
1847 state
.layout <- layout;
1848 state
.throttle
<- None
;
1849 G.postRedisplay "throttle";
1858 dolog
"Inconsistent tiling state";
1859 logcurrently state
.currently
;
1863 | "pdim" :: args
:: [] ->
1864 let (n, w, h, _) as pdim
=
1865 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1868 match conf
.fitmodel
with
1870 | FitPage
| FitProportional
->
1871 match conf
.columns
with
1872 | Csplit
_ -> (n, w, h, 0)
1873 | Csingle
_ | Cmulti
_ -> pdim
1875 state
.uioh#infochanged Pdim
;
1876 state
.pdims
<- pdim :: state
.pdims
1878 | "o" :: args
:: [] ->
1879 let (l, n, t
, h, pos
) =
1880 scan args
"%u %u %d %u %n"
1881 (fun l n t
h pos
-> l, n, t
, h, pos
)
1883 let s = String.sub args pos
(String.length args
- pos
) in
1884 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1886 | "ou" :: args
:: [] ->
1887 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1888 let s = String.sub args pos
len in
1889 let pos2 = pos
+ len + 1 in
1890 let uri = String.sub args
pos2 (String.length args
- pos2) in
1891 addoutline (s, l, Ouri
uri)
1893 | "on" :: args
:: [] ->
1894 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1895 let s = String.sub args pos
(String.length args
- pos
) in
1896 addoutline (s, l, Onone
)
1898 | "a" :: args
:: [] ->
1900 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1902 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1904 | "info" :: args
:: [] ->
1905 let pos = nindex args '
\t'
in
1906 if pos >= 0 && String.sub args
0 pos = "Title"
1908 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1912 state
.docinfo
<- (1, args
) :: state
.docinfo
1914 | "infoend" :: [] ->
1915 state
.uioh#infochanged Docinfo
;
1916 state
.docinfo
<- List.rev state
.docinfo
1920 then Wsi.settitle
"Wrong password";
1921 let password = getpassword () in
1922 if emptystr
password
1923 then error
"document is password protected"
1924 else opendoc state
.path
password
1926 error
"unknown cmd `%S'" cmds
1931 let action = function
1932 | HCprev
-> cbget cb ~
-1
1933 | HCnext
-> cbget cb
1
1934 | HCfirst
-> cbget cb ~
-(cb
.rc)
1935 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1936 and cancel
() = cb
.rc <- rc
1940 let search pattern forward
=
1941 match conf
.columns
with
1942 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1945 if nonemptystr pattern
1948 match state
.layout with
1951 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1953 wcmd "search %d %d %d %d,%s\000"
1954 (btod conf
.icase
) pn py (btod forward
) pattern
;
1957 let intentry text key =
1959 if key >= 32 && key < 127
1965 let text = addchar
text c in
1969 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1977 let l = String.length
s in
1978 let rec loop pos n = if pos = l then n else
1979 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1980 loop (pos+1) (n*26 + m)
1983 let rec loop n = function
1986 match getopaque l.pageno with
1987 | None
-> loop n rest
1989 let m = getlinkcount
opaque in
1992 let under = getlink
opaque n in
1995 else loop (n-m) rest
1997 loop n state
.layout;
2001 let linknentry text key =
2003 if key >= 32 && key < 127
2009 let text = addchar
text c in
2010 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2014 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2018 let textentry text key =
2019 if key land 0xff00 = 0xff00
2021 else TEcont
(text ^ toutf8
key)
2024 let reqlayout angle fitmodel
=
2025 match state
.throttle
with
2027 if nogeomcmds state
.geomcmds
2028 then state
.anchor <- getanchor
();
2029 conf
.angle
<- angle
mod 360;
2032 match state
.mode
with
2033 | LinkNav
_ -> state
.mode
<- View
2038 conf
.fitmodel
<- fitmodel
;
2039 invalidate "reqlayout"
2041 wcmd "reqlayout %d %d %d"
2042 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2047 let settrim trimmargins trimfuzz
=
2048 if nogeomcmds state
.geomcmds
2049 then state
.anchor <- getanchor
();
2050 conf
.trimmargins
<- trimmargins
;
2051 conf
.trimfuzz
<- trimfuzz
;
2052 let x0, y0, x1, y1 = trimfuzz
in
2053 invalidate "settrim"
2055 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2060 match state
.throttle
with
2062 let zoom = max
0.0001 zoom in
2063 if zoom <> conf
.zoom
2065 state
.prevzoom
<- (conf
.zoom, state
.x);
2067 reshape state
.winw state
.winh
;
2068 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2071 | Some
(layout, y, started
) ->
2073 match conf
.maxwait
with
2077 let dt = now
() -. started
in
2085 let setcolumns mode columns coverA coverB
=
2086 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2090 then impmsg "split mode doesn't work in bird's eye"
2092 conf
.columns
<- Csplit
(-columns
, E.a);
2100 conf
.columns
<- Csingle
E.a;
2105 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2109 reshape state
.winw state
.winh
;
2112 let resetmstate () =
2113 state
.mstate
<- Mnone
;
2114 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2117 let enterbirdseye () =
2118 let zoom = float conf
.thumbw
/. float state
.winw
in
2119 let birdseyepageno =
2120 let cy = state
.winh
/ 2 in
2124 let rec fold best
= function
2127 let d = cy - (l.pagedispy + l.pagevh/2)
2128 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2129 if abs
d < abs dbest
2136 state
.mode
<- Birdseye
(
2137 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2141 conf
.presentation
<- false;
2142 conf
.interpagespace
<- 10;
2143 conf
.hlinks
<- false;
2144 conf
.fitmodel
<- FitPage
;
2146 conf
.maxwait
<- None
;
2148 match conf
.beyecolumns
with
2151 Cmulti
((c, 0, 0), E.a)
2152 | None
-> Csingle
E.a
2156 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2161 reshape state
.winw state
.winh
;
2164 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2166 conf
.zoom <- c.zoom;
2167 conf
.presentation
<- c.presentation
;
2168 conf
.interpagespace
<- c.interpagespace
;
2169 conf
.maxwait
<- c.maxwait
;
2170 conf
.hlinks
<- c.hlinks
;
2171 conf
.fitmodel
<- c.fitmodel
;
2172 conf
.beyecolumns
<- (
2173 match conf
.columns
with
2174 | Cmulti
((c, _, _), _) -> Some
c
2176 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2179 match c.columns
with
2180 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2181 | Csingle
_ -> Csingle
E.a
2182 | Csplit
(c, _) -> Csplit
(c, E.a)
2186 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2189 reshape state
.winw state
.winh
;
2190 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2194 let togglebirdseye () =
2195 match state
.mode
with
2196 | Birdseye vals
-> leavebirdseye vals
true
2197 | View
-> enterbirdseye ()
2202 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2203 let pageno = max
0 (pageno - incr
) in
2204 let rec loop = function
2205 | [] -> gotopage1 pageno 0
2206 | l :: _ when l.pageno = pageno ->
2207 if l.pagedispy >= 0 && l.pagey = 0
2208 then G.postRedisplay "upbirdseye"
2209 else gotopage1 pageno 0
2210 | _ :: rest
-> loop rest
2214 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2217 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2218 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2219 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2220 let rec loop = function
2222 let y, h = getpageyh
pageno in
2223 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2225 | l :: _ when l.pageno = pageno ->
2226 if l.pagevh != l.pageh
2227 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2228 else G.postRedisplay "downbirdseye"
2229 | _ :: rest
-> loop rest
2235 let optentry mode
_ key =
2236 let btos b = if b then "on" else "off" in
2237 if key >= 32 && key < 127
2239 let c = Char.chr
key in
2243 try conf
.scrollstep
<- int_of_string
s with exc
->
2244 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2246 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2251 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2252 if state
.autoscroll
<> None
2253 then state
.autoscroll
<- Some conf
.autoscrollstep
2255 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2257 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2262 let n, a, b = multicolumns_of_string
s in
2263 setcolumns mode
n a b;
2265 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2267 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2272 let zoom = float (int_of_string
s) /. 100.0 in
2275 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2277 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2282 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2284 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2285 begin match mode
with
2287 leavebirdseye beye
false;
2294 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2296 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2301 Some
(int_of_string
s)
2304 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2307 | Some angle
-> reqlayout angle conf
.fitmodel
2310 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2313 conf
.icase
<- not conf
.icase
;
2314 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2317 conf
.preload <- not conf
.preload;
2319 TEdone
("preload " ^
(btos conf
.preload))
2322 conf
.verbose
<- not conf
.verbose
;
2323 TEdone
("verbose " ^
(btos conf
.verbose
))
2326 conf
.debug
<- not conf
.debug
;
2327 TEdone
("debug " ^
(btos conf
.debug
))
2330 conf
.maxhfit
<- not conf
.maxhfit
;
2331 state
.maxy
<- calcheight
();
2332 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2335 conf
.crophack
<- not conf
.crophack
;
2336 TEdone
("crophack " ^
btos conf
.crophack
)
2340 match conf
.maxwait
with
2342 conf
.maxwait
<- Some infinity
;
2343 "always wait for page to complete"
2345 conf
.maxwait
<- None
;
2346 "show placeholder if page is not ready"
2351 conf
.underinfo
<- not conf
.underinfo
;
2352 TEdone
("underinfo " ^
btos conf
.underinfo
)
2355 conf
.savebmarks
<- not conf
.savebmarks
;
2356 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2362 match state
.layout with
2367 conf
.interpagespace
<- int_of_string
s;
2368 docolumns conf
.columns
;
2369 state
.maxy
<- calcheight
();
2370 let y = getpagey
pageno in
2373 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2375 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2379 match conf
.fitmodel
with
2380 | FitProportional
-> FitWidth
2381 | FitWidth
| FitPage
-> FitProportional
2383 reqlayout conf
.angle
fm;
2384 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2387 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2388 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2391 conf
.invert
<- not conf
.invert
;
2392 TEdone
("invert colors " ^
btos conf
.invert
)
2396 cbput state
.hists
.sel
s;
2399 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2400 textentry, ondone, true)
2404 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2405 else conf
.pax
<- None
;
2406 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2409 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2415 class type lvsource
= object
2416 method getitemcount
: int
2417 method getitem
: int -> (string * int)
2418 method hasaction
: int -> bool
2426 method getactive
: int
2427 method getfirst
: int
2429 method getminfo
: (int * int) array
2432 class virtual lvsourcebase
= object
2433 val mutable m_active
= 0
2434 val mutable m_first
= 0
2435 val mutable m_pan
= 0
2436 method getactive
= m_active
2437 method getfirst
= m_first
2438 method getpan
= m_pan
2439 method getminfo
: (int * int) array
= E.a
2442 let textentrykeyboard
2443 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2446 if key >= 0xffb0 && key <= 0xffb9
2447 then key - 0xffb0 + 48 else key
2450 state
.mode
<- Textentry
(te
, onleave
);
2452 G.postRedisplay "textentrykeyboard enttext";
2454 let histaction cmd
=
2457 | Some
(action, _) ->
2458 state
.mode
<- Textentry
(
2459 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2461 G.postRedisplay "textentry histaction"
2465 if emptystr
text && cancelonempty
2468 G.postRedisplay "textentrykeyboard after cancel";
2471 let s = withoutlastutf8
text in
2472 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2474 | @enter
| @kpenter
->
2477 G.postRedisplay "textentrykeyboard after confirm"
2479 | @up
| @kpup
-> histaction HCprev
2480 | @down
| @kpdown
-> histaction HCnext
2481 | @home
| @kphome
-> histaction HCfirst
2482 | @jend
| @kpend
-> histaction HClast
2487 begin match opthist
with
2489 | Some
(_, onhistcancel
) -> onhistcancel
()
2493 G.postRedisplay "textentrykeyboard after cancel2"
2496 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2499 | @delete
| @kpdelete
-> ()
2502 && key land 0xff00 != 0xff00 (* keyboard *)
2503 && key land 0xfe00 != 0xfe00 (* xkb *)
2504 && key land 0xfd00 != 0xfd00 (* 3270 *)
2506 begin match onkey
text key with
2510 G.postRedisplay "textentrykeyboard after confirm2";
2513 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2517 G.postRedisplay "textentrykeyboard after cancel3"
2520 state
.mode
<- Textentry
(te
, onleave
);
2521 G.postRedisplay "textentrykeyboard switch";
2525 vlog "unhandled key %s" (Wsi.keyname
key)
2528 let firstof first active
=
2529 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2530 then max
0 (active
- (fstate
.maxrows
/2))
2534 let calcfirst first active
=
2537 let rows = active
- first
in
2538 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2542 let scrollph y maxy
=
2543 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2544 let sh = float state
.winh
/. sh in
2545 let sh = max
sh (float conf
.scrollh
) in
2547 let percent = float y /. float maxy
in
2548 let position = (float state
.winh
-. sh) *. percent in
2551 if position +. sh > float state
.winh
2552 then float state
.winh
-. sh
2558 let coe s = (s :> uioh
);;
2560 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2562 val m_pan
= source#getpan
2563 val m_first
= source#getfirst
2564 val m_active
= source#getactive
2566 val m_prev_uioh
= state
.uioh
2568 method private elemunder
y =
2572 let n = y / (fstate
.fontsize
+1) in
2573 if m_first
+ n < source#getitemcount
2575 if source#hasaction
(m_first
+ n)
2576 then Some
(m_first
+ n)
2583 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2584 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2585 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2586 GlDraw.color (1., 1., 1.);
2587 Gl.enable `texture_2d
;
2588 let fs = fstate
.fontsize
in
2590 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2591 let ww = fstate
.wwidth
in
2592 let tabw = 17.0*.ww in
2593 let itemcount = source#getitemcount
in
2594 let minfo = source#getminfo
in
2597 then float (xadjsb ()), float (state
.winw
- 1)
2598 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2600 let xadj = xadjsb () in
2602 if (row - m_first
) > fstate
.maxrows
2605 if row >= 0 && row < itemcount
2607 let (s, level
) = source#getitem
row in
2608 let y = (row - m_first
) * nfs in
2610 (if conf
.leftscroll
then float xadj else 5.0)
2611 +. (float (level
+ m_pan
)) *. ww in
2614 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2618 Gl.disable `texture_2d
;
2619 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2620 GlDraw.color (1., 1., 1.) ~
alpha;
2621 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2622 Gl.enable `texture_2d
;
2625 if zebra
&& row land 1 = 1
2629 GlDraw.color (c,c,c);
2630 let drawtabularstring s =
2632 let x'
= truncate
(x0 +. x) in
2633 let pos = nindex
s '
\000'
in
2635 then drawstring1 fs x'
(y+nfs) s
2637 let s1 = String.sub
s 0 pos
2638 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2643 let s'
= withoutlastutf8
s in
2644 let s = s' ^
"@Uellipsis" in
2645 let w = measurestr
fs s in
2646 if float x'
+. w +. ww < float (hw + x'
)
2651 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2655 ignore
(drawstring1 fs x'
(y+nfs) s1);
2656 drawstring1 fs (hw + x'
) (y+nfs) s2
2660 let x = if helpmode
&& row > 0 then x +. ww else x in
2661 let tabpos = nindex
s '
\t'
in
2664 let len = String.length
s - tabpos - 1 in
2665 let s1 = String.sub
s 0 tabpos
2666 and s2
= String.sub
s (tabpos + 1) len in
2667 let nx = drawstr x s1 in
2669 let x = x +. (max
tabw sw) in
2672 let len = String.length
s - 2 in
2673 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2675 let s = String.sub
s 2 len in
2676 let x = if not helpmode
then x +. ww else x in
2677 GlDraw.color (1.2, 1.2, 1.2);
2678 let vinc = drawstring1 (fs+fs/4)
2679 (truncate
(x -. ww)) (y+nfs) s in
2680 GlDraw.color (1., 1., 1.);
2681 vinc +. (float fs *. 0.8)
2687 ignore
(drawtabularstring s);
2693 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2694 let xadj = float (xadjsb () + 5) in
2696 if (row - m_first
) > fstate
.maxrows
2699 if row >= 0 && row < itemcount
2701 let (s, level
) = source#getitem
row in
2702 let pos0 = nindex
s '
\000'
in
2703 let y = (row - m_first
) * nfs in
2704 let x = float (level
+ m_pan
) *. ww in
2705 let (first
, last
) = minfo.(row) in
2707 if pos0 > 0 && first
> pos0
2708 then String.sub
s (pos0+1) (first
-pos0-1)
2709 else String.sub
s 0 first
2711 let suffix = String.sub
s first
(last
- first
) in
2712 let w1 = measurestr fstate
.fontsize
prefix in
2713 let w2 = measurestr fstate
.fontsize
suffix in
2714 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2715 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2717 and y0 = float (y+2) in
2719 and y1 = float (y+fs+3) in
2720 filledrect x0 y0 x1 y1;
2725 Gl.disable `texture_2d
;
2726 if Array.length
minfo > 0 then loop m_first
;
2729 method updownlevel incr
=
2730 let len = source#getitemcount
in
2732 if m_active
>= 0 && m_active
< len
2733 then snd
(source#getitem m_active
)
2737 if i
= len then i
-1 else if i
= -1 then 0 else
2738 let _, l = source#getitem i
in
2739 if l != curlevel then i
else flow (i
+incr
)
2741 let active = flow m_active
in
2742 let first = calcfirst m_first
active in
2743 G.postRedisplay "outline updownlevel";
2744 {< m_active
= active; m_first
= first >}
2746 method private key1
key mask
=
2747 let set1 active first qsearch
=
2748 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2750 let search active pattern incr
=
2751 let active = if active = -1 then m_first
else active in
2754 if n >= 0 && n < source#getitemcount
2756 let s, _ = source#getitem
n in
2757 match Str.search_forward re
s 0 with
2758 | (exception Not_found
) -> loop (n + incr
)
2765 Str.regexp_case_fold pattern
|> dosearch
2767 let itemcount = source#getitemcount
in
2768 let find start incr
=
2770 if i
= -1 || i
= itemcount
2773 if source#hasaction i
2775 else find (i
+ incr
)
2780 let set active first =
2781 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2783 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2786 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2788 let incr1 = if incr
> 0 then 1 else -1 in
2789 if isvisible m_first m_active
2792 let next = m_active
+ incr
in
2794 if next < 0 || next >= itemcount
2796 else find next incr1
2798 if abs
(m_active
- next) > fstate
.maxrows
2804 let first = m_first
+ incr
in
2805 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2807 let next = m_active
+ incr
in
2808 let next = bound
next 0 (itemcount - 1) in
2815 if isvisible first next
2822 let first = min
next m_first
in
2824 if abs
(next - first) > fstate
.maxrows
2830 let first = m_first
+ incr
in
2831 let first = bound
first 0 (itemcount - 1) in
2833 let next = m_active
+ incr
in
2834 let next = bound
next 0 (itemcount - 1) in
2835 let next = find next incr1 in
2837 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2839 let active = if m_active
= -1 then next else m_active
in
2844 if isvisible first active
2850 G.postRedisplay "listview navigate";
2854 | (@r
|@s) when Wsi.withctrl mask
->
2855 let incr = if key = @r
then -1 else 1 in
2857 match search (m_active
+ incr) m_qsearch
incr with
2859 state
.text <- m_qsearch ^
" [not found]";
2862 state
.text <- m_qsearch
;
2863 active, firstof m_first
active
2865 G.postRedisplay "listview ctrl-r/s";
2866 set1 active first m_qsearch
;
2868 | @insert
when Wsi.withctrl mask
->
2869 if m_active
>= 0 && m_active
< source#getitemcount
2871 let s, _ = source#getitem m_active
in
2877 if emptystr m_qsearch
2880 let qsearch = withoutlastutf8 m_qsearch
in
2884 G.postRedisplay "listview empty qsearch";
2885 set1 m_active m_first
E.s;
2889 match search m_active
qsearch ~
-1 with
2891 state
.text <- qsearch ^
" [not found]";
2894 state
.text <- qsearch;
2895 active, firstof m_first
active
2897 G.postRedisplay "listview backspace qsearch";
2898 set1 active first qsearch
2901 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2902 let pattern = m_qsearch ^ toutf8
key in
2904 match search m_active
pattern 1 with
2906 state
.text <- pattern ^
" [not found]";
2909 state
.text <- pattern;
2910 active, firstof m_first
active
2912 G.postRedisplay "listview qsearch add";
2913 set1 active first pattern;
2917 if emptystr m_qsearch
2919 G.postRedisplay "list view escape";
2920 let mx, my
= state
.mpos
in
2924 source#exit ~uioh
:(coe self
)
2925 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2927 | None
-> m_prev_uioh
2932 G.postRedisplay "list view kill qsearch";
2933 coe {< m_qsearch
= E.s >}
2936 | @enter
| @kpenter
->
2938 let self = {< m_qsearch
= E.s >} in
2940 G.postRedisplay "listview enter";
2941 if m_active
>= 0 && m_active
< source#getitemcount
2943 source#exit ~uioh
:(coe self) ~cancel
:false
2944 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2947 source#exit ~uioh
:(coe self) ~cancel
:true
2948 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2951 begin match opt with
2952 | None
-> m_prev_uioh
2956 | @delete
| @kpdelete
->
2959 | @up
| @kpup
-> navigate ~
-1
2960 | @down
| @kpdown
-> navigate 1
2961 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2962 | @next | @kpnext
-> navigate fstate
.maxrows
2964 | @right
| @kpright
->
2966 G.postRedisplay "listview right";
2967 coe {< m_pan
= m_pan
- 1 >}
2969 | @left | @kpleft
->
2971 G.postRedisplay "listview left";
2972 coe {< m_pan
= m_pan
+ 1 >}
2974 | @home
| @kphome
->
2975 let active = find 0 1 in
2976 G.postRedisplay "listview home";
2980 let first = max
0 (itemcount - fstate
.maxrows
) in
2981 let active = find (itemcount - 1) ~
-1 in
2982 G.postRedisplay "listview end";
2985 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2989 dolog
"listview unknown key %#x" key; coe self
2991 method key key mask
=
2992 match state
.mode
with
2993 | Textentry te
-> textentrykeyboard key mask te
; coe self
2996 | LinkNav
_ -> self#key1
key mask
2998 method button button down
x y _ =
3001 | 1 when vscrollhit x ->
3002 G.postRedisplay "listview scroll";
3005 let _, position, sh = self#
scrollph in
3006 if y > truncate
position && y < truncate
(position +. sh)
3008 state
.mstate
<- Mscrolly
;
3012 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3013 let first = truncate
(s *. float source#getitemcount
) in
3014 let first = min source#getitemcount
first in
3015 Some
(coe {< m_first
= first; m_active
= first >})
3017 state
.mstate
<- Mnone
;
3021 begin match self#elemunder
y with
3023 G.postRedisplay "listview click";
3024 source#exit ~uioh
:(coe {< m_active
= n >})
3025 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3029 | n when (n == 4 || n == 5) && not down
->
3030 let len = source#getitemcount
in
3032 if n = 5 && m_first
+ fstate
.maxrows
>= len
3036 let first = m_first
+ (if n == 4 then -1 else 1) in
3037 bound
first 0 (len - 1)
3039 G.postRedisplay "listview wheel";
3040 Some
(coe {< m_first
= first >})
3041 | n when (n = 6 || n = 7) && not down
->
3042 let inc = if n = 7 then -1 else 1 in
3043 G.postRedisplay "listview hwheel";
3044 Some
(coe {< m_pan
= m_pan
+ inc >})
3049 | None
-> m_prev_uioh
3052 method multiclick
_ x y = self#button
1 true x y
3055 match state
.mstate
with
3057 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3058 let first = truncate
(s *. float source#getitemcount
) in
3059 let first = min source#getitemcount
first in
3060 G.postRedisplay "listview motion";
3061 coe {< m_first
= first; m_active
= first >}
3069 method pmotion
x y =
3070 if x < state
.winw
- conf
.scrollbw
3073 match self#elemunder
y with
3074 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3075 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3079 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3084 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3088 method infochanged
_ = ()
3090 method scrollpw
= (0, 0.0, 0.0)
3092 let nfs = fstate
.fontsize
+ 1 in
3093 let y = m_first
* nfs in
3094 let itemcount = source#getitemcount
in
3095 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3096 let maxy = maxi * nfs in
3097 let p, h = scrollph y maxy in
3100 method modehash
= modehash
3101 method eformsgs
= false
3102 method alwaysscrolly
= true
3105 class outlinelistview ~zebra ~source
=
3106 let settext autonarrow
s =
3109 let ss = source#statestr
in
3113 else "{" ^
ss ^
"} [" ^
s ^
"]"
3114 else state
.text <- s
3120 ~source
:(source
:> lvsource
)
3122 ~modehash
:(findkeyhash conf
"outline")
3125 val m_autonarrow
= false
3127 method! key key mask
=
3129 if emptystr state
.text
3131 else fstate
.maxrows - 2
3133 let calcfirst first active =
3136 let rows = active - first in
3137 if rows > maxrows then active - maxrows else first
3141 let active = m_active
+ incr in
3142 let active = bound
active 0 (source#getitemcount
- 1) in
3143 let first = calcfirst m_first
active in
3144 G.postRedisplay "outline navigate";
3145 coe {< m_active
= active; m_first
= first >}
3147 let navscroll first =
3149 let dist = m_active
- first in
3155 else first + maxrows
3158 G.postRedisplay "outline navscroll";
3159 coe {< m_first
= first; m_active
= active >}
3161 let ctrl = Wsi.withctrl mask
in
3166 then (source#denarrow
; E.s)
3168 let pattern = source#renarrow
in
3169 if nonemptystr m_qsearch
3170 then (source#narrow m_qsearch
; m_qsearch
)
3174 settext (not m_autonarrow
) text;
3175 G.postRedisplay "toggle auto narrowing";
3176 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3178 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3180 G.postRedisplay "toggle auto narrowing";
3181 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3184 source#narrow m_qsearch
;
3186 then source#add_narrow_pattern m_qsearch
;
3187 G.postRedisplay "outline ctrl-n";
3188 coe {< m_first
= 0; m_active
= 0 >}
3191 let active = source#calcactive
(getanchor
()) in
3192 let first = firstof m_first
active in
3193 G.postRedisplay "outline ctrl-s";
3194 coe {< m_first
= first; m_active
= active >}
3197 G.postRedisplay "outline ctrl-u";
3198 if m_autonarrow
&& nonemptystr m_qsearch
3200 ignore
(source#renarrow
);
3201 settext m_autonarrow
E.s;
3202 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3205 source#del_narrow_pattern
;
3206 let pattern = source#renarrow
in
3208 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3210 settext m_autonarrow
text;
3211 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3215 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3216 G.postRedisplay "outline ctrl-l";
3217 coe {< m_first
= first >}
3219 | @tab
when m_autonarrow
->
3220 if nonemptystr m_qsearch
3222 G.postRedisplay "outline list view tab";
3223 source#add_narrow_pattern m_qsearch
;
3225 coe {< m_qsearch
= E.s >}
3229 | @escape
when m_autonarrow
->
3230 if nonemptystr m_qsearch
3231 then source#add_narrow_pattern m_qsearch
;
3234 | @enter
| @kpenter
when m_autonarrow
->
3235 if nonemptystr m_qsearch
3236 then source#add_narrow_pattern m_qsearch
;
3239 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3240 let pattern = m_qsearch ^ toutf8
key in
3241 G.postRedisplay "outlinelistview autonarrow add";
3242 source#narrow
pattern;
3243 settext true pattern;
3244 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3246 | key when m_autonarrow
&& key = @backspace
->
3247 if emptystr m_qsearch
3250 let pattern = withoutlastutf8 m_qsearch
in
3251 G.postRedisplay "outlinelistview autonarrow backspace";
3252 ignore
(source#renarrow
);
3253 source#narrow
pattern;
3254 settext true pattern;
3255 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3257 | @up
| @kpup
when ctrl ->
3258 navscroll (max
0 (m_first
- 1))
3260 | @down
| @kpdown
when ctrl ->
3261 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3263 | @up
| @kpup
-> navigate ~
-1
3264 | @down
| @kpdown
-> navigate 1
3265 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3266 | @next | @kpnext
-> navigate fstate
.maxrows
3268 | @right
| @kpright
->
3272 G.postRedisplay "outline ctrl right";
3273 {< m_pan
= m_pan
+ 1 >}
3275 else self#updownlevel
1
3279 | @left | @kpleft
->
3283 G.postRedisplay "outline ctrl left";
3284 {< m_pan
= m_pan
- 1 >}
3286 else self#updownlevel ~
-1
3290 | @home
| @kphome
->
3291 G.postRedisplay "outline home";
3292 coe {< m_first
= 0; m_active
= 0 >}
3295 let active = source#getitemcount
- 1 in
3296 let first = max
0 (active - fstate
.maxrows) in
3297 G.postRedisplay "outline end";
3298 coe {< m_active
= active; m_first
= first >}
3300 | _ -> super#
key key mask
3303 let genhistoutlines () =
3305 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3306 compare c2
.lastvisit c1
.lastvisit
)
3308 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3309 let path = if nonemptystr origin
then origin
else path in
3310 let base = mbtoutf8
@@ Filename.basename
path in
3311 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3316 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3317 Config.save
leavebirdseye;
3318 state
.anchor <- anchor;
3319 state
.bookmarks
<- bookmarks
;
3320 state
.origin
<- origin
;
3323 let x0, y0, x1, y1 = conf
.trimfuzz
in
3324 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3325 reshape ~firsttime
:true state
.winw state
.winh
;
3326 opendoc path origin
;
3330 let makecheckers () =
3331 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3333 converted by Issac Trotts. July 25, 2002 *)
3334 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3335 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3336 let id = GlTex.gen_texture
() in
3337 GlTex.bind_texture ~target
:`texture_2d
id;
3338 GlPix.store
(`unpack_alignment
1);
3339 GlTex.image2d
image;
3340 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3341 [ `mag_filter `nearest
; `min_filter `nearest
];
3345 let setcheckers enabled
=
3346 match state
.checkerstexid
with
3348 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3350 | Some checkerstexid
->
3353 GlTex.delete_texture checkerstexid
;
3354 state
.checkerstexid
<- None
;
3358 let describe_location () =
3359 let fn = page_of_y state
.y in
3360 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3361 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3365 else (100. *. (float state
.y /. float maxy))
3369 Printf.sprintf
"page %d of %d [%.2f%%]"
3370 (fn+1) state
.pagecount
percent
3373 "pages %d-%d of %d [%.2f%%]"
3374 (fn+1) (ln+1) state
.pagecount
percent
3377 let setpresentationmode v
=
3378 let n = page_of_y state
.y in
3379 state
.anchor <- (n, 0.0, 1.0);
3380 conf
.presentation
<- v
;
3381 if conf
.fitmodel
= FitPage
3382 then reqlayout conf
.angle conf
.fitmodel
;
3387 let btos b = if b then "@Uradical" else E.s in
3388 let showextended = ref false in
3389 let leave mode
_ = state
.mode
<- mode
in
3392 val mutable m_l
= []
3393 val mutable m_a
= E.a
3394 val mutable m_prev_uioh
= nouioh
3395 val mutable m_prev_mode
= View
3397 inherit lvsourcebase
3399 method reset prev_mode prev_uioh
=
3400 m_a
<- Array.of_list
(List.rev m_l
);
3402 m_prev_mode
<- prev_mode
;
3403 m_prev_uioh
<- prev_uioh
;
3405 method int name get
set =
3407 (name
, `
int get
, 1, Action
(
3410 try set (int_of_string
s)
3412 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3416 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3417 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3421 method int_with_suffix name get
set =
3423 (name
, `intws get
, 1, Action
(
3426 try set (int_of_string_with_suffix
s)
3428 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3433 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3435 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3439 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3441 (name
, `
bool (btos, get
), offset
, Action
(
3448 method color name get
set =
3450 (name
, `
color get
, 1, Action
(
3452 let invalid = (nan
, nan
, nan
) in
3455 try color_of_string
s
3457 state
.text <- Printf.sprintf
"bad color `%s': %s"
3464 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3465 state
.text <- color_to_string
(get
());
3466 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3470 method string name get
set =
3472 (name
, `
string get
, 1, Action
(
3474 let ondone s = set s in
3475 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3476 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3480 method colorspace name get
set =
3482 (name
, `
string get
, 1, Action
(
3486 inherit lvsourcebase
3489 m_active
<- CSTE.to_int conf
.colorspace
;
3492 method getitemcount
=
3493 Array.length
CSTE.names
3496 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3497 ignore
(uioh
, first, pan
);
3498 if not cancel
then set active;
3500 method hasaction
_ = true
3504 let modehash = findkeyhash conf
"info" in
3505 coe (new listview ~zebra
:false ~helpmode
:false
3506 ~
source ~trusted
:true ~
modehash)
3509 method paxmark name get
set =
3511 (name
, `
string get
, 1, Action
(
3515 inherit lvsourcebase
3518 m_active
<- MTE.to_int conf
.paxmark
;
3521 method getitemcount
= Array.length
MTE.names
3522 method getitem
n = (MTE.names
.(n), 0)
3523 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3524 ignore
(uioh
, first, pan
);
3525 if not cancel
then set active;
3527 method hasaction
_ = true
3531 let modehash = findkeyhash conf
"info" in
3532 coe (new listview ~zebra
:false ~helpmode
:false
3533 ~
source ~trusted
:true ~
modehash)
3536 method fitmodel name get
set =
3538 (name
, `
string get
, 1, Action
(
3542 inherit lvsourcebase
3545 m_active
<- FMTE.to_int conf
.fitmodel
;
3548 method getitemcount
= Array.length
FMTE.names
3549 method getitem
n = (FMTE.names
.(n), 0)
3550 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3551 ignore
(uioh
, first, pan
);
3552 if not cancel
then set active;
3554 method hasaction
_ = true
3558 let modehash = findkeyhash conf
"info" in
3559 coe (new listview ~zebra
:false ~helpmode
:false
3560 ~
source ~trusted
:true ~
modehash)
3563 method caption
s offset
=
3564 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3566 method caption2
s f offset
=
3567 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3569 method getitemcount
= Array.length m_a
3572 let tostr = function
3573 | `
int f -> string_of_int
(f ())
3574 | `intws
f -> string_with_suffix_of_int
(f ())
3576 | `
color f -> color_to_string
(f ())
3577 | `
bool (btos, f) -> btos (f ())
3580 let name, t
, offset
, _ = m_a
.(n) in
3581 ((let s = tostr t
in
3583 then Printf.sprintf
"%s\t%s" name s
3587 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3592 match m_a
.(active) with
3593 | _, _, _, Action
f -> f uioh
3594 | _, _, _, Noaction
-> uioh
3605 method hasaction
n =
3607 | _, _, _, Action
_ -> true
3608 | _, _, _, Noaction
-> false
3610 initializer m_active
<- 1
3613 let rec fillsrc prevmode prevuioh
=
3614 let sep () = src#caption
E.s 0 in
3615 let colorp name get
set =
3617 (fun () -> color_to_string
(get
()))
3620 let c = color_of_string
v in
3623 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3626 let oldmode = state
.mode
in
3627 let birdseye = isbirdseye state
.mode
in
3629 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3631 src#
bool "presentation mode"
3632 (fun () -> conf
.presentation
)
3633 (fun v -> setpresentationmode v);
3635 src#
bool "ignore case in searches"
3636 (fun () -> conf
.icase
)
3637 (fun v -> conf
.icase
<- v);
3640 (fun () -> conf
.preload)
3641 (fun v -> conf
.preload <- v);
3643 src#
bool "highlight links"
3644 (fun () -> conf
.hlinks
)
3645 (fun v -> conf
.hlinks
<- v);
3647 src#
bool "under info"
3648 (fun () -> conf
.underinfo
)
3649 (fun v -> conf
.underinfo
<- v);
3651 src#
bool "persistent bookmarks"
3652 (fun () -> conf
.savebmarks
)
3653 (fun v -> conf
.savebmarks
<- v);
3655 src#fitmodel
"fit model"
3656 (fun () -> FMTE.to_string conf
.fitmodel
)
3657 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3659 src#
bool "trim margins"
3660 (fun () -> conf
.trimmargins
)
3661 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3663 src#
bool "persistent location"
3664 (fun () -> conf
.jumpback
)
3665 (fun v -> conf
.jumpback
<- v);
3668 src#
int "inter-page space"
3669 (fun () -> conf
.interpagespace
)
3671 conf
.interpagespace
<- n;
3672 docolumns conf
.columns
;
3674 match state
.layout with
3679 state
.maxy <- calcheight
();
3680 let y = getpagey
pageno in
3685 (fun () -> conf
.pagebias
)
3686 (fun v -> conf
.pagebias
<- v);
3688 src#
int "scroll step"
3689 (fun () -> conf
.scrollstep
)
3690 (fun n -> conf
.scrollstep
<- n);
3692 src#
int "horizontal scroll step"
3693 (fun () -> conf
.hscrollstep
)
3694 (fun v -> conf
.hscrollstep
<- v);
3696 src#
int "auto scroll step"
3698 match state
.autoscroll
with
3700 | _ -> conf
.autoscrollstep
)
3702 let n = boundastep state
.winh
n in
3703 if state
.autoscroll
<> None
3704 then state
.autoscroll
<- Some
n;
3705 conf
.autoscrollstep
<- n);
3708 (fun () -> truncate
(conf
.zoom *. 100.))
3709 (fun v -> setzoom ((float v) /. 100.));
3712 (fun () -> conf
.angle
)
3713 (fun v -> reqlayout v conf
.fitmodel
);
3715 src#
int "scroll bar width"
3716 (fun () -> conf
.scrollbw
)
3719 reshape state
.winw state
.winh
;
3722 src#
int "scroll handle height"
3723 (fun () -> conf
.scrollh
)
3724 (fun v -> conf
.scrollh
<- v;);
3726 src#
int "thumbnail width"
3727 (fun () -> conf
.thumbw
)
3729 conf
.thumbw
<- min
4096 v;
3732 leavebirdseye beye
false;
3739 let mode = state
.mode in
3740 src#
string "columns"
3742 match conf
.columns
with
3744 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3745 | Csplit
(count
, _) -> "-" ^ string_of_int count
3748 let n, a, b = multicolumns_of_string
v in
3749 setcolumns mode n a b);
3752 src#caption
"Pixmap cache" 0;
3753 src#int_with_suffix
"size (advisory)"
3754 (fun () -> conf
.memlimit
)
3755 (fun v -> conf
.memlimit
<- v);
3758 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3759 (string_with_suffix_of_int state
.memused
)
3760 (Hashtbl.length state
.tilemap
)) 1;
3763 src#caption
"Layout" 0;
3764 src#caption2
"Dimension"
3766 Printf.sprintf
"%dx%d (virtual %dx%d)"
3767 state
.winw state
.winh
3772 src#caption2
"Position" (fun () ->
3773 Printf.sprintf
"%dx%d" state
.x state
.y
3776 src#caption2
"Position" (fun () -> describe_location ()) 1
3780 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3781 "Save these parameters as global defaults at exit"
3782 (fun () -> conf
.bedefault
)
3783 (fun v -> conf
.bedefault
<- v)
3787 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3788 src#
bool ~offset
:0 ~
btos "Extended parameters"
3789 (fun () -> !showextended)
3790 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3794 (fun () -> conf
.checkers
)
3795 (fun v -> conf
.checkers
<- v; setcheckers v);
3796 src#
bool "update cursor"
3797 (fun () -> conf
.updatecurs
)
3798 (fun v -> conf
.updatecurs
<- v);
3799 src#
bool "scroll-bar on the left"
3800 (fun () -> conf
.leftscroll
)
3801 (fun v -> conf
.leftscroll
<- v);
3803 (fun () -> conf
.verbose
)
3804 (fun v -> conf
.verbose
<- v);
3805 src#
bool "invert colors"
3806 (fun () -> conf
.invert
)
3807 (fun v -> conf
.invert
<- v);
3809 (fun () -> conf
.maxhfit
)
3810 (fun v -> conf
.maxhfit
<- v);
3812 (fun () -> conf
.pax
!= None
)
3815 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3816 else conf
.pax
<- None
);
3817 src#
string "uri launcher"
3818 (fun () -> conf
.urilauncher
)
3819 (fun v -> conf
.urilauncher
<- v);
3820 src#
string "path launcher"
3821 (fun () -> conf
.pathlauncher
)
3822 (fun v -> conf
.pathlauncher
<- v);
3823 src#
string "tile size"
3824 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3827 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3828 conf
.tilew
<- max
64 w;
3829 conf
.tileh
<- max
64 h;
3832 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3835 src#
int "texture count"
3836 (fun () -> conf
.texcount
)
3839 then conf
.texcount
<- v
3840 else impmsg "failed to set texture count please retry later"
3842 src#
int "slice height"
3843 (fun () -> conf
.sliceheight
)
3845 conf
.sliceheight
<- v;
3846 wcmd "sliceh %d" conf
.sliceheight
;
3848 src#
int "anti-aliasing level"
3849 (fun () -> conf
.aalevel
)
3851 conf
.aalevel
<- bound
v 0 8;
3852 state
.anchor <- getanchor
();
3853 opendoc state
.path state
.password;
3855 src#
string "page scroll scaling factor"
3856 (fun () -> string_of_float conf
.pgscale)
3859 let s = float_of_string
v in
3862 state
.text <- Printf.sprintf
3863 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3866 src#
int "ui font size"
3867 (fun () -> fstate
.fontsize
)
3868 (fun v -> setfontsize (bound
v 5 100));
3869 src#
int "hint font size"
3870 (fun () -> conf
.hfsize
)
3871 (fun v -> conf
.hfsize
<- bound
v 5 100);
3872 colorp "background color"
3873 (fun () -> conf
.bgcolor
)
3874 (fun v -> conf
.bgcolor
<- v);
3875 src#
bool "crop hack"
3876 (fun () -> conf
.crophack
)
3877 (fun v -> conf
.crophack
<- v);
3878 src#
string "trim fuzz"
3879 (fun () -> irect_to_string conf
.trimfuzz
)
3882 conf
.trimfuzz
<- irect_of_string
v;
3884 then settrim true conf
.trimfuzz
;
3886 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3888 src#
string "throttle"
3890 match conf
.maxwait
with
3891 | None
-> "show place holder if page is not ready"
3894 then "wait for page to fully render"
3896 "wait " ^ string_of_float
time
3897 ^
" seconds before showing placeholder"
3901 let f = float_of_string
v in
3903 then conf
.maxwait
<- None
3904 else conf
.maxwait
<- Some
f
3906 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3908 src#
string "ghyll scroll"
3910 match conf
.ghyllscroll
with
3912 | Some nab
-> ghyllscroll_to_string nab
3915 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3918 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3922 src#
string "selection command"
3923 (fun () -> conf
.selcmd
)
3924 (fun v -> conf
.selcmd
<- v);
3925 src#
string "synctex command"
3926 (fun () -> conf
.stcmd
)
3927 (fun v -> conf
.stcmd
<- v);
3928 src#
string "pax command"
3929 (fun () -> conf
.paxcmd
)
3930 (fun v -> conf
.paxcmd
<- v);
3931 src#
string "ask password command"
3932 (fun () -> conf
.passcmd)
3933 (fun v -> conf
.passcmd <- v);
3934 src#
string "save path command"
3935 (fun () -> conf
.savecmd
)
3936 (fun v -> conf
.savecmd
<- v);
3937 src#colorspace
"color space"
3938 (fun () -> CSTE.to_string conf
.colorspace
)
3940 conf
.colorspace
<- CSTE.of_int
v;
3944 src#paxmark
"pax mark method"
3945 (fun () -> MTE.to_string conf
.paxmark
)
3946 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3950 (fun () -> conf
.usepbo
)
3951 (fun v -> conf
.usepbo
<- v);
3952 src#
bool "mouse wheel scrolls pages"
3953 (fun () -> conf
.wheelbypage
)
3954 (fun v -> conf
.wheelbypage
<- v);
3955 src#
bool "open remote links in a new instance"
3956 (fun () -> conf
.riani
)
3957 (fun v -> conf
.riani
<- v);
3958 src#
bool "edit annotations inline"
3959 (fun () -> conf
.annotinline
)
3960 (fun v -> conf
.annotinline
<- v);
3964 src#caption
"Document" 0;
3965 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3966 src#caption2
"Pages"
3967 (fun () -> string_of_int state
.pagecount
) 1;
3968 src#caption2
"Dimensions"
3969 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3973 src#caption
"Trimmed margins" 0;
3974 src#caption2
"Dimensions"
3975 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3979 src#caption
"OpenGL" 0;
3980 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3981 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3984 src#caption
"Location" 0;
3985 if nonemptystr state
.origin
3986 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3987 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3989 src#reset prevmode prevuioh
;
3994 let prevmode = state
.mode
3995 and prevuioh
= state
.uioh in
3996 fillsrc prevmode prevuioh
;
3997 let source = (src :> lvsource
) in
3998 let modehash = findkeyhash conf
"info" in
3999 state
.uioh <- coe (object (self)
4000 inherit listview ~zebra
:false ~helpmode
:false
4001 ~
source ~trusted
:true ~
modehash as super
4002 val mutable m_prevmemused
= 0
4003 method! infochanged
= function
4005 if m_prevmemused
!= state
.memused
4007 m_prevmemused
<- state
.memused
;
4008 G.postRedisplay "memusedchanged";
4010 | Pdim
-> G.postRedisplay "pdimchanged"
4011 | Docinfo
-> fillsrc prevmode prevuioh
4013 method! key key mask
=
4014 if not
(Wsi.withctrl mask
)
4017 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4018 | @right
| @kpright
-> coe (self#updownlevel
1)
4019 | _ -> super#
key key mask
4020 else super#
key key mask
4022 G.postRedisplay "info";
4028 inherit lvsourcebase
4029 method getitemcount
= Array.length state
.help
4031 let s, l, _ = state
.help
.(n) in
4034 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4038 match state
.help
.(active) with
4039 | _, _, Action
f -> Some
(f uioh)
4040 | _, _, Noaction
-> Some
uioh
4049 method hasaction
n =
4050 match state
.help
.(n) with
4051 | _, _, Action
_ -> true
4052 | _, _, Noaction
-> false
4058 let modehash = findkeyhash conf
"help" in
4060 state
.uioh <- coe (new listview
4061 ~zebra
:false ~helpmode
:true
4062 ~
source ~trusted
:true ~
modehash);
4063 G.postRedisplay "help";
4069 inherit lvsourcebase
4070 val mutable m_items
= E.a
4072 method getitemcount
= 1 + Array.length m_items
4077 else m_items
.(n-1), 0
4079 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4084 then Buffer.clear state
.errmsgs
;
4091 method hasaction
n =
4095 state
.newerrmsgs
<- false;
4096 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4097 m_items
<- Array.of_list
l
4106 let source = (msgsource :> lvsource
) in
4107 let modehash = findkeyhash conf
"listview" in
4108 state
.uioh <- coe (object
4109 inherit listview ~zebra
:false ~helpmode
:false
4110 ~
source ~trusted
:false ~
modehash as super
4113 then msgsource#reset
;
4116 G.postRedisplay "msgs";
4120 let editor = getenvwithdef
"EDITOR" E.s in
4124 let tmppath = Filename.temp_file
"llpp" "note" in
4127 let oc = open_out
tmppath in
4131 let execstr = editor ^
" " ^
tmppath in
4133 match spawn
execstr [] with
4134 | (exception exn
) ->
4135 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4138 match Unix.waitpid
[] pid with
4139 | (exception exn
) ->
4140 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4144 | Unix.WEXITED
0 -> filecontents
tmppath
4146 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4148 | Unix.WSIGNALED
n ->
4149 impmsg "editor process(%s) was killed by signal %d" execstr n;
4151 | Unix.WSTOPPED
n ->
4152 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4155 match Unix.unlink
tmppath with
4156 | (exception exn
) ->
4157 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4162 let enterannotmode opaque slinkindex
=
4165 inherit lvsourcebase
4166 val mutable m_text
= E.s
4167 val mutable m_items
= E.a
4169 method getitemcount
= Array.length m_items
4172 let label, _func
= m_items
.(n) in
4175 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4176 ignore
(uioh, first, pan
);
4179 let _label, func
= m_items
.(active) in
4184 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4187 let rec split accu b i
=
4189 if p = String.length
s
4190 then (String.sub
s b (p-b), unit) :: accu
4192 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4194 let ss = if i
= 0 then E.s else String.sub
s b i
in
4195 split ((ss, unit)::accu) (p+1) 0
4200 wcmd "freepage %s" (~
> opaque);
4202 Hashtbl.fold (fun key opaque'
accu ->
4203 if opaque'
= opaque'
4204 then key :: accu else accu) state
.pagemap
[]
4206 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4211 delannot
opaque slinkindex
;
4214 let edit inline
() =
4219 modannot
opaque slinkindex
s;
4225 let mode = state
.mode in
4228 ("annotation: ", m_text
, None
, textentry, update, true),
4229 fun _ -> state
.mode <- mode);
4233 let s = getusertext m_text
in
4238 ( "[Copy]", fun () -> selstring m_text
)
4239 :: ("[Delete]", dele)
4240 :: ("[Edit]", edit conf
.annotinline
)
4242 :: split [] 0 0 |> List.rev
|> Array.of_list
4249 let s = getannotcontents
opaque slinkindex
in
4252 let source = (msgsource :> lvsource
) in
4253 let modehash = findkeyhash conf
"listview" in
4254 state
.uioh <- coe (object
4255 inherit listview ~zebra
:false ~helpmode
:false
4256 ~
source ~trusted
:false ~
modehash
4258 G.postRedisplay "enterannotmode";
4261 let gotounder under =
4262 let getpath filename
=
4264 if nonemptystr filename
4266 if Filename.is_relative filename
4268 let dir = Filename.dirname state
.path in
4270 if Filename.is_implicit
dir
4271 then Filename.concat
(Sys.getcwd
()) dir
4274 Filename.concat
dir filename
4278 if Sys.file_exists
path
4283 | Ulinkgoto
(pageno, top) ->
4287 gotopage1 pageno top;
4290 | Ulinkuri
s -> gotouri
s
4292 | Uremote
(filename
, pageno) ->
4293 let path = getpath filename
in
4298 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4299 match spawn
command [] with
4301 | (exception exn
) ->
4302 dolog
"failed to execute `%s': %s" command @@ exntos exn
4304 let anchor = getanchor
() in
4305 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4306 state
.origin
<- E.s;
4307 state
.anchor <- (pageno, 0.0, 0.0);
4308 state
.ranchors
<- ranchor :: state
.ranchors
;
4311 else impmsg "cannot find %s" filename
4313 | Uremotedest
(filename
, destname
) ->
4314 let path = getpath filename
in
4319 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4320 match spawn
command [] with
4321 | (exception exn
) ->
4322 dolog
"failed to execute `%s': %s" command @@ exntos exn
4325 let anchor = getanchor
() in
4326 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4327 state
.origin
<- E.s;
4328 state
.nameddest
<- destname
;
4329 state
.ranchors
<- ranchor :: state
.ranchors
;
4332 else impmsg "cannot find %s" filename
4334 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4335 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4338 let gotooutline (_, _, kind
) =
4342 let (pageno, y, _) = anchor in
4344 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4348 | Ouri
uri -> gotounder (Ulinkuri
uri)
4349 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4350 | Oremote remote
-> gotounder (Uremote remote
)
4351 | Ohistory hist
-> gotohist hist
4352 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4355 let outlinesource fetchoutlines
=
4357 inherit lvsourcebase
4358 val mutable m_items
= E.a
4359 val mutable m_minfo
= E.a
4360 val mutable m_orig_items
= E.a
4361 val mutable m_orig_minfo
= E.a
4362 val mutable m_narrow_patterns
= []
4363 val mutable m_gen
= -1
4365 method getitemcount
= Array.length m_items
4368 let s, n, _ = m_items
.(n) in
4371 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4372 ignore
(uioh, first);
4374 if m_narrow_patterns
= []
4375 then m_orig_items
, m_orig_minfo
4376 else m_items
, m_minfo
4383 gotooutline m_items
.(active);
4391 method hasaction
_ = true
4394 if Array.length m_items
!= Array.length m_orig_items
4397 match m_narrow_patterns
with
4399 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4401 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4405 match m_narrow_patterns
with
4408 | head
:: _ -> "@Uellipsis" ^ head
4410 method narrow
pattern =
4411 match Str.regexp_case_fold
pattern with
4412 | (exception _) -> ()
4414 let rec loop accu minfo n =
4417 m_items
<- Array.of_list
accu;
4418 m_minfo
<- Array.of_list
minfo;
4421 let (s, _, _) as o = m_items
.(n) in
4423 match Str.search_forward re
s 0 with
4424 | (exception Not_found
) -> accu, minfo
4425 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4427 loop accu minfo (n-1)
4429 loop [] [] (Array.length m_items
- 1)
4431 method! getminfo
= m_minfo
4434 m_orig_items
<- fetchoutlines
();
4435 m_minfo
<- m_orig_minfo
;
4436 m_items
<- m_orig_items
4438 method add_narrow_pattern
pattern =
4439 m_narrow_patterns
<- pattern :: m_narrow_patterns
4441 method del_narrow_pattern
=
4442 match m_narrow_patterns
with
4443 | _ :: rest
-> m_narrow_patterns
<- rest
4448 match m_narrow_patterns
with
4449 | pattern :: [] -> self#narrow
pattern; pattern
4451 List.fold_left
(fun accu pattern ->
4452 self#narrow
pattern;
4453 pattern ^
"@Uellipsis" ^
accu) E.s list
4455 method calcactive
anchor =
4456 let rely = getanchory anchor in
4457 let rec loop n best bestd
=
4458 if n = Array.length m_items
4461 let _, _, kind
= m_items
.(n) in
4464 let orely = getanchory anchor in
4465 let d = abs
(orely - rely) in
4468 else loop (n+1) best bestd
4469 | Onone
| Oremote
_ | Olaunch
_
4470 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4471 loop (n+1) best bestd
4475 method reset
anchor items =
4476 if state
.gen
!= m_gen
4478 m_orig_items
<- items;
4480 m_narrow_patterns
<- [];
4482 m_orig_minfo
<- E.a;
4486 if items != m_orig_items
4488 m_orig_items
<- items;
4489 if m_narrow_patterns
== []
4490 then m_items
<- items;
4493 let active = self#calcactive
anchor in
4495 m_first
<- firstof m_first
active
4499 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4500 let mkselector sourcetype
=
4501 let fetchoutlines () =
4502 match sourcetype
with
4503 | `bookmarks
-> Array.of_list state
.bookmarks
4504 | `outlines
-> state
.outlines
4505 | `history
-> genhistoutlines ()
4507 let source = outlinesource fetchoutlines in
4509 let outlines = fetchoutlines () in
4510 if Array.length
outlines = 0
4512 showtext ' ' errmsg
;
4516 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4517 let anchor = getanchor
() in
4518 source#reset
anchor outlines;
4519 state
.text <- source#greetmsg
;
4521 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4522 G.postRedisplay "enter selector";
4525 let mkenter sourcetype errmsg
=
4526 let enter = mkselector sourcetype
in
4527 fun () -> enter errmsg
4529 (**)mkenter `
outlines "document has no outline"
4530 , mkenter `bookmarks
"document has no bookmarks (yet)"
4531 , mkenter `history
"history is empty"
4534 let quickbookmark ?title
() =
4535 match state
.layout with
4541 let tm = Unix.localtime
(now
()) in
4543 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4547 (tm.Unix.tm_year
+ 1900)
4550 | Some
title -> title
4552 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4555 let setautoscrollspeed step goingdown
=
4556 let incr = max
1 ((abs step
) / 2) in
4557 let incr = if goingdown
then incr else -incr in
4558 let astep = boundastep state
.winh
(step
+ incr) in
4559 state
.autoscroll
<- Some
astep;
4563 match conf
.columns
with
4565 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4568 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4570 let existsinrow pageno (columns
, coverA
, coverB
) p =
4571 let last = ((pageno - coverA
) mod columns
) + columns
in
4572 let rec any = function
4575 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4579 then (if l.pageno = last then false else any rest
)
4587 match state
.layout with
4589 let pageno = page_of_y state
.y in
4590 gotoghyll (getpagey
(pageno+1))
4592 match conf
.columns
with
4594 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4596 let y = clamp (pgscale state
.winh
) in
4599 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4600 gotoghyll (getpagey
pageno)
4601 | Cmulti
((c, _, _) as cl, _) ->
4602 if conf
.presentation
4603 && (existsinrow l.pageno cl
4604 (fun l -> l.pageh
> l.pagey + l.pagevh))
4606 let y = clamp (pgscale state
.winh
) in
4609 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4610 gotoghyll (getpagey
pageno)
4612 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4614 let pagey, pageh
= getpageyh
l.pageno in
4615 let pagey = pagey + pageh
* l.pagecol
in
4616 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4617 gotoghyll (pagey + pageh
+ ips)
4621 match state
.layout with
4623 let pageno = page_of_y state
.y in
4624 gotoghyll (getpagey
(pageno-1))
4626 match conf
.columns
with
4628 if conf
.presentation
&& l.pagey != 0
4630 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4632 let pageno = max
0 (l.pageno-1) in
4633 gotoghyll (getpagey
pageno)
4634 | Cmulti
((c, _, coverB
) as cl, _) ->
4635 if conf
.presentation
&&
4636 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4638 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4641 if l.pageno = state
.pagecount
- coverB
4645 let pageno = max
0 (l.pageno-decr) in
4646 gotoghyll (getpagey
pageno)
4654 let pageno = max
0 (l.pageno-1) in
4655 let pagey, pageh
= getpageyh
pageno in
4658 let pagey, pageh
= getpageyh
l.pageno in
4659 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4665 if emptystr conf
.savecmd
4666 then error
"don't know where to save modified document"
4668 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4671 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4676 let tmp = path ^
".tmp" in
4678 Unix.rename
tmp path;
4681 let viewkeyboard key mask
=
4683 let mode = state
.mode in
4684 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4687 G.postRedisplay "view:enttext"
4689 let ctrl = Wsi.withctrl mask
in
4691 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4697 if hasunsavedchanges
()
4701 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4703 state
.mode <- LinkNav
(Ltgendir
0);
4706 else impmsg "keyboard link navigation does not work under rotation"
4709 begin match state
.mstate
with
4712 G.postRedisplay "kill rect";
4715 | Mscrolly
| Mscrollx
4718 begin match state
.mode with
4721 G.postRedisplay "esc leave linknav"
4725 match state
.ranchors
with
4727 | (path, password, anchor, origin
) :: rest
->
4728 state
.ranchors
<- rest
;
4729 state
.anchor <- anchor;
4730 state
.origin
<- origin
;
4731 state
.nameddest
<- E.s;
4732 opendoc path password
4737 gotoghyll (getnav ~
-1)
4748 Hashtbl.iter
(fun _ opaque ->
4750 Hashtbl.clear state
.prects
) state
.pagemap
;
4751 G.postRedisplay "dehighlight";
4753 | @slash
| @question
->
4754 let ondone isforw
s =
4755 cbput state
.hists
.pat
s;
4756 state
.searchpattern
<- s;
4759 let s = String.make
1 (Char.chr
key) in
4760 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4761 textentry, ondone (key = @slash
), true)
4763 | @plus
| @kpplus
| @equals
when ctrl ->
4764 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4765 setzoom (conf
.zoom +. incr)
4767 | @plus
| @kpplus
->
4770 try int_of_string
s with exc
->
4771 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4777 state
.text <- "page bias is now " ^ string_of_int
n;
4780 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4782 | @minus
| @kpminus
when ctrl ->
4783 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4784 setzoom (max
0.01 (conf
.zoom -. decr))
4786 | @minus
| @kpminus
->
4787 let ondone msg
= state
.text <- msg
in
4789 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4790 optentry state
.mode, ondone, true
4801 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4803 match conf
.columns
with
4804 | Csingle
_ | Cmulti
_ -> 1
4805 | Csplit
(n, _) -> n
4807 let h = state
.winh
-
4808 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4810 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4811 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4816 match conf
.fitmodel
with
4817 | FitWidth
-> FitProportional
4818 | FitProportional
-> FitPage
4819 | FitPage
-> FitWidth
4821 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4822 reqlayout conf
.angle
fm
4824 | @4 when ctrl -> (* ctrl-4 *)
4825 let zoom = getmaxw
() /. float state
.winw
in
4826 if zoom > 0.0 then setzoom zoom
4834 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4835 when not
ctrl -> (* 0..9 *)
4838 try int_of_string
s with exc
->
4839 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4845 cbput state
.hists
.pag
(string_of_int
n);
4846 gotopage1 (n + conf
.pagebias
- 1) 0;
4849 let pageentry text key =
4850 match Char.unsafe_chr
key with
4851 | '
g'
-> TEdone
text
4852 | _ -> intentry text key
4854 let text = String.make
1 (Char.chr
key) in
4855 enttext (":", text, Some
(onhist state
.hists
.pag
),
4856 pageentry, ondone, true)
4859 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4860 reshape state
.winw state
.winh
;
4863 state
.bzoom
<- not state
.bzoom
;
4865 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4868 conf
.hlinks
<- not conf
.hlinks
;
4869 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4870 G.postRedisplay "toggle highlightlinks";
4873 if conf
.angle
mod 360 = 0
4875 state
.glinks
<- true;
4876 let mode = state
.mode in
4879 (":", E.s, None
, linknentry, linknact gotounder, false),
4881 state
.glinks
<- false;
4885 G.postRedisplay "view:linkent(F)"
4887 else impmsg "hint mode does not work under rotation"
4890 state
.glinks
<- true;
4891 let mode = state
.mode in
4892 state
.mode <- Textentry
(
4894 ":", E.s, None
, linknentry, linknact (fun under ->
4895 selstring (undertext under);
4899 state
.glinks
<- false;
4903 G.postRedisplay "view:linkent"
4906 begin match state
.autoscroll
with
4908 conf
.autoscrollstep
<- step
;
4909 state
.autoscroll
<- None
4911 if conf
.autoscrollstep
= 0
4912 then state
.autoscroll
<- Some
1
4913 else state
.autoscroll
<- Some conf
.autoscrollstep
4917 launchpath () (* XXX where do error messages go? *)
4920 setpresentationmode (not conf
.presentation
);
4921 showtext ' '
("presentation mode " ^
4922 if conf
.presentation
then "on" else "off");
4925 if List.mem
Wsi.Fullscreen state
.winstate
4926 then Wsi.reshape conf
.cwinw conf
.cwinh
4927 else Wsi.fullscreen
()
4930 search state
.searchpattern
false
4933 search state
.searchpattern
true
4936 begin match state
.layout with
4939 gotoghyll (getpagey
l.pageno)
4945 | @delete
| @kpdelete
-> (* delete *)
4949 showtext ' '
(describe_location ());
4952 begin match state
.layout with
4955 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4960 enterbookmarkmode
()
4968 | @e when Buffer.length state
.errmsgs
> 0 ->
4973 match state
.layout with
4978 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4981 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4985 showtext ' '
"Quick bookmark added";
4988 begin match state
.layout with
4990 let rect = getpdimrect
l.pagedimno
in
4994 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4995 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4997 (truncate
(rect.(1) -. rect.(0)),
4998 truncate
(rect.(3) -. rect.(0)))
5000 let w = truncate
((float w)*.conf
.zoom)
5001 and h = truncate
((float h)*.conf
.zoom) in
5004 state
.anchor <- getanchor
();
5005 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5007 G.postRedisplay "z";
5012 | @x -> state
.roam
()
5015 reqlayout (conf
.angle
+
5016 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5020 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5022 G.postRedisplay "brightness";
5024 | @c when state
.mode = View
->
5029 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5031 gotoy_and_clear_text state
.y
5035 match state
.prevcolumns
with
5036 | None
-> (1, 0, 0), 1.0
5037 | Some
(columns
, z
) ->
5040 | Csplit
(c, _) -> -c, 0, 0
5041 | Cmulti
((c, a, b), _) -> c, a, b
5042 | Csingle
_ -> 1, 0, 0
5046 setcolumns View
c a b;
5049 | @down
| @up
when ctrl && Wsi.withshift mask
->
5050 let zoom, x = state
.prevzoom
in
5054 | @k
| @up
| @kpup
->
5055 begin match state
.autoscroll
with
5057 begin match state
.mode with
5058 | Birdseye beye
-> upbirdseye 1 beye
5063 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5065 if not
(Wsi.withshift mask
) && conf
.presentation
5067 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5071 setautoscrollspeed n false
5074 | @j
| @down
| @kpdown
->
5075 begin match state
.autoscroll
with
5077 begin match state
.mode with
5078 | Birdseye beye
-> downbirdseye 1 beye
5083 then gotoy_and_clear_text (clamp (state
.winh
/2))
5085 if not
(Wsi.withshift mask
) && conf
.presentation
5087 else gotoghyll1 true (clamp (conf
.scrollstep
))
5091 setautoscrollspeed n true
5094 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5100 else conf
.hscrollstep
5102 let dx = if key = @left || key = @kpleft
then dx else -dx in
5103 state
.x <- panbound (state
.x + dx);
5104 gotoy_and_clear_text state
.y
5107 G.postRedisplay "left/right"
5110 | @prior
| @kpprior
->
5114 match state
.layout with
5116 | l :: _ -> state
.y - l.pagey
5118 clamp (pgscale (-state
.winh
))
5122 | @next | @kpnext
->
5126 match List.rev state
.layout with
5128 | l :: _ -> getpagey
l.pageno
5130 clamp (pgscale state
.winh
)
5134 | @g | @home
| @kphome
->
5137 | @G
| @jend
| @kpend
->
5139 gotoghyll (clamp state
.maxy)
5141 | @right
| @kpright
when Wsi.withalt mask
->
5142 gotoghyll (getnav 1)
5143 | @left | @kpleft
when Wsi.withalt mask
->
5144 gotoghyll (getnav ~
-1)
5149 | @v when conf
.debug
->
5152 match getopaque l.pageno with
5155 let x0, y0, x1, y1 = pagebbox
opaque in
5156 let a,b = float x0, float y0 in
5157 let c,d = float x1, float y0 in
5158 let e,f = float x1, float y1 in
5159 let h,j
= float x0, float y1 in
5160 let rect = (a,b,c,d,e,f,h,j
) in
5162 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5163 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5165 G.postRedisplay "v";
5168 let mode = state
.mode in
5169 let cmd = ref E.s in
5170 let onleave = function
5171 | Cancel
-> state
.mode <- mode
5174 match getopaque l.pageno with
5175 | Some
opaque -> pipesel opaque !cmd
5176 | None
-> ()) state
.layout;
5180 cbput state
.hists
.sel
s;
5184 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5186 G.postRedisplay "|";
5187 state
.mode <- Textentry
(te, onleave);
5190 vlog "huh? %s" (Wsi.keyname
key)
5193 let linknavkeyboard key mask
linknav =
5194 let getpage pageno =
5195 let rec loop = function
5197 | l :: _ when l.pageno = pageno -> Some
l
5198 | _ :: rest
-> loop rest
5199 in loop state
.layout
5201 let doexact (pageno, n) =
5202 match getopaque pageno, getpage pageno with
5203 | Some
opaque, Some
l ->
5204 if key = @enter || key = @kpenter
5206 let under = getlink
opaque n in
5207 G.postRedisplay "link gotounder";
5214 Some
(findlink
opaque LDfirst
), -1
5217 Some
(findlink
opaque LDlast
), 1
5220 Some
(findlink
opaque (LDleft
n)), -1
5223 Some
(findlink
opaque (LDright
n)), 1
5226 Some
(findlink
opaque (LDup
n)), -1
5229 Some
(findlink
opaque (LDdown
n)), 1
5234 begin match findpwl
l.pageno dir with
5238 state
.mode <- LinkNav
(Ltgendir
dir);
5239 let y, h = getpageyh
pageno in
5242 then y + h - state
.winh
5247 begin match getopaque pageno, getpage pageno with
5248 | Some
opaque, Some
_ ->
5250 let ld = if dir > 0 then LDfirst
else LDlast
in
5253 begin match link with
5255 showlinktype (getlink
opaque m);
5256 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5257 G.postRedisplay "linknav jpage";
5258 | Lnotfound
-> notfound dir
5264 begin match opt with
5265 | Some Lnotfound
-> pwl l dir;
5266 | Some
(Lfound
m) ->
5270 let _, y0, _, y1 = getlinkrect
opaque m in
5272 then gotopage1 l.pageno y0
5274 let d = fstate
.fontsize
+ 1 in
5275 if y1 - l.pagey > l.pagevh - d
5276 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5277 else G.postRedisplay "linknav";
5279 showlinktype (getlink
opaque m);
5280 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5283 | None
-> viewkeyboard key mask
5285 | _ -> viewkeyboard key mask
5290 G.postRedisplay "leave linknav"
5294 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5295 | Ltexact exact
-> doexact exact
5298 let keyboard key mask
=
5299 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5300 then wcmd "interrupt"
5301 else state
.uioh <- state
.uioh#
key key mask
5304 let birdseyekeyboard key mask
5305 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5307 match conf
.columns
with
5309 | Cmulti
((c, _, _), _) -> c
5310 | Csplit
_ -> failwith
"bird's eye split mode"
5312 let pgh layout = List.fold_left
5313 (fun m l -> max
l.pageh
m) state
.winh
layout in
5315 | @l when Wsi.withctrl mask
->
5316 let y, h = getpageyh
pageno in
5317 let top = (state
.winh
- h) / 2 in
5318 gotoy (max
0 (y - top))
5319 | @enter | @kpenter
-> leavebirdseye beye
false
5320 | @escape
-> leavebirdseye beye
true
5321 | @up
-> upbirdseye incr beye
5322 | @down
-> downbirdseye incr beye
5323 | @left -> upbirdseye 1 beye
5324 | @right
-> downbirdseye 1 beye
5327 begin match state
.layout with
5331 state
.mode <- Birdseye
(
5332 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5334 gotopage1 l.pageno 0;
5337 let layout = layout state
.x (state
.y-state
.winh
)
5339 (pgh state
.layout) in
5341 | [] -> gotoy (clamp (-state
.winh
))
5343 state
.mode <- Birdseye
(
5344 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5346 gotopage1 l.pageno 0
5349 | [] -> gotoy (clamp (-state
.winh
))
5353 begin match List.rev state
.layout with
5355 let layout = layout state
.x
5356 (state
.y + (pgh state
.layout))
5357 state
.winw state
.winh
in
5358 begin match layout with
5360 let incr = l.pageh
- l.pagevh in
5365 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5367 G.postRedisplay "birdseye pagedown";
5369 else gotoy (clamp (incr + conf
.interpagespace
*2));
5373 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5374 gotopage1 l.pageno 0;
5377 | [] -> gotoy (clamp state
.winh
)
5381 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5385 let pageno = state
.pagecount
- 1 in
5386 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5387 if not
(pagevisible state
.layout pageno)
5390 match List.rev state
.pdims
with
5392 | (_, _, h, _) :: _ -> h
5394 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5395 else G.postRedisplay "birdseye end";
5397 | _ -> viewkeyboard key mask
5402 match state
.mode with
5403 | Textentry
_ -> scalecolor 0.4
5405 | View
-> scalecolor 1.0
5406 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5407 if l.pageno = hooverpageno
5410 if l.pageno = pageno
5412 let c = scalecolor 1.0 in
5414 GlDraw.line_width
3.0;
5415 let dispx = xadjsb () + l.pagedispx in
5417 (float (dispx-1)) (float (l.pagedispy-1))
5418 (float (dispx+l.pagevw+1))
5419 (float (l.pagedispy+l.pagevh+1))
5421 GlDraw.line_width
1.0;
5430 let postdrawpage l linkindexbase
=
5431 match getopaque l.pageno with
5433 if tileready l l.pagex
l.pagey
5435 let x = l.pagedispx - l.pagex
+ xadjsb ()
5436 and y = l.pagedispy - l.pagey in
5438 match conf
.columns
with
5439 | Csingle
_ | Cmulti
_ ->
5440 (if conf
.hlinks
then 1 else 0)
5442 && not
(isbirdseye state
.mode) then 2 else 0)
5446 match state
.mode with
5447 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5453 Hashtbl.find_all state
.prects
l.pageno |>
5454 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5455 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5460 let scrollindicator () =
5461 let sbw, ph
, sh = state
.uioh#
scrollph in
5462 let sbh, pw, sw = state
.uioh#scrollpw
in
5467 else ((state
.winw
- sbw), state
.winw
, 0)
5470 GlDraw.color (0.64, 0.64, 0.64);
5471 filledrect (float x0) 0. (float x1) (float state
.winh
);
5473 (float hx0
) (float (state
.winh
- sbh))
5474 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5476 GlDraw.color (0.0, 0.0, 0.0);
5478 filledrect (float x0) ph
(float x1) (ph
+. sh);
5479 let pw = pw +. float hx0
in
5480 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5484 match state
.mstate
with
5485 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5488 | Msel
((x0, y0), (x1, y1)) ->
5489 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5490 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5491 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5492 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5495 let showrects = function [] -> () | rects
->
5497 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5498 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5500 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5502 if l.pageno = pageno
5504 let dx = float (l.pagedispx - l.pagex
) in
5505 let dy = float (l.pagedispy - l.pagey) in
5506 let r, g, b, alpha = c in
5507 GlDraw.color (r, g, b) ~
alpha;
5508 Raw.sets_float state
.vraw ~
pos:0
5513 GlArray.vertex `two state
.vraw
;
5514 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5523 GlClear.color (scalecolor2 conf
.bgcolor
);
5524 GlClear.clear
[`
color];
5525 List.iter
drawpage state
.layout;
5527 match state
.mode with
5528 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5529 begin match getopaque pageno with
5531 let dx = xadjsb () in
5532 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5533 let x0 = x0 + dx and x1 = x1 + dx in
5534 let color = (0.0, 0.0, 0.5, 0.5) in
5541 | None
-> state
.rects
5543 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5546 | View
-> state
.rects
5549 let rec postloop linkindexbase
= function
5551 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5552 postloop linkindexbase rest
5556 postloop 0 state
.layout;
5558 begin match state
.mstate
with
5559 | Mzoomrect
((x0, y0), (x1, y1)) ->
5561 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5562 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5563 filledrect (float x0) (float y0) (float x1) (float y1);
5567 | Mscrolly
| Mscrollx
5576 let zoomrect x y x1 y1 =
5579 and y0 = min
y y1 in
5580 gotoy (state
.y + y0);
5581 state
.anchor <- getanchor
();
5582 let zoom = (float state
.w) /. float (x1 - x0) in
5585 let adjw = wadjsb () + state
.winw
in
5587 then (adjw - state
.w) / 2
5590 match conf
.fitmodel
with
5591 | FitWidth
| FitProportional
-> simple ()
5593 match conf
.columns
with
5595 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5596 | Cmulti
_ | Csingle
_ -> simple ()
5598 state
.x <- (state
.x + margin) - x0;
5603 let annot inline
x y =
5604 match unproject x y with
5605 | Some
(opaque, n, ux
, uy
) ->
5607 addannot
opaque ux uy
text;
5608 wcmd "freepage %s" (~
> opaque);
5609 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5615 let ondone s = add s in
5616 let mode = state
.mode in
5617 state
.mode <- Textentry
(
5618 ("annotation: ", E.s, None
, textentry, ondone, true),
5619 fun _ -> state
.mode <- mode);
5622 G.postRedisplay "annot"
5624 add @@ getusertext E.s
5629 let g opaque l px py =
5630 match rectofblock
opaque px py with
5632 let x0 = a.(0) -. 20. in
5633 let x1 = a.(1) +. 20. in
5634 let y0 = a.(2) -. 20. in
5635 let zoom = (float state
.w) /. (x1 -. x0) in
5636 let pagey = getpagey
l.pageno in
5637 gotoy_and_clear_text (pagey + truncate
y0);
5638 state
.anchor <- getanchor
();
5639 let margin = (state
.w - l.pagew
)/2 in
5640 state
.x <- -truncate
x0 - margin;
5645 match conf
.columns
with
5647 impmsg "block zooming does not work properly in split columns mode"
5648 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5652 let winw = wadjsb () + state
.winw - 1 in
5653 let s = float x /. float winw in
5654 let destx = truncate
(float (state
.w + winw) *. s) in
5655 state
.x <- winw - destx;
5656 gotoy_and_clear_text state
.y;
5657 state
.mstate
<- Mscrollx
;
5661 let s = float y /. float state
.winh
in
5662 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5663 gotoy_and_clear_text desty;
5664 state
.mstate
<- Mscrolly
;
5667 let viewmulticlick clicks
x y mask
=
5668 let g opaque l px py =
5676 if markunder
opaque px py mark
5680 match getopaque l.pageno with
5682 | Some
opaque -> pipesel opaque cmd
5684 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5685 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5690 G.postRedisplay "viewmulticlick";
5691 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5695 match conf
.columns
with
5697 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5700 let viewmouse button down
x y mask
=
5702 | n when (n == 4 || n == 5) && not down
->
5703 if Wsi.withctrl mask
5705 match state
.mstate
with
5706 | Mzoom
(oldn
, i
) ->
5714 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5716 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5718 let zoom = conf
.zoom -. incr in
5720 state
.mstate
<- Mzoom
(n, 0);
5722 state
.mstate
<- Mzoom
(n, i
+1);
5724 else state
.mstate
<- Mzoom
(n, 0)
5728 | Mscrolly
| Mscrollx
5730 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5733 match state
.autoscroll
with
5734 | Some step
-> setautoscrollspeed step
(n=4)
5736 if conf
.wheelbypage
|| conf
.presentation
5745 then -conf
.scrollstep
5746 else conf
.scrollstep
5748 let incr = incr * 2 in
5749 let y = clamp incr in
5750 gotoy_and_clear_text y
5753 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5755 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5756 gotoy_and_clear_text state
.y
5758 | 1 when Wsi.withshift mask
->
5759 state
.mstate
<- Mnone
;
5762 match unproject x y with
5764 | Some
(_, pageno, ux
, uy
) ->
5765 let cmd = Printf.sprintf
5767 conf
.stcmd state
.path pageno ux uy
5769 match spawn
cmd [] with
5770 | (exception exn
) ->
5771 impmsg "execution of synctex command(%S) failed: %S"
5772 conf
.stcmd
@@ exntos exn
5776 | 1 when Wsi.withctrl mask
->
5779 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5780 state
.mstate
<- Mpan
(x, y)
5783 state
.mstate
<- Mnone
5788 if Wsi.withshift mask
5790 annot conf
.annotinline
x y;
5791 G.postRedisplay "addannot"
5795 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5796 state
.mstate
<- Mzoomrect
(p, p)
5799 match state
.mstate
with
5800 | Mzoomrect
((x0, y0), _) ->
5801 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5802 then zoomrect x0 y0 x y
5805 G.postRedisplay "kill accidental zoom rect";
5809 | Mscrolly
| Mscrollx
5815 | 1 when vscrollhit x ->
5818 let _, position, sh = state
.uioh#
scrollph in
5819 if y > truncate
position && y < truncate
(position +. sh)
5820 then state
.mstate
<- Mscrolly
5823 state
.mstate
<- Mnone
5825 | 1 when y > state
.winh
- hscrollh () ->
5828 let _, position, sw = state
.uioh#scrollpw
in
5829 if x > truncate
position && x < truncate
(position +. sw)
5830 then state
.mstate
<- Mscrollx
5833 state
.mstate
<- Mnone
5835 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5838 let dest = if down
then getunder x y else Unone
in
5839 begin match dest with
5842 | Uremote
_ | Uremotedest
_
5843 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5846 | Unone
when down
->
5847 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5848 state
.mstate
<- Mpan
(x, y);
5850 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5852 | Unone
| Utext
_ ->
5857 state
.mstate
<- Msel
((x, y), (x, y));
5858 G.postRedisplay "mouse select";
5862 match state
.mstate
with
5865 | Mzoom
_ | Mscrollx
| Mscrolly
->
5866 state
.mstate
<- Mnone
5868 | Mzoomrect
((x0, y0), _) ->
5872 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5873 state
.mstate
<- Mnone
5875 | Msel
((x0, y0), (x1, y1)) ->
5876 let rec loop = function
5880 let a0 = l.pagedispy in
5881 let a1 = a0 + l.pagevh in
5882 let b0 = l.pagedispx in
5883 let b1 = b0 + l.pagevw in
5884 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5885 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5889 match getopaque l.pageno with
5892 match Unix.pipe
() with
5893 | (exception exn
) ->
5894 impmsg "cannot create sel pipe: %s" @@
5898 Ne.clo fd
(fun msg
->
5899 dolog
"%s close failed: %s" what msg
)
5902 try spawn
cmd [r, 0; w, -1]
5904 dolog
"cannot execute %S: %s"
5911 G.postRedisplay "copysel";
5913 else clo "Msel pipe/w" w;
5914 clo "Msel pipe/r" r;
5916 dosel conf
.selcmd
();
5917 state
.roam
<- dosel conf
.paxcmd
;
5929 let birdseyemouse button down
x y mask
5930 (conf
, leftx
, _, hooverpageno
, anchor) =
5933 let rec loop = function
5936 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5937 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5939 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5945 | _ -> viewmouse button down
x y mask
5951 method key key mask
=
5952 begin match state
.mode with
5953 | Textentry
textentry -> textentrykeyboard key mask
textentry
5954 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5955 | View
-> viewkeyboard key mask
5956 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5960 method button button bstate
x y mask
=
5961 begin match state
.mode with
5963 | View
-> viewmouse button bstate
x y mask
5964 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5969 method multiclick clicks
x y mask
=
5970 begin match state
.mode with
5972 | View
-> viewmulticlick clicks
x y mask
5979 begin match state
.mode with
5981 | View
| Birdseye
_ | LinkNav
_ ->
5982 match state
.mstate
with
5983 | Mzoom
_ | Mnone
-> ()
5988 state
.mstate
<- Mpan
(x, y);
5990 then state
.x <- panbound (state
.x + dx);
5992 gotoy_and_clear_text y
5995 state
.mstate
<- Msel
(a, (x, y));
5996 G.postRedisplay "motion select";
5999 let y = min state
.winh
(max
0 y) in
6003 let x = min state
.winw (max
0 x) in
6006 | Mzoomrect
(p0
, _) ->
6007 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6008 G.postRedisplay "motion zoomrect";
6012 method pmotion
x y =
6013 begin match state
.mode with
6014 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6015 let rec loop = function
6017 if hooverpageno
!= -1
6019 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6020 G.postRedisplay "pmotion birdseye no hoover";
6023 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6024 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6026 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6027 G.postRedisplay "pmotion birdseye hoover";
6037 match state
.mstate
with
6038 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6046 let past, _, _ = !r in
6048 let delta = now -. past in
6051 else r := (now, x, y)
6055 method infochanged
_ = ()
6058 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6061 then 0.0, float state
.winh
6062 else scrollph state
.y maxy
6067 let winw = wadjsb () + state
.winw in
6068 let fwinw = float winw in
6070 let sw = fwinw /. float state
.w in
6071 let sw = fwinw *. sw in
6072 max
sw (float conf
.scrollh
)
6075 let maxx = state
.w + winw in
6076 let x = winw - state
.x in
6077 let percent = float x /. float maxx in
6078 (fwinw -. sw) *. percent
6080 hscrollh (), position, sw
6084 match state
.mode with
6085 | LinkNav
_ -> "links"
6086 | Textentry
_ -> "textentry"
6087 | Birdseye
_ -> "birdseye"
6090 findkeyhash conf
modename
6092 method eformsgs
= true
6093 method alwaysscrolly
= false
6096 let adderrmsg src msg
=
6097 Buffer.add_string state
.errmsgs msg
;
6098 state
.newerrmsgs
<- true;
6102 let adderrfmt src fmt
=
6103 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6106 let addrect pageno r g b a x0 y0 x1 y1 =
6107 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6111 let cl = splitatspace cmds
in
6113 try Scanf.sscanf
s fmt
f
6115 adderrfmt "remote exec"
6116 "error processing '%S': %s\n" cmds
@@ exntos exn
6118 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6119 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6120 s pageno r g b a x0 y0 x1 y1;
6124 let _,w1,h1
,_ = getpagedim
pageno in
6125 let sw = float w1 /. float w
6126 and sh = float h1
/. float h in
6130 and y1s
= y1 *. sh in
6131 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6132 let color = (r, g, b, a) in
6133 if conf
.verbose
then debugrect rect;
6134 state
.rects <- (pageno, color, rect) :: state
.rects;
6139 | "reload" :: [] -> reload ()
6140 | "goto" :: args
:: [] ->
6141 scan args
"%u %f %f"
6143 let cmd, _ = state
.geomcmds
in
6145 then gotopagexy pageno x y
6148 gotopagexy pageno x y;
6151 state
.reprf
<- f state
.reprf
6153 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6154 | "gotor" :: args
:: [] ->
6156 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6157 | "gotord" :: args
:: [] ->
6159 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6160 | "rect" :: args
:: [] ->
6161 scan args
"%u %u %f %f %f %f"
6162 (fun pageno c x0 y0 x1 y1 ->
6163 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6164 rectx "rect" pageno color x0 y0 x1 y1;
6166 | "prect" :: args
:: [] ->
6167 scan args
"%u %f %f %f %f %f %f %f %f"
6168 (fun pageno r g b alpha x0 y0 x1 y1 ->
6169 addrect pageno r g b alpha x0 y0 x1 y1;
6170 G.postRedisplay "prect"
6172 | "pgoto" :: args
:: [] ->
6173 scan args
"%u %f %f"
6176 match getopaque pageno with
6177 | Some
opaque -> opaque
6180 pgoto optopaque pageno x y;
6181 let rec fixx = function
6184 if l.pageno = pageno
6186 state
.x <- state
.x - l.pagedispx;
6193 match conf
.columns
with
6194 | Csingle
_ | Csplit
_ -> 1
6195 | Cmulti
((n, _, _), _) -> n
6197 layout 0 state
.y (state
.winw * mult) state
.winh
6201 | "activatewin" :: [] -> Wsi.activatewin
()
6202 | "quit" :: [] -> raise Quit
6203 | "clearrects" :: [] ->
6204 Hashtbl.clear state
.prects
;
6205 G.postRedisplay "clearrects"
6207 adderrfmt "remote command"
6208 "error processing remote command: %S\n" cmds
;
6212 let scratch = Bytes.create
80 in
6213 let buf = Buffer.create
80 in
6215 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6216 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6219 if Buffer.length
buf > 0
6221 let s = Buffer.contents
buf in
6229 match Bytes.index_from
scratch ppos '
\n'
with
6230 | pos -> if pos >= n then -1 else pos
6231 | (exception Not_found
) -> -1
6235 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6236 let s = Buffer.contents
buf in
6242 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6248 let remoteopen path =
6249 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6251 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6256 let gcconfig = ref E.s in
6257 let trimcachepath = ref E.s in
6258 let rcmdpath = ref E.s in
6259 let pageno = ref None
in
6260 let rootwid = ref 0 in
6261 let openlast = ref false in
6262 let nofc = ref false in
6263 let doreap = ref false in
6264 selfexec := Sys.executable_name
;
6267 [("-p", Arg.String
(fun s -> state
.password <- s),
6268 "<password> Set password");
6272 Config.fontpath
:= s;
6273 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6275 "<path> Set path to the user interface font");
6279 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6280 Config.confpath
:= s),
6281 "<path> Set path to the configuration file");
6283 ("-last", Arg.Set
openlast, " Open last document");
6285 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6286 "<page-number> Jump to page");
6288 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6289 "<path> Set path to the trim cache file");
6291 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6292 "<named-destination> Set named destination");
6294 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6295 ("-cxack", Arg.Set
cxack, " Cut corners");
6297 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6298 "<path> Set path to the remote commands source");
6300 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6301 "<original-path> Set original path");
6303 ("-gc", Arg.Set_string
gcconfig,
6304 "<script-path> Collect garbage with the help of a script");
6306 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6308 ("-v", Arg.Unit
(fun () ->
6310 "%s\nconfiguration path: %s\n"
6314 exit
0), " Print version and exit");
6316 ("-embed", Arg.Set_int
rootwid,
6317 "<window-id> Embed into window")
6320 (fun s -> state
.path <- s)
6321 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6324 then selfexec := !selfexec ^
" -wtmode";
6326 let histmode = emptystr state
.path && not
!openlast in
6328 if not
(Config.load !openlast)
6329 then dolog
"failed to load configuration";
6330 begin match !pageno with
6331 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6335 if nonemptystr
!gcconfig
6338 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6339 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6342 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6343 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6345 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6350 let wsfd, winw, winh
= Wsi.init
(object (self)
6351 val mutable m_clicks
= 0
6352 val mutable m_click_x
= 0
6353 val mutable m_click_y
= 0
6354 val mutable m_lastclicktime
= infinity
6356 method private cleanup =
6357 state
.roam
<- noroam
;
6358 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6359 method expose
= G.postRedisplay"expose"
6363 | Wsi.Unobscured
-> "unobscured"
6364 | Wsi.PartiallyObscured
-> "partiallyobscured"
6365 | Wsi.FullyObscured
-> "fullyobscured"
6367 vlog "visibility change %s" name
6368 method display = display ()
6369 method map mapped
= vlog "mappped %b" mapped
6370 method reshape w h =
6373 method mouse
b d x y m =
6374 if d && canselect ()
6376 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6382 if abs
x - m_click_x
> 10
6383 || abs
y - m_click_y
> 10
6384 || abs_float
(t -. m_lastclicktime
) > 0.3
6386 m_clicks
<- m_clicks
+ 1;
6387 m_lastclicktime
<- t;
6391 G.postRedisplay "cleanup";
6392 state
.uioh <- state
.uioh#button
b d x y m;
6394 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6399 m_lastclicktime
<- infinity
;
6400 state
.uioh <- state
.uioh#button
b d x y m
6404 state
.uioh <- state
.uioh#button
b d x y m
6407 state
.mpos
<- (x, y);
6408 state
.uioh <- state
.uioh#motion
x y
6409 method pmotion
x y =
6410 state
.mpos
<- (x, y);
6411 state
.uioh <- state
.uioh#pmotion
x y
6413 let mascm = m land (
6414 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6417 let x = state
.x and y = state
.y in
6419 if x != state
.x || y != state
.y then self#
cleanup
6421 match state
.keystate
with
6423 let km = k
, mascm in
6426 let modehash = state
.uioh#
modehash in
6427 try Hashtbl.find modehash km
6429 try Hashtbl.find (findkeyhash conf
"global") km
6430 with Not_found
-> KMinsrt
(k
, m)
6432 | KMinsrt
(k
, m) -> keyboard k
m
6433 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6434 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6436 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6437 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6438 state
.keystate
<- KSnone
6439 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6440 state
.keystate
<- KSinto
(keys, insrt
)
6441 | KSinto
_ -> state
.keystate
<- KSnone
6444 state
.mpos
<- (x, y);
6445 state
.uioh <- state
.uioh#pmotion
x y
6446 method leave = state
.mpos
<- (-1, -1)
6447 method winstate wsl
= state
.winstate
<- wsl
6448 method quit
= raise Quit
6449 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6454 List.exists
GlMisc.check_extension
6455 [ "GL_ARB_texture_rectangle"
6456 ; "GL_EXT_texture_recangle"
6457 ; "GL_NV_texture_rectangle" ]
6459 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6462 let r = GlMisc.get_string `renderer
in
6463 let p = "Mesa DRI Intel(" in
6464 let l = String.length
p in
6465 String.length
r > l && String.sub
r 0 l = p
6468 defconf
.sliceheight
<- 1024;
6469 defconf
.texcount
<- 32;
6470 defconf
.usepbo
<- true;
6474 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6475 | (exception exn
) ->
6476 dolog
"socketpair failed: %s" @@ exntos exn
;
6484 setcheckers conf
.checkers
;
6487 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6488 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6489 !Config.fontpath
, !trimcachepath,
6490 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6493 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6495 reshape ~firsttime
:true winw winh
;
6499 Wsi.settitle
"llpp (history)";
6503 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6504 opendoc state
.path state
.password;
6508 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6509 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6512 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6513 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6514 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6516 | _pid
, _status
-> reap ()
6518 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6522 if nonemptystr
!rcmdpath
6523 then remoteopen !rcmdpath
6528 let rec loop deadline
=
6534 let r = [state
.ss; state
.wsfd] in
6538 | Some fd
-> fd
:: r
6542 state
.redisplay
<- false;
6549 if deadline
= infinity
6551 else max
0.0 (deadline
-. now)
6556 try Unix.select
r [] [] timeout
6557 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6563 if state
.ghyll
== noghyll
6565 match state
.autoscroll
with
6566 | Some step
when step
!= 0 ->
6567 let y = state
.y + step
in
6571 else if y >= state
.maxy then 0 else y
6573 if state
.mode = View
6574 then gotoy_and_clear_text y
6578 else deadline
+. 0.01
6583 let rec checkfds = function
6585 | fd
:: rest
when fd
= state
.ss ->
6586 let cmd = readcmd state
.ss in
6590 | fd
:: rest
when fd
= state
.wsfd ->
6594 | fd
:: rest
when Some fd
= !optrfd ->
6595 begin match remote fd
with
6596 | None
-> optrfd := remoteopen !rcmdpath;
6597 | opt -> optrfd := opt
6602 dolog
"select returned unknown descriptor";
6608 if deadline
= infinity
6612 match state
.autoscroll
with
6613 | Some step
when step
!= 0 -> deadline1
6614 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6622 Config.save leavebirdseye;
6623 if hasunsavedchanges
()