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 drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
16 external measurestr
: int -> string -> float = "ml_measure_string";;
17 external postprocess
:
18 opaque
-> int -> int -> int -> (int * string * int) -> int
20 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
21 external setaalevel
: int -> unit = "ml_setaalevel";;
22 external realloctexts
: int -> bool = "ml_realloctexts";;
23 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
24 external getlink
: opaque
-> int -> under
= "ml_getlink";;
25 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
26 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
27 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
28 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
29 external freepbo
: opaque
-> unit = "ml_freepbo";;
30 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
31 external pbousable
: unit -> bool = "ml_pbo_usable";;
32 external unproject
: opaque
-> int -> int -> (int * int) option
34 external project
: opaque
-> float -> float -> (float * float) = "ml_project";;
35 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
36 external rectofblock
: opaque
-> int -> int -> float array
option
38 external begintiles
: unit -> unit = "ml_begintiles";;
39 external endtiles
: unit -> unit = "ml_endtiles";;
40 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
41 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
42 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
43 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
44 external savedoc
: string -> unit = "ml_savedoc";;
45 external getannotcontents
: opaque
-> slinkindex
-> string
46 = "ml_getannotcontents";;
47 external drawprect
: opaque
-> int -> int -> float array
-> unit =
50 let selfexec = ref E.s
;;
52 let drawstring size x y s
=
54 Gl.enable `texture_2d
;
55 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
56 ignore
(drawstr size x y s
);
58 Gl.disable `texture_2d
;
61 let drawstring1 size x y s
=
65 let drawstring2 size x y fmt
=
66 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
70 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
71 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
72 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
73 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
74 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
75 dolog
" column %d" l
.pagecol
;
79 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
81 dolog
" x0,y0=(% f, % f)" x0 y0
;
82 dolog
" x1,y1=(% f, % f)" x1 y1
;
83 dolog
" x2,y2=(% f, % f)" x2 y2
;
84 dolog
" x3,y3=(% f, % f)" x3 y3
;
88 let isbirdseye = function
95 let istextentry = function
102 let wtmode = ref false;;
103 let cxack = ref false;;
105 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
108 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
109 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
115 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
123 else x
> state
.winw
- vscrollw ()
126 let wadjsb () = -vscrollw ();;
127 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
130 fstate
.fontsize
<- n
;
131 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
132 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
138 else Printf.kprintf ignore fmt
142 if emptystr conf
.pathlauncher
143 then dolog
"%s" state
.path
145 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
146 match spawn
command [] with
149 dolog
"failed to execute `%s': %s" command @@ exntos exn
155 let postRedisplay who
=
156 vlog "redisplay for [%S]" who
;
157 state
.redisplay
<- true;
161 let getopaque pageno
=
162 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
163 with Not_found
-> None
166 let pagetranslatepoint l x y
=
167 let dy = y
- l
.pagedispy
in
168 let y = dy + l
.pagey
in
169 let dx = x
- l
.pagedispx
in
170 let x = dx + l
.pagex
in
174 let onppundermouse g
x y d
=
177 begin match getopaque l
.pageno
with
179 let x0 = l
.pagedispx
in
180 let x1 = x0 + l
.pagevw
in
181 let y0 = l
.pagedispy
in
182 let y1 = y0 + l
.pagevh
in
183 if y >= y0 && y <= y1 && x >= x0 && x <= x1
185 let px, py
= pagetranslatepoint l
x y in
186 match g opaque l
px py
with
199 let g opaque l
px py
=
202 match rectofblock opaque
px py
with
203 | Some
[|x0;x1;y0;y1|] ->
204 let ox = xadjsb () |> float in
205 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
206 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
207 state
.rects
<- [l
.pageno
, color, rect];
208 G.postRedisplay "getunder";
211 let under = whatsunder opaque
px py
in
212 if under = Unone
then None
else Some
under
214 onppundermouse g x y Unone
219 match unproject opaque
x y with
220 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
223 onppundermouse g x y None
;
227 state
.text
<- Printf.sprintf
"%c%s" c s
;
228 G.postRedisplay "showtext";
232 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
235 let pipesel opaque cmd
=
238 match Unix.pipe
() with
239 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
241 let doclose what fd
=
242 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
245 try spawn cmd
[r
, 0; w
, -1]
247 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
253 G.postRedisplay "pipesel";
255 else doclose "pipesel pipe/w" w
;
256 doclose "pipesel pipe/r" r
;
260 let g opaque l
px py
=
261 if markunder opaque
px py conf
.paxmark
264 match getopaque l
.pageno
with
266 | Some opaque
-> pipesel opaque conf
.paxcmd
271 G.postRedisplay "paxunder";
272 if conf
.paxmark
= Mark_page
275 match getopaque l
.pageno
with
277 | Some opaque
-> clearmark opaque
) state
.layout
;
278 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
282 match Unix.pipe
() with
283 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
286 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
289 try spawn conf
.selcmd
[r
, 0; w
, -1]
291 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
297 let l = String.length s
in
298 let bytes = Bytes.unsafe_of_string s
in
299 let n = tempfailureretry
(Unix.write w
bytes 0) l in
301 then impmsg "failed to write %d characters to sel pipe, wrote %d"
304 impmsg "failed to write to sel pipe: %s" @@ exntos exn
307 clo "selstring pipe/r" r
;
308 clo "selstring pipe/w" w
;
311 let undertext ?
(nopath
=false) = function
314 | Ulinkgoto
(pageno
, _
) ->
316 then "page " ^ string_of_int
(pageno
+1)
317 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
318 | Utext s
-> "font: " ^ s
319 | Uunexpected s
-> "unexpected: " ^ s
320 | Ulaunch s
-> "launch: " ^ s
321 | Unamed s
-> "named: " ^ s
322 | Uremote
(filename
, pageno
) ->
323 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
324 | Uremotedest
(filename
, destname
) ->
325 Printf.sprintf
"%s: destination %S" filename destname
326 | Uannotation
(opaque
, slinkindex
) ->
327 "annotation: " ^ getannotcontents opaque slinkindex
330 let updateunder x y =
331 match getunder x y with
332 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
334 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
335 Wsi.setcursor
Wsi.CURSOR_INFO
336 | Ulinkgoto
(pageno
, _
) ->
338 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
339 Wsi.setcursor
Wsi.CURSOR_INFO
341 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
342 Wsi.setcursor
Wsi.CURSOR_TEXT
344 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
345 Wsi.setcursor
Wsi.CURSOR_INHERIT
347 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
348 Wsi.setcursor
Wsi.CURSOR_INHERIT
350 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
351 Wsi.setcursor
Wsi.CURSOR_INHERIT
352 | Uremote
(filename
, pageno
) ->
353 if conf
.underinfo
then showtext 'r'
354 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
355 Wsi.setcursor
Wsi.CURSOR_INFO
356 | Uremotedest
(filename
, destname
) ->
357 if conf
.underinfo
then showtext 'r'
358 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
359 Wsi.setcursor
Wsi.CURSOR_INFO
361 if conf
.underinfo
then showtext 'a'
"nnotation";
362 Wsi.setcursor
Wsi.CURSOR_INFO
365 let showlinktype under =
366 if conf
.underinfo
&& under != Unone
367 then showtext ' '
@@ undertext under
370 let intentry_with_suffix text key
=
372 if key
>= 32 && key
< 127
376 match Char.lowercase
c with
378 let text = addchar
text c in
382 let text = addchar
text c in
386 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
391 let s = Bytes.create
4 in
392 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
393 if n != 4 then error
"incomplete read(len) = %d" n;
394 let len = (Char.code
(Bytes.get
s 0) lsl 24)
395 lor (Char.code
(Bytes.get
s 1) lsl 16)
396 lor (Char.code
(Bytes.get
s 2) lsl 8)
397 lor (Char.code
(Bytes.get
s 3))
399 let s = Bytes.create
len in
400 let n = tempfailureretry
(Unix.read fd
s 0) len in
401 if n != len then error
"incomplete read(data) %d vs %d" n len;
406 let b = Buffer.create
16 in
407 Buffer.add_string
b "llll";
410 let s = Buffer.to_bytes
b in
411 let n = Bytes.length
s in
413 (* dolog "wcmd %S" (String.sub s 4 len); *)
414 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
415 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
416 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
417 Bytes.set
s 3 (Char.chr
(len land 0xff));
418 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
419 if n'
!= n then error
"write failed %d vs %d" n'
n;
423 let nogeomcmds cmds
=
425 | s, [] -> emptystr
s
429 let layoutN ((columns
, coverA
, coverB
), b) y sh
=
430 let sh = sh - (hscrollh ()) in
431 let wadj = wadjsb () in
432 let rec fold accu
n =
433 if n = Array.length
b
436 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
439 || n = state
.pagecount
- coverB
440 || (n - coverA
) mod columns
= columns
- 1)
446 let pagey = max
0 (y - vy
) in
447 let pagedispy = if pagey > 0 then 0 else vy
- y in
448 let pagedispx, pagex
=
450 if n = coverA
- 1 || n = state
.pagecount
- coverB
451 then state
.x + (wadj + state
.winw
- w
) / 2
452 else dx + xoff
+ state
.x
459 let vw = wadj + state
.winw
- pagedispx in
460 let pw = w
- pagex
in
463 let pagevh = min
(h
- pagey) (sh - pagedispy) in
464 if pagevw > 0 && pagevh > 0
475 ; pagedispx = pagedispx
476 ; pagedispy = pagedispy
488 if Array.length
b = 0
490 else List.rev
(fold [] (page_of_y
y))
493 let layoutS (columns
, b) y sh =
494 let sh = sh - hscrollh () in
495 let wadj = wadjsb () in
496 let rec fold accu n =
497 if n = Array.length
b
500 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
507 let x = xoff
+ state
.x in
508 let pagey = max
0 (y - vy
) in
509 let pagedispy = if pagey > 0 then 0 else vy
- y in
510 let pagedispx, pagex
=
524 let pagecolw = pagew
/columns
in
526 if pagecolw < state
.winw
527 then pagedispx + ((wadj + state
.winw
- pagecolw) / 2)
531 let vw = wadj + state
.winw
- pagedispx in
532 let pw = pagew
- pagex
in
535 let pagevw = min
pagevw pagecolw in
536 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
537 if pagevw > 0 && pagevh > 0
548 ; pagedispx = pagedispx
549 ; pagedispy = pagedispy
550 ; pagecol
= n mod columns
565 if nogeomcmds state
.geomcmds
567 match conf
.columns
with
568 | Csingle
b -> layoutN ((1, 0, 0), b) y sh
569 | Cmulti
c -> layoutN c y sh
570 | Csplit
s -> layoutS s y sh
575 let y = state
.y + incr
in
577 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
582 let tilex = l.pagex
mod conf
.tilew
in
583 let tiley = l.pagey mod conf
.tileh
in
585 let col = l.pagex
/ conf
.tilew
in
586 let row = l.pagey / conf
.tileh
in
588 let xadj = xadjsb () in
589 let rec rowloop row y0 dispy h
=
593 let dh = conf
.tileh
- y0 in
595 let rec colloop col x0 dispx w
=
599 let dw = conf
.tilew
- x0 in
601 let dispx'
= xadj + dispx in
602 f col row dispx' dispy
x0 y0 dw dh;
603 colloop (col+1) 0 (dispx+dw) (w
-dw)
606 colloop col tilex l.pagedispx l.pagevw;
607 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
610 if l.pagevw > 0 && l.pagevh > 0
611 then rowloop row tiley l.pagedispy l.pagevh;
614 let gettileopaque l col row =
616 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
618 try Some
(Hashtbl.find state
.tilemap
key)
619 with Not_found
-> None
622 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
623 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
624 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
627 let filledrect x0 y0 x1 y1 =
628 GlArray.disable `texture_coord
;
629 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
630 GlArray.vertex `two state
.vraw
;
631 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
632 GlArray.enable `texture_coord
;
635 let linerect x0 y0 x1 y1 =
636 GlArray.disable `texture_coord
;
637 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
638 GlArray.vertex `two state
.vraw
;
639 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
640 GlArray.enable `texture_coord
;
643 let drawtiles l color =
645 let wadj = wadjsb () in
647 let f col row x y tilex tiley w h
=
648 match gettileopaque l col row with
649 | Some
(opaque
, _
, t
) ->
650 let params = x, y, w
, h
, tilex, tiley in
652 then GlTex.env
(`mode `blend
);
653 drawtile
params opaque
;
655 then GlTex.env
(`mode `modulate
);
659 let s = Printf.sprintf
663 let w = measurestr fstate
.fontsize
s in
664 GlDraw.color (0.0, 0.0, 0.0);
665 filledrect (float (x-2))
668 (float (y + fstate
.fontsize
+ 2));
669 GlDraw.color (1.0, 1.0, 1.0);
670 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
680 let lw = wadj + state
.winw
- x in
683 let lh = state
.winh
- y in
687 then GlTex.env
(`mode `blend
);
688 begin match state
.checkerstexid
with
690 Gl.enable `texture_2d
;
691 GlTex.bind_texture ~target
:`texture_2d id
;
695 and y1 = float (y+h
) in
697 let tw = float w /. 16.0
698 and th
= float h
/. 16.0 in
699 let tx0 = float tilex /. 16.0
700 and ty0
= float tiley /. 16.0 in
702 and ty1
= ty0
+. th
in
703 Raw.sets_float state
.vraw ~pos
:0
704 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
705 Raw.sets_float state
.traw ~pos
:0
706 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
707 GlArray.vertex `two state
.vraw
;
708 GlArray.tex_coord `two state
.traw
;
709 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
710 Gl.disable `texture_2d
;
713 GlDraw.color (1.0, 1.0, 1.0);
714 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
717 then GlTex.env
(`mode `modulate
);
718 if w > 128 && h
> fstate
.fontsize
+ 10
720 let c = if conf
.invert
then 1.0 else 0.0 in
721 GlDraw.color (c, c, c);
724 then (col*conf
.tilew
, row*conf
.tileh
)
727 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
736 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
738 let tilevisible1 l x y =
740 and ax1
= l.pagex
+ l.pagevw
742 and ay1
= l.pagey + l.pagevh in
746 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
747 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
749 let rx0 = max
ax0 bx0
750 and ry0
= max ay0 by0
751 and rx1
= min ax1
bx1
752 and ry1
= min ay1 by1
in
754 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
758 let tilevisible layout n x y =
759 let rec findpageinlayout m
= function
760 | l :: rest
when l.pageno
= n ->
761 tilevisible1 l x y || (
762 match conf
.columns
with
763 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
768 | _
:: rest
-> findpageinlayout 0 rest
771 findpageinlayout 0 layout;
774 let tileready l x y =
775 tilevisible1 l x y &&
776 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
779 let tilepage n p
layout =
780 let rec loop = function
784 let f col row _ _ _ _ _ _
=
785 if state
.currently
= Idle
787 match gettileopaque l col row with
790 let x = col*conf
.tilew
791 and y = row*conf
.tileh
in
793 let w = l.pagew
- x in
797 let h = l.pageh
- y in
802 then getpbo
w h conf
.colorspace
805 wcmd "tile %s %d %d %d %d %s"
806 (~
> p
) x y w h (~
> pbo);
809 l, p
, conf
.colorspace
, conf
.angle
,
810 state
.gen
, col, row, conf
.tilew
, conf
.tileh
819 if nogeomcmds state
.geomcmds
823 let preloadlayout y =
824 let y = if y < state
.winh
then 0 else y - state
.winh
in
825 let h = state
.winh
*3 in
831 if state
.currently
!= Idle
836 begin match getopaque l.pageno
with
838 wcmd "page %d %d" l.pageno
l.pagedimno
;
839 state
.currently
<- Loading
(l, state
.gen
);
841 tilepage l.pageno opaque pages
;
846 if nogeomcmds state
.geomcmds
852 if conf
.preload && state
.currently
= Idle
853 then load (preloadlayout state
.y);
856 let layoutready layout =
857 let rec fold all ls
=
860 let seen = ref false in
861 let allvisible = ref true in
862 let foo col row _ _ _ _ _ _
=
864 allvisible := !allvisible &&
865 begin match gettileopaque l col row with
871 fold (!seen && !allvisible) rest
874 let alltilesvisible = fold true layout in
879 let y = bound
y 0 state
.maxy
in
880 let y, layout, proceed
=
881 match conf
.maxwait
with
882 | Some time
when state
.ghyll
== noghyll
->
883 begin match state
.throttle
with
885 let layout = layout y state
.winh
in
886 let ready = layoutready layout in
890 state
.throttle
<- Some
(layout, y, now
());
892 else G.postRedisplay "gotoy showall (None)";
894 | Some
(_
, _
, started
) ->
895 let dt = now
() -. started
in
898 state
.throttle
<- None
;
899 let layout = layout y state
.winh
in
901 G.postRedisplay "maxwait";
908 let layout = layout y state
.winh
in
909 if not
!wtmode || layoutready layout
910 then G.postRedisplay "gotoy ready";
916 state
.layout <- layout;
917 begin match state
.mode
with
920 | Ltexact
(pageno
, linkno
) ->
921 let rec loop = function
923 state
.mode
<- LinkNav
(Ltgendir
0)
924 | l :: _
when l.pageno
= pageno
->
925 begin match getopaque pageno
with
926 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
928 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
929 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
930 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
931 then state
.mode
<- LinkNav
(Ltgendir
0)
933 | _
:: rest
-> loop rest
936 | Ltnotready _
| Ltgendir _
-> ()
942 begin match state
.mode
with
943 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
944 if not
(pagevisible layout pageno
)
946 match state
.layout with
949 state
.mode
<- Birdseye
(
950 conf
, leftx
, l.pageno
, hooverpageno
, anchor
955 | Ltnotready
(_
, dir
)
958 let rec loop = function
961 match getopaque l.pageno
with
962 | None
-> Ltnotready
(l.pageno
, dir
)
967 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
969 if dir
> 0 then LDfirst
else LDlast
975 | Lnotfound
-> loop rest
977 showlinktype (getlink opaque
n);
978 Ltexact
(l.pageno
, n)
982 state
.mode
<- LinkNav
linknav
990 state
.ghyll
<- noghyll
;
993 let mx, my
= state
.mpos
in
998 let conttiling pageno opaque
=
999 tilepage pageno opaque
1000 (if conf
.preload then preloadlayout state
.y else state
.layout)
1003 let gotoy_and_clear_text y =
1004 if not conf
.verbose
then state
.text <- E.s;
1008 let getanchory (n, top
, dtop
) =
1009 let y, h = getpageyh
n in
1010 if conf
.presentation
1012 let ips = calcips
h in
1013 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1015 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1018 let gotoanchor anchor
=
1019 gotoy (getanchory anchor
);
1023 cbput state
.hists
.nav
(getanchor
());
1027 let anchor = cbgetc state
.hists
.nav dir
in
1031 let gotoghyll1 single
y =
1032 let scroll f n a
b =
1033 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1035 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1037 then s (float f /. float a
)
1040 then 1.0 -. s ((float (f-b) /. float (n-b)))
1046 let ins = float a
*. 0.5
1047 and outs
= float (n-b) *. 0.5 in
1049 ins +. outs
+. float ones
1051 let rec set nab
y sy
=
1052 let (_N
, _A
, _B
), y =
1055 let scl = if y > sy
then 2 else -2 in
1056 let _N, _
, _
= nab
in
1057 (_N,0,_N), y+conf
.scrollstep
*scl
1059 let sum = summa
_N _A _B
in
1060 let dy = float (y - sy
) in
1064 then state
.ghyll
<- noghyll
1067 let s = scroll n _N _A _B
in
1068 let y1 = y1 +. ((s *. dy) /. sum) in
1069 gotoy_and_clear_text (truncate
y1);
1070 state
.ghyll
<- gf (n+1) y1;
1074 | Some
y'
when single
-> set nab
y' state
.y
1075 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1077 gf 0 (float state
.y)
1080 match conf
.ghyllscroll
with
1081 | Some nab
when not conf
.presentation
->
1082 if state
.ghyll
== noghyll
1083 then set nab
y state
.y
1084 else state
.ghyll
(Some
y)
1086 gotoy_and_clear_text y
1089 let gotoghyll = gotoghyll1 false;;
1091 let gotopage n top
=
1092 let y, h = getpageyh
n in
1093 let y = y + (truncate
(top
*. float h)) in
1097 let gotopage1 n top
=
1098 let y = getpagey
n in
1103 let invalidate s f =
1108 match state
.geomcmds
with
1109 | ps
, [] when emptystr ps
->
1111 state
.geomcmds
<- s, [];
1114 state
.geomcmds
<- ps
, [s, f];
1116 | ps
, (s'
, _
) :: rest
when s'
= s ->
1117 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1120 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1124 Hashtbl.iter
(fun _ opaque
->
1125 wcmd "freepage %s" (~
> opaque
);
1127 Hashtbl.clear state
.pagemap
;
1131 if not
(Queue.is_empty state
.tilelru
)
1133 Queue.iter
(fun (k
, p
, s) ->
1134 wcmd "freetile %s" (~
> p
);
1135 state
.memused
<- state
.memused
- s;
1136 Hashtbl.remove state
.tilemap k
;
1138 state
.uioh#infochanged Memused
;
1139 Queue.clear state
.tilelru
;
1145 let h = truncate
(float h*.conf
.zoom
) in
1146 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1150 let opendoc path password
=
1152 state
.password
<- password
;
1153 state
.gen
<- state
.gen
+ 1;
1154 state
.docinfo
<- [];
1155 state
.outlines
<- [||];
1158 setaalevel conf
.aalevel
;
1160 if emptystr state
.origin
1164 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1165 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1166 invalidate "reqlayout"
1168 wcmd "reqlayout %d %d %d %s\000"
1169 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1170 (stateh state
.winh
) state
.nameddest
1175 state
.anchor <- getanchor
();
1176 opendoc state
.path state
.password
;
1180 let c = c *. conf
.colorscale
in
1184 let scalecolor2 (r
, g, b) =
1185 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1188 let docolumns columns
=
1189 let wadj = wadjsb () in
1192 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1193 let wadj = wadjsb () in
1194 let rec loop pageno
pdimno pdim
y ph pdims
=
1195 if pageno
= state
.pagecount
1198 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1200 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1201 pdimno+1, pdim
, rest
1205 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1207 (if conf
.presentation
1208 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1209 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1212 a.(pageno
) <- (pdimno, x, y, pdim
);
1213 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1215 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1216 conf
.columns
<- Csingle
a;
1218 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1219 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1220 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1221 let rec fixrow m
= if m
= pageno
then () else
1222 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1225 let y = y + (rowh
- h) / 2 in
1226 a.(m
) <- (pdimno, x, y, pdim
);
1230 if pageno
= state
.pagecount
1231 then fixrow (((pageno
- 1) / columns
) * columns
)
1233 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1235 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1236 pdimno+1, pdim
, rest
1241 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1243 let x = (wadj + state
.winw
- w) / 2 in
1245 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1246 x, y + ips + rowh
, h
1249 if (pageno
- coverA
) mod columns
= 0
1251 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1253 if conf
.presentation
1255 let ips = calcips
h in
1256 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1258 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1262 else x, y, max rowh
h
1266 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1269 if pageno
= columns
&& conf
.presentation
1271 let ips = calcips rowh
in
1272 for i
= 0 to pred columns
1274 let (pdimno, x, y, pdim
) = a.(i
) in
1275 a.(i
) <- (pdimno, x, y+ips, pdim
)
1281 fixrow (pageno
- columns
);
1286 a.(pageno
) <- (pdimno, x, y, pdim
);
1287 let x = x + w + xoff
*2 + conf
.interpagespace
in
1288 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1290 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1291 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1294 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1295 let rec loop pageno
pdimno pdim
y pdims
=
1296 if pageno
= state
.pagecount
1299 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1301 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1302 pdimno+1, pdim
, rest
1307 let rec loop1 n x y =
1308 if n = c then y else (
1309 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1310 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1313 let y = loop1 0 0 y in
1314 loop (pageno
+1) pdimno pdim
y pdims
1316 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1317 conf
.columns
<- Csplit
(c, a);
1321 docolumns conf
.columns
;
1322 state
.maxy
<- calcheight
();
1323 if state
.reprf
== noreprf
1325 match state
.mode
with
1326 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1327 let y, h = getpageyh pageno
in
1328 let top = (state
.winh
- h) / 2 in
1329 gotoy (max
0 (y - top))
1332 | LinkNav _
-> gotoanchor state
.anchor
1336 state
.reprf
<- noreprf
;
1340 let reshape ?
(firsttime
=false) w h =
1341 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1342 if not firsttime
&& nogeomcmds state
.geomcmds
1343 then state
.anchor <- getanchor
();
1346 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1349 setfontsize fstate
.fontsize
;
1350 GlMat.mode `modelview
;
1351 GlMat.load_identity
();
1353 GlMat.mode `projection
;
1354 GlMat.load_identity
();
1355 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1356 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1357 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1362 else float state
.x /. float state
.w
1364 invalidate "geometry"
1368 then state
.x <- truncate
(relx *. float w);
1370 match conf
.columns
with
1372 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1373 | Csplit
(c, _
) -> w * c
1375 wcmd "geometry %d %d %d"
1376 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1381 let len = String.length state
.text in
1382 let x0 = xadjsb () in
1385 match state
.mode
with
1386 | Textentry _
| View
| LinkNav _
->
1387 let h, _
, _
= state
.uioh#scrollpw
in
1392 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1393 (x+.w) (float (state
.winh
- hscrollh))
1396 let w = float (wadjsb () + state
.winw
- 1) in
1397 if state
.progress
>= 0.0 && state
.progress
< 1.0
1399 GlDraw.color (0.3, 0.3, 0.3);
1400 let w1 = w *. state
.progress
in
1402 GlDraw.color (0.0, 0.0, 0.0);
1403 rect (float x0+.w1) (float x0+.w-.w1)
1406 GlDraw.color (0.0, 0.0, 0.0);
1410 GlDraw.color (1.0, 1.0, 1.0);
1411 drawstring fstate
.fontsize
1412 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1413 (state
.winh
- hscrollh - 5) s;
1416 match state
.mode
with
1417 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1421 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1423 Printf.sprintf
"%s%s_" prefix
text
1429 | LinkNav _
-> state
.text
1434 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1436 let s1 = "(press 'e' to review error messasges)" in
1437 if nonemptystr
s then s ^
" " ^
s1 else s1
1447 let len = Queue.length state
.tilelru
in
1449 match state
.throttle
with
1452 then preloadlayout state
.y
1454 | Some
(layout, _
, _
) ->
1458 if state
.memused
<= conf
.memlimit
1463 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1464 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1465 let (_
, pw, ph
, _
) = getpagedim
n in
1468 && colorspace
= conf
.colorspace
1469 && angle
= conf
.angle
1473 let x = col*conf
.tilew
1474 and y = row*conf
.tileh
in
1475 tilevisible (Lazy.force_val
layout) n x y
1477 then Queue.push lruitem state
.tilelru
1480 wcmd "freetile %s" (~
> p
);
1481 state
.memused
<- state
.memused
- s;
1482 state
.uioh#infochanged Memused
;
1483 Hashtbl.remove state
.tilemap k
;
1491 let onpagerect pageno
f =
1493 match conf
.columns
with
1494 | Cmulti
(_
, b) -> b
1496 | Csplit
(_
, b) -> b
1498 if pageno
>= 0 && pageno
< Array.length
b
1500 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1504 let gotopagexy1 pageno
x y =
1505 let _,w1,h1
,leftx
= getpagedim pageno
in
1506 let top = y /. (float h1
) in
1507 let left = x /. (float w1) in
1508 let py, w, h = getpageywh pageno
in
1509 let wh = state
.winh
- hscrollh () in
1510 let x = left *. (float w) in
1511 let x = leftx
+ state
.x + truncate
x in
1512 let wadj = wadjsb () in
1514 if x < 0 || x >= wadj + state
.winw
1518 let pdy = truncate
(top *. float h) in
1519 let y'
= py + pdy in
1520 let dy = y'
- state
.y in
1522 if x != state
.x || not
(dy > 0 && dy < wh)
1524 if conf
.presentation
1526 if abs
(py - y'
) > wh
1533 if state
.x != sx || state
.y != sy
1538 let ww = wadj + state
.winw
in
1540 and qy
= pdy / wh in
1542 and y = py + qy
* wh in
1543 let x = if -x + ww > w1 then -(w1-ww) else x
1544 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1546 if conf
.presentation
1548 if abs
(py - y'
) > wh
1558 gotoy_and_clear_text y;
1560 else gotoy_and_clear_text state
.y;
1563 let gotopagexy pageno
x y =
1564 match state
.mode
with
1565 | Birdseye
_ -> gotopage pageno
0.0
1568 | LinkNav
_ -> gotopagexy1 pageno
x y
1571 let getpassword () =
1572 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1577 impmsg "error getting password: %s" s;
1578 dolog
"%s" s) passcmd;
1581 let pgoto pageno opaque
x y =
1582 let x, y = project opaque
x y in
1583 gotopagexy pageno
x y;
1587 (* dolog "%S" cmds; *)
1588 let cl = splitatspace cmds
in
1590 try Scanf.sscanf
s fmt
f
1592 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1595 let addoutline outline
=
1596 match state
.currently
with
1597 | Outlining outlines
->
1598 state
.currently
<- Outlining
(outline
:: outlines
)
1599 | Idle
-> state
.currently
<- Outlining
[outline
]
1602 dolog
"invalid outlining state";
1603 logcurrently state
.currently
1607 state
.uioh#infochanged Pdim
;
1610 | "clearrects" :: [] ->
1611 state
.rects
<- state
.rects1
;
1612 G.postRedisplay "clearrects";
1614 | "continue" :: args
:: [] ->
1615 let n = scan args
"%u" (fun n -> n) in
1616 state
.pagecount
<- n;
1617 begin match state
.currently
with
1619 state
.currently
<- Idle
;
1620 state
.outlines
<- Array.of_list
(List.rev
l)
1626 let cur, cmds
= state
.geomcmds
in
1628 then failwith
"umpossible";
1630 begin match List.rev cmds
with
1632 state
.geomcmds
<- E.s, [];
1633 state
.throttle
<- None
;
1637 state
.geomcmds
<- s, List.rev rest
;
1639 if conf
.maxwait
= None
&& not
!wtmode
1640 then G.postRedisplay "continue";
1642 | "msg" :: args
:: [] ->
1645 | "vmsg" :: args
:: [] ->
1647 then showtext ' ' args
1649 | "emsg" :: args
:: [] ->
1650 Buffer.add_string state
.errmsgs args
;
1651 state
.newerrmsgs
<- true;
1652 G.postRedisplay "error message"
1654 | "progress" :: args
:: [] ->
1655 let progress, text =
1658 f, String.sub args pos
(String.length args
- pos
))
1661 state
.progress <- progress;
1662 G.postRedisplay "progress"
1664 | "firstmatch" :: args
:: [] ->
1665 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1666 scan args
"%u %d %f %f %f %f %f %f %f %f"
1667 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1668 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1670 let xoff = float (xadjsb ()) in
1674 and x3
= x3
+. xoff in
1675 let y = (getpagey
pageno) + truncate
y0 in
1678 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1679 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1681 | "match" :: args
:: [] ->
1682 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1683 scan args
"%u %d %f %f %f %f %f %f %f %f"
1684 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1685 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1687 let xoff = float (xadjsb ()) in
1691 and x3
= x3
+. xoff in
1692 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1694 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1696 | "page" :: args
:: [] ->
1697 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1698 let pageopaque = ~
< pageopaques in
1699 begin match state
.currently
with
1700 | Loading
(l, gen
) ->
1701 vlog "page %d took %f sec" l.pageno t
;
1702 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1703 begin match state
.throttle
with
1705 let preloadedpages =
1707 then preloadlayout state
.y
1712 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1713 IntSet.empty
preloadedpages
1716 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1717 if not
(IntSet.mem
pageno set)
1719 wcmd "freepage %s" (~
> opaque
);
1725 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1728 state
.currently
<- Idle
;
1731 tilepage l.pageno pageopaque state
.layout;
1733 load preloadedpages;
1734 let visible = pagevisible state
.layout l.pageno in
1737 match state
.mode
with
1738 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1739 if pageno = l.pageno
1744 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1746 if dir
> 0 then LDfirst
else LDlast
1749 findlink
pageopaque ld
1754 showlinktype (getlink
pageopaque n);
1755 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1757 | LinkNav
(Ltgendir
_)
1758 | LinkNav
(Ltexact
_)
1764 if visible && layoutready state
.layout
1766 G.postRedisplay "page";
1770 | Some
(layout, _, _) ->
1771 state
.currently
<- Idle
;
1772 tilepage l.pageno pageopaque layout;
1779 dolog
"Inconsistent loading state";
1780 logcurrently state
.currently
;
1784 | "tile" :: args
:: [] ->
1785 let (x, y, opaques
, size
, t
) =
1786 scan args
"%u %u %s %u %f"
1787 (fun x y p size t
-> (x, y, p
, size
, t
))
1789 let opaque = ~
< opaques
in
1790 begin match state
.currently
with
1791 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1792 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1795 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1797 wcmd "freetile %s" (~
> opaque);
1798 state
.currently
<- Idle
;
1802 puttileopaque l col row gen cs angle
opaque size t
;
1803 state
.memused
<- state
.memused
+ size
;
1804 state
.uioh#infochanged Memused
;
1806 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1807 opaque, size
) state
.tilelru
;
1810 match state
.throttle
with
1811 | None
-> state
.layout
1812 | Some
(layout, _, _) -> layout
1815 state
.currently
<- Idle
;
1817 && conf
.colorspace
= cs
1818 && conf
.angle
= angle
1819 && tilevisible layout l.pageno x y
1820 then conttiling l.pageno pageopaque;
1822 begin match state
.throttle
with
1824 preload state
.layout;
1826 && conf
.colorspace
= cs
1827 && conf
.angle
= angle
1828 && tilevisible state
.layout l.pageno x y
1829 && (not
!wtmode || layoutready state
.layout)
1830 then G.postRedisplay "tile nothrottle";
1832 | Some
(layout, y, _) ->
1833 let ready = layoutready layout in
1837 state
.layout <- layout;
1838 state
.throttle
<- None
;
1839 G.postRedisplay "throttle";
1848 dolog
"Inconsistent tiling state";
1849 logcurrently state
.currently
;
1853 | "pdim" :: args
:: [] ->
1854 let (n, w, h, _) as pdim
=
1855 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1858 match conf
.fitmodel
with
1860 | FitPage
| FitProportional
->
1861 match conf
.columns
with
1862 | Csplit
_ -> (n, w, h, 0)
1863 | Csingle
_ | Cmulti
_ -> pdim
1865 state
.uioh#infochanged Pdim
;
1866 state
.pdims
<- pdim :: state
.pdims
1868 | "o" :: args
:: [] ->
1869 let (l, n, t
, h, pos
) =
1870 scan args
"%u %u %d %u %n"
1871 (fun l n t
h pos
-> l, n, t
, h, pos
)
1873 let s = String.sub args pos
(String.length args
- pos
) in
1874 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1876 | "ou" :: args
:: [] ->
1877 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1878 let s = String.sub args pos
len in
1879 let pos2 = pos
+ len + 1 in
1880 let uri = String.sub args
pos2 (String.length args
- pos2) in
1881 addoutline (s, l, Ouri
uri)
1883 | "on" :: args
:: [] ->
1884 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1885 let s = String.sub args pos
(String.length args
- pos
) in
1886 addoutline (s, l, Onone
)
1888 | "a" :: args
:: [] ->
1890 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1892 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1894 | "info" :: args
:: [] ->
1895 let pos = nindex args '
\t'
in
1896 if pos >= 0 && String.sub args
0 pos = "Title"
1898 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1902 state
.docinfo
<- (1, args
) :: state
.docinfo
1904 | "infoend" :: [] ->
1905 state
.uioh#infochanged Docinfo
;
1906 state
.docinfo
<- List.rev state
.docinfo
1910 then Wsi.settitle
"Wrong password";
1911 let password = getpassword () in
1912 if emptystr
password
1913 then error
"document is password protected"
1914 else opendoc state
.path
password
1916 | "pgoto" :: args
:: [] ->
1917 let (pageno, x, y) = scan args
"%u %f %f" (fun n x y -> (n, x, y)) in
1918 begin match getopaque pageno with
1919 | Some
opaque -> pgoto pageno opaque x y
1920 | None
-> impmsg "failure to get page information for %d" pageno
1923 error
"unknown cmd `%S'" cmds
1928 let action = function
1929 | HCprev
-> cbget cb ~
-1
1930 | HCnext
-> cbget cb
1
1931 | HCfirst
-> cbget cb ~
-(cb
.rc)
1932 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1933 and cancel
() = cb
.rc <- rc
1937 let search pattern forward
=
1938 match conf
.columns
with
1939 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1942 if nonemptystr pattern
1945 match state
.layout with
1948 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1950 wcmd "search %d %d %d %d,%s\000"
1951 (btod conf
.icase
) pn py (btod forward
) pattern
;
1954 let intentry text key =
1956 if key >= 32 && key < 127
1962 let text = addchar
text c in
1966 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1974 let l = String.length
s in
1975 let rec loop pos n = if pos = l then n else
1976 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1977 loop (pos+1) (n*26 + m)
1980 let rec loop n = function
1983 match getopaque l.pageno with
1984 | None
-> loop n rest
1986 let m = getlinkcount
opaque in
1989 let under = getlink
opaque n in
1992 else loop (n-m) rest
1994 loop n state
.layout;
1998 let linknentry text key =
2000 if key >= 32 && key < 127
2006 let text = addchar
text c in
2007 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2011 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2015 let textentry text key =
2016 if key land 0xff00 = 0xff00
2018 else TEcont
(text ^ toutf8
key)
2021 let reqlayout angle fitmodel
=
2022 match state
.throttle
with
2024 if nogeomcmds state
.geomcmds
2025 then state
.anchor <- getanchor
();
2026 conf
.angle
<- angle
mod 360;
2029 match state
.mode
with
2030 | LinkNav
_ -> state
.mode
<- View
2035 conf
.fitmodel
<- fitmodel
;
2036 invalidate "reqlayout"
2038 wcmd "reqlayout %d %d %d"
2039 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2044 let settrim trimmargins trimfuzz
=
2045 if nogeomcmds state
.geomcmds
2046 then state
.anchor <- getanchor
();
2047 conf
.trimmargins
<- trimmargins
;
2048 conf
.trimfuzz
<- trimfuzz
;
2049 let x0, y0, x1, y1 = trimfuzz
in
2050 invalidate "settrim"
2052 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2057 match state
.throttle
with
2059 let zoom = max
0.0001 zoom in
2060 if zoom <> conf
.zoom
2062 state
.prevzoom
<- (conf
.zoom, state
.x);
2064 reshape state
.winw state
.winh
;
2065 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2068 | Some
(layout, y, started
) ->
2070 match conf
.maxwait
with
2074 let dt = now
() -. started
in
2082 let setcolumns mode columns coverA coverB
=
2083 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2087 then impmsg "split mode doesn't work in bird's eye"
2089 conf
.columns
<- Csplit
(-columns
, E.a);
2097 conf
.columns
<- Csingle
E.a;
2102 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2106 reshape state
.winw state
.winh
;
2109 let resetmstate () =
2110 state
.mstate
<- Mnone
;
2111 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2114 let enterbirdseye () =
2115 let zoom = float conf
.thumbw
/. float state
.winw
in
2116 let birdseyepageno =
2117 let cy = state
.winh
/ 2 in
2121 let rec fold best
= function
2124 let d = cy - (l.pagedispy + l.pagevh/2)
2125 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2126 if abs
d < abs dbest
2133 state
.mode
<- Birdseye
(
2134 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2138 conf
.presentation
<- false;
2139 conf
.interpagespace
<- 10;
2140 conf
.hlinks
<- false;
2141 conf
.fitmodel
<- FitPage
;
2143 conf
.maxwait
<- None
;
2145 match conf
.beyecolumns
with
2148 Cmulti
((c, 0, 0), E.a)
2149 | None
-> Csingle
E.a
2153 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2158 reshape state
.winw state
.winh
;
2161 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2163 conf
.zoom <- c.zoom;
2164 conf
.presentation
<- c.presentation
;
2165 conf
.interpagespace
<- c.interpagespace
;
2166 conf
.maxwait
<- c.maxwait
;
2167 conf
.hlinks
<- c.hlinks
;
2168 conf
.fitmodel
<- c.fitmodel
;
2169 conf
.beyecolumns
<- (
2170 match conf
.columns
with
2171 | Cmulti
((c, _, _), _) -> Some
c
2173 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2176 match c.columns
with
2177 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2178 | Csingle
_ -> Csingle
E.a
2179 | Csplit
(c, _) -> Csplit
(c, E.a)
2183 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2186 reshape state
.winw state
.winh
;
2187 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2191 let togglebirdseye () =
2192 match state
.mode
with
2193 | Birdseye vals
-> leavebirdseye vals
true
2194 | View
-> enterbirdseye ()
2199 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2200 let pageno = max
0 (pageno - incr
) in
2201 let rec loop = function
2202 | [] -> gotopage1 pageno 0
2203 | l :: _ when l.pageno = pageno ->
2204 if l.pagedispy >= 0 && l.pagey = 0
2205 then G.postRedisplay "upbirdseye"
2206 else gotopage1 pageno 0
2207 | _ :: rest
-> loop rest
2211 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2214 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2215 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2216 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2217 let rec loop = function
2219 let y, h = getpageyh
pageno in
2220 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2222 | l :: _ when l.pageno = pageno ->
2223 if l.pagevh != l.pageh
2224 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2225 else G.postRedisplay "downbirdseye"
2226 | _ :: rest
-> loop rest
2232 let optentry mode
_ key =
2233 let btos b = if b then "on" else "off" in
2234 if key >= 32 && key < 127
2236 let c = Char.chr
key in
2240 try conf
.scrollstep
<- int_of_string
s with exc
->
2241 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2243 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2248 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2249 if state
.autoscroll
<> None
2250 then state
.autoscroll
<- Some conf
.autoscrollstep
2252 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2254 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2259 let n, a, b = multicolumns_of_string
s in
2260 setcolumns mode
n a b;
2262 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2264 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2269 let zoom = float (int_of_string
s) /. 100.0 in
2272 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2274 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2279 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2281 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2282 begin match mode
with
2284 leavebirdseye beye
false;
2291 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2293 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2298 Some
(int_of_string
s)
2301 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2304 | Some angle
-> reqlayout angle conf
.fitmodel
2307 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2310 conf
.icase
<- not conf
.icase
;
2311 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2314 conf
.preload <- not conf
.preload;
2316 TEdone
("preload " ^
(btos conf
.preload))
2319 conf
.verbose
<- not conf
.verbose
;
2320 TEdone
("verbose " ^
(btos conf
.verbose
))
2323 conf
.debug
<- not conf
.debug
;
2324 TEdone
("debug " ^
(btos conf
.debug
))
2327 conf
.maxhfit
<- not conf
.maxhfit
;
2328 state
.maxy
<- calcheight
();
2329 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2332 conf
.crophack
<- not conf
.crophack
;
2333 TEdone
("crophack " ^
btos conf
.crophack
)
2337 match conf
.maxwait
with
2339 conf
.maxwait
<- Some infinity
;
2340 "always wait for page to complete"
2342 conf
.maxwait
<- None
;
2343 "show placeholder if page is not ready"
2348 conf
.underinfo
<- not conf
.underinfo
;
2349 TEdone
("underinfo " ^
btos conf
.underinfo
)
2352 conf
.savebmarks
<- not conf
.savebmarks
;
2353 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2359 match state
.layout with
2364 conf
.interpagespace
<- int_of_string
s;
2365 docolumns conf
.columns
;
2366 state
.maxy
<- calcheight
();
2367 let y = getpagey
pageno in
2370 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2372 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2376 match conf
.fitmodel
with
2377 | FitProportional
-> FitWidth
2378 | FitWidth
| FitPage
-> FitProportional
2380 reqlayout conf
.angle
fm;
2381 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2384 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2385 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2388 conf
.invert
<- not conf
.invert
;
2389 TEdone
("invert colors " ^
btos conf
.invert
)
2393 cbput state
.hists
.sel
s;
2396 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2397 textentry, ondone, true)
2401 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2402 else conf
.pax
<- None
;
2403 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2406 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2412 class type lvsource
= object
2413 method getitemcount
: int
2414 method getitem
: int -> (string * int)
2415 method hasaction
: int -> bool
2423 method getactive
: int
2424 method getfirst
: int
2426 method getminfo
: (int * int) array
2429 class virtual lvsourcebase
= object
2430 val mutable m_active
= 0
2431 val mutable m_first
= 0
2432 val mutable m_pan
= 0
2433 method getactive
= m_active
2434 method getfirst
= m_first
2435 method getpan
= m_pan
2436 method getminfo
: (int * int) array
= E.a
2439 let textentrykeyboard
2440 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2443 if key >= 0xffb0 && key <= 0xffb9
2444 then key - 0xffb0 + 48 else key
2447 state
.mode
<- Textentry
(te
, onleave
);
2449 G.postRedisplay "textentrykeyboard enttext";
2451 let histaction cmd
=
2454 | Some
(action, _) ->
2455 state
.mode
<- Textentry
(
2456 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2458 G.postRedisplay "textentry histaction"
2462 if emptystr
text && cancelonempty
2465 G.postRedisplay "textentrykeyboard after cancel";
2468 let s = withoutlastutf8
text in
2469 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2471 | @enter
| @kpenter
->
2474 G.postRedisplay "textentrykeyboard after confirm"
2476 | @up
| @kpup
-> histaction HCprev
2477 | @down
| @kpdown
-> histaction HCnext
2478 | @home
| @kphome
-> histaction HCfirst
2479 | @jend
| @kpend
-> histaction HClast
2484 begin match opthist
with
2486 | Some
(_, onhistcancel
) -> onhistcancel
()
2490 G.postRedisplay "textentrykeyboard after cancel2"
2493 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2496 | @delete
| @kpdelete
-> ()
2499 && key land 0xff00 != 0xff00 (* keyboard *)
2500 && key land 0xfe00 != 0xfe00 (* xkb *)
2501 && key land 0xfd00 != 0xfd00 (* 3270 *)
2503 begin match onkey
text key with
2507 G.postRedisplay "textentrykeyboard after confirm2";
2510 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2514 G.postRedisplay "textentrykeyboard after cancel3"
2517 state
.mode
<- Textentry
(te
, onleave
);
2518 G.postRedisplay "textentrykeyboard switch";
2522 vlog "unhandled key %s" (Wsi.keyname
key)
2525 let firstof first active
=
2526 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2527 then max
0 (active
- (fstate
.maxrows
/2))
2531 let calcfirst first active
=
2534 let rows = active
- first
in
2535 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2539 let scrollph y maxy
=
2540 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2541 let sh = float state
.winh
/. sh in
2542 let sh = max
sh (float conf
.scrollh
) in
2544 let percent = float y /. float maxy
in
2545 let position = (float state
.winh
-. sh) *. percent in
2548 if position +. sh > float state
.winh
2549 then float state
.winh
-. sh
2555 let coe s = (s :> uioh
);;
2557 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2559 val m_pan
= source#getpan
2560 val m_first
= source#getfirst
2561 val m_active
= source#getactive
2563 val m_prev_uioh
= state
.uioh
2565 method private elemunder
y =
2569 let n = y / (fstate
.fontsize
+1) in
2570 if m_first
+ n < source#getitemcount
2572 if source#hasaction
(m_first
+ n)
2573 then Some
(m_first
+ n)
2580 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2581 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2582 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2583 GlDraw.color (1., 1., 1.);
2584 Gl.enable `texture_2d
;
2585 let fs = fstate
.fontsize
in
2587 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2588 let ww = fstate
.wwidth
in
2589 let tabw = 17.0*.ww in
2590 let itemcount = source#getitemcount
in
2591 let minfo = source#getminfo
in
2594 then float (xadjsb ()), float (state
.winw
- 1)
2595 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2597 let xadj = xadjsb () in
2599 if (row - m_first
) > fstate
.maxrows
2602 if row >= 0 && row < itemcount
2604 let (s, level
) = source#getitem
row in
2605 let y = (row - m_first
) * nfs in
2607 (if conf
.leftscroll
then float xadj else 5.0)
2608 +. (float (level
+ m_pan
)) *. ww in
2611 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2615 Gl.disable `texture_2d
;
2616 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2617 GlDraw.color (1., 1., 1.) ~
alpha;
2618 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2619 Gl.enable `texture_2d
;
2622 if zebra
&& row land 1 = 1
2626 GlDraw.color (c,c,c);
2627 let drawtabularstring s =
2629 let x'
= truncate
(x0 +. x) in
2630 let pos = nindex
s '
\000'
in
2632 then drawstring1 fs x'
(y+nfs) s
2634 let s1 = String.sub
s 0 pos
2635 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2640 let s'
= withoutlastutf8
s in
2641 let s = s' ^
"@Uellipsis" in
2642 let w = measurestr
fs s in
2643 if float x'
+. w +. ww < float (hw + x'
)
2648 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2652 ignore
(drawstring1 fs x'
(y+nfs) s1);
2653 drawstring1 fs (hw + x'
) (y+nfs) s2
2657 let x = if helpmode
&& row > 0 then x +. ww else x in
2658 let tabpos = nindex
s '
\t'
in
2661 let len = String.length
s - tabpos - 1 in
2662 let s1 = String.sub
s 0 tabpos
2663 and s2
= String.sub
s (tabpos + 1) len in
2664 let nx = drawstr x s1 in
2666 let x = x +. (max
tabw sw) in
2669 let len = String.length
s - 2 in
2670 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2672 let s = String.sub
s 2 len in
2673 let x = if not helpmode
then x +. ww else x in
2674 GlDraw.color (1.2, 1.2, 1.2);
2675 let vinc = drawstring1 (fs+fs/4)
2676 (truncate
(x -. ww)) (y+nfs) s in
2677 GlDraw.color (1., 1., 1.);
2678 vinc +. (float fs *. 0.8)
2684 ignore
(drawtabularstring s);
2690 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2691 let xadj = float (xadjsb () + 5) in
2693 if (row - m_first
) > fstate
.maxrows
2696 if row >= 0 && row < itemcount
2698 let (s, level
) = source#getitem
row in
2699 let pos0 = nindex
s '
\000'
in
2700 let y = (row - m_first
) * nfs in
2701 let x = float (level
+ m_pan
) *. ww in
2702 let (first
, last
) = minfo.(row) in
2704 if pos0 > 0 && first
> pos0
2705 then String.sub
s (pos0+1) (first
-pos0-1)
2706 else String.sub
s 0 first
2708 let suffix = String.sub
s first
(last
- first
) in
2709 let w1 = measurestr fstate
.fontsize
prefix in
2710 let w2 = measurestr fstate
.fontsize
suffix in
2711 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2712 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2714 and y0 = float (y+2) in
2716 and y1 = float (y+fs+3) in
2717 filledrect x0 y0 x1 y1;
2722 Gl.disable `texture_2d
;
2723 if Array.length
minfo > 0 then loop m_first
;
2726 method updownlevel incr
=
2727 let len = source#getitemcount
in
2729 if m_active
>= 0 && m_active
< len
2730 then snd
(source#getitem m_active
)
2734 if i
= len then i
-1 else if i
= -1 then 0 else
2735 let _, l = source#getitem i
in
2736 if l != curlevel then i
else flow (i
+incr
)
2738 let active = flow m_active
in
2739 let first = calcfirst m_first
active in
2740 G.postRedisplay "outline updownlevel";
2741 {< m_active
= active; m_first
= first >}
2743 method private key1
key mask
=
2744 let set1 active first qsearch
=
2745 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2747 let search active pattern incr
=
2748 let active = if active = -1 then m_first
else active in
2751 if n >= 0 && n < source#getitemcount
2753 let s, _ = source#getitem
n in
2754 match Str.search_forward re
s 0 with
2755 | (exception Not_found
) -> loop (n + incr
)
2762 Str.regexp_case_fold pattern
|> dosearch
2764 let itemcount = source#getitemcount
in
2765 let find start incr
=
2767 if i
= -1 || i
= itemcount
2770 if source#hasaction i
2772 else find (i
+ incr
)
2777 let set active first =
2778 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2780 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2783 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2785 let incr1 = if incr
> 0 then 1 else -1 in
2786 if isvisible m_first m_active
2789 let next = m_active
+ incr
in
2791 if next < 0 || next >= itemcount
2793 else find next incr1
2795 if abs
(m_active
- next) > fstate
.maxrows
2801 let first = m_first
+ incr
in
2802 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2804 let next = m_active
+ incr
in
2805 let next = bound
next 0 (itemcount - 1) in
2812 if isvisible first next
2819 let first = min
next m_first
in
2821 if abs
(next - first) > fstate
.maxrows
2827 let first = m_first
+ incr
in
2828 let first = bound
first 0 (itemcount - 1) in
2830 let next = m_active
+ incr
in
2831 let next = bound
next 0 (itemcount - 1) in
2832 let next = find next incr1 in
2834 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2836 let active = if m_active
= -1 then next else m_active
in
2841 if isvisible first active
2847 G.postRedisplay "listview navigate";
2851 | (@r
|@s) when Wsi.withctrl mask
->
2852 let incr = if key = @r
then -1 else 1 in
2854 match search (m_active
+ incr) m_qsearch
incr with
2856 state
.text <- m_qsearch ^
" [not found]";
2859 state
.text <- m_qsearch
;
2860 active, firstof m_first
active
2862 G.postRedisplay "listview ctrl-r/s";
2863 set1 active first m_qsearch
;
2865 | @insert
when Wsi.withctrl mask
->
2866 if m_active
>= 0 && m_active
< source#getitemcount
2868 let s, _ = source#getitem m_active
in
2874 if emptystr m_qsearch
2877 let qsearch = withoutlastutf8 m_qsearch
in
2881 G.postRedisplay "listview empty qsearch";
2882 set1 m_active m_first
E.s;
2886 match search m_active
qsearch ~
-1 with
2888 state
.text <- qsearch ^
" [not found]";
2891 state
.text <- qsearch;
2892 active, firstof m_first
active
2894 G.postRedisplay "listview backspace qsearch";
2895 set1 active first qsearch
2898 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2899 let pattern = m_qsearch ^ toutf8
key in
2901 match search m_active
pattern 1 with
2903 state
.text <- pattern ^
" [not found]";
2906 state
.text <- pattern;
2907 active, firstof m_first
active
2909 G.postRedisplay "listview qsearch add";
2910 set1 active first pattern;
2914 if emptystr m_qsearch
2916 G.postRedisplay "list view escape";
2917 let mx, my
= state
.mpos
in
2921 source#exit ~uioh
:(coe self
)
2922 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2924 | None
-> m_prev_uioh
2929 G.postRedisplay "list view kill qsearch";
2930 coe {< m_qsearch
= E.s >}
2933 | @enter
| @kpenter
->
2935 let self = {< m_qsearch
= E.s >} in
2937 G.postRedisplay "listview enter";
2938 if m_active
>= 0 && m_active
< source#getitemcount
2940 source#exit ~uioh
:(coe self) ~cancel
:false
2941 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2944 source#exit ~uioh
:(coe self) ~cancel
:true
2945 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2948 begin match opt with
2949 | None
-> m_prev_uioh
2953 | @delete
| @kpdelete
->
2956 | @up
| @kpup
-> navigate ~
-1
2957 | @down
| @kpdown
-> navigate 1
2958 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2959 | @next | @kpnext
-> navigate fstate
.maxrows
2961 | @right
| @kpright
->
2963 G.postRedisplay "listview right";
2964 coe {< m_pan
= m_pan
- 1 >}
2966 | @left | @kpleft
->
2968 G.postRedisplay "listview left";
2969 coe {< m_pan
= m_pan
+ 1 >}
2971 | @home
| @kphome
->
2972 let active = find 0 1 in
2973 G.postRedisplay "listview home";
2977 let first = max
0 (itemcount - fstate
.maxrows
) in
2978 let active = find (itemcount - 1) ~
-1 in
2979 G.postRedisplay "listview end";
2982 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2986 dolog
"listview unknown key %#x" key; coe self
2988 method key key mask
=
2989 match state
.mode
with
2990 | Textentry te
-> textentrykeyboard key mask te
; coe self
2993 | LinkNav
_ -> self#key1
key mask
2995 method button button down
x y _ =
2998 | 1 when vscrollhit x ->
2999 G.postRedisplay "listview scroll";
3002 let _, position, sh = self#
scrollph in
3003 if y > truncate
position && y < truncate
(position +. sh)
3005 state
.mstate
<- Mscrolly
;
3009 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3010 let first = truncate
(s *. float source#getitemcount
) in
3011 let first = min source#getitemcount
first in
3012 Some
(coe {< m_first
= first; m_active
= first >})
3014 state
.mstate
<- Mnone
;
3018 begin match self#elemunder
y with
3020 G.postRedisplay "listview click";
3021 source#exit ~uioh
:(coe {< m_active
= n >})
3022 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3026 | n when (n == 4 || n == 5) && not down
->
3027 let len = source#getitemcount
in
3029 if n = 5 && m_first
+ fstate
.maxrows
>= len
3033 let first = m_first
+ (if n == 4 then -1 else 1) in
3034 bound
first 0 (len - 1)
3036 G.postRedisplay "listview wheel";
3037 Some
(coe {< m_first
= first >})
3038 | n when (n = 6 || n = 7) && not down
->
3039 let inc = if n = 7 then -1 else 1 in
3040 G.postRedisplay "listview hwheel";
3041 Some
(coe {< m_pan
= m_pan
+ inc >})
3046 | None
-> m_prev_uioh
3049 method multiclick
_ x y = self#button
1 true x y
3052 match state
.mstate
with
3054 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3055 let first = truncate
(s *. float source#getitemcount
) in
3056 let first = min source#getitemcount
first in
3057 G.postRedisplay "listview motion";
3058 coe {< m_first
= first; m_active
= first >}
3066 method pmotion
x y =
3067 if x < state
.winw
- conf
.scrollbw
3070 match self#elemunder
y with
3071 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3072 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3076 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3081 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3085 method infochanged
_ = ()
3087 method scrollpw
= (0, 0.0, 0.0)
3089 let nfs = fstate
.fontsize
+ 1 in
3090 let y = m_first
* nfs in
3091 let itemcount = source#getitemcount
in
3092 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3093 let maxy = maxi * nfs in
3094 let p, h = scrollph y maxy in
3097 method modehash
= modehash
3098 method eformsgs
= false
3099 method alwaysscrolly
= true
3102 class outlinelistview ~zebra ~source
=
3103 let settext autonarrow
s =
3106 let ss = source#statestr
in
3110 else "{" ^
ss ^
"} [" ^
s ^
"]"
3111 else state
.text <- s
3117 ~source
:(source
:> lvsource
)
3119 ~modehash
:(findkeyhash conf
"outline")
3122 val m_autonarrow
= false
3124 method! key key mask
=
3126 if emptystr state
.text
3128 else fstate
.maxrows - 2
3130 let calcfirst first active =
3133 let rows = active - first in
3134 if rows > maxrows then active - maxrows else first
3138 let active = m_active
+ incr in
3139 let active = bound
active 0 (source#getitemcount
- 1) in
3140 let first = calcfirst m_first
active in
3141 G.postRedisplay "outline navigate";
3142 coe {< m_active
= active; m_first
= first >}
3144 let navscroll first =
3146 let dist = m_active
- first in
3152 else first + maxrows
3155 G.postRedisplay "outline navscroll";
3156 coe {< m_first
= first; m_active
= active >}
3158 let ctrl = Wsi.withctrl mask
in
3163 then (source#denarrow
; E.s)
3165 let pattern = source#renarrow
in
3166 if nonemptystr m_qsearch
3167 then (source#narrow m_qsearch
; m_qsearch
)
3171 settext (not m_autonarrow
) text;
3172 G.postRedisplay "toggle auto narrowing";
3173 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3175 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3177 G.postRedisplay "toggle auto narrowing";
3178 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3181 source#narrow m_qsearch
;
3183 then source#add_narrow_pattern m_qsearch
;
3184 G.postRedisplay "outline ctrl-n";
3185 coe {< m_first
= 0; m_active
= 0 >}
3188 let active = source#calcactive
(getanchor
()) in
3189 let first = firstof m_first
active in
3190 G.postRedisplay "outline ctrl-s";
3191 coe {< m_first
= first; m_active
= active >}
3194 G.postRedisplay "outline ctrl-u";
3195 if m_autonarrow
&& nonemptystr m_qsearch
3197 ignore
(source#renarrow
);
3198 settext m_autonarrow
E.s;
3199 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3202 source#del_narrow_pattern
;
3203 let pattern = source#renarrow
in
3205 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3207 settext m_autonarrow
text;
3208 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3212 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3213 G.postRedisplay "outline ctrl-l";
3214 coe {< m_first
= first >}
3216 | @tab
when m_autonarrow
->
3217 if nonemptystr m_qsearch
3219 G.postRedisplay "outline list view tab";
3220 source#add_narrow_pattern m_qsearch
;
3222 coe {< m_qsearch
= E.s >}
3226 | @escape
when m_autonarrow
->
3227 if nonemptystr m_qsearch
3228 then source#add_narrow_pattern m_qsearch
;
3231 | @enter
| @kpenter
when m_autonarrow
->
3232 if nonemptystr m_qsearch
3233 then source#add_narrow_pattern m_qsearch
;
3236 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3237 let pattern = m_qsearch ^ toutf8
key in
3238 G.postRedisplay "outlinelistview autonarrow add";
3239 source#narrow
pattern;
3240 settext true pattern;
3241 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3243 | key when m_autonarrow
&& key = @backspace
->
3244 if emptystr m_qsearch
3247 let pattern = withoutlastutf8 m_qsearch
in
3248 G.postRedisplay "outlinelistview autonarrow backspace";
3249 ignore
(source#renarrow
);
3250 source#narrow
pattern;
3251 settext true pattern;
3252 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3254 | @up
| @kpup
when ctrl ->
3255 navscroll (max
0 (m_first
- 1))
3257 | @down
| @kpdown
when ctrl ->
3258 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3260 | @up
| @kpup
-> navigate ~
-1
3261 | @down
| @kpdown
-> navigate 1
3262 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3263 | @next | @kpnext
-> navigate fstate
.maxrows
3265 | @right
| @kpright
->
3269 G.postRedisplay "outline ctrl right";
3270 {< m_pan
= m_pan
+ 1 >}
3272 else self#updownlevel
1
3276 | @left | @kpleft
->
3280 G.postRedisplay "outline ctrl left";
3281 {< m_pan
= m_pan
- 1 >}
3283 else self#updownlevel ~
-1
3287 | @home
| @kphome
->
3288 G.postRedisplay "outline home";
3289 coe {< m_first
= 0; m_active
= 0 >}
3292 let active = source#getitemcount
- 1 in
3293 let first = max
0 (active - fstate
.maxrows) in
3294 G.postRedisplay "outline end";
3295 coe {< m_active
= active; m_first
= first >}
3297 | _ -> super#
key key mask
3300 let genhistoutlines () =
3302 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3303 compare c2
.lastvisit c1
.lastvisit
)
3305 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3306 let path = if nonemptystr origin
then origin
else path in
3307 let base = mbtoutf8
@@ Filename.basename
path in
3308 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3313 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3314 Config.save
leavebirdseye;
3315 state
.anchor <- anchor;
3316 state
.bookmarks
<- bookmarks
;
3317 state
.origin
<- origin
;
3320 let x0, y0, x1, y1 = conf
.trimfuzz
in
3321 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3322 reshape ~firsttime
:true state
.winw state
.winh
;
3323 opendoc path origin
;
3327 let makecheckers () =
3328 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3330 converted by Issac Trotts. July 25, 2002 *)
3331 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3332 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3333 let id = GlTex.gen_texture
() in
3334 GlTex.bind_texture ~target
:`texture_2d
id;
3335 GlPix.store
(`unpack_alignment
1);
3336 GlTex.image2d
image;
3337 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3338 [ `mag_filter `nearest
; `min_filter `nearest
];
3342 let setcheckers enabled
=
3343 match state
.checkerstexid
with
3345 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3347 | Some checkerstexid
->
3350 GlTex.delete_texture checkerstexid
;
3351 state
.checkerstexid
<- None
;
3355 let describe_location () =
3356 let fn = page_of_y state
.y in
3357 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3358 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3362 else (100. *. (float state
.y /. float maxy))
3366 Printf.sprintf
"page %d of %d [%.2f%%]"
3367 (fn+1) state
.pagecount
percent
3370 "pages %d-%d of %d [%.2f%%]"
3371 (fn+1) (ln+1) state
.pagecount
percent
3374 let setpresentationmode v
=
3375 let n = page_of_y state
.y in
3376 state
.anchor <- (n, 0.0, 1.0);
3377 conf
.presentation
<- v
;
3378 if conf
.fitmodel
= FitPage
3379 then reqlayout conf
.angle conf
.fitmodel
;
3384 let btos b = if b then "@Uradical" else E.s in
3385 let showextended = ref false in
3386 let leave mode
_ = state
.mode
<- mode
in
3389 val mutable m_l
= []
3390 val mutable m_a
= E.a
3391 val mutable m_prev_uioh
= nouioh
3392 val mutable m_prev_mode
= View
3394 inherit lvsourcebase
3396 method reset prev_mode prev_uioh
=
3397 m_a
<- Array.of_list
(List.rev m_l
);
3399 m_prev_mode
<- prev_mode
;
3400 m_prev_uioh
<- prev_uioh
;
3402 method int name get
set =
3404 (name
, `
int get
, 1, Action
(
3407 try set (int_of_string
s)
3409 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3413 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3414 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3418 method int_with_suffix name get
set =
3420 (name
, `intws get
, 1, Action
(
3423 try set (int_of_string_with_suffix
s)
3425 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3430 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3432 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3436 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3438 (name
, `
bool (btos, get
), offset
, Action
(
3445 method color name get
set =
3447 (name
, `
color get
, 1, Action
(
3449 let invalid = (nan
, nan
, nan
) in
3452 try color_of_string
s
3454 state
.text <- Printf.sprintf
"bad color `%s': %s"
3461 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3462 state
.text <- color_to_string
(get
());
3463 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3467 method string name get
set =
3469 (name
, `
string get
, 1, Action
(
3471 let ondone s = set s in
3472 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3473 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3477 method colorspace name get
set =
3479 (name
, `
string get
, 1, Action
(
3483 inherit lvsourcebase
3486 m_active
<- CSTE.to_int conf
.colorspace
;
3489 method getitemcount
=
3490 Array.length
CSTE.names
3493 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3494 ignore
(uioh
, first, pan
);
3495 if not cancel
then set active;
3497 method hasaction
_ = true
3501 let modehash = findkeyhash conf
"info" in
3502 coe (new listview ~zebra
:false ~helpmode
:false
3503 ~
source ~trusted
:true ~
modehash)
3506 method paxmark name get
set =
3508 (name
, `
string get
, 1, Action
(
3512 inherit lvsourcebase
3515 m_active
<- MTE.to_int conf
.paxmark
;
3518 method getitemcount
= Array.length
MTE.names
3519 method getitem
n = (MTE.names
.(n), 0)
3520 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3521 ignore
(uioh
, first, pan
);
3522 if not cancel
then set active;
3524 method hasaction
_ = true
3528 let modehash = findkeyhash conf
"info" in
3529 coe (new listview ~zebra
:false ~helpmode
:false
3530 ~
source ~trusted
:true ~
modehash)
3533 method fitmodel name get
set =
3535 (name
, `
string get
, 1, Action
(
3539 inherit lvsourcebase
3542 m_active
<- FMTE.to_int conf
.fitmodel
;
3545 method getitemcount
= Array.length
FMTE.names
3546 method getitem
n = (FMTE.names
.(n), 0)
3547 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3548 ignore
(uioh
, first, pan
);
3549 if not cancel
then set active;
3551 method hasaction
_ = true
3555 let modehash = findkeyhash conf
"info" in
3556 coe (new listview ~zebra
:false ~helpmode
:false
3557 ~
source ~trusted
:true ~
modehash)
3560 method caption
s offset
=
3561 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3563 method caption2
s f offset
=
3564 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3566 method getitemcount
= Array.length m_a
3569 let tostr = function
3570 | `
int f -> string_of_int
(f ())
3571 | `intws
f -> string_with_suffix_of_int
(f ())
3573 | `
color f -> color_to_string
(f ())
3574 | `
bool (btos, f) -> btos (f ())
3577 let name, t
, offset
, _ = m_a
.(n) in
3578 ((let s = tostr t
in
3580 then Printf.sprintf
"%s\t%s" name s
3584 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3589 match m_a
.(active) with
3590 | _, _, _, Action
f -> f uioh
3591 | _, _, _, Noaction
-> uioh
3602 method hasaction
n =
3604 | _, _, _, Action
_ -> true
3605 | _, _, _, Noaction
-> false
3607 initializer m_active
<- 1
3610 let rec fillsrc prevmode prevuioh
=
3611 let sep () = src#caption
E.s 0 in
3612 let colorp name get
set =
3614 (fun () -> color_to_string
(get
()))
3617 let c = color_of_string
v in
3620 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3623 let oldmode = state
.mode
in
3624 let birdseye = isbirdseye state
.mode
in
3626 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3628 src#
bool "presentation mode"
3629 (fun () -> conf
.presentation
)
3630 (fun v -> setpresentationmode v);
3632 src#
bool "ignore case in searches"
3633 (fun () -> conf
.icase
)
3634 (fun v -> conf
.icase
<- v);
3637 (fun () -> conf
.preload)
3638 (fun v -> conf
.preload <- v);
3640 src#
bool "highlight links"
3641 (fun () -> conf
.hlinks
)
3642 (fun v -> conf
.hlinks
<- v);
3644 src#
bool "under info"
3645 (fun () -> conf
.underinfo
)
3646 (fun v -> conf
.underinfo
<- v);
3648 src#
bool "persistent bookmarks"
3649 (fun () -> conf
.savebmarks
)
3650 (fun v -> conf
.savebmarks
<- v);
3652 src#fitmodel
"fit model"
3653 (fun () -> FMTE.to_string conf
.fitmodel
)
3654 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3656 src#
bool "trim margins"
3657 (fun () -> conf
.trimmargins
)
3658 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3660 src#
bool "persistent location"
3661 (fun () -> conf
.jumpback
)
3662 (fun v -> conf
.jumpback
<- v);
3665 src#
int "inter-page space"
3666 (fun () -> conf
.interpagespace
)
3668 conf
.interpagespace
<- n;
3669 docolumns conf
.columns
;
3671 match state
.layout with
3676 state
.maxy <- calcheight
();
3677 let y = getpagey
pageno in
3682 (fun () -> conf
.pagebias
)
3683 (fun v -> conf
.pagebias
<- v);
3685 src#
int "scroll step"
3686 (fun () -> conf
.scrollstep
)
3687 (fun n -> conf
.scrollstep
<- n);
3689 src#
int "horizontal scroll step"
3690 (fun () -> conf
.hscrollstep
)
3691 (fun v -> conf
.hscrollstep
<- v);
3693 src#
int "auto scroll step"
3695 match state
.autoscroll
with
3697 | _ -> conf
.autoscrollstep
)
3699 let n = boundastep state
.winh
n in
3700 if state
.autoscroll
<> None
3701 then state
.autoscroll
<- Some
n;
3702 conf
.autoscrollstep
<- n);
3705 (fun () -> truncate
(conf
.zoom *. 100.))
3706 (fun v -> setzoom ((float v) /. 100.));
3709 (fun () -> conf
.angle
)
3710 (fun v -> reqlayout v conf
.fitmodel
);
3712 src#
int "scroll bar width"
3713 (fun () -> conf
.scrollbw
)
3716 reshape state
.winw state
.winh
;
3719 src#
int "scroll handle height"
3720 (fun () -> conf
.scrollh
)
3721 (fun v -> conf
.scrollh
<- v;);
3723 src#
int "thumbnail width"
3724 (fun () -> conf
.thumbw
)
3726 conf
.thumbw
<- min
4096 v;
3729 leavebirdseye beye
false;
3736 let mode = state
.mode in
3737 src#
string "columns"
3739 match conf
.columns
with
3741 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3742 | Csplit
(count
, _) -> "-" ^ string_of_int count
3745 let n, a, b = multicolumns_of_string
v in
3746 setcolumns mode n a b);
3749 src#caption
"Pixmap cache" 0;
3750 src#int_with_suffix
"size (advisory)"
3751 (fun () -> conf
.memlimit
)
3752 (fun v -> conf
.memlimit
<- v);
3755 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3756 (string_with_suffix_of_int state
.memused
)
3757 (Hashtbl.length state
.tilemap
)) 1;
3760 src#caption
"Layout" 0;
3761 src#caption2
"Dimension"
3763 Printf.sprintf
"%dx%d (virtual %dx%d)"
3764 state
.winw state
.winh
3769 src#caption2
"Position" (fun () ->
3770 Printf.sprintf
"%dx%d" state
.x state
.y
3773 src#caption2
"Position" (fun () -> describe_location ()) 1
3777 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3778 "Save these parameters as global defaults at exit"
3779 (fun () -> conf
.bedefault
)
3780 (fun v -> conf
.bedefault
<- v)
3784 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3785 src#
bool ~offset
:0 ~
btos "Extended parameters"
3786 (fun () -> !showextended)
3787 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3791 (fun () -> conf
.checkers
)
3792 (fun v -> conf
.checkers
<- v; setcheckers v);
3793 src#
bool "update cursor"
3794 (fun () -> conf
.updatecurs
)
3795 (fun v -> conf
.updatecurs
<- v);
3796 src#
bool "scroll-bar on the left"
3797 (fun () -> conf
.leftscroll
)
3798 (fun v -> conf
.leftscroll
<- v);
3800 (fun () -> conf
.verbose
)
3801 (fun v -> conf
.verbose
<- v);
3802 src#
bool "invert colors"
3803 (fun () -> conf
.invert
)
3804 (fun v -> conf
.invert
<- v);
3806 (fun () -> conf
.maxhfit
)
3807 (fun v -> conf
.maxhfit
<- v);
3809 (fun () -> conf
.pax
!= None
)
3812 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3813 else conf
.pax
<- None
);
3814 src#
string "uri launcher"
3815 (fun () -> conf
.urilauncher
)
3816 (fun v -> conf
.urilauncher
<- v);
3817 src#
string "path launcher"
3818 (fun () -> conf
.pathlauncher
)
3819 (fun v -> conf
.pathlauncher
<- v);
3820 src#
string "tile size"
3821 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3824 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3825 conf
.tilew
<- max
64 w;
3826 conf
.tileh
<- max
64 h;
3829 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3832 src#
int "texture count"
3833 (fun () -> conf
.texcount
)
3836 then conf
.texcount
<- v
3837 else impmsg "failed to set texture count please retry later"
3839 src#
int "slice height"
3840 (fun () -> conf
.sliceheight
)
3842 conf
.sliceheight
<- v;
3843 wcmd "sliceh %d" conf
.sliceheight
;
3845 src#
int "anti-aliasing level"
3846 (fun () -> conf
.aalevel
)
3848 conf
.aalevel
<- bound
v 0 8;
3849 state
.anchor <- getanchor
();
3850 opendoc state
.path state
.password;
3852 src#
string "page scroll scaling factor"
3853 (fun () -> string_of_float conf
.pgscale)
3856 let s = float_of_string
v in
3859 state
.text <- Printf.sprintf
3860 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3863 src#
int "ui font size"
3864 (fun () -> fstate
.fontsize
)
3865 (fun v -> setfontsize (bound
v 5 100));
3866 src#
int "hint font size"
3867 (fun () -> conf
.hfsize
)
3868 (fun v -> conf
.hfsize
<- bound
v 5 100);
3869 colorp "background color"
3870 (fun () -> conf
.bgcolor
)
3871 (fun v -> conf
.bgcolor
<- v);
3872 src#
bool "crop hack"
3873 (fun () -> conf
.crophack
)
3874 (fun v -> conf
.crophack
<- v);
3875 src#
string "trim fuzz"
3876 (fun () -> irect_to_string conf
.trimfuzz
)
3879 conf
.trimfuzz
<- irect_of_string
v;
3881 then settrim true conf
.trimfuzz
;
3883 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3885 src#
string "throttle"
3887 match conf
.maxwait
with
3888 | None
-> "show place holder if page is not ready"
3891 then "wait for page to fully render"
3893 "wait " ^ string_of_float
time
3894 ^
" seconds before showing placeholder"
3898 let f = float_of_string
v in
3900 then conf
.maxwait
<- None
3901 else conf
.maxwait
<- Some
f
3903 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3905 src#
string "ghyll scroll"
3907 match conf
.ghyllscroll
with
3909 | Some nab
-> ghyllscroll_to_string nab
3912 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3915 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3917 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3919 src#
string "selection command"
3920 (fun () -> conf
.selcmd
)
3921 (fun v -> conf
.selcmd
<- v);
3922 src#
string "synctex command"
3923 (fun () -> conf
.stcmd
)
3924 (fun v -> conf
.stcmd
<- v);
3925 src#
string "pax command"
3926 (fun () -> conf
.paxcmd
)
3927 (fun v -> conf
.paxcmd
<- v);
3928 src#
string "ask password command"
3929 (fun () -> conf
.passcmd)
3930 (fun v -> conf
.passcmd <- v);
3931 src#
string "save path command"
3932 (fun () -> conf
.savecmd
)
3933 (fun v -> conf
.savecmd
<- v);
3934 src#colorspace
"color space"
3935 (fun () -> CSTE.to_string conf
.colorspace
)
3937 conf
.colorspace
<- CSTE.of_int
v;
3941 src#paxmark
"pax mark method"
3942 (fun () -> MTE.to_string conf
.paxmark
)
3943 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3947 (fun () -> conf
.usepbo
)
3948 (fun v -> conf
.usepbo
<- v);
3949 src#
bool "mouse wheel scrolls pages"
3950 (fun () -> conf
.wheelbypage
)
3951 (fun v -> conf
.wheelbypage
<- v);
3952 src#
bool "open remote links in a new instance"
3953 (fun () -> conf
.riani
)
3954 (fun v -> conf
.riani
<- v);
3955 src#
bool "edit annotations inline"
3956 (fun () -> conf
.annotinline
)
3957 (fun v -> conf
.annotinline
<- v);
3961 src#caption
"Document" 0;
3962 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3963 src#caption2
"Pages"
3964 (fun () -> string_of_int state
.pagecount
) 1;
3965 src#caption2
"Dimensions"
3966 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3970 src#caption
"Trimmed margins" 0;
3971 src#caption2
"Dimensions"
3972 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3976 src#caption
"OpenGL" 0;
3977 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3978 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3981 src#caption
"Location" 0;
3982 if nonemptystr state
.origin
3983 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3984 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3986 src#reset prevmode prevuioh
;
3991 let prevmode = state
.mode
3992 and prevuioh
= state
.uioh in
3993 fillsrc prevmode prevuioh
;
3994 let source = (src :> lvsource
) in
3995 let modehash = findkeyhash conf
"info" in
3996 state
.uioh <- coe (object (self)
3997 inherit listview ~zebra
:false ~helpmode
:false
3998 ~
source ~trusted
:true ~
modehash as super
3999 val mutable m_prevmemused
= 0
4000 method! infochanged
= function
4002 if m_prevmemused
!= state
.memused
4004 m_prevmemused
<- state
.memused
;
4005 G.postRedisplay "memusedchanged";
4007 | Pdim
-> G.postRedisplay "pdimchanged"
4008 | Docinfo
-> fillsrc prevmode prevuioh
4010 method! key key mask
=
4011 if not
(Wsi.withctrl mask
)
4014 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4015 | @right
| @kpright
-> coe (self#updownlevel
1)
4016 | _ -> super#
key key mask
4017 else super#
key key mask
4019 G.postRedisplay "info";
4025 inherit lvsourcebase
4026 method getitemcount
= Array.length state
.help
4028 let s, l, _ = state
.help
.(n) in
4031 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4035 match state
.help
.(active) with
4036 | _, _, Action
f -> Some
(f uioh)
4037 | _, _, Noaction
-> Some
uioh
4046 method hasaction
n =
4047 match state
.help
.(n) with
4048 | _, _, Action
_ -> true
4049 | _, _, Noaction
-> false
4055 let modehash = findkeyhash conf
"help" in
4057 state
.uioh <- coe (new listview
4058 ~zebra
:false ~helpmode
:true
4059 ~
source ~trusted
:true ~
modehash);
4060 G.postRedisplay "help";
4066 inherit lvsourcebase
4067 val mutable m_items
= E.a
4069 method getitemcount
= 1 + Array.length m_items
4074 else m_items
.(n-1), 0
4076 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4081 then Buffer.clear state
.errmsgs
;
4088 method hasaction
n =
4092 state
.newerrmsgs
<- false;
4093 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4094 m_items
<- Array.of_list
l
4103 let source = (msgsource :> lvsource
) in
4104 let modehash = findkeyhash conf
"listview" in
4105 state
.uioh <- coe (object
4106 inherit listview ~zebra
:false ~helpmode
:false
4107 ~
source ~trusted
:false ~
modehash as super
4110 then msgsource#reset
;
4113 G.postRedisplay "msgs";
4117 let editor = getenvwithdef
"EDITOR" E.s in
4121 let tmppath = Filename.temp_file
"llpp" "note" in
4124 let oc = open_out
tmppath in
4128 let execstr = editor ^
" " ^
tmppath in
4130 match spawn
execstr [] with
4131 | (exception exn
) ->
4132 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4135 match Unix.waitpid
[] pid with
4136 | (exception exn
) ->
4137 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4141 | Unix.WEXITED
0 -> filecontents
tmppath
4143 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4145 | Unix.WSIGNALED
n ->
4146 impmsg "editor process(%s) was killed by signal %d" execstr n;
4148 | Unix.WSTOPPED
n ->
4149 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4152 match Unix.unlink
tmppath with
4153 | (exception exn
) ->
4154 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4159 let enterannotmode opaque slinkindex
=
4162 inherit lvsourcebase
4163 val mutable m_text
= E.s
4164 val mutable m_items
= E.a
4166 method getitemcount
= Array.length m_items
4169 let label, _func
= m_items
.(n) in
4172 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4173 ignore
(uioh, first, pan
);
4176 let _label, func
= m_items
.(active) in
4181 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4184 let rec split accu b i
=
4186 if p = String.length
s
4187 then (String.sub
s b (p-b), unit) :: accu
4189 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4191 let ss = if i
= 0 then E.s else String.sub
s b i
in
4192 split ((ss, unit)::accu) (p+1) 0
4197 wcmd "freepage %s" (~
> opaque);
4199 Hashtbl.fold (fun key opaque'
accu ->
4200 if opaque'
= opaque'
4201 then key :: accu else accu) state
.pagemap
[]
4203 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4208 delannot
opaque slinkindex
;
4211 let edit inline
() =
4216 modannot
opaque slinkindex
s;
4222 let mode = state
.mode in
4225 ("annotation: ", m_text
, None
, textentry, update, true),
4226 fun _ -> state
.mode <- mode);
4230 let s = getusertext m_text
in
4235 ( "[Copy]", fun () -> selstring m_text
)
4236 :: ("[Delete]", dele)
4237 :: ("[Edit]", edit conf
.annotinline
)
4239 :: split [] 0 0 |> List.rev
|> Array.of_list
4246 let s = getannotcontents
opaque slinkindex
in
4249 let source = (msgsource :> lvsource
) in
4250 let modehash = findkeyhash conf
"listview" in
4251 state
.uioh <- coe (object
4252 inherit listview ~zebra
:false ~helpmode
:false
4253 ~
source ~trusted
:false ~
modehash
4255 G.postRedisplay "enterannotmode";
4258 let gotounder under =
4259 let getpath filename
=
4261 if nonemptystr filename
4263 if Filename.is_relative filename
4265 let dir = Filename.dirname state
.path in
4267 if Filename.is_implicit
dir
4268 then Filename.concat
(Sys.getcwd
()) dir
4271 Filename.concat
dir filename
4275 if Sys.file_exists
path
4280 | Ulinkgoto
(pageno, top) ->
4284 gotopage1 pageno top;
4287 | Ulinkuri
s -> gotouri
s
4289 | Uremote
(filename
, pageno) ->
4290 let path = getpath filename
in
4295 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4296 match spawn
command [] with
4298 | (exception exn
) ->
4299 dolog
"failed to execute `%s': %s" command @@ exntos exn
4301 let anchor = getanchor
() in
4302 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4303 state
.origin
<- E.s;
4304 state
.anchor <- (pageno, 0.0, 0.0);
4305 state
.ranchors
<- ranchor :: state
.ranchors
;
4308 else impmsg "cannot find %s" filename
4310 | Uremotedest
(filename
, destname
) ->
4311 let path = getpath filename
in
4316 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4317 match spawn
command [] with
4318 | (exception exn
) ->
4319 dolog
"failed to execute `%s': %s" command @@ exntos exn
4322 let anchor = getanchor
() in
4323 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4324 state
.origin
<- E.s;
4325 state
.nameddest
<- destname
;
4326 state
.ranchors
<- ranchor :: state
.ranchors
;
4329 else impmsg "cannot find %s" filename
4331 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4332 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4335 let gotooutline (_, _, kind
) =
4339 let (pageno, y, _) = anchor in
4341 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4345 | Ouri
uri -> gotounder (Ulinkuri
uri)
4346 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4347 | Oremote remote
-> gotounder (Uremote remote
)
4348 | Ohistory hist
-> gotohist hist
4349 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4352 let outlinesource fetchoutlines
=
4354 inherit lvsourcebase
4355 val mutable m_items
= E.a
4356 val mutable m_minfo
= E.a
4357 val mutable m_orig_items
= E.a
4358 val mutable m_orig_minfo
= E.a
4359 val mutable m_narrow_patterns
= []
4360 val mutable m_gen
= -1
4362 method getitemcount
= Array.length m_items
4365 let s, n, _ = m_items
.(n) in
4368 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4369 ignore
(uioh, first);
4371 if m_narrow_patterns
= []
4372 then m_orig_items
, m_orig_minfo
4373 else m_items
, m_minfo
4380 gotooutline m_items
.(active);
4388 method hasaction
_ = true
4391 if Array.length m_items
!= Array.length m_orig_items
4394 match m_narrow_patterns
with
4396 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4398 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4402 match m_narrow_patterns
with
4405 | head
:: _ -> "@Uellipsis" ^ head
4407 method narrow
pattern =
4408 match Str.regexp_case_fold
pattern with
4409 | (exception _) -> ()
4411 let rec loop accu minfo n =
4414 m_items
<- Array.of_list
accu;
4415 m_minfo
<- Array.of_list
minfo;
4418 let (s, _, _) as o = m_items
.(n) in
4420 match Str.search_forward re
s 0 with
4421 | (exception Not_found
) -> accu, minfo
4422 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4424 loop accu minfo (n-1)
4426 loop [] [] (Array.length m_items
- 1)
4428 method! getminfo
= m_minfo
4431 m_orig_items
<- fetchoutlines
();
4432 m_minfo
<- m_orig_minfo
;
4433 m_items
<- m_orig_items
4435 method add_narrow_pattern
pattern =
4436 m_narrow_patterns
<- pattern :: m_narrow_patterns
4438 method del_narrow_pattern
=
4439 match m_narrow_patterns
with
4440 | _ :: rest
-> m_narrow_patterns
<- rest
4445 match m_narrow_patterns
with
4446 | pattern :: [] -> self#narrow
pattern; pattern
4448 List.fold_left
(fun accu pattern ->
4449 self#narrow
pattern;
4450 pattern ^
"@Uellipsis" ^
accu) E.s list
4452 method calcactive
anchor =
4453 let rely = getanchory anchor in
4454 let rec loop n best bestd
=
4455 if n = Array.length m_items
4458 let _, _, kind
= m_items
.(n) in
4461 let orely = getanchory anchor in
4462 let d = abs
(orely - rely) in
4465 else loop (n+1) best bestd
4466 | Onone
| Oremote
_ | Olaunch
_
4467 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4468 loop (n+1) best bestd
4472 method reset
anchor items =
4473 if state
.gen
!= m_gen
4475 m_orig_items
<- items;
4477 m_narrow_patterns
<- [];
4479 m_orig_minfo
<- E.a;
4483 if items != m_orig_items
4485 m_orig_items
<- items;
4486 if m_narrow_patterns
== []
4487 then m_items
<- items;
4490 let active = self#calcactive
anchor in
4492 m_first
<- firstof m_first
active
4496 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4497 let mkselector sourcetype
=
4498 let fetchoutlines () =
4499 match sourcetype
with
4500 | `bookmarks
-> Array.of_list state
.bookmarks
4501 | `outlines
-> state
.outlines
4502 | `history
-> genhistoutlines ()
4504 let source = outlinesource fetchoutlines in
4506 let outlines = fetchoutlines () in
4507 if Array.length
outlines = 0
4509 showtext ' ' errmsg
;
4513 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4514 let anchor = getanchor
() in
4515 source#reset
anchor outlines;
4516 state
.text <- source#greetmsg
;
4518 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4519 G.postRedisplay "enter selector";
4522 let mkenter sourcetype errmsg
=
4523 let enter = mkselector sourcetype
in
4524 fun () -> enter errmsg
4526 (**)mkenter `
outlines "document has no outline"
4527 , mkenter `bookmarks
"document has no bookmarks (yet)"
4528 , mkenter `history
"history is empty"
4531 let quickbookmark ?title
() =
4532 match state
.layout with
4538 let tm = Unix.localtime
(now
()) in
4540 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4544 (tm.Unix.tm_year
+ 1900)
4547 | Some
title -> title
4549 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4552 let setautoscrollspeed step goingdown
=
4553 let incr = max
1 ((abs step
) / 2) in
4554 let incr = if goingdown
then incr else -incr in
4555 let astep = boundastep state
.winh
(step
+ incr) in
4556 state
.autoscroll
<- Some
astep;
4560 match conf
.columns
with
4562 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4565 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4567 let existsinrow pageno (columns
, coverA
, coverB
) p =
4568 let last = ((pageno - coverA
) mod columns
) + columns
in
4569 let rec any = function
4572 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4576 then (if l.pageno = last then false else any rest
)
4584 match state
.layout with
4586 let pageno = page_of_y state
.y in
4587 gotoghyll (getpagey
(pageno+1))
4589 match conf
.columns
with
4591 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4593 let y = clamp (pgscale state
.winh
) in
4596 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4597 gotoghyll (getpagey
pageno)
4598 | Cmulti
((c, _, _) as cl, _) ->
4599 if conf
.presentation
4600 && (existsinrow l.pageno cl
4601 (fun l -> l.pageh
> l.pagey + l.pagevh))
4603 let y = clamp (pgscale state
.winh
) in
4606 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4607 gotoghyll (getpagey
pageno)
4609 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4611 let pagey, pageh
= getpageyh
l.pageno in
4612 let pagey = pagey + pageh
* l.pagecol
in
4613 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4614 gotoghyll (pagey + pageh
+ ips)
4618 match state
.layout with
4620 let pageno = page_of_y state
.y in
4621 gotoghyll (getpagey
(pageno-1))
4623 match conf
.columns
with
4625 if conf
.presentation
&& l.pagey != 0
4627 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4629 let pageno = max
0 (l.pageno-1) in
4630 gotoghyll (getpagey
pageno)
4631 | Cmulti
((c, _, coverB
) as cl, _) ->
4632 if conf
.presentation
&&
4633 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4635 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4638 if l.pageno = state
.pagecount
- coverB
4642 let pageno = max
0 (l.pageno-decr) in
4643 gotoghyll (getpagey
pageno)
4651 let pageno = max
0 (l.pageno-1) in
4652 let pagey, pageh
= getpageyh
pageno in
4655 let pagey, pageh
= getpageyh
l.pageno in
4656 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4662 if emptystr conf
.savecmd
4663 then error
"don't know where to save modified document"
4665 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4668 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4673 let tmp = path ^
".tmp" in
4675 Unix.rename
tmp path;
4678 let viewkeyboard key mask
=
4680 let mode = state
.mode in
4681 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4684 G.postRedisplay "view:enttext"
4686 let ctrl = Wsi.withctrl mask
in
4688 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4694 if hasunsavedchanges
()
4698 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4700 state
.mode <- LinkNav
(Ltgendir
0);
4703 else impmsg "keyboard link navigation does not work under rotation"
4706 begin match state
.mstate
with
4709 G.postRedisplay "kill rect";
4712 | Mscrolly
| Mscrollx
4715 begin match state
.mode with
4718 G.postRedisplay "esc leave linknav"
4722 match state
.ranchors
with
4724 | (path, password, anchor, origin
) :: rest
->
4725 state
.ranchors
<- rest
;
4726 state
.anchor <- anchor;
4727 state
.origin
<- origin
;
4728 state
.nameddest
<- E.s;
4729 opendoc path password
4734 gotoghyll (getnav ~
-1)
4745 Hashtbl.iter
(fun _ opaque ->
4747 Hashtbl.clear state
.prects
) state
.pagemap
;
4748 G.postRedisplay "dehighlight";
4750 | @slash
| @question
->
4751 let ondone isforw
s =
4752 cbput state
.hists
.pat
s;
4753 state
.searchpattern
<- s;
4756 let s = String.make
1 (Char.chr
key) in
4757 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4758 textentry, ondone (key = @slash
), true)
4760 | @plus
| @kpplus
| @equals
when ctrl ->
4761 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4762 setzoom (conf
.zoom +. incr)
4764 | @plus
| @kpplus
->
4767 try int_of_string
s with exc
->
4768 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4774 state
.text <- "page bias is now " ^ string_of_int
n;
4777 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4779 | @minus
| @kpminus
when ctrl ->
4780 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4781 setzoom (max
0.01 (conf
.zoom -. decr))
4783 | @minus
| @kpminus
->
4784 let ondone msg
= state
.text <- msg
in
4786 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4787 optentry state
.mode, ondone, true
4798 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4800 match conf
.columns
with
4801 | Csingle
_ | Cmulti
_ -> 1
4802 | Csplit
(n, _) -> n
4804 let h = state
.winh
-
4805 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4807 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4808 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4813 match conf
.fitmodel
with
4814 | FitWidth
-> FitProportional
4815 | FitProportional
-> FitPage
4816 | FitPage
-> FitWidth
4818 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4819 reqlayout conf
.angle
fm
4827 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4828 when not
ctrl -> (* 0..9 *)
4831 try int_of_string
s with exc
->
4832 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4838 cbput state
.hists
.pag
(string_of_int
n);
4839 gotopage1 (n + conf
.pagebias
- 1) 0;
4842 let pageentry text key =
4843 match Char.unsafe_chr
key with
4844 | '
g'
-> TEdone
text
4845 | _ -> intentry text key
4847 let text = String.make
1 (Char.chr
key) in
4848 enttext (":", text, Some
(onhist state
.hists
.pag
),
4849 pageentry, ondone, true)
4852 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4853 reshape state
.winw state
.winh
;
4856 state
.bzoom
<- not state
.bzoom
;
4858 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4861 conf
.hlinks
<- not conf
.hlinks
;
4862 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4863 G.postRedisplay "toggle highlightlinks";
4866 if conf
.angle
mod 360 = 0
4868 state
.glinks
<- true;
4869 let mode = state
.mode in
4872 (":", E.s, None
, linknentry, linknact gotounder, false),
4874 state
.glinks
<- false;
4878 G.postRedisplay "view:linkent(F)"
4880 else impmsg "hint mode does not work under rotation"
4883 state
.glinks
<- true;
4884 let mode = state
.mode in
4885 state
.mode <- Textentry
(
4887 ":", E.s, None
, linknentry, linknact (fun under ->
4888 selstring (undertext under);
4892 state
.glinks
<- false;
4896 G.postRedisplay "view:linkent"
4899 begin match state
.autoscroll
with
4901 conf
.autoscrollstep
<- step
;
4902 state
.autoscroll
<- None
4904 if conf
.autoscrollstep
= 0
4905 then state
.autoscroll
<- Some
1
4906 else state
.autoscroll
<- Some conf
.autoscrollstep
4910 launchpath () (* XXX where do error messages go? *)
4913 setpresentationmode (not conf
.presentation
);
4914 showtext ' '
("presentation mode " ^
4915 if conf
.presentation
then "on" else "off");
4918 if List.mem
Wsi.Fullscreen state
.winstate
4919 then Wsi.reshape conf
.cwinw conf
.cwinh
4920 else Wsi.fullscreen
()
4923 search state
.searchpattern
false
4926 search state
.searchpattern
true
4929 begin match state
.layout with
4932 gotoghyll (getpagey
l.pageno)
4938 | @delete
| @kpdelete
-> (* delete *)
4942 showtext ' '
(describe_location ());
4945 begin match state
.layout with
4948 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4953 enterbookmarkmode
()
4961 | @e when Buffer.length state
.errmsgs
> 0 ->
4966 match state
.layout with
4971 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4974 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4978 showtext ' '
"Quick bookmark added";
4981 begin match state
.layout with
4983 let rect = getpdimrect
l.pagedimno
in
4987 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4988 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4990 (truncate
(rect.(1) -. rect.(0)),
4991 truncate
(rect.(3) -. rect.(0)))
4993 let w = truncate
((float w)*.conf
.zoom)
4994 and h = truncate
((float h)*.conf
.zoom) in
4997 state
.anchor <- getanchor
();
4998 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
5000 G.postRedisplay "z";
5005 | @x -> state
.roam
()
5008 reqlayout (conf
.angle
+
5009 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5013 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5015 G.postRedisplay "brightness";
5017 | @c when state
.mode = View
->
5022 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5024 gotoy_and_clear_text state
.y
5028 match state
.prevcolumns
with
5029 | None
-> (1, 0, 0), 1.0
5030 | Some
(columns
, z
) ->
5033 | Csplit
(c, _) -> -c, 0, 0
5034 | Cmulti
((c, a, b), _) -> c, a, b
5035 | Csingle
_ -> 1, 0, 0
5039 setcolumns View
c a b;
5042 | @down
| @up
when ctrl && Wsi.withshift mask
->
5043 let zoom, x = state
.prevzoom
in
5047 | @k
| @up
| @kpup
->
5048 begin match state
.autoscroll
with
5050 begin match state
.mode with
5051 | Birdseye beye
-> upbirdseye 1 beye
5056 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5058 if not
(Wsi.withshift mask
) && conf
.presentation
5060 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5064 setautoscrollspeed n false
5067 | @j
| @down
| @kpdown
->
5068 begin match state
.autoscroll
with
5070 begin match state
.mode with
5071 | Birdseye beye
-> downbirdseye 1 beye
5076 then gotoy_and_clear_text (clamp (state
.winh
/2))
5078 if not
(Wsi.withshift mask
) && conf
.presentation
5080 else gotoghyll1 true (clamp (conf
.scrollstep
))
5084 setautoscrollspeed n true
5087 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5093 else conf
.hscrollstep
5095 let dx = if key = @left || key = @kpleft
then dx else -dx in
5096 state
.x <- panbound (state
.x + dx);
5097 gotoy_and_clear_text state
.y
5100 G.postRedisplay "left/right"
5103 | @prior
| @kpprior
->
5107 match state
.layout with
5109 | l :: _ -> state
.y - l.pagey
5111 clamp (pgscale (-state
.winh
))
5115 | @next | @kpnext
->
5119 match List.rev state
.layout with
5121 | l :: _ -> getpagey
l.pageno
5123 clamp (pgscale state
.winh
)
5127 | @g | @home
| @kphome
->
5130 | @G
| @jend
| @kpend
->
5132 gotoghyll (clamp state
.maxy)
5134 | @right
| @kpright
when Wsi.withalt mask
->
5135 gotoghyll (getnav 1)
5136 | @left | @kpleft
when Wsi.withalt mask
->
5137 gotoghyll (getnav ~
-1)
5142 | @v when conf
.debug
->
5145 match getopaque l.pageno with
5148 let x0, y0, x1, y1 = pagebbox
opaque in
5149 let a,b = float x0, float y0 in
5150 let c,d = float x1, float y0 in
5151 let e,f = float x1, float y1 in
5152 let h,j
= float x0, float y1 in
5153 let rect = (a,b,c,d,e,f,h,j
) in
5155 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5156 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5158 G.postRedisplay "v";
5161 let mode = state
.mode in
5162 let cmd = ref E.s in
5163 let onleave = function
5164 | Cancel
-> state
.mode <- mode
5167 match getopaque l.pageno with
5168 | Some
opaque -> pipesel opaque !cmd
5169 | None
-> ()) state
.layout;
5173 cbput state
.hists
.sel
s;
5177 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5179 G.postRedisplay "|";
5180 state
.mode <- Textentry
(te, onleave);
5183 vlog "huh? %s" (Wsi.keyname
key)
5186 let linknavkeyboard key mask
linknav =
5187 let getpage pageno =
5188 let rec loop = function
5190 | l :: _ when l.pageno = pageno -> Some
l
5191 | _ :: rest
-> loop rest
5192 in loop state
.layout
5194 let doexact (pageno, n) =
5195 match getopaque pageno, getpage pageno with
5196 | Some
opaque, Some
l ->
5197 if key = @enter || key = @kpenter
5199 let under = getlink
opaque n in
5200 G.postRedisplay "link gotounder";
5207 Some
(findlink
opaque LDfirst
), -1
5210 Some
(findlink
opaque LDlast
), 1
5213 Some
(findlink
opaque (LDleft
n)), -1
5216 Some
(findlink
opaque (LDright
n)), 1
5219 Some
(findlink
opaque (LDup
n)), -1
5222 Some
(findlink
opaque (LDdown
n)), 1
5227 begin match findpwl
l.pageno dir with
5231 state
.mode <- LinkNav
(Ltgendir
dir);
5232 let y, h = getpageyh
pageno in
5235 then y + h - state
.winh
5240 begin match getopaque pageno, getpage pageno with
5241 | Some
opaque, Some
_ ->
5243 let ld = if dir > 0 then LDfirst
else LDlast
in
5246 begin match link with
5248 showlinktype (getlink
opaque m);
5249 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5250 G.postRedisplay "linknav jpage";
5251 | Lnotfound
-> notfound dir
5257 begin match opt with
5258 | Some Lnotfound
-> pwl l dir;
5259 | Some
(Lfound
m) ->
5263 let _, y0, _, y1 = getlinkrect
opaque m in
5265 then gotopage1 l.pageno y0
5267 let d = fstate
.fontsize
+ 1 in
5268 if y1 - l.pagey > l.pagevh - d
5269 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5270 else G.postRedisplay "linknav";
5272 showlinktype (getlink
opaque m);
5273 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5276 | None
-> viewkeyboard key mask
5278 | _ -> viewkeyboard key mask
5283 G.postRedisplay "leave linknav"
5287 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5288 | Ltexact exact
-> doexact exact
5291 let keyboard key mask
=
5292 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5293 then wcmd "interrupt"
5294 else state
.uioh <- state
.uioh#
key key mask
5297 let birdseyekeyboard key mask
5298 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5300 match conf
.columns
with
5302 | Cmulti
((c, _, _), _) -> c
5303 | Csplit
_ -> failwith
"bird's eye split mode"
5305 let pgh layout = List.fold_left
5306 (fun m l -> max
l.pageh
m) state
.winh
layout in
5308 | @l when Wsi.withctrl mask
->
5309 let y, h = getpageyh
pageno in
5310 let top = (state
.winh
- h) / 2 in
5311 gotoy (max
0 (y - top))
5312 | @enter | @kpenter
-> leavebirdseye beye
false
5313 | @escape
-> leavebirdseye beye
true
5314 | @up
-> upbirdseye incr beye
5315 | @down
-> downbirdseye incr beye
5316 | @left -> upbirdseye 1 beye
5317 | @right
-> downbirdseye 1 beye
5320 begin match state
.layout with
5324 state
.mode <- Birdseye
(
5325 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5327 gotopage1 l.pageno 0;
5330 let layout = layout (state
.y-state
.winh
) (pgh state
.layout) in
5332 | [] -> gotoy (clamp (-state
.winh
))
5334 state
.mode <- Birdseye
(
5335 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5337 gotopage1 l.pageno 0
5340 | [] -> gotoy (clamp (-state
.winh
))
5344 begin match List.rev state
.layout with
5346 let layout = layout (state
.y + (pgh state
.layout)) state
.winh
in
5347 begin match layout with
5349 let incr = l.pageh
- l.pagevh in
5354 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5356 G.postRedisplay "birdseye pagedown";
5358 else gotoy (clamp (incr + conf
.interpagespace
*2));
5362 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5363 gotopage1 l.pageno 0;
5366 | [] -> gotoy (clamp state
.winh
)
5370 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5374 let pageno = state
.pagecount
- 1 in
5375 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5376 if not
(pagevisible state
.layout pageno)
5379 match List.rev state
.pdims
with
5381 | (_, _, h, _) :: _ -> h
5383 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5384 else G.postRedisplay "birdseye end";
5386 | _ -> viewkeyboard key mask
5391 match state
.mode with
5392 | Textentry
_ -> scalecolor 0.4
5394 | View
-> scalecolor 1.0
5395 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5396 if l.pageno = hooverpageno
5399 if l.pageno = pageno
5401 let c = scalecolor 1.0 in
5403 GlDraw.line_width
3.0;
5404 let dispx = xadjsb () + l.pagedispx in
5406 (float (dispx-1)) (float (l.pagedispy-1))
5407 (float (dispx+l.pagevw+1))
5408 (float (l.pagedispy+l.pagevh+1))
5410 GlDraw.line_width
1.0;
5419 let postdrawpage l linkindexbase
=
5420 match getopaque l.pageno with
5422 if tileready l l.pagex
l.pagey
5424 let x = l.pagedispx - l.pagex
+ xadjsb ()
5425 and y = l.pagedispy - l.pagey in
5427 match conf
.columns
with
5428 | Csingle
_ | Cmulti
_ ->
5429 (if conf
.hlinks
then 1 else 0)
5431 && not
(isbirdseye state
.mode) then 2 else 0)
5435 match state
.mode with
5436 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5442 Hashtbl.find_all state
.prects
l.pageno |>
5443 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5444 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5449 let scrollindicator () =
5450 let sbw, ph
, sh = state
.uioh#
scrollph in
5451 let sbh, pw, sw = state
.uioh#scrollpw
in
5456 else ((state
.winw
- sbw), state
.winw
, 0)
5459 GlDraw.color (0.64, 0.64, 0.64);
5460 filledrect (float x0) 0. (float x1) (float state
.winh
);
5462 (float hx0
) (float (state
.winh
- sbh))
5463 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5465 GlDraw.color (0.0, 0.0, 0.0);
5467 filledrect (float x0) ph
(float x1) (ph
+. sh);
5468 let pw = pw +. float hx0
in
5469 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5473 match state
.mstate
with
5474 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5477 | Msel
((x0, y0), (x1, y1)) ->
5478 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5479 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5480 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5481 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5484 let showrects = function [] -> () | rects
->
5486 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5487 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5489 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5491 if l.pageno = pageno
5493 let dx = float (l.pagedispx - l.pagex
) in
5494 let dy = float (l.pagedispy - l.pagey) in
5495 let r, g, b, alpha = c in
5496 GlDraw.color (r, g, b) ~
alpha;
5497 Raw.sets_float state
.vraw ~
pos:0
5502 GlArray.vertex `two state
.vraw
;
5503 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5512 GlClear.color (scalecolor2 conf
.bgcolor
);
5513 GlClear.clear
[`
color];
5514 List.iter
drawpage state
.layout;
5516 match state
.mode with
5517 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5518 begin match getopaque pageno with
5520 let dx = xadjsb () in
5521 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5522 let x0 = x0 + dx and x1 = x1 + dx in
5523 let color = (0.0, 0.0, 0.5, 0.5) in
5530 | None
-> state
.rects
5532 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5535 | View
-> state
.rects
5538 let rec postloop linkindexbase
= function
5540 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5541 postloop linkindexbase rest
5545 postloop 0 state
.layout;
5547 begin match state
.mstate
with
5548 | Mzoomrect
((x0, y0), (x1, y1)) ->
5550 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5551 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5552 filledrect (float x0) (float y0) (float x1) (float y1);
5556 | Mscrolly
| Mscrollx
5565 let zoomrect x y x1 y1 =
5568 and y0 = min
y y1 in
5569 gotoy (state
.y + y0);
5570 state
.anchor <- getanchor
();
5571 let zoom = (float state
.w) /. float (x1 - x0) in
5574 let adjw = wadjsb () + state
.winw
in
5576 then (adjw - state
.w) / 2
5579 match conf
.fitmodel
with
5580 | FitWidth
| FitProportional
-> simple ()
5582 match conf
.columns
with
5584 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5585 | Cmulti
_ | Csingle
_ -> simple ()
5587 state
.x <- (state
.x + margin) - x0;
5592 let annot inline
x y =
5593 match unproject x y with
5594 | Some
(opaque, n, ux
, uy
) ->
5596 addannot
opaque ux uy
text;
5597 wcmd "freepage %s" (~
> opaque);
5598 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5604 let ondone s = add s in
5605 let mode = state
.mode in
5606 state
.mode <- Textentry
(
5607 ("annotation: ", E.s, None
, textentry, ondone, true),
5608 fun _ -> state
.mode <- mode);
5611 G.postRedisplay "annot"
5613 add @@ getusertext E.s
5618 let g opaque l px py =
5619 match rectofblock
opaque px py with
5621 let x0 = a.(0) -. 20. in
5622 let x1 = a.(1) +. 20. in
5623 let y0 = a.(2) -. 20. in
5624 let zoom = (float state
.w) /. (x1 -. x0) in
5625 let pagey = getpagey
l.pageno in
5626 gotoy_and_clear_text (pagey + truncate
y0);
5627 state
.anchor <- getanchor
();
5628 let margin = (state
.w - l.pagew
)/2 in
5629 state
.x <- -truncate
x0 - margin;
5634 match conf
.columns
with
5636 impmsg "block zooming does not work properly in split columns mode"
5637 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5641 let winw = wadjsb () + state
.winw - 1 in
5642 let s = float x /. float winw in
5643 let destx = truncate
(float (state
.w + winw) *. s) in
5644 state
.x <- winw - destx;
5645 gotoy_and_clear_text state
.y;
5646 state
.mstate
<- Mscrollx
;
5650 let s = float y /. float state
.winh
in
5651 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5652 gotoy_and_clear_text desty;
5653 state
.mstate
<- Mscrolly
;
5656 let viewmulticlick clicks
x y mask
=
5657 let g opaque l px py =
5665 if markunder
opaque px py mark
5669 match getopaque l.pageno with
5671 | Some
opaque -> pipesel opaque cmd
5673 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5674 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5679 G.postRedisplay "viewmulticlick";
5680 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5684 match conf
.columns
with
5686 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5689 let viewmouse button down
x y mask
=
5691 | n when (n == 4 || n == 5) && not down
->
5692 if Wsi.withctrl mask
5694 match state
.mstate
with
5695 | Mzoom
(oldn
, i
) ->
5703 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5705 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5707 let zoom = conf
.zoom -. incr in
5709 state
.mstate
<- Mzoom
(n, 0);
5711 state
.mstate
<- Mzoom
(n, i
+1);
5713 else state
.mstate
<- Mzoom
(n, 0)
5717 | Mscrolly
| Mscrollx
5719 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5722 match state
.autoscroll
with
5723 | Some step
-> setautoscrollspeed step
(n=4)
5725 if conf
.wheelbypage
|| conf
.presentation
5734 then -conf
.scrollstep
5735 else conf
.scrollstep
5737 let incr = incr * 2 in
5738 let y = clamp incr in
5739 gotoy_and_clear_text y
5742 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5744 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5745 gotoy_and_clear_text state
.y
5747 | 1 when Wsi.withshift mask
->
5748 state
.mstate
<- Mnone
;
5751 match unproject x y with
5753 | Some
(_, pageno, ux
, uy
) ->
5754 let cmd = Printf.sprintf
5756 conf
.stcmd state
.path pageno ux uy
5758 match spawn
cmd [] with
5759 | (exception exn
) ->
5760 impmsg "execution of synctex command(%S) failed: %S"
5761 conf
.stcmd
@@ exntos exn
5765 | 1 when Wsi.withctrl mask
->
5768 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5769 state
.mstate
<- Mpan
(x, y)
5772 state
.mstate
<- Mnone
5777 if Wsi.withshift mask
5779 annot conf
.annotinline
x y;
5780 G.postRedisplay "addannot"
5784 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5785 state
.mstate
<- Mzoomrect
(p, p)
5788 match state
.mstate
with
5789 | Mzoomrect
((x0, y0), _) ->
5790 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5791 then zoomrect x0 y0 x y
5794 G.postRedisplay "kill accidental zoom rect";
5798 | Mscrolly
| Mscrollx
5804 | 1 when vscrollhit x ->
5807 let _, position, sh = state
.uioh#
scrollph in
5808 if y > truncate
position && y < truncate
(position +. sh)
5809 then state
.mstate
<- Mscrolly
5812 state
.mstate
<- Mnone
5814 | 1 when y > state
.winh
- hscrollh () ->
5817 let _, position, sw = state
.uioh#scrollpw
in
5818 if x > truncate
position && x < truncate
(position +. sw)
5819 then state
.mstate
<- Mscrollx
5822 state
.mstate
<- Mnone
5824 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5827 let dest = if down
then getunder x y else Unone
in
5828 begin match dest with
5831 | Uremote
_ | Uremotedest
_
5832 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5835 | Unone
when down
->
5836 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5837 state
.mstate
<- Mpan
(x, y);
5839 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5841 | Unone
| Utext
_ ->
5846 state
.mstate
<- Msel
((x, y), (x, y));
5847 G.postRedisplay "mouse select";
5851 match state
.mstate
with
5854 | Mzoom
_ | Mscrollx
| Mscrolly
->
5855 state
.mstate
<- Mnone
5857 | Mzoomrect
((x0, y0), _) ->
5861 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5862 state
.mstate
<- Mnone
5864 | Msel
((x0, y0), (x1, y1)) ->
5865 let rec loop = function
5869 let a0 = l.pagedispy in
5870 let a1 = a0 + l.pagevh in
5871 let b0 = l.pagedispx in
5872 let b1 = b0 + l.pagevw in
5873 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5874 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5878 match getopaque l.pageno with
5881 match Unix.pipe
() with
5882 | (exception exn
) ->
5883 impmsg "cannot create sel pipe: %s" @@
5887 Ne.clo fd
(fun msg
->
5888 dolog
"%s close failed: %s" what msg
)
5891 try spawn
cmd [r, 0; w, -1]
5893 dolog
"cannot execute %S: %s"
5900 G.postRedisplay "copysel";
5902 else clo "Msel pipe/w" w;
5903 clo "Msel pipe/r" r;
5905 dosel conf
.selcmd
();
5906 state
.roam
<- dosel conf
.paxcmd
;
5918 let birdseyemouse button down
x y mask
5919 (conf
, leftx
, _, hooverpageno
, anchor) =
5922 let rec loop = function
5925 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5926 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5928 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5934 | _ -> viewmouse button down
x y mask
5940 method key key mask
=
5941 begin match state
.mode with
5942 | Textentry
textentry -> textentrykeyboard key mask
textentry
5943 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5944 | View
-> viewkeyboard key mask
5945 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5949 method button button bstate
x y mask
=
5950 begin match state
.mode with
5952 | View
-> viewmouse button bstate
x y mask
5953 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5958 method multiclick clicks
x y mask
=
5959 begin match state
.mode with
5961 | View
-> viewmulticlick clicks
x y mask
5968 begin match state
.mode with
5970 | View
| Birdseye
_ | LinkNav
_ ->
5971 match state
.mstate
with
5972 | Mzoom
_ | Mnone
-> ()
5977 state
.mstate
<- Mpan
(x, y);
5979 then state
.x <- panbound (state
.x + dx);
5981 gotoy_and_clear_text y
5984 state
.mstate
<- Msel
(a, (x, y));
5985 G.postRedisplay "motion select";
5988 let y = min state
.winh
(max
0 y) in
5992 let x = min state
.winw (max
0 x) in
5995 | Mzoomrect
(p0
, _) ->
5996 state
.mstate
<- Mzoomrect
(p0
, (x, y));
5997 G.postRedisplay "motion zoomrect";
6001 method pmotion
x y =
6002 begin match state
.mode with
6003 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6004 let rec loop = function
6006 if hooverpageno
!= -1
6008 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6009 G.postRedisplay "pmotion birdseye no hoover";
6012 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6013 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6015 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6016 G.postRedisplay "pmotion birdseye hoover";
6026 match state
.mstate
with
6027 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6035 let past, _, _ = !r in
6037 let delta = now -. past in
6040 else r := (now, x, y)
6044 method infochanged
_ = ()
6047 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6050 then 0.0, float state
.winh
6051 else scrollph state
.y maxy
6056 let winw = wadjsb () + state
.winw in
6057 let fwinw = float winw in
6059 let sw = fwinw /. float state
.w in
6060 let sw = fwinw *. sw in
6061 max
sw (float conf
.scrollh
)
6064 let maxx = state
.w + winw in
6065 let x = winw - state
.x in
6066 let percent = float x /. float maxx in
6067 (fwinw -. sw) *. percent
6069 hscrollh (), position, sw
6073 match state
.mode with
6074 | LinkNav
_ -> "links"
6075 | Textentry
_ -> "textentry"
6076 | Birdseye
_ -> "birdseye"
6079 findkeyhash conf
modename
6081 method eformsgs
= true
6082 method alwaysscrolly
= false
6085 let adderrmsg src msg
=
6086 Buffer.add_string state
.errmsgs msg
;
6087 state
.newerrmsgs
<- true;
6091 let adderrfmt src fmt
=
6092 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6095 let addrect pageno r g b a x0 y0 x1 y1 =
6096 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6100 let cl = splitatspace cmds
in
6102 try Scanf.sscanf
s fmt
f
6104 adderrfmt "remote exec"
6105 "error processing '%S': %s\n" cmds
@@ exntos exn
6107 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6108 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6109 s pageno r g b a x0 y0 x1 y1;
6113 let _,w1,h1
,_ = getpagedim
pageno in
6114 let sw = float w1 /. float w
6115 and sh = float h1
/. float h in
6119 and y1s
= y1 *. sh in
6120 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6121 let color = (r, g, b, a) in
6122 if conf
.verbose
then debugrect rect;
6123 state
.rects <- (pageno, color, rect) :: state
.rects;
6128 | "reload" :: [] -> reload ()
6129 | "goto" :: args
:: [] ->
6130 scan args
"%u %f %f"
6132 let cmd, _ = state
.geomcmds
in
6134 then gotopagexy pageno x y
6137 gotopagexy pageno x y;
6140 state
.reprf
<- f state
.reprf
6142 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6143 | "gotor" :: args
:: [] ->
6145 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6146 | "gotord" :: args
:: [] ->
6148 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6149 | "rect" :: args
:: [] ->
6150 scan args
"%u %u %f %f %f %f"
6151 (fun pageno c x0 y0 x1 y1 ->
6152 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6153 rectx "rect" pageno color x0 y0 x1 y1;
6155 | "prect" :: args
:: [] ->
6156 scan args
"%u %f %f %f %f %f %f %f %f"
6157 (fun pageno r g b alpha x0 y0 x1 y1 ->
6158 addrect pageno r g b alpha x0 y0 x1 y1;
6159 G.postRedisplay "prect"
6161 | "pgoto" :: args
:: [] ->
6162 scan args
"%u %f %f"
6164 match getopaque pageno with
6165 | Some
opaque -> pgoto pageno opaque x y
6167 gotopage pageno 0.0;
6168 wcmd "pgoto %u %f %f" pageno x y
6170 | "activatewin" :: [] -> Wsi.activatewin
()
6171 | "quit" :: [] -> raise Quit
6172 | "clearrects" :: [] ->
6173 Hashtbl.clear state
.prects
;
6174 G.postRedisplay "clearrects"
6176 adderrfmt "remote command"
6177 "error processing remote command: %S\n" cmds
;
6181 let scratch = Bytes.create
80 in
6182 let buf = Buffer.create
80 in
6184 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6185 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6188 if Buffer.length
buf > 0
6190 let s = Buffer.contents
buf in
6198 match Bytes.index_from
scratch ppos '
\n'
with
6199 | pos -> if pos >= n then -1 else pos
6200 | (exception Not_found
) -> -1
6204 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6205 let s = Buffer.contents
buf in
6211 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6217 let remoteopen path =
6218 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6220 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6225 let gcconfig = ref E.s in
6226 let trimcachepath = ref E.s in
6227 let rcmdpath = ref E.s in
6228 let pageno = ref None
in
6229 let rootwid = ref 0 in
6230 let openlast = ref false in
6231 let nofc = ref false in
6232 let doreap = ref false in
6233 selfexec := Sys.executable_name
;
6236 [("-p", Arg.String
(fun s -> state
.password <- s),
6237 "<password> Set password");
6241 Config.fontpath
:= s;
6242 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6244 "<path> Set path to the user interface font");
6248 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6249 Config.confpath
:= s),
6250 "<path> Set path to the configuration file");
6252 ("-last", Arg.Set
openlast, " Open last document");
6254 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6255 "<page-number> Jump to page");
6257 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6258 "<path> Set path to the trim cache file");
6260 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6261 "<named-destination> Set named destination");
6263 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6264 ("-cxack", Arg.Set
cxack, " Cut corners");
6266 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6267 "<path> Set path to the remote commands source");
6269 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6270 "<original-path> Set original path");
6272 ("-gc", Arg.Set_string
gcconfig,
6273 "<script-path> Collect garbage with the help of a script");
6275 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6277 ("-v", Arg.Unit
(fun () ->
6279 "%s\nconfiguration path: %s\n"
6283 exit
0), " Print version and exit");
6285 ("-embed", Arg.Set_int
rootwid,
6286 "<window-id> Embed into window")
6289 (fun s -> state
.path <- s)
6290 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6293 then selfexec := !selfexec ^
" -wtmode";
6295 let histmode = emptystr state
.path && not
!openlast in
6297 if not
(Config.load !openlast)
6298 then dolog
"failed to load configuration";
6299 begin match !pageno with
6300 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6304 if nonemptystr
!gcconfig
6307 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6308 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6311 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6312 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6314 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6319 let wsfd, winw, winh
= Wsi.init
(object (self)
6320 val mutable m_clicks
= 0
6321 val mutable m_click_x
= 0
6322 val mutable m_click_y
= 0
6323 val mutable m_lastclicktime
= infinity
6325 method private cleanup =
6326 state
.roam
<- noroam
;
6327 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6328 method expose
= G.postRedisplay"expose"
6332 | Wsi.Unobscured
-> "unobscured"
6333 | Wsi.PartiallyObscured
-> "partiallyobscured"
6334 | Wsi.FullyObscured
-> "fullyobscured"
6336 vlog "visibility change %s" name
6337 method display = display ()
6338 method map mapped
= vlog "mappped %b" mapped
6339 method reshape w h =
6342 method mouse
b d x y m =
6343 if d && canselect ()
6345 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6351 if abs
x - m_click_x
> 10
6352 || abs
y - m_click_y
> 10
6353 || abs_float
(t -. m_lastclicktime
) > 0.3
6355 m_clicks
<- m_clicks
+ 1;
6356 m_lastclicktime
<- t;
6360 G.postRedisplay "cleanup";
6361 state
.uioh <- state
.uioh#button
b d x y m;
6363 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6368 m_lastclicktime
<- infinity
;
6369 state
.uioh <- state
.uioh#button
b d x y m
6373 state
.uioh <- state
.uioh#button
b d x y m
6376 state
.mpos
<- (x, y);
6377 state
.uioh <- state
.uioh#motion
x y
6378 method pmotion
x y =
6379 state
.mpos
<- (x, y);
6380 state
.uioh <- state
.uioh#pmotion
x y
6382 let mascm = m land (
6383 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6386 let x = state
.x and y = state
.y in
6388 if x != state
.x || y != state
.y then self#
cleanup
6390 match state
.keystate
with
6392 let km = k
, mascm in
6395 let modehash = state
.uioh#
modehash in
6396 try Hashtbl.find modehash km
6398 try Hashtbl.find (findkeyhash conf
"global") km
6399 with Not_found
-> KMinsrt
(k
, m)
6401 | KMinsrt
(k
, m) -> keyboard k
m
6402 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6403 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6405 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6406 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6407 state
.keystate
<- KSnone
6408 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6409 state
.keystate
<- KSinto
(keys, insrt
)
6410 | KSinto
_ -> state
.keystate
<- KSnone
6413 state
.mpos
<- (x, y);
6414 state
.uioh <- state
.uioh#pmotion
x y
6415 method leave = state
.mpos
<- (-1, -1)
6416 method winstate wsl
= state
.winstate
<- wsl
6417 method quit
= raise Quit
6418 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6423 List.exists
GlMisc.check_extension
6424 [ "GL_ARB_texture_rectangle"
6425 ; "GL_EXT_texture_recangle"
6426 ; "GL_NV_texture_rectangle" ]
6428 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6431 let r = GlMisc.get_string `renderer
in
6432 let p = "Mesa DRI Intel(" in
6433 let l = String.length
p in
6434 String.length
r > l && String.sub
r 0 l = p
6437 defconf
.sliceheight
<- 1024;
6438 defconf
.texcount
<- 32;
6439 defconf
.usepbo
<- true;
6443 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6444 | (exception exn
) ->
6445 dolog
"socketpair failed: %s" @@ exntos exn
;
6453 setcheckers conf
.checkers
;
6456 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6457 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6458 !Config.fontpath
, !trimcachepath,
6459 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6462 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6464 reshape ~firsttime
:true winw winh
;
6468 Wsi.settitle
"llpp (history)";
6472 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6473 opendoc state
.path state
.password;
6477 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6478 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6481 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6482 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6483 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6485 | _pid
, _status
-> reap ()
6487 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6491 if nonemptystr
!rcmdpath
6492 then remoteopen !rcmdpath
6497 let rec loop deadline
=
6503 let r = [state
.ss; state
.wsfd] in
6507 | Some fd
-> fd
:: r
6511 state
.redisplay
<- false;
6518 if deadline
= infinity
6520 else max
0.0 (deadline
-. now)
6525 try Unix.select
r [] [] timeout
6526 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6532 if state
.ghyll
== noghyll
6534 match state
.autoscroll
with
6535 | Some step
when step
!= 0 ->
6536 let y = state
.y + step
in
6540 else if y >= state
.maxy then 0 else y
6542 if state
.mode = View
6543 then gotoy_and_clear_text y
6547 else deadline
+. 0.01
6552 let rec checkfds = function
6554 | fd
:: rest
when fd
= state
.ss ->
6555 let cmd = readcmd state
.ss in
6559 | fd
:: rest
when fd
= state
.wsfd ->
6563 | fd
:: rest
when Some fd
= !optrfd ->
6564 begin match remote fd
with
6565 | None
-> optrfd := remoteopen !rcmdpath;
6566 | opt -> optrfd := opt
6571 dolog
"select returned unknown descriptor";
6577 if deadline
= infinity
6581 match state
.autoscroll
with
6582 | Some step
when step
!= 0 -> deadline1
6583 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6591 Config.save leavebirdseye;
6592 if hasunsavedchanges
()