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
-> int -> int -> float -> float -> (float * float)
36 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
37 external rectofblock
: opaque
-> int -> int -> float array
option
39 external begintiles
: unit -> unit = "ml_begintiles";;
40 external endtiles
: unit -> unit = "ml_endtiles";;
41 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
42 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
43 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
44 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
45 external savedoc
: string -> unit = "ml_savedoc";;
46 external getannotcontents
: opaque
-> slinkindex
-> string
47 = "ml_getannotcontents";;
48 external drawprect
: opaque
-> int -> int -> float array
-> unit =
51 let selfexec = ref E.s
;;
53 let drawstring size x y s
=
55 Gl.enable `texture_2d
;
56 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
57 ignore
(drawstr size x y s
);
59 Gl.disable `texture_2d
;
62 let drawstring1 size x y s
=
66 let drawstring2 size x y fmt
=
67 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
71 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
72 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
73 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
74 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
75 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
76 dolog
" column %d" l
.pagecol
;
80 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
82 dolog
" x0,y0=(% f, % f)" x0 y0
;
83 dolog
" x1,y1=(% f, % f)" x1 y1
;
84 dolog
" x2,y2=(% f, % f)" x2 y2
;
85 dolog
" x3,y3=(% f, % f)" x3 y3
;
89 let isbirdseye = function
96 let istextentry = function
103 let wtmode = ref false;;
104 let cxack = ref false;;
106 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
109 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbhv
= 0)
110 || (state
.x
= 0 && state
.w
<= state
.winw
- conf
.scrollbw
)
116 if not state
.uioh#alwaysscrolly
&& (conf
.scrollb
land scrollbvv
= 0)
124 else x
> state
.winw
- vscrollw ()
127 let wadjsb () = -vscrollw ();;
128 let xadjsb () = if conf
.leftscroll
then vscrollw () else 0;;
131 fstate
.fontsize
<- n
;
132 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
133 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
139 else Printf.kprintf ignore fmt
143 if emptystr conf
.pathlauncher
144 then dolog
"%s" state
.path
146 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
147 match spawn
command [] with
150 dolog
"failed to execute `%s': %s" command @@ exntos exn
156 let postRedisplay who
=
157 vlog "redisplay for [%S]" who
;
158 state
.redisplay
<- true;
162 let getopaque pageno
=
163 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
164 with Not_found
-> None
167 let pagetranslatepoint l x y
=
168 let dy = y
- l
.pagedispy
in
169 let y = dy + l
.pagey
in
170 let dx = x
- l
.pagedispx
in
171 let x = dx + l
.pagex
in
175 let onppundermouse g
x y d
=
178 begin match getopaque l
.pageno
with
180 let x0 = l
.pagedispx
in
181 let x1 = x0 + l
.pagevw
in
182 let y0 = l
.pagedispy
in
183 let y1 = y0 + l
.pagevh
in
184 if y >= y0 && y <= y1 && x >= x0 && x <= x1
186 let px, py
= pagetranslatepoint l
x y in
187 match g opaque l
px py
with
200 let g opaque l
px py
=
203 match rectofblock opaque
px py
with
204 | Some
[|x0;x1;y0;y1|] ->
205 let ox = xadjsb () |> float in
206 let rect = (x0+.ox, y0, x1+.ox, y0, x1+.ox, y1, x0+.ox, y1) in
207 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
208 state
.rects
<- [l
.pageno
, color, rect];
209 G.postRedisplay "getunder";
212 let under = whatsunder opaque
px py
in
213 if under = Unone
then None
else Some
under
215 onppundermouse g x y Unone
220 match unproject opaque
x y with
221 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
224 onppundermouse g x y None
;
228 state
.text
<- Printf.sprintf
"%c%s" c s
;
229 G.postRedisplay "showtext";
233 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
236 let pipesel opaque cmd
=
239 match Unix.pipe
() with
240 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
242 let doclose what fd
=
243 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
246 try spawn cmd
[r
, 0; w
, -1]
248 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
254 G.postRedisplay "pipesel";
256 else doclose "pipesel pipe/w" w
;
257 doclose "pipesel pipe/r" r
;
261 let g opaque l
px py
=
262 if markunder opaque
px py conf
.paxmark
265 match getopaque l
.pageno
with
267 | Some opaque
-> pipesel opaque conf
.paxcmd
272 G.postRedisplay "paxunder";
273 if conf
.paxmark
= Mark_page
276 match getopaque l
.pageno
with
278 | Some opaque
-> clearmark opaque
) state
.layout
;
279 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
283 match Unix.pipe
() with
284 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
287 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
290 try spawn conf
.selcmd
[r
, 0; w
, -1]
292 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
298 let l = String.length s
in
299 let bytes = Bytes.unsafe_of_string s
in
300 let n = tempfailureretry
(Unix.write w
bytes 0) l in
302 then impmsg "failed to write %d characters to sel pipe, wrote %d"
305 impmsg "failed to write to sel pipe: %s" @@ exntos exn
308 clo "selstring pipe/r" r
;
309 clo "selstring pipe/w" w
;
312 let undertext ?
(nopath
=false) = function
315 | Ulinkgoto
(pageno
, _
) ->
317 then "page " ^ string_of_int
(pageno
+1)
318 else Printf.sprintf
"%s: page %d" state
.path
(pageno
+1)
319 | Utext s
-> "font: " ^ s
320 | Uunexpected s
-> "unexpected: " ^ s
321 | Ulaunch s
-> "launch: " ^ s
322 | Unamed s
-> "named: " ^ s
323 | Uremote
(filename
, pageno
) ->
324 Printf.sprintf
"%s: page %d" filename
(pageno
+1)
325 | Uremotedest
(filename
, destname
) ->
326 Printf.sprintf
"%s: destination %S" filename destname
327 | Uannotation
(opaque
, slinkindex
) ->
328 "annotation: " ^ getannotcontents opaque slinkindex
331 let updateunder x y =
332 match getunder x y with
333 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
335 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
336 Wsi.setcursor
Wsi.CURSOR_INFO
337 | Ulinkgoto
(pageno
, _
) ->
339 then showtext 'p'
("age: " ^ string_of_int
(pageno
+1));
340 Wsi.setcursor
Wsi.CURSOR_INFO
342 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
343 Wsi.setcursor
Wsi.CURSOR_TEXT
345 if conf
.underinfo
then showtext 'u'
("nexpected: " ^ s
);
346 Wsi.setcursor
Wsi.CURSOR_INHERIT
348 if conf
.underinfo
then showtext '
l'
("aunch: " ^ s
);
349 Wsi.setcursor
Wsi.CURSOR_INHERIT
351 if conf
.underinfo
then showtext '
n'
("amed: " ^ s
);
352 Wsi.setcursor
Wsi.CURSOR_INHERIT
353 | Uremote
(filename
, pageno
) ->
354 if conf
.underinfo
then showtext 'r'
355 (Printf.sprintf
"emote: %s (%d)" filename
(pageno
+1));
356 Wsi.setcursor
Wsi.CURSOR_INFO
357 | Uremotedest
(filename
, destname
) ->
358 if conf
.underinfo
then showtext 'r'
359 (Printf.sprintf
"emote destination: %s (%S)" filename destname
);
360 Wsi.setcursor
Wsi.CURSOR_INFO
362 if conf
.underinfo
then showtext 'a'
"nnotation";
363 Wsi.setcursor
Wsi.CURSOR_INFO
366 let showlinktype under =
367 if conf
.underinfo
&& under != Unone
368 then showtext ' '
@@ undertext under
371 let intentry_with_suffix text key
=
373 if key
>= 32 && key
< 127
377 match Char.lowercase
c with
379 let text = addchar
text c in
383 let text = addchar
text c in
387 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key
c;
392 let s = Bytes.create
4 in
393 let n = tempfailureretry
(Unix.read fd
s 0) 4 in
394 if n != 4 then error
"incomplete read(len) = %d" n;
395 let len = (Char.code
(Bytes.get
s 0) lsl 24)
396 lor (Char.code
(Bytes.get
s 1) lsl 16)
397 lor (Char.code
(Bytes.get
s 2) lsl 8)
398 lor (Char.code
(Bytes.get
s 3))
400 let s = Bytes.create
len in
401 let n = tempfailureretry
(Unix.read fd
s 0) len in
402 if n != len then error
"incomplete read(data) %d vs %d" n len;
407 let b = Buffer.create
16 in
408 Buffer.add_string
b "llll";
411 let s = Buffer.to_bytes
b in
412 let n = Bytes.length
s in
414 (* dolog "wcmd %S" (String.sub s 4 len); *)
415 Bytes.set
s 0 (Char.chr
((len lsr 24) land 0xff));
416 Bytes.set
s 1 (Char.chr
((len lsr 16) land 0xff));
417 Bytes.set
s 2 (Char.chr
((len lsr 8) land 0xff));
418 Bytes.set
s 3 (Char.chr
(len land 0xff));
419 let n'
= tempfailureretry
(Unix.write state
.ss
s 0) n in
420 if n'
!= n then error
"write failed %d vs %d" n'
n;
424 let nogeomcmds cmds
=
426 | s, [] -> emptystr
s
430 let layoutN ((columns
, coverA
, coverB
), b) y sh
=
431 let sh = sh - (hscrollh ()) in
432 let wadj = wadjsb () in
433 let rec fold accu
n =
434 if n = Array.length
b
437 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
440 || n = state
.pagecount
- coverB
441 || (n - coverA
) mod columns
= columns
- 1)
447 let pagey = max
0 (y - vy
) in
448 let pagedispy = if pagey > 0 then 0 else vy
- y in
449 let pagedispx, pagex
=
451 if n = coverA
- 1 || n = state
.pagecount
- coverB
452 then state
.x + (wadj + state
.winw
- w
) / 2
453 else dx + xoff
+ state
.x
460 let vw = wadj + state
.winw
- pagedispx in
461 let pw = w
- pagex
in
464 let pagevh = min
(h
- pagey) (sh - pagedispy) in
465 if pagevw > 0 && pagevh > 0
476 ; pagedispx = pagedispx
477 ; pagedispy = pagedispy
489 if Array.length
b = 0
491 else List.rev
(fold [] (page_of_y
y))
494 let layoutS (columns
, b) y sh =
495 let sh = sh - hscrollh () in
496 let wadj = wadjsb () in
497 let rec fold accu n =
498 if n = Array.length
b
501 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
508 let x = xoff
+ state
.x in
509 let pagey = max
0 (y - vy
) in
510 let pagedispy = if pagey > 0 then 0 else vy
- y in
511 let pagedispx, pagex
=
525 let pagecolw = pagew
/columns
in
527 if pagecolw < state
.winw
528 then pagedispx + ((wadj + state
.winw
- pagecolw) / 2)
532 let vw = wadj + state
.winw
- pagedispx in
533 let pw = pagew
- pagex
in
536 let pagevw = min
pagevw pagecolw in
537 let pagevh = min
(pageh
- pagey) (sh - pagedispy) in
538 if pagevw > 0 && pagevh > 0
549 ; pagedispx = pagedispx
550 ; pagedispy = pagedispy
551 ; pagecol
= n mod columns
566 if nogeomcmds state
.geomcmds
568 match conf
.columns
with
569 | Csingle
b -> layoutN ((1, 0, 0), b) y sh
570 | Cmulti
c -> layoutN c y sh
571 | Csplit
s -> layoutS s y sh
576 let y = state
.y + incr
in
578 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
583 let tilex = l.pagex
mod conf
.tilew
in
584 let tiley = l.pagey mod conf
.tileh
in
586 let col = l.pagex
/ conf
.tilew
in
587 let row = l.pagey / conf
.tileh
in
589 let xadj = xadjsb () in
590 let rec rowloop row y0 dispy h
=
594 let dh = conf
.tileh
- y0 in
596 let rec colloop col x0 dispx w
=
600 let dw = conf
.tilew
- x0 in
602 let dispx'
= xadj + dispx in
603 f col row dispx' dispy
x0 y0 dw dh;
604 colloop (col+1) 0 (dispx+dw) (w
-dw)
607 colloop col tilex l.pagedispx l.pagevw;
608 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
611 if l.pagevw > 0 && l.pagevh > 0
612 then rowloop row tiley l.pagedispy l.pagevh;
615 let gettileopaque l col row =
617 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
619 try Some
(Hashtbl.find state
.tilemap
key)
620 with Not_found
-> None
623 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
624 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
625 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
628 let filledrect x0 y0 x1 y1 =
629 GlArray.disable `texture_coord
;
630 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
631 GlArray.vertex `two state
.vraw
;
632 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
633 GlArray.enable `texture_coord
;
636 let linerect x0 y0 x1 y1 =
637 GlArray.disable `texture_coord
;
638 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
639 GlArray.vertex `two state
.vraw
;
640 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
641 GlArray.enable `texture_coord
;
644 let drawtiles l color =
646 let wadj = wadjsb () in
648 let f col row x y tilex tiley w h
=
649 match gettileopaque l col row with
650 | Some
(opaque
, _
, t
) ->
651 let params = x, y, w
, h
, tilex, tiley in
653 then GlTex.env
(`mode `blend
);
654 drawtile
params opaque
;
656 then GlTex.env
(`mode `modulate
);
660 let s = Printf.sprintf
664 let w = measurestr fstate
.fontsize
s in
665 GlDraw.color (0.0, 0.0, 0.0);
666 filledrect (float (x-2))
669 (float (y + fstate
.fontsize
+ 2));
670 GlDraw.color (1.0, 1.0, 1.0);
671 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
681 let lw = wadj + state
.winw
- x in
684 let lh = state
.winh
- y in
688 then GlTex.env
(`mode `blend
);
689 begin match state
.checkerstexid
with
691 Gl.enable `texture_2d
;
692 GlTex.bind_texture ~target
:`texture_2d id
;
696 and y1 = float (y+h
) in
698 let tw = float w /. 16.0
699 and th
= float h
/. 16.0 in
700 let tx0 = float tilex /. 16.0
701 and ty0
= float tiley /. 16.0 in
703 and ty1
= ty0
+. th
in
704 Raw.sets_float state
.vraw ~pos
:0
705 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
706 Raw.sets_float state
.traw ~pos
:0
707 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
708 GlArray.vertex `two state
.vraw
;
709 GlArray.tex_coord `two state
.traw
;
710 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
711 Gl.disable `texture_2d
;
714 GlDraw.color (1.0, 1.0, 1.0);
715 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
718 then GlTex.env
(`mode `modulate
);
719 if w > 128 && h
> fstate
.fontsize
+ 10
721 let c = if conf
.invert
then 1.0 else 0.0 in
722 GlDraw.color (c, c, c);
725 then (col*conf
.tilew
, row*conf
.tileh
)
728 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
737 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
739 let tilevisible1 l x y =
741 and ax1
= l.pagex
+ l.pagevw
743 and ay1
= l.pagey + l.pagevh in
747 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
748 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
750 let rx0 = max
ax0 bx0
751 and ry0
= max ay0 by0
752 and rx1
= min ax1
bx1
753 and ry1
= min ay1 by1
in
755 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
759 let tilevisible layout n x y =
760 let rec findpageinlayout m
= function
761 | l :: rest
when l.pageno
= n ->
762 tilevisible1 l x y || (
763 match conf
.columns
with
764 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
769 | _
:: rest
-> findpageinlayout 0 rest
772 findpageinlayout 0 layout;
775 let tileready l x y =
776 tilevisible1 l x y &&
777 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
780 let tilepage n p
layout =
781 let rec loop = function
785 let f col row _ _ _ _ _ _
=
786 if state
.currently
= Idle
788 match gettileopaque l col row with
791 let x = col*conf
.tilew
792 and y = row*conf
.tileh
in
794 let w = l.pagew
- x in
798 let h = l.pageh
- y in
803 then getpbo
w h conf
.colorspace
806 wcmd "tile %s %d %d %d %d %s"
807 (~
> p
) x y w h (~
> pbo);
810 l, p
, conf
.colorspace
, conf
.angle
,
811 state
.gen
, col, row, conf
.tilew
, conf
.tileh
820 if nogeomcmds state
.geomcmds
824 let preloadlayout y =
825 let y = if y < state
.winh
then 0 else y - state
.winh
in
826 let h = state
.winh
*3 in
832 if state
.currently
!= Idle
837 begin match getopaque l.pageno
with
839 wcmd "page %d %d" l.pageno
l.pagedimno
;
840 state
.currently
<- Loading
(l, state
.gen
);
842 tilepage l.pageno opaque pages
;
847 if nogeomcmds state
.geomcmds
853 if conf
.preload && state
.currently
= Idle
854 then load (preloadlayout state
.y);
857 let layoutready layout =
858 let rec fold all ls
=
861 let seen = ref false in
862 let allvisible = ref true in
863 let foo col row _ _ _ _ _ _
=
865 allvisible := !allvisible &&
866 begin match gettileopaque l col row with
872 fold (!seen && !allvisible) rest
875 let alltilesvisible = fold true layout in
880 let y = bound
y 0 state
.maxy
in
881 let y, layout, proceed
=
882 match conf
.maxwait
with
883 | Some time
when state
.ghyll
== noghyll
->
884 begin match state
.throttle
with
886 let layout = layout y state
.winh
in
887 let ready = layoutready layout in
891 state
.throttle
<- Some
(layout, y, now
());
893 else G.postRedisplay "gotoy showall (None)";
895 | Some
(_
, _
, started
) ->
896 let dt = now
() -. started
in
899 state
.throttle
<- None
;
900 let layout = layout y state
.winh
in
902 G.postRedisplay "maxwait";
909 let layout = layout y state
.winh
in
910 if not
!wtmode || layoutready layout
911 then G.postRedisplay "gotoy ready";
917 state
.layout <- layout;
918 begin match state
.mode
with
921 | Ltexact
(pageno
, linkno
) ->
922 let rec loop = function
924 state
.mode
<- LinkNav
(Ltgendir
0)
925 | l :: _
when l.pageno
= pageno
->
926 begin match getopaque pageno
with
927 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
929 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
930 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
931 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
932 then state
.mode
<- LinkNav
(Ltgendir
0)
934 | _
:: rest
-> loop rest
937 | Ltnotready _
| Ltgendir _
-> ()
943 begin match state
.mode
with
944 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
945 if not
(pagevisible layout pageno
)
947 match state
.layout with
950 state
.mode
<- Birdseye
(
951 conf
, leftx
, l.pageno
, hooverpageno
, anchor
956 | Ltnotready
(_
, dir
)
959 let rec loop = function
962 match getopaque l.pageno
with
963 | None
-> Ltnotready
(l.pageno
, dir
)
968 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
970 if dir
> 0 then LDfirst
else LDlast
976 | Lnotfound
-> loop rest
978 showlinktype (getlink opaque
n);
979 Ltexact
(l.pageno
, n)
983 state
.mode
<- LinkNav
linknav
991 state
.ghyll
<- noghyll
;
994 let mx, my
= state
.mpos
in
999 let conttiling pageno opaque
=
1000 tilepage pageno opaque
1001 (if conf
.preload then preloadlayout state
.y else state
.layout)
1004 let gotoy_and_clear_text y =
1005 if not conf
.verbose
then state
.text <- E.s;
1009 let getanchory (n, top
, dtop
) =
1010 let y, h = getpageyh
n in
1011 if conf
.presentation
1013 let ips = calcips
h in
1014 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
1016 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
1019 let gotoanchor anchor
=
1020 gotoy (getanchory anchor
);
1024 cbput state
.hists
.nav
(getanchor
());
1028 let anchor = cbgetc state
.hists
.nav dir
in
1032 let gotoghyll1 single
y =
1033 let scroll f n a
b =
1034 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1036 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1038 then s (float f /. float a
)
1041 then 1.0 -. s ((float (f-b) /. float (n-b)))
1047 let ins = float a
*. 0.5
1048 and outs
= float (n-b) *. 0.5 in
1050 ins +. outs
+. float ones
1052 let rec set nab
y sy
=
1053 let (_N
, _A
, _B
), y =
1056 let scl = if y > sy
then 2 else -2 in
1057 let _N, _
, _
= nab
in
1058 (_N,0,_N), y+conf
.scrollstep
*scl
1060 let sum = summa
_N _A _B
in
1061 let dy = float (y - sy
) in
1065 then state
.ghyll
<- noghyll
1068 let s = scroll n _N _A _B
in
1069 let y1 = y1 +. ((s *. dy) /. sum) in
1070 gotoy_and_clear_text (truncate
y1);
1071 state
.ghyll
<- gf (n+1) y1;
1075 | Some
y'
when single
-> set nab
y' state
.y
1076 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1078 gf 0 (float state
.y)
1081 match conf
.ghyllscroll
with
1082 | Some nab
when not conf
.presentation
->
1083 if state
.ghyll
== noghyll
1084 then set nab
y state
.y
1085 else state
.ghyll
(Some
y)
1087 gotoy_and_clear_text y
1090 let gotoghyll = gotoghyll1 false;;
1092 let gotopage n top
=
1093 let y, h = getpageyh
n in
1094 let y = y + (truncate
(top
*. float h)) in
1098 let gotopage1 n top
=
1099 let y = getpagey
n in
1104 let invalidate s f =
1109 match state
.geomcmds
with
1110 | ps
, [] when emptystr ps
->
1112 state
.geomcmds
<- s, [];
1115 state
.geomcmds
<- ps
, [s, f];
1117 | ps
, (s'
, _
) :: rest
when s'
= s ->
1118 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1121 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1125 Hashtbl.iter
(fun _ opaque
->
1126 wcmd "freepage %s" (~
> opaque
);
1128 Hashtbl.clear state
.pagemap
;
1132 if not
(Queue.is_empty state
.tilelru
)
1134 Queue.iter
(fun (k
, p
, s) ->
1135 wcmd "freetile %s" (~
> p
);
1136 state
.memused
<- state
.memused
- s;
1137 Hashtbl.remove state
.tilemap k
;
1139 state
.uioh#infochanged Memused
;
1140 Queue.clear state
.tilelru
;
1146 let h = truncate
(float h*.conf
.zoom
) in
1147 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1151 let opendoc path password
=
1153 state
.password
<- password
;
1154 state
.gen
<- state
.gen
+ 1;
1155 state
.docinfo
<- [];
1156 state
.outlines
<- [||];
1159 setaalevel conf
.aalevel
;
1161 if emptystr state
.origin
1165 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1166 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1167 invalidate "reqlayout"
1169 wcmd "reqlayout %d %d %d %s\000"
1170 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1171 (stateh state
.winh
) state
.nameddest
1176 state
.anchor <- getanchor
();
1177 opendoc state
.path state
.password
;
1181 let c = c *. conf
.colorscale
in
1185 let scalecolor2 (r
, g, b) =
1186 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1189 let docolumns columns
=
1190 let wadj = wadjsb () in
1193 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1194 let wadj = wadjsb () in
1195 let rec loop pageno
pdimno pdim
y ph pdims
=
1196 if pageno
= state
.pagecount
1199 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1201 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1202 pdimno+1, pdim
, rest
1206 let x = max
0 (((wadj + state
.winw
- w) / 2) - xoff
) in
1208 (if conf
.presentation
1209 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1210 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1213 a.(pageno
) <- (pdimno, x, y, pdim
);
1214 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1216 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1217 conf
.columns
<- Csingle
a;
1219 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1220 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1221 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1222 let rec fixrow m
= if m
= pageno
then () else
1223 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1226 let y = y + (rowh
- h) / 2 in
1227 a.(m
) <- (pdimno, x, y, pdim
);
1231 if pageno
= state
.pagecount
1232 then fixrow (((pageno
- 1) / columns
) * columns
)
1234 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1236 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1237 pdimno+1, pdim
, rest
1242 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1244 let x = (wadj + state
.winw
- w) / 2 in
1246 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1247 x, y + ips + rowh
, h
1250 if (pageno
- coverA
) mod columns
= 0
1252 let x = max
0 (wadj + state
.winw
- state
.w) / 2 in
1254 if conf
.presentation
1256 let ips = calcips
h in
1257 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1259 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1263 else x, y, max rowh
h
1267 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1270 if pageno
= columns
&& conf
.presentation
1272 let ips = calcips rowh
in
1273 for i
= 0 to pred columns
1275 let (pdimno, x, y, pdim
) = a.(i
) in
1276 a.(i
) <- (pdimno, x, y+ips, pdim
)
1282 fixrow (pageno
- columns
);
1287 a.(pageno
) <- (pdimno, x, y, pdim
);
1288 let x = x + w + xoff
*2 + conf
.interpagespace
in
1289 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1291 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1292 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1295 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1296 let rec loop pageno
pdimno pdim
y pdims
=
1297 if pageno
= state
.pagecount
1300 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1302 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1303 pdimno+1, pdim
, rest
1308 let rec loop1 n x y =
1309 if n = c then y else (
1310 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1311 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1314 let y = loop1 0 0 y in
1315 loop (pageno
+1) pdimno pdim
y pdims
1317 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1318 conf
.columns
<- Csplit
(c, a);
1322 docolumns conf
.columns
;
1323 state
.maxy
<- calcheight
();
1324 if state
.reprf
== noreprf
1326 match state
.mode
with
1327 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1328 let y, h = getpageyh pageno
in
1329 let top = (state
.winh
- h) / 2 in
1330 gotoy (max
0 (y - top))
1333 | LinkNav _
-> gotoanchor state
.anchor
1337 state
.reprf
<- noreprf
;
1341 let reshape ?
(firsttime
=false) w h =
1342 GlDraw.viewport ~
x:0 ~
y:0 ~
w:w ~
h:h;
1343 if not firsttime
&& nogeomcmds state
.geomcmds
1344 then state
.anchor <- getanchor
();
1347 let w = wadjsb () + (truncate
(float w *. conf
.zoom
)) in
1350 setfontsize fstate
.fontsize
;
1351 GlMat.mode `modelview
;
1352 GlMat.load_identity
();
1354 GlMat.mode `projection
;
1355 GlMat.load_identity
();
1356 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1357 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1358 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1363 else float state
.x /. float state
.w
1365 invalidate "geometry"
1369 then state
.x <- truncate
(relx *. float w);
1371 match conf
.columns
with
1373 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1374 | Csplit
(c, _
) -> w * c
1376 wcmd "geometry %d %d %d"
1377 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1382 let len = String.length state
.text in
1383 let x0 = xadjsb () in
1386 match state
.mode
with
1387 | Textentry _
| View
| LinkNav _
->
1388 let h, _
, _
= state
.uioh#scrollpw
in
1393 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1394 (x+.w) (float (state
.winh
- hscrollh))
1397 let w = float (wadjsb () + state
.winw
- 1) in
1398 if state
.progress
>= 0.0 && state
.progress
< 1.0
1400 GlDraw.color (0.3, 0.3, 0.3);
1401 let w1 = w *. state
.progress
in
1403 GlDraw.color (0.0, 0.0, 0.0);
1404 rect (float x0+.w1) (float x0+.w-.w1)
1407 GlDraw.color (0.0, 0.0, 0.0);
1411 GlDraw.color (1.0, 1.0, 1.0);
1412 drawstring fstate
.fontsize
1413 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1414 (state
.winh
- hscrollh - 5) s;
1417 match state
.mode
with
1418 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1422 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1424 Printf.sprintf
"%s%s_" prefix
text
1430 | LinkNav _
-> state
.text
1435 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1437 let s1 = "(press 'e' to review error messasges)" in
1438 if nonemptystr
s then s ^
" " ^
s1 else s1
1448 let len = Queue.length state
.tilelru
in
1450 match state
.throttle
with
1453 then preloadlayout state
.y
1455 | Some
(layout, _
, _
) ->
1459 if state
.memused
<= conf
.memlimit
1464 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1465 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1466 let (_
, pw, ph
, _
) = getpagedim
n in
1469 && colorspace
= conf
.colorspace
1470 && angle
= conf
.angle
1474 let x = col*conf
.tilew
1475 and y = row*conf
.tileh
in
1476 tilevisible (Lazy.force_val
layout) n x y
1478 then Queue.push lruitem state
.tilelru
1481 wcmd "freetile %s" (~
> p
);
1482 state
.memused
<- state
.memused
- s;
1483 state
.uioh#infochanged Memused
;
1484 Hashtbl.remove state
.tilemap k
;
1492 let onpagerect pageno
f =
1494 match conf
.columns
with
1495 | Cmulti
(_
, b) -> b
1497 | Csplit
(_
, b) -> b
1499 if pageno
>= 0 && pageno
< Array.length
b
1501 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1505 let gotopagexy1 pageno
x y =
1506 let _,w1,h1
,leftx
= getpagedim pageno
in
1507 let top = y /. (float h1
) in
1508 let left = x /. (float w1) in
1509 let py, w, h = getpageywh pageno
in
1510 let wh = state
.winh
- hscrollh () in
1511 let x = left *. (float w) in
1512 let x = leftx
+ state
.x + truncate
x in
1513 let wadj = wadjsb () in
1515 if x < 0 || x >= wadj + state
.winw
1519 let pdy = truncate
(top *. float h) in
1520 let y'
= py + pdy in
1521 let dy = y'
- state
.y in
1523 if x != state
.x || not
(dy > 0 && dy < wh)
1525 if conf
.presentation
1527 if abs
(py - y'
) > wh
1534 if state
.x != sx || state
.y != sy
1539 let ww = wadj + state
.winw
in
1541 and qy
= pdy / wh in
1543 and y = py + qy
* wh in
1544 let x = if -x + ww > w1 then -(w1-ww) else x
1545 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1547 if conf
.presentation
1549 if abs
(py - y'
) > wh
1559 gotoy_and_clear_text y;
1561 else gotoy_and_clear_text state
.y;
1564 let gotopagexy pageno
x y =
1565 match state
.mode
with
1566 | Birdseye
_ -> gotopage pageno
0.0
1569 | LinkNav
_ -> gotopagexy1 pageno
x y
1572 let getpassword () =
1573 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1578 impmsg "error getting password: %s" s;
1579 dolog
"%s" s) passcmd;
1582 let pgoto opaque pageno
x y =
1583 let pdimno = getpdimno pageno
in
1584 let x, y = project opaque pageno
pdimno x y in
1585 gotopagexy pageno
x y;
1589 (* dolog "%S" cmds; *)
1590 let cl = splitatspace cmds
in
1592 try Scanf.sscanf
s fmt
f
1594 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1597 let addoutline outline
=
1598 match state
.currently
with
1599 | Outlining outlines
->
1600 state
.currently
<- Outlining
(outline
:: outlines
)
1601 | Idle
-> state
.currently
<- Outlining
[outline
]
1604 dolog
"invalid outlining state";
1605 logcurrently state
.currently
1609 state
.uioh#infochanged Pdim
;
1612 | "clearrects" :: [] ->
1613 state
.rects
<- state
.rects1
;
1614 G.postRedisplay "clearrects";
1616 | "continue" :: args
:: [] ->
1617 let n = scan args
"%u" (fun n -> n) in
1618 state
.pagecount
<- n;
1619 begin match state
.currently
with
1621 state
.currently
<- Idle
;
1622 state
.outlines
<- Array.of_list
(List.rev
l)
1628 let cur, cmds
= state
.geomcmds
in
1630 then failwith
"umpossible";
1632 begin match List.rev cmds
with
1634 state
.geomcmds
<- E.s, [];
1635 state
.throttle
<- None
;
1639 state
.geomcmds
<- s, List.rev rest
;
1641 if conf
.maxwait
= None
&& not
!wtmode
1642 then G.postRedisplay "continue";
1644 | "msg" :: args
:: [] ->
1647 | "vmsg" :: args
:: [] ->
1649 then showtext ' ' args
1651 | "emsg" :: args
:: [] ->
1652 Buffer.add_string state
.errmsgs args
;
1653 state
.newerrmsgs
<- true;
1654 G.postRedisplay "error message"
1656 | "progress" :: args
:: [] ->
1657 let progress, text =
1660 f, String.sub args pos
(String.length args
- pos
))
1663 state
.progress <- progress;
1664 G.postRedisplay "progress"
1666 | "firstmatch" :: args
:: [] ->
1667 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1668 scan args
"%u %d %f %f %f %f %f %f %f %f"
1669 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1670 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1672 let xoff = float (xadjsb ()) in
1676 and x3
= x3
+. xoff in
1677 let y = (getpagey
pageno) + truncate
y0 in
1679 then state
.x <- truncate
(xoff -. x0);
1682 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1683 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1685 | "match" :: args
:: [] ->
1686 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1687 scan args
"%u %d %f %f %f %f %f %f %f %f"
1688 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1689 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1691 let xoff = float (xadjsb ()) in
1695 and x3
= x3
+. xoff in
1696 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1698 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1700 | "page" :: args
:: [] ->
1701 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1702 let pageopaque = ~
< pageopaques in
1703 begin match state
.currently
with
1704 | Loading
(l, gen
) ->
1705 vlog "page %d took %f sec" l.pageno t
;
1706 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1707 begin match state
.throttle
with
1709 let preloadedpages =
1711 then preloadlayout state
.y
1716 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1717 IntSet.empty
preloadedpages
1720 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1721 if not
(IntSet.mem
pageno set)
1723 wcmd "freepage %s" (~
> opaque
);
1729 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1732 state
.currently
<- Idle
;
1735 tilepage l.pageno pageopaque state
.layout;
1737 load preloadedpages;
1738 let visible = pagevisible state
.layout l.pageno in
1741 match state
.mode
with
1742 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1743 if pageno = l.pageno
1748 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1750 if dir
> 0 then LDfirst
else LDlast
1753 findlink
pageopaque ld
1758 showlinktype (getlink
pageopaque n);
1759 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1761 | LinkNav
(Ltgendir
_)
1762 | LinkNav
(Ltexact
_)
1768 if visible && layoutready state
.layout
1770 G.postRedisplay "page";
1774 | Some
(layout, _, _) ->
1775 state
.currently
<- Idle
;
1776 tilepage l.pageno pageopaque layout;
1783 dolog
"Inconsistent loading state";
1784 logcurrently state
.currently
;
1788 | "tile" :: args
:: [] ->
1789 let (x, y, opaques
, size
, t
) =
1790 scan args
"%u %u %s %u %f"
1791 (fun x y p size t
-> (x, y, p
, size
, t
))
1793 let opaque = ~
< opaques
in
1794 begin match state
.currently
with
1795 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1796 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1799 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1801 wcmd "freetile %s" (~
> opaque);
1802 state
.currently
<- Idle
;
1806 puttileopaque l col row gen cs angle
opaque size t
;
1807 state
.memused
<- state
.memused
+ size
;
1808 state
.uioh#infochanged Memused
;
1810 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1811 opaque, size
) state
.tilelru
;
1814 match state
.throttle
with
1815 | None
-> state
.layout
1816 | Some
(layout, _, _) -> layout
1819 state
.currently
<- Idle
;
1821 && conf
.colorspace
= cs
1822 && conf
.angle
= angle
1823 && tilevisible layout l.pageno x y
1824 then conttiling l.pageno pageopaque;
1826 begin match state
.throttle
with
1828 preload state
.layout;
1830 && conf
.colorspace
= cs
1831 && conf
.angle
= angle
1832 && tilevisible state
.layout l.pageno x y
1833 && (not
!wtmode || layoutready state
.layout)
1834 then G.postRedisplay "tile nothrottle";
1836 | Some
(layout, y, _) ->
1837 let ready = layoutready layout in
1841 state
.layout <- layout;
1842 state
.throttle
<- None
;
1843 G.postRedisplay "throttle";
1852 dolog
"Inconsistent tiling state";
1853 logcurrently state
.currently
;
1857 | "pdim" :: args
:: [] ->
1858 let (n, w, h, _) as pdim
=
1859 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1862 match conf
.fitmodel
with
1864 | FitPage
| FitProportional
->
1865 match conf
.columns
with
1866 | Csplit
_ -> (n, w, h, 0)
1867 | Csingle
_ | Cmulti
_ -> pdim
1869 state
.uioh#infochanged Pdim
;
1870 state
.pdims
<- pdim :: state
.pdims
1872 | "o" :: args
:: [] ->
1873 let (l, n, t
, h, pos
) =
1874 scan args
"%u %u %d %u %n"
1875 (fun l n t
h pos
-> l, n, t
, h, pos
)
1877 let s = String.sub args pos
(String.length args
- pos
) in
1878 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1880 | "ou" :: args
:: [] ->
1881 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1882 let s = String.sub args pos
len in
1883 let pos2 = pos
+ len + 1 in
1884 let uri = String.sub args
pos2 (String.length args
- pos2) in
1885 addoutline (s, l, Ouri
uri)
1887 | "on" :: args
:: [] ->
1888 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1889 let s = String.sub args pos
(String.length args
- pos
) in
1890 addoutline (s, l, Onone
)
1892 | "a" :: args
:: [] ->
1894 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1896 state
.reprf
<- (fun () -> gotopagexy n (float l) (float t
))
1898 | "info" :: args
:: [] ->
1899 let pos = nindex args '
\t'
in
1900 if pos >= 0 && String.sub args
0 pos = "Title"
1902 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1906 state
.docinfo
<- (1, args
) :: state
.docinfo
1908 | "infoend" :: [] ->
1909 state
.uioh#infochanged Docinfo
;
1910 state
.docinfo
<- List.rev state
.docinfo
1914 then Wsi.settitle
"Wrong password";
1915 let password = getpassword () in
1916 if emptystr
password
1917 then error
"document is password protected"
1918 else opendoc state
.path
password
1920 error
"unknown cmd `%S'" cmds
1925 let action = function
1926 | HCprev
-> cbget cb ~
-1
1927 | HCnext
-> cbget cb
1
1928 | HCfirst
-> cbget cb ~
-(cb
.rc)
1929 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1930 and cancel
() = cb
.rc <- rc
1934 let search pattern forward
=
1935 match conf
.columns
with
1936 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1939 if nonemptystr pattern
1942 match state
.layout with
1945 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1947 wcmd "search %d %d %d %d,%s\000"
1948 (btod conf
.icase
) pn py (btod forward
) pattern
;
1951 let intentry text key =
1953 if key >= 32 && key < 127
1959 let text = addchar
text c in
1963 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1971 let l = String.length
s in
1972 let rec loop pos n = if pos = l then n else
1973 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1974 loop (pos+1) (n*26 + m)
1977 let rec loop n = function
1980 match getopaque l.pageno with
1981 | None
-> loop n rest
1983 let m = getlinkcount
opaque in
1986 let under = getlink
opaque n in
1989 else loop (n-m) rest
1991 loop n state
.layout;
1995 let linknentry text key =
1997 if key >= 32 && key < 127
2003 let text = addchar
text c in
2004 linknact (fun under -> state
.text <- undertext ~nopath
:true under) text;
2008 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
2012 let textentry text key =
2013 if key land 0xff00 = 0xff00
2015 else TEcont
(text ^ toutf8
key)
2018 let reqlayout angle fitmodel
=
2019 match state
.throttle
with
2021 if nogeomcmds state
.geomcmds
2022 then state
.anchor <- getanchor
();
2023 conf
.angle
<- angle
mod 360;
2026 match state
.mode
with
2027 | LinkNav
_ -> state
.mode
<- View
2032 conf
.fitmodel
<- fitmodel
;
2033 invalidate "reqlayout"
2035 wcmd "reqlayout %d %d %d"
2036 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2041 let settrim trimmargins trimfuzz
=
2042 if nogeomcmds state
.geomcmds
2043 then state
.anchor <- getanchor
();
2044 conf
.trimmargins
<- trimmargins
;
2045 conf
.trimfuzz
<- trimfuzz
;
2046 let x0, y0, x1, y1 = trimfuzz
in
2047 invalidate "settrim"
2049 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2054 match state
.throttle
with
2056 let zoom = max
0.0001 zoom in
2057 if zoom <> conf
.zoom
2059 state
.prevzoom
<- (conf
.zoom, state
.x);
2061 reshape state
.winw state
.winh
;
2062 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2065 | Some
(layout, y, started
) ->
2067 match conf
.maxwait
with
2071 let dt = now
() -. started
in
2079 let setcolumns mode columns coverA coverB
=
2080 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2084 then impmsg "split mode doesn't work in bird's eye"
2086 conf
.columns
<- Csplit
(-columns
, E.a);
2094 conf
.columns
<- Csingle
E.a;
2099 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2103 reshape state
.winw state
.winh
;
2106 let resetmstate () =
2107 state
.mstate
<- Mnone
;
2108 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2111 let enterbirdseye () =
2112 let zoom = float conf
.thumbw
/. float state
.winw
in
2113 let birdseyepageno =
2114 let cy = state
.winh
/ 2 in
2118 let rec fold best
= function
2121 let d = cy - (l.pagedispy + l.pagevh/2)
2122 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2123 if abs
d < abs dbest
2130 state
.mode
<- Birdseye
(
2131 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2135 conf
.presentation
<- false;
2136 conf
.interpagespace
<- 10;
2137 conf
.hlinks
<- false;
2138 conf
.fitmodel
<- FitPage
;
2140 conf
.maxwait
<- None
;
2142 match conf
.beyecolumns
with
2145 Cmulti
((c, 0, 0), E.a)
2146 | None
-> Csingle
E.a
2150 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2155 reshape state
.winw state
.winh
;
2158 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2160 conf
.zoom <- c.zoom;
2161 conf
.presentation
<- c.presentation
;
2162 conf
.interpagespace
<- c.interpagespace
;
2163 conf
.maxwait
<- c.maxwait
;
2164 conf
.hlinks
<- c.hlinks
;
2165 conf
.fitmodel
<- c.fitmodel
;
2166 conf
.beyecolumns
<- (
2167 match conf
.columns
with
2168 | Cmulti
((c, _, _), _) -> Some
c
2170 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2173 match c.columns
with
2174 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2175 | Csingle
_ -> Csingle
E.a
2176 | Csplit
(c, _) -> Csplit
(c, E.a)
2180 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2183 reshape state
.winw state
.winh
;
2184 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2188 let togglebirdseye () =
2189 match state
.mode
with
2190 | Birdseye vals
-> leavebirdseye vals
true
2191 | View
-> enterbirdseye ()
2196 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2197 let pageno = max
0 (pageno - incr
) in
2198 let rec loop = function
2199 | [] -> gotopage1 pageno 0
2200 | l :: _ when l.pageno = pageno ->
2201 if l.pagedispy >= 0 && l.pagey = 0
2202 then G.postRedisplay "upbirdseye"
2203 else gotopage1 pageno 0
2204 | _ :: rest
-> loop rest
2208 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2211 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2212 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2213 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2214 let rec loop = function
2216 let y, h = getpageyh
pageno in
2217 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2219 | l :: _ when l.pageno = pageno ->
2220 if l.pagevh != l.pageh
2221 then gotoy (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2222 else G.postRedisplay "downbirdseye"
2223 | _ :: rest
-> loop rest
2229 let optentry mode
_ key =
2230 let btos b = if b then "on" else "off" in
2231 if key >= 32 && key < 127
2233 let c = Char.chr
key in
2237 try conf
.scrollstep
<- int_of_string
s with exc
->
2238 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2240 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2245 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2246 if state
.autoscroll
<> None
2247 then state
.autoscroll
<- Some conf
.autoscrollstep
2249 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2251 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2256 let n, a, b = multicolumns_of_string
s in
2257 setcolumns mode
n a b;
2259 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exc
2261 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2266 let zoom = float (int_of_string
s) /. 100.0 in
2269 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2271 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2276 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2278 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2279 begin match mode
with
2281 leavebirdseye beye
false;
2288 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2290 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2295 Some
(int_of_string
s)
2298 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
2301 | Some angle
-> reqlayout angle conf
.fitmodel
2304 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2307 conf
.icase
<- not conf
.icase
;
2308 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2311 conf
.preload <- not conf
.preload;
2313 TEdone
("preload " ^
(btos conf
.preload))
2316 conf
.verbose
<- not conf
.verbose
;
2317 TEdone
("verbose " ^
(btos conf
.verbose
))
2320 conf
.debug
<- not conf
.debug
;
2321 TEdone
("debug " ^
(btos conf
.debug
))
2324 conf
.maxhfit
<- not conf
.maxhfit
;
2325 state
.maxy
<- calcheight
();
2326 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2329 conf
.crophack
<- not conf
.crophack
;
2330 TEdone
("crophack " ^
btos conf
.crophack
)
2334 match conf
.maxwait
with
2336 conf
.maxwait
<- Some infinity
;
2337 "always wait for page to complete"
2339 conf
.maxwait
<- None
;
2340 "show placeholder if page is not ready"
2345 conf
.underinfo
<- not conf
.underinfo
;
2346 TEdone
("underinfo " ^
btos conf
.underinfo
)
2349 conf
.savebmarks
<- not conf
.savebmarks
;
2350 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2356 match state
.layout with
2361 conf
.interpagespace
<- int_of_string
s;
2362 docolumns conf
.columns
;
2363 state
.maxy
<- calcheight
();
2364 let y = getpagey
pageno in
2367 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
2369 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2373 match conf
.fitmodel
with
2374 | FitProportional
-> FitWidth
2375 | FitWidth
| FitPage
-> FitProportional
2377 reqlayout conf
.angle
fm;
2378 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2381 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2382 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2385 conf
.invert
<- not conf
.invert
;
2386 TEdone
("invert colors " ^
btos conf
.invert
)
2390 cbput state
.hists
.sel
s;
2393 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2394 textentry, ondone, true)
2398 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2399 else conf
.pax
<- None
;
2400 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2403 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2409 class type lvsource
= object
2410 method getitemcount
: int
2411 method getitem
: int -> (string * int)
2412 method hasaction
: int -> bool
2420 method getactive
: int
2421 method getfirst
: int
2423 method getminfo
: (int * int) array
2426 class virtual lvsourcebase
= object
2427 val mutable m_active
= 0
2428 val mutable m_first
= 0
2429 val mutable m_pan
= 0
2430 method getactive
= m_active
2431 method getfirst
= m_first
2432 method getpan
= m_pan
2433 method getminfo
: (int * int) array
= E.a
2436 let textentrykeyboard
2437 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2440 if key >= 0xffb0 && key <= 0xffb9
2441 then key - 0xffb0 + 48 else key
2444 state
.mode
<- Textentry
(te
, onleave
);
2446 G.postRedisplay "textentrykeyboard enttext";
2448 let histaction cmd
=
2451 | Some
(action, _) ->
2452 state
.mode
<- Textentry
(
2453 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2455 G.postRedisplay "textentry histaction"
2459 if emptystr
text && cancelonempty
2462 G.postRedisplay "textentrykeyboard after cancel";
2465 let s = withoutlastutf8
text in
2466 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2468 | @enter
| @kpenter
->
2471 G.postRedisplay "textentrykeyboard after confirm"
2473 | @up
| @kpup
-> histaction HCprev
2474 | @down
| @kpdown
-> histaction HCnext
2475 | @home
| @kphome
-> histaction HCfirst
2476 | @jend
| @kpend
-> histaction HClast
2481 begin match opthist
with
2483 | Some
(_, onhistcancel
) -> onhistcancel
()
2487 G.postRedisplay "textentrykeyboard after cancel2"
2490 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2493 | @delete
| @kpdelete
-> ()
2496 && key land 0xff00 != 0xff00 (* keyboard *)
2497 && key land 0xfe00 != 0xfe00 (* xkb *)
2498 && key land 0xfd00 != 0xfd00 (* 3270 *)
2500 begin match onkey
text key with
2504 G.postRedisplay "textentrykeyboard after confirm2";
2507 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2511 G.postRedisplay "textentrykeyboard after cancel3"
2514 state
.mode
<- Textentry
(te
, onleave
);
2515 G.postRedisplay "textentrykeyboard switch";
2519 vlog "unhandled key %s" (Wsi.keyname
key)
2522 let firstof first active
=
2523 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2524 then max
0 (active
- (fstate
.maxrows
/2))
2528 let calcfirst first active
=
2531 let rows = active
- first
in
2532 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2536 let scrollph y maxy
=
2537 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2538 let sh = float state
.winh
/. sh in
2539 let sh = max
sh (float conf
.scrollh
) in
2541 let percent = float y /. float maxy
in
2542 let position = (float state
.winh
-. sh) *. percent in
2545 if position +. sh > float state
.winh
2546 then float state
.winh
-. sh
2552 let coe s = (s :> uioh
);;
2554 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2556 val m_pan
= source#getpan
2557 val m_first
= source#getfirst
2558 val m_active
= source#getactive
2560 val m_prev_uioh
= state
.uioh
2562 method private elemunder
y =
2566 let n = y / (fstate
.fontsize
+1) in
2567 if m_first
+ n < source#getitemcount
2569 if source#hasaction
(m_first
+ n)
2570 then Some
(m_first
+ n)
2577 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2578 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2579 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2580 GlDraw.color (1., 1., 1.);
2581 Gl.enable `texture_2d
;
2582 let fs = fstate
.fontsize
in
2584 let hw = (wadjsb () + xadjsb () + state
.winw
)/3 in
2585 let ww = fstate
.wwidth
in
2586 let tabw = 17.0*.ww in
2587 let itemcount = source#getitemcount
in
2588 let minfo = source#getminfo
in
2591 then float (xadjsb ()), float (state
.winw
- 1)
2592 else 0.0, float (state
.winw
- conf
.scrollbw
- 1)
2594 let xadj = xadjsb () in
2596 if (row - m_first
) > fstate
.maxrows
2599 if row >= 0 && row < itemcount
2601 let (s, level
) = source#getitem
row in
2602 let y = (row - m_first
) * nfs in
2604 (if conf
.leftscroll
then float xadj else 5.0)
2605 +. (float (level
+ m_pan
)) *. ww in
2608 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2612 Gl.disable `texture_2d
;
2613 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2614 GlDraw.color (1., 1., 1.) ~
alpha;
2615 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2616 Gl.enable `texture_2d
;
2619 if zebra
&& row land 1 = 1
2623 GlDraw.color (c,c,c);
2624 let drawtabularstring s =
2626 let x'
= truncate
(x0 +. x) in
2627 let pos = nindex
s '
\000'
in
2629 then drawstring1 fs x'
(y+nfs) s
2631 let s1 = String.sub
s 0 pos
2632 and s2
= String.sub
s (pos+1) (String.length
s - pos - 1) in
2637 let s'
= withoutlastutf8
s in
2638 let s = s' ^
"@Uellipsis" in
2639 let w = measurestr
fs s in
2640 if float x'
+. w +. ww < float (hw + x'
)
2645 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2649 ignore
(drawstring1 fs x'
(y+nfs) s1);
2650 drawstring1 fs (hw + x'
) (y+nfs) s2
2654 let x = if helpmode
&& row > 0 then x +. ww else x in
2655 let tabpos = nindex
s '
\t'
in
2658 let len = String.length
s - tabpos - 1 in
2659 let s1 = String.sub
s 0 tabpos
2660 and s2
= String.sub
s (tabpos + 1) len in
2661 let nx = drawstr x s1 in
2663 let x = x +. (max
tabw sw) in
2666 let len = String.length
s - 2 in
2667 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2669 let s = String.sub
s 2 len in
2670 let x = if not helpmode
then x +. ww else x in
2671 GlDraw.color (1.2, 1.2, 1.2);
2672 let vinc = drawstring1 (fs+fs/4)
2673 (truncate
(x -. ww)) (y+nfs) s in
2674 GlDraw.color (1., 1., 1.);
2675 vinc +. (float fs *. 0.8)
2681 ignore
(drawtabularstring s);
2687 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2688 let xadj = float (xadjsb () + 5) in
2690 if (row - m_first
) > fstate
.maxrows
2693 if row >= 0 && row < itemcount
2695 let (s, level
) = source#getitem
row in
2696 let pos0 = nindex
s '
\000'
in
2697 let y = (row - m_first
) * nfs in
2698 let x = float (level
+ m_pan
) *. ww in
2699 let (first
, last
) = minfo.(row) in
2701 if pos0 > 0 && first
> pos0
2702 then String.sub
s (pos0+1) (first
-pos0-1)
2703 else String.sub
s 0 first
2705 let suffix = String.sub
s first
(last
- first
) in
2706 let w1 = measurestr fstate
.fontsize
prefix in
2707 let w2 = measurestr fstate
.fontsize
suffix in
2708 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2709 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2711 and y0 = float (y+2) in
2713 and y1 = float (y+fs+3) in
2714 filledrect x0 y0 x1 y1;
2719 Gl.disable `texture_2d
;
2720 if Array.length
minfo > 0 then loop m_first
;
2723 method updownlevel incr
=
2724 let len = source#getitemcount
in
2726 if m_active
>= 0 && m_active
< len
2727 then snd
(source#getitem m_active
)
2731 if i
= len then i
-1 else if i
= -1 then 0 else
2732 let _, l = source#getitem i
in
2733 if l != curlevel then i
else flow (i
+incr
)
2735 let active = flow m_active
in
2736 let first = calcfirst m_first
active in
2737 G.postRedisplay "outline updownlevel";
2738 {< m_active
= active; m_first
= first >}
2740 method private key1
key mask
=
2741 let set1 active first qsearch
=
2742 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2744 let search active pattern incr
=
2745 let active = if active = -1 then m_first
else active in
2748 if n >= 0 && n < source#getitemcount
2750 let s, _ = source#getitem
n in
2751 match Str.search_forward re
s 0 with
2752 | (exception Not_found
) -> loop (n + incr
)
2759 Str.regexp_case_fold pattern
|> dosearch
2761 let itemcount = source#getitemcount
in
2762 let find start incr
=
2764 if i
= -1 || i
= itemcount
2767 if source#hasaction i
2769 else find (i
+ incr
)
2774 let set active first =
2775 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2777 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2780 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2782 let incr1 = if incr
> 0 then 1 else -1 in
2783 if isvisible m_first m_active
2786 let next = m_active
+ incr
in
2788 if next < 0 || next >= itemcount
2790 else find next incr1
2792 if abs
(m_active
- next) > fstate
.maxrows
2798 let first = m_first
+ incr
in
2799 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2801 let next = m_active
+ incr
in
2802 let next = bound
next 0 (itemcount - 1) in
2809 if isvisible first next
2816 let first = min
next m_first
in
2818 if abs
(next - first) > fstate
.maxrows
2824 let first = m_first
+ incr
in
2825 let first = bound
first 0 (itemcount - 1) in
2827 let next = m_active
+ incr
in
2828 let next = bound
next 0 (itemcount - 1) in
2829 let next = find next incr1 in
2831 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2833 let active = if m_active
= -1 then next else m_active
in
2838 if isvisible first active
2844 G.postRedisplay "listview navigate";
2848 | (@r
|@s) when Wsi.withctrl mask
->
2849 let incr = if key = @r
then -1 else 1 in
2851 match search (m_active
+ incr) m_qsearch
incr with
2853 state
.text <- m_qsearch ^
" [not found]";
2856 state
.text <- m_qsearch
;
2857 active, firstof m_first
active
2859 G.postRedisplay "listview ctrl-r/s";
2860 set1 active first m_qsearch
;
2862 | @insert
when Wsi.withctrl mask
->
2863 if m_active
>= 0 && m_active
< source#getitemcount
2865 let s, _ = source#getitem m_active
in
2871 if emptystr m_qsearch
2874 let qsearch = withoutlastutf8 m_qsearch
in
2878 G.postRedisplay "listview empty qsearch";
2879 set1 m_active m_first
E.s;
2883 match search m_active
qsearch ~
-1 with
2885 state
.text <- qsearch ^
" [not found]";
2888 state
.text <- qsearch;
2889 active, firstof m_first
active
2891 G.postRedisplay "listview backspace qsearch";
2892 set1 active first qsearch
2895 | key when (key != 0 && key land 0xff00 != 0xff00) ->
2896 let pattern = m_qsearch ^ toutf8
key in
2898 match search m_active
pattern 1 with
2900 state
.text <- pattern ^
" [not found]";
2903 state
.text <- pattern;
2904 active, firstof m_first
active
2906 G.postRedisplay "listview qsearch add";
2907 set1 active first pattern;
2911 if emptystr m_qsearch
2913 G.postRedisplay "list view escape";
2914 let mx, my
= state
.mpos
in
2918 source#exit ~uioh
:(coe self
)
2919 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2921 | None
-> m_prev_uioh
2926 G.postRedisplay "list view kill qsearch";
2927 coe {< m_qsearch
= E.s >}
2930 | @enter
| @kpenter
->
2932 let self = {< m_qsearch
= E.s >} in
2934 G.postRedisplay "listview enter";
2935 if m_active
>= 0 && m_active
< source#getitemcount
2937 source#exit ~uioh
:(coe self) ~cancel
:false
2938 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2941 source#exit ~uioh
:(coe self) ~cancel
:true
2942 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2945 begin match opt with
2946 | None
-> m_prev_uioh
2950 | @delete
| @kpdelete
->
2953 | @up
| @kpup
-> navigate ~
-1
2954 | @down
| @kpdown
-> navigate 1
2955 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2956 | @next | @kpnext
-> navigate fstate
.maxrows
2958 | @right
| @kpright
->
2960 G.postRedisplay "listview right";
2961 coe {< m_pan
= m_pan
- 1 >}
2963 | @left | @kpleft
->
2965 G.postRedisplay "listview left";
2966 coe {< m_pan
= m_pan
+ 1 >}
2968 | @home
| @kphome
->
2969 let active = find 0 1 in
2970 G.postRedisplay "listview home";
2974 let first = max
0 (itemcount - fstate
.maxrows
) in
2975 let active = find (itemcount - 1) ~
-1 in
2976 G.postRedisplay "listview end";
2979 | key when (key = 0 || key land 0xff00 = 0xff00) ->
2983 dolog
"listview unknown key %#x" key; coe self
2985 method key key mask
=
2986 match state
.mode
with
2987 | Textentry te
-> textentrykeyboard key mask te
; coe self
2990 | LinkNav
_ -> self#key1
key mask
2992 method button button down
x y _ =
2995 | 1 when vscrollhit x ->
2996 G.postRedisplay "listview scroll";
2999 let _, position, sh = self#
scrollph in
3000 if y > truncate
position && y < truncate
(position +. sh)
3002 state
.mstate
<- Mscrolly
;
3006 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3007 let first = truncate
(s *. float source#getitemcount
) in
3008 let first = min source#getitemcount
first in
3009 Some
(coe {< m_first
= first; m_active
= first >})
3011 state
.mstate
<- Mnone
;
3015 begin match self#elemunder
y with
3017 G.postRedisplay "listview click";
3018 source#exit ~uioh
:(coe {< m_active
= n >})
3019 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3023 | n when (n == 4 || n == 5) && not down
->
3024 let len = source#getitemcount
in
3026 if n = 5 && m_first
+ fstate
.maxrows
>= len
3030 let first = m_first
+ (if n == 4 then -1 else 1) in
3031 bound
first 0 (len - 1)
3033 G.postRedisplay "listview wheel";
3034 Some
(coe {< m_first
= first >})
3035 | n when (n = 6 || n = 7) && not down
->
3036 let inc = if n = 7 then -1 else 1 in
3037 G.postRedisplay "listview hwheel";
3038 Some
(coe {< m_pan
= m_pan
+ inc >})
3043 | None
-> m_prev_uioh
3046 method multiclick
_ x y = self#button
1 true x y
3049 match state
.mstate
with
3051 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3052 let first = truncate
(s *. float source#getitemcount
) in
3053 let first = min source#getitemcount
first in
3054 G.postRedisplay "listview motion";
3055 coe {< m_first
= first; m_active
= first >}
3063 method pmotion
x y =
3064 if x < state
.winw
- conf
.scrollbw
3067 match self#elemunder
y with
3068 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3069 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3073 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3078 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3082 method infochanged
_ = ()
3084 method scrollpw
= (0, 0.0, 0.0)
3086 let nfs = fstate
.fontsize
+ 1 in
3087 let y = m_first
* nfs in
3088 let itemcount = source#getitemcount
in
3089 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3090 let maxy = maxi * nfs in
3091 let p, h = scrollph y maxy in
3094 method modehash
= modehash
3095 method eformsgs
= false
3096 method alwaysscrolly
= true
3099 class outlinelistview ~zebra ~source
=
3100 let settext autonarrow
s =
3103 let ss = source#statestr
in
3107 else "{" ^
ss ^
"} [" ^
s ^
"]"
3108 else state
.text <- s
3114 ~source
:(source
:> lvsource
)
3116 ~modehash
:(findkeyhash conf
"outline")
3119 val m_autonarrow
= false
3121 method! key key mask
=
3123 if emptystr state
.text
3125 else fstate
.maxrows - 2
3127 let calcfirst first active =
3130 let rows = active - first in
3131 if rows > maxrows then active - maxrows else first
3135 let active = m_active
+ incr in
3136 let active = bound
active 0 (source#getitemcount
- 1) in
3137 let first = calcfirst m_first
active in
3138 G.postRedisplay "outline navigate";
3139 coe {< m_active
= active; m_first
= first >}
3141 let navscroll first =
3143 let dist = m_active
- first in
3149 else first + maxrows
3152 G.postRedisplay "outline navscroll";
3153 coe {< m_first
= first; m_active
= active >}
3155 let ctrl = Wsi.withctrl mask
in
3160 then (source#denarrow
; E.s)
3162 let pattern = source#renarrow
in
3163 if nonemptystr m_qsearch
3164 then (source#narrow m_qsearch
; m_qsearch
)
3168 settext (not m_autonarrow
) text;
3169 G.postRedisplay "toggle auto narrowing";
3170 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3172 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3174 G.postRedisplay "toggle auto narrowing";
3175 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3178 source#narrow m_qsearch
;
3180 then source#add_narrow_pattern m_qsearch
;
3181 G.postRedisplay "outline ctrl-n";
3182 coe {< m_first
= 0; m_active
= 0 >}
3185 let active = source#calcactive
(getanchor
()) in
3186 let first = firstof m_first
active in
3187 G.postRedisplay "outline ctrl-s";
3188 coe {< m_first
= first; m_active
= active >}
3191 G.postRedisplay "outline ctrl-u";
3192 if m_autonarrow
&& nonemptystr m_qsearch
3194 ignore
(source#renarrow
);
3195 settext m_autonarrow
E.s;
3196 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3199 source#del_narrow_pattern
;
3200 let pattern = source#renarrow
in
3202 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3204 settext m_autonarrow
text;
3205 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3209 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3210 G.postRedisplay "outline ctrl-l";
3211 coe {< m_first
= first >}
3213 | @tab
when m_autonarrow
->
3214 if nonemptystr m_qsearch
3216 G.postRedisplay "outline list view tab";
3217 source#add_narrow_pattern m_qsearch
;
3219 coe {< m_qsearch
= E.s >}
3223 | @escape
when m_autonarrow
->
3224 if nonemptystr m_qsearch
3225 then source#add_narrow_pattern m_qsearch
;
3228 | @enter
| @kpenter
when m_autonarrow
->
3229 if nonemptystr m_qsearch
3230 then source#add_narrow_pattern m_qsearch
;
3233 | key when m_autonarrow
&& (key != 0 && key land 0xff00 != 0xff00) ->
3234 let pattern = m_qsearch ^ toutf8
key in
3235 G.postRedisplay "outlinelistview autonarrow add";
3236 source#narrow
pattern;
3237 settext true pattern;
3238 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3240 | key when m_autonarrow
&& key = @backspace
->
3241 if emptystr m_qsearch
3244 let pattern = withoutlastutf8 m_qsearch
in
3245 G.postRedisplay "outlinelistview autonarrow backspace";
3246 ignore
(source#renarrow
);
3247 source#narrow
pattern;
3248 settext true pattern;
3249 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3251 | @up
| @kpup
when ctrl ->
3252 navscroll (max
0 (m_first
- 1))
3254 | @down
| @kpdown
when ctrl ->
3255 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3257 | @up
| @kpup
-> navigate ~
-1
3258 | @down
| @kpdown
-> navigate 1
3259 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3260 | @next | @kpnext
-> navigate fstate
.maxrows
3262 | @right
| @kpright
->
3266 G.postRedisplay "outline ctrl right";
3267 {< m_pan
= m_pan
+ 1 >}
3269 else self#updownlevel
1
3273 | @left | @kpleft
->
3277 G.postRedisplay "outline ctrl left";
3278 {< m_pan
= m_pan
- 1 >}
3280 else self#updownlevel ~
-1
3284 | @home
| @kphome
->
3285 G.postRedisplay "outline home";
3286 coe {< m_first
= 0; m_active
= 0 >}
3289 let active = source#getitemcount
- 1 in
3290 let first = max
0 (active - fstate
.maxrows) in
3291 G.postRedisplay "outline end";
3292 coe {< m_active
= active; m_first
= first >}
3294 | _ -> super#
key key mask
3297 let genhistoutlines () =
3299 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3300 compare c2
.lastvisit c1
.lastvisit
)
3302 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3303 let path = if nonemptystr origin
then origin
else path in
3304 let base = mbtoutf8
@@ Filename.basename
path in
3305 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3310 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3311 Config.save
leavebirdseye;
3312 state
.anchor <- anchor;
3313 state
.bookmarks
<- bookmarks
;
3314 state
.origin
<- origin
;
3317 let x0, y0, x1, y1 = conf
.trimfuzz
in
3318 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3319 reshape ~firsttime
:true state
.winw state
.winh
;
3320 opendoc path origin
;
3324 let makecheckers () =
3325 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3327 converted by Issac Trotts. July 25, 2002 *)
3328 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3329 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3330 let id = GlTex.gen_texture
() in
3331 GlTex.bind_texture ~target
:`texture_2d
id;
3332 GlPix.store
(`unpack_alignment
1);
3333 GlTex.image2d
image;
3334 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3335 [ `mag_filter `nearest
; `min_filter `nearest
];
3339 let setcheckers enabled
=
3340 match state
.checkerstexid
with
3342 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3344 | Some checkerstexid
->
3347 GlTex.delete_texture checkerstexid
;
3348 state
.checkerstexid
<- None
;
3352 let describe_location () =
3353 let fn = page_of_y state
.y in
3354 let ln = page_of_y
(state
.y + state
.winh
- hscrollh () - 1) in
3355 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3359 else (100. *. (float state
.y /. float maxy))
3363 Printf.sprintf
"page %d of %d [%.2f%%]"
3364 (fn+1) state
.pagecount
percent
3367 "pages %d-%d of %d [%.2f%%]"
3368 (fn+1) (ln+1) state
.pagecount
percent
3371 let setpresentationmode v
=
3372 let n = page_of_y state
.y in
3373 state
.anchor <- (n, 0.0, 1.0);
3374 conf
.presentation
<- v
;
3375 if conf
.fitmodel
= FitPage
3376 then reqlayout conf
.angle conf
.fitmodel
;
3381 let btos b = if b then "@Uradical" else E.s in
3382 let showextended = ref false in
3383 let leave mode
_ = state
.mode
<- mode
in
3386 val mutable m_l
= []
3387 val mutable m_a
= E.a
3388 val mutable m_prev_uioh
= nouioh
3389 val mutable m_prev_mode
= View
3391 inherit lvsourcebase
3393 method reset prev_mode prev_uioh
=
3394 m_a
<- Array.of_list
(List.rev m_l
);
3396 m_prev_mode
<- prev_mode
;
3397 m_prev_uioh
<- prev_uioh
;
3399 method int name get
set =
3401 (name
, `
int get
, 1, Action
(
3404 try set (int_of_string
s)
3406 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3410 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3411 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3415 method int_with_suffix name get
set =
3417 (name
, `intws get
, 1, Action
(
3420 try set (int_of_string_with_suffix
s)
3422 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3427 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3429 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3433 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3435 (name
, `
bool (btos, get
), offset
, Action
(
3442 method color name get
set =
3444 (name
, `
color get
, 1, Action
(
3446 let invalid = (nan
, nan
, nan
) in
3449 try color_of_string
s
3451 state
.text <- Printf.sprintf
"bad color `%s': %s"
3458 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3459 state
.text <- color_to_string
(get
());
3460 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3464 method string name get
set =
3466 (name
, `
string get
, 1, Action
(
3468 let ondone s = set s in
3469 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3470 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3474 method colorspace name get
set =
3476 (name
, `
string get
, 1, Action
(
3480 inherit lvsourcebase
3483 m_active
<- CSTE.to_int conf
.colorspace
;
3486 method getitemcount
=
3487 Array.length
CSTE.names
3490 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3491 ignore
(uioh
, first, pan
);
3492 if not cancel
then set active;
3494 method hasaction
_ = true
3498 let modehash = findkeyhash conf
"info" in
3499 coe (new listview ~zebra
:false ~helpmode
:false
3500 ~
source ~trusted
:true ~
modehash)
3503 method paxmark name get
set =
3505 (name
, `
string get
, 1, Action
(
3509 inherit lvsourcebase
3512 m_active
<- MTE.to_int conf
.paxmark
;
3515 method getitemcount
= Array.length
MTE.names
3516 method getitem
n = (MTE.names
.(n), 0)
3517 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3518 ignore
(uioh
, first, pan
);
3519 if not cancel
then set active;
3521 method hasaction
_ = true
3525 let modehash = findkeyhash conf
"info" in
3526 coe (new listview ~zebra
:false ~helpmode
:false
3527 ~
source ~trusted
:true ~
modehash)
3530 method fitmodel name get
set =
3532 (name
, `
string get
, 1, Action
(
3536 inherit lvsourcebase
3539 m_active
<- FMTE.to_int conf
.fitmodel
;
3542 method getitemcount
= Array.length
FMTE.names
3543 method getitem
n = (FMTE.names
.(n), 0)
3544 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3545 ignore
(uioh
, first, pan
);
3546 if not cancel
then set active;
3548 method hasaction
_ = true
3552 let modehash = findkeyhash conf
"info" in
3553 coe (new listview ~zebra
:false ~helpmode
:false
3554 ~
source ~trusted
:true ~
modehash)
3557 method caption
s offset
=
3558 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3560 method caption2
s f offset
=
3561 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3563 method getitemcount
= Array.length m_a
3566 let tostr = function
3567 | `
int f -> string_of_int
(f ())
3568 | `intws
f -> string_with_suffix_of_int
(f ())
3570 | `
color f -> color_to_string
(f ())
3571 | `
bool (btos, f) -> btos (f ())
3574 let name, t
, offset
, _ = m_a
.(n) in
3575 ((let s = tostr t
in
3577 then Printf.sprintf
"%s\t%s" name s
3581 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3586 match m_a
.(active) with
3587 | _, _, _, Action
f -> f uioh
3588 | _, _, _, Noaction
-> uioh
3599 method hasaction
n =
3601 | _, _, _, Action
_ -> true
3602 | _, _, _, Noaction
-> false
3604 initializer m_active
<- 1
3607 let rec fillsrc prevmode prevuioh
=
3608 let sep () = src#caption
E.s 0 in
3609 let colorp name get
set =
3611 (fun () -> color_to_string
(get
()))
3614 let c = color_of_string
v in
3617 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3620 let oldmode = state
.mode
in
3621 let birdseye = isbirdseye state
.mode
in
3623 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3625 src#
bool "presentation mode"
3626 (fun () -> conf
.presentation
)
3627 (fun v -> setpresentationmode v);
3629 src#
bool "ignore case in searches"
3630 (fun () -> conf
.icase
)
3631 (fun v -> conf
.icase
<- v);
3634 (fun () -> conf
.preload)
3635 (fun v -> conf
.preload <- v);
3637 src#
bool "highlight links"
3638 (fun () -> conf
.hlinks
)
3639 (fun v -> conf
.hlinks
<- v);
3641 src#
bool "under info"
3642 (fun () -> conf
.underinfo
)
3643 (fun v -> conf
.underinfo
<- v);
3645 src#
bool "persistent bookmarks"
3646 (fun () -> conf
.savebmarks
)
3647 (fun v -> conf
.savebmarks
<- v);
3649 src#fitmodel
"fit model"
3650 (fun () -> FMTE.to_string conf
.fitmodel
)
3651 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3653 src#
bool "trim margins"
3654 (fun () -> conf
.trimmargins
)
3655 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3657 src#
bool "persistent location"
3658 (fun () -> conf
.jumpback
)
3659 (fun v -> conf
.jumpback
<- v);
3662 src#
int "inter-page space"
3663 (fun () -> conf
.interpagespace
)
3665 conf
.interpagespace
<- n;
3666 docolumns conf
.columns
;
3668 match state
.layout with
3673 state
.maxy <- calcheight
();
3674 let y = getpagey
pageno in
3679 (fun () -> conf
.pagebias
)
3680 (fun v -> conf
.pagebias
<- v);
3682 src#
int "scroll step"
3683 (fun () -> conf
.scrollstep
)
3684 (fun n -> conf
.scrollstep
<- n);
3686 src#
int "horizontal scroll step"
3687 (fun () -> conf
.hscrollstep
)
3688 (fun v -> conf
.hscrollstep
<- v);
3690 src#
int "auto scroll step"
3692 match state
.autoscroll
with
3694 | _ -> conf
.autoscrollstep
)
3696 let n = boundastep state
.winh
n in
3697 if state
.autoscroll
<> None
3698 then state
.autoscroll
<- Some
n;
3699 conf
.autoscrollstep
<- n);
3702 (fun () -> truncate
(conf
.zoom *. 100.))
3703 (fun v -> setzoom ((float v) /. 100.));
3706 (fun () -> conf
.angle
)
3707 (fun v -> reqlayout v conf
.fitmodel
);
3709 src#
int "scroll bar width"
3710 (fun () -> conf
.scrollbw
)
3713 reshape state
.winw state
.winh
;
3716 src#
int "scroll handle height"
3717 (fun () -> conf
.scrollh
)
3718 (fun v -> conf
.scrollh
<- v;);
3720 src#
int "thumbnail width"
3721 (fun () -> conf
.thumbw
)
3723 conf
.thumbw
<- min
4096 v;
3726 leavebirdseye beye
false;
3733 let mode = state
.mode in
3734 src#
string "columns"
3736 match conf
.columns
with
3738 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3739 | Csplit
(count
, _) -> "-" ^ string_of_int count
3742 let n, a, b = multicolumns_of_string
v in
3743 setcolumns mode n a b);
3746 src#caption
"Pixmap cache" 0;
3747 src#int_with_suffix
"size (advisory)"
3748 (fun () -> conf
.memlimit
)
3749 (fun v -> conf
.memlimit
<- v);
3752 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3753 (string_with_suffix_of_int state
.memused
)
3754 (Hashtbl.length state
.tilemap
)) 1;
3757 src#caption
"Layout" 0;
3758 src#caption2
"Dimension"
3760 Printf.sprintf
"%dx%d (virtual %dx%d)"
3761 state
.winw state
.winh
3766 src#caption2
"Position" (fun () ->
3767 Printf.sprintf
"%dx%d" state
.x state
.y
3770 src#caption2
"Position" (fun () -> describe_location ()) 1
3774 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3775 "Save these parameters as global defaults at exit"
3776 (fun () -> conf
.bedefault
)
3777 (fun v -> conf
.bedefault
<- v)
3781 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3782 src#
bool ~offset
:0 ~
btos "Extended parameters"
3783 (fun () -> !showextended)
3784 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3788 (fun () -> conf
.checkers
)
3789 (fun v -> conf
.checkers
<- v; setcheckers v);
3790 src#
bool "update cursor"
3791 (fun () -> conf
.updatecurs
)
3792 (fun v -> conf
.updatecurs
<- v);
3793 src#
bool "scroll-bar on the left"
3794 (fun () -> conf
.leftscroll
)
3795 (fun v -> conf
.leftscroll
<- v);
3797 (fun () -> conf
.verbose
)
3798 (fun v -> conf
.verbose
<- v);
3799 src#
bool "invert colors"
3800 (fun () -> conf
.invert
)
3801 (fun v -> conf
.invert
<- v);
3803 (fun () -> conf
.maxhfit
)
3804 (fun v -> conf
.maxhfit
<- v);
3806 (fun () -> conf
.pax
!= None
)
3809 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3810 else conf
.pax
<- None
);
3811 src#
string "uri launcher"
3812 (fun () -> conf
.urilauncher
)
3813 (fun v -> conf
.urilauncher
<- v);
3814 src#
string "path launcher"
3815 (fun () -> conf
.pathlauncher
)
3816 (fun v -> conf
.pathlauncher
<- v);
3817 src#
string "tile size"
3818 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3821 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3822 conf
.tilew
<- max
64 w;
3823 conf
.tileh
<- max
64 h;
3826 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3829 src#
int "texture count"
3830 (fun () -> conf
.texcount
)
3833 then conf
.texcount
<- v
3834 else impmsg "failed to set texture count please retry later"
3836 src#
int "slice height"
3837 (fun () -> conf
.sliceheight
)
3839 conf
.sliceheight
<- v;
3840 wcmd "sliceh %d" conf
.sliceheight
;
3842 src#
int "anti-aliasing level"
3843 (fun () -> conf
.aalevel
)
3845 conf
.aalevel
<- bound
v 0 8;
3846 state
.anchor <- getanchor
();
3847 opendoc state
.path state
.password;
3849 src#
string "page scroll scaling factor"
3850 (fun () -> string_of_float conf
.pgscale)
3853 let s = float_of_string
v in
3856 state
.text <- Printf.sprintf
3857 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3860 src#
int "ui font size"
3861 (fun () -> fstate
.fontsize
)
3862 (fun v -> setfontsize (bound
v 5 100));
3863 src#
int "hint font size"
3864 (fun () -> conf
.hfsize
)
3865 (fun v -> conf
.hfsize
<- bound
v 5 100);
3866 colorp "background color"
3867 (fun () -> conf
.bgcolor
)
3868 (fun v -> conf
.bgcolor
<- v);
3869 src#
bool "crop hack"
3870 (fun () -> conf
.crophack
)
3871 (fun v -> conf
.crophack
<- v);
3872 src#
string "trim fuzz"
3873 (fun () -> irect_to_string conf
.trimfuzz
)
3876 conf
.trimfuzz
<- irect_of_string
v;
3878 then settrim true conf
.trimfuzz
;
3880 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3882 src#
string "throttle"
3884 match conf
.maxwait
with
3885 | None
-> "show place holder if page is not ready"
3888 then "wait for page to fully render"
3890 "wait " ^ string_of_float
time
3891 ^
" seconds before showing placeholder"
3895 let f = float_of_string
v in
3897 then conf
.maxwait
<- None
3898 else conf
.maxwait
<- Some
f
3900 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3902 src#
string "ghyll scroll"
3904 match conf
.ghyllscroll
with
3906 | Some nab
-> ghyllscroll_to_string nab
3909 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3912 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3914 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3916 src#
string "selection command"
3917 (fun () -> conf
.selcmd
)
3918 (fun v -> conf
.selcmd
<- v);
3919 src#
string "synctex command"
3920 (fun () -> conf
.stcmd
)
3921 (fun v -> conf
.stcmd
<- v);
3922 src#
string "pax command"
3923 (fun () -> conf
.paxcmd
)
3924 (fun v -> conf
.paxcmd
<- v);
3925 src#
string "ask password command"
3926 (fun () -> conf
.passcmd)
3927 (fun v -> conf
.passcmd <- v);
3928 src#
string "save path command"
3929 (fun () -> conf
.savecmd
)
3930 (fun v -> conf
.savecmd
<- v);
3931 src#colorspace
"color space"
3932 (fun () -> CSTE.to_string conf
.colorspace
)
3934 conf
.colorspace
<- CSTE.of_int
v;
3938 src#paxmark
"pax mark method"
3939 (fun () -> MTE.to_string conf
.paxmark
)
3940 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3944 (fun () -> conf
.usepbo
)
3945 (fun v -> conf
.usepbo
<- v);
3946 src#
bool "mouse wheel scrolls pages"
3947 (fun () -> conf
.wheelbypage
)
3948 (fun v -> conf
.wheelbypage
<- v);
3949 src#
bool "open remote links in a new instance"
3950 (fun () -> conf
.riani
)
3951 (fun v -> conf
.riani
<- v);
3952 src#
bool "edit annotations inline"
3953 (fun () -> conf
.annotinline
)
3954 (fun v -> conf
.annotinline
<- v);
3958 src#caption
"Document" 0;
3959 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3960 src#caption2
"Pages"
3961 (fun () -> string_of_int state
.pagecount
) 1;
3962 src#caption2
"Dimensions"
3963 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3967 src#caption
"Trimmed margins" 0;
3968 src#caption2
"Dimensions"
3969 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3973 src#caption
"OpenGL" 0;
3974 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3975 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3978 src#caption
"Location" 0;
3979 if nonemptystr state
.origin
3980 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3981 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3983 src#reset prevmode prevuioh
;
3988 let prevmode = state
.mode
3989 and prevuioh
= state
.uioh in
3990 fillsrc prevmode prevuioh
;
3991 let source = (src :> lvsource
) in
3992 let modehash = findkeyhash conf
"info" in
3993 state
.uioh <- coe (object (self)
3994 inherit listview ~zebra
:false ~helpmode
:false
3995 ~
source ~trusted
:true ~
modehash as super
3996 val mutable m_prevmemused
= 0
3997 method! infochanged
= function
3999 if m_prevmemused
!= state
.memused
4001 m_prevmemused
<- state
.memused
;
4002 G.postRedisplay "memusedchanged";
4004 | Pdim
-> G.postRedisplay "pdimchanged"
4005 | Docinfo
-> fillsrc prevmode prevuioh
4007 method! key key mask
=
4008 if not
(Wsi.withctrl mask
)
4011 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4012 | @right
| @kpright
-> coe (self#updownlevel
1)
4013 | _ -> super#
key key mask
4014 else super#
key key mask
4016 G.postRedisplay "info";
4022 inherit lvsourcebase
4023 method getitemcount
= Array.length state
.help
4025 let s, l, _ = state
.help
.(n) in
4028 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4032 match state
.help
.(active) with
4033 | _, _, Action
f -> Some
(f uioh)
4034 | _, _, Noaction
-> Some
uioh
4043 method hasaction
n =
4044 match state
.help
.(n) with
4045 | _, _, Action
_ -> true
4046 | _, _, Noaction
-> false
4052 let modehash = findkeyhash conf
"help" in
4054 state
.uioh <- coe (new listview
4055 ~zebra
:false ~helpmode
:true
4056 ~
source ~trusted
:true ~
modehash);
4057 G.postRedisplay "help";
4063 inherit lvsourcebase
4064 val mutable m_items
= E.a
4066 method getitemcount
= 1 + Array.length m_items
4071 else m_items
.(n-1), 0
4073 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4078 then Buffer.clear state
.errmsgs
;
4085 method hasaction
n =
4089 state
.newerrmsgs
<- false;
4090 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4091 m_items
<- Array.of_list
l
4100 let source = (msgsource :> lvsource
) in
4101 let modehash = findkeyhash conf
"listview" in
4102 state
.uioh <- coe (object
4103 inherit listview ~zebra
:false ~helpmode
:false
4104 ~
source ~trusted
:false ~
modehash as super
4107 then msgsource#reset
;
4110 G.postRedisplay "msgs";
4114 let editor = getenvwithdef
"EDITOR" E.s in
4118 let tmppath = Filename.temp_file
"llpp" "note" in
4121 let oc = open_out
tmppath in
4125 let execstr = editor ^
" " ^
tmppath in
4127 match spawn
execstr [] with
4128 | (exception exn
) ->
4129 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4132 match Unix.waitpid
[] pid with
4133 | (exception exn
) ->
4134 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4138 | Unix.WEXITED
0 -> filecontents
tmppath
4140 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4142 | Unix.WSIGNALED
n ->
4143 impmsg "editor process(%s) was killed by signal %d" execstr n;
4145 | Unix.WSTOPPED
n ->
4146 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4149 match Unix.unlink
tmppath with
4150 | (exception exn
) ->
4151 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4156 let enterannotmode opaque slinkindex
=
4159 inherit lvsourcebase
4160 val mutable m_text
= E.s
4161 val mutable m_items
= E.a
4163 method getitemcount
= Array.length m_items
4166 let label, _func
= m_items
.(n) in
4169 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4170 ignore
(uioh, first, pan
);
4173 let _label, func
= m_items
.(active) in
4178 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4181 let rec split accu b i
=
4183 if p = String.length
s
4184 then (String.sub
s b (p-b), unit) :: accu
4186 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4188 let ss = if i
= 0 then E.s else String.sub
s b i
in
4189 split ((ss, unit)::accu) (p+1) 0
4194 wcmd "freepage %s" (~
> opaque);
4196 Hashtbl.fold (fun key opaque'
accu ->
4197 if opaque'
= opaque'
4198 then key :: accu else accu) state
.pagemap
[]
4200 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4205 delannot
opaque slinkindex
;
4208 let edit inline
() =
4213 modannot
opaque slinkindex
s;
4219 let mode = state
.mode in
4222 ("annotation: ", m_text
, None
, textentry, update, true),
4223 fun _ -> state
.mode <- mode);
4227 let s = getusertext m_text
in
4232 ( "[Copy]", fun () -> selstring m_text
)
4233 :: ("[Delete]", dele)
4234 :: ("[Edit]", edit conf
.annotinline
)
4236 :: split [] 0 0 |> List.rev
|> Array.of_list
4243 let s = getannotcontents
opaque slinkindex
in
4246 let source = (msgsource :> lvsource
) in
4247 let modehash = findkeyhash conf
"listview" in
4248 state
.uioh <- coe (object
4249 inherit listview ~zebra
:false ~helpmode
:false
4250 ~
source ~trusted
:false ~
modehash
4252 G.postRedisplay "enterannotmode";
4255 let gotounder under =
4256 let getpath filename
=
4258 if nonemptystr filename
4260 if Filename.is_relative filename
4262 let dir = Filename.dirname state
.path in
4264 if Filename.is_implicit
dir
4265 then Filename.concat
(Sys.getcwd
()) dir
4268 Filename.concat
dir filename
4272 if Sys.file_exists
path
4277 | Ulinkgoto
(pageno, top) ->
4281 gotopage1 pageno top;
4284 | Ulinkuri
s -> gotouri
s
4286 | Uremote
(filename
, pageno) ->
4287 let path = getpath filename
in
4292 let command = Printf.sprintf
"%s -page %d %S" !selfexec pageno path in
4293 match spawn
command [] with
4295 | (exception exn
) ->
4296 dolog
"failed to execute `%s': %s" command @@ exntos exn
4298 let anchor = getanchor
() in
4299 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4300 state
.origin
<- E.s;
4301 state
.anchor <- (pageno, 0.0, 0.0);
4302 state
.ranchors
<- ranchor :: state
.ranchors
;
4305 else impmsg "cannot find %s" filename
4307 | Uremotedest
(filename
, destname
) ->
4308 let path = getpath filename
in
4313 let command = !selfexec ^
" " ^
path ^
" -dest " ^ destname
in
4314 match spawn
command [] with
4315 | (exception exn
) ->
4316 dolog
"failed to execute `%s': %s" command @@ exntos exn
4319 let anchor = getanchor
() in
4320 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4321 state
.origin
<- E.s;
4322 state
.nameddest
<- destname
;
4323 state
.ranchors
<- ranchor :: state
.ranchors
;
4326 else impmsg "cannot find %s" filename
4328 | Uunexpected
_ | Ulaunch
_ | Unamed
_ | Utext
_ | Unone
-> ()
4329 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4332 let gotooutline (_, _, kind
) =
4336 let (pageno, y, _) = anchor in
4338 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4342 | Ouri
uri -> gotounder (Ulinkuri
uri)
4343 | Olaunch cmd
-> gotounder (Ulaunch cmd
)
4344 | Oremote remote
-> gotounder (Uremote remote
)
4345 | Ohistory hist
-> gotohist hist
4346 | Oremotedest remotedest
-> gotounder (Uremotedest remotedest
)
4349 let outlinesource fetchoutlines
=
4351 inherit lvsourcebase
4352 val mutable m_items
= E.a
4353 val mutable m_minfo
= E.a
4354 val mutable m_orig_items
= E.a
4355 val mutable m_orig_minfo
= E.a
4356 val mutable m_narrow_patterns
= []
4357 val mutable m_gen
= -1
4359 method getitemcount
= Array.length m_items
4362 let s, n, _ = m_items
.(n) in
4365 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4366 ignore
(uioh, first);
4368 if m_narrow_patterns
= []
4369 then m_orig_items
, m_orig_minfo
4370 else m_items
, m_minfo
4377 gotooutline m_items
.(active);
4385 method hasaction
_ = true
4388 if Array.length m_items
!= Array.length m_orig_items
4391 match m_narrow_patterns
with
4393 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4395 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4399 match m_narrow_patterns
with
4402 | head
:: _ -> "@Uellipsis" ^ head
4404 method narrow
pattern =
4405 match Str.regexp_case_fold
pattern with
4406 | (exception _) -> ()
4408 let rec loop accu minfo n =
4411 m_items
<- Array.of_list
accu;
4412 m_minfo
<- Array.of_list
minfo;
4415 let (s, _, _) as o = m_items
.(n) in
4417 match Str.search_forward re
s 0 with
4418 | (exception Not_found
) -> accu, minfo
4419 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4421 loop accu minfo (n-1)
4423 loop [] [] (Array.length m_items
- 1)
4425 method! getminfo
= m_minfo
4428 m_orig_items
<- fetchoutlines
();
4429 m_minfo
<- m_orig_minfo
;
4430 m_items
<- m_orig_items
4432 method add_narrow_pattern
pattern =
4433 m_narrow_patterns
<- pattern :: m_narrow_patterns
4435 method del_narrow_pattern
=
4436 match m_narrow_patterns
with
4437 | _ :: rest
-> m_narrow_patterns
<- rest
4442 match m_narrow_patterns
with
4443 | pattern :: [] -> self#narrow
pattern; pattern
4445 List.fold_left
(fun accu pattern ->
4446 self#narrow
pattern;
4447 pattern ^
"@Uellipsis" ^
accu) E.s list
4449 method calcactive
anchor =
4450 let rely = getanchory anchor in
4451 let rec loop n best bestd
=
4452 if n = Array.length m_items
4455 let _, _, kind
= m_items
.(n) in
4458 let orely = getanchory anchor in
4459 let d = abs
(orely - rely) in
4462 else loop (n+1) best bestd
4463 | Onone
| Oremote
_ | Olaunch
_
4464 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4465 loop (n+1) best bestd
4469 method reset
anchor items =
4470 if state
.gen
!= m_gen
4472 m_orig_items
<- items;
4474 m_narrow_patterns
<- [];
4476 m_orig_minfo
<- E.a;
4480 if items != m_orig_items
4482 m_orig_items
<- items;
4483 if m_narrow_patterns
== []
4484 then m_items
<- items;
4487 let active = self#calcactive
anchor in
4489 m_first
<- firstof m_first
active
4493 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4494 let mkselector sourcetype
=
4495 let fetchoutlines () =
4496 match sourcetype
with
4497 | `bookmarks
-> Array.of_list state
.bookmarks
4498 | `outlines
-> state
.outlines
4499 | `history
-> genhistoutlines ()
4501 let source = outlinesource fetchoutlines in
4503 let outlines = fetchoutlines () in
4504 if Array.length
outlines = 0
4506 showtext ' ' errmsg
;
4510 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4511 let anchor = getanchor
() in
4512 source#reset
anchor outlines;
4513 state
.text <- source#greetmsg
;
4515 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4516 G.postRedisplay "enter selector";
4519 let mkenter sourcetype errmsg
=
4520 let enter = mkselector sourcetype
in
4521 fun () -> enter errmsg
4523 (**)mkenter `
outlines "document has no outline"
4524 , mkenter `bookmarks
"document has no bookmarks (yet)"
4525 , mkenter `history
"history is empty"
4528 let quickbookmark ?title
() =
4529 match state
.layout with
4535 let tm = Unix.localtime
(now
()) in
4537 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4541 (tm.Unix.tm_year
+ 1900)
4544 | Some
title -> title
4546 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4549 let setautoscrollspeed step goingdown
=
4550 let incr = max
1 ((abs step
) / 2) in
4551 let incr = if goingdown
then incr else -incr in
4552 let astep = boundastep state
.winh
(step
+ incr) in
4553 state
.autoscroll
<- Some
astep;
4557 match conf
.columns
with
4559 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4562 let panbound x = bound
x (-state
.w) (wadjsb () + state
.winw
);;
4564 let existsinrow pageno (columns
, coverA
, coverB
) p =
4565 let last = ((pageno - coverA
) mod columns
) + columns
in
4566 let rec any = function
4569 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4573 then (if l.pageno = last then false else any rest
)
4581 match state
.layout with
4583 let pageno = page_of_y state
.y in
4584 gotoghyll (getpagey
(pageno+1))
4586 match conf
.columns
with
4588 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4590 let y = clamp (pgscale state
.winh
) in
4593 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4594 gotoghyll (getpagey
pageno)
4595 | Cmulti
((c, _, _) as cl, _) ->
4596 if conf
.presentation
4597 && (existsinrow l.pageno cl
4598 (fun l -> l.pageh
> l.pagey + l.pagevh))
4600 let y = clamp (pgscale state
.winh
) in
4603 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4604 gotoghyll (getpagey
pageno)
4606 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4608 let pagey, pageh
= getpageyh
l.pageno in
4609 let pagey = pagey + pageh
* l.pagecol
in
4610 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4611 gotoghyll (pagey + pageh
+ ips)
4615 match state
.layout with
4617 let pageno = page_of_y state
.y in
4618 gotoghyll (getpagey
(pageno-1))
4620 match conf
.columns
with
4622 if conf
.presentation
&& l.pagey != 0
4624 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4626 let pageno = max
0 (l.pageno-1) in
4627 gotoghyll (getpagey
pageno)
4628 | Cmulti
((c, _, coverB
) as cl, _) ->
4629 if conf
.presentation
&&
4630 (existsinrow l.pageno cl (fun l -> l.pagey != 0))
4632 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4635 if l.pageno = state
.pagecount
- coverB
4639 let pageno = max
0 (l.pageno-decr) in
4640 gotoghyll (getpagey
pageno)
4648 let pageno = max
0 (l.pageno-1) in
4649 let pagey, pageh
= getpageyh
pageno in
4652 let pagey, pageh
= getpageyh
l.pageno in
4653 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4659 if emptystr conf
.savecmd
4660 then error
"don't know where to save modified document"
4662 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4665 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4670 let tmp = path ^
".tmp" in
4672 Unix.rename
tmp path;
4675 let viewkeyboard key mask
=
4677 let mode = state
.mode in
4678 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4681 G.postRedisplay "view:enttext"
4683 let ctrl = Wsi.withctrl mask
in
4685 if key >= 0xffb0 && key < 0xffb9 then key - 0xffb0 + 48 else key
4691 if hasunsavedchanges
()
4695 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4697 state
.mode <- LinkNav
(Ltgendir
0);
4700 else impmsg "keyboard link navigation does not work under rotation"
4703 begin match state
.mstate
with
4706 G.postRedisplay "kill rect";
4709 | Mscrolly
| Mscrollx
4712 begin match state
.mode with
4715 G.postRedisplay "esc leave linknav"
4719 match state
.ranchors
with
4721 | (path, password, anchor, origin
) :: rest
->
4722 state
.ranchors
<- rest
;
4723 state
.anchor <- anchor;
4724 state
.origin
<- origin
;
4725 state
.nameddest
<- E.s;
4726 opendoc path password
4731 gotoghyll (getnav ~
-1)
4742 Hashtbl.iter
(fun _ opaque ->
4744 Hashtbl.clear state
.prects
) state
.pagemap
;
4745 G.postRedisplay "dehighlight";
4747 | @slash
| @question
->
4748 let ondone isforw
s =
4749 cbput state
.hists
.pat
s;
4750 state
.searchpattern
<- s;
4753 let s = String.make
1 (Char.chr
key) in
4754 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4755 textentry, ondone (key = @slash
), true)
4757 | @plus
| @kpplus
| @equals
when ctrl ->
4758 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4759 setzoom (conf
.zoom +. incr)
4761 | @plus
| @kpplus
->
4764 try int_of_string
s with exc
->
4765 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4771 state
.text <- "page bias is now " ^ string_of_int
n;
4774 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4776 | @minus
| @kpminus
when ctrl ->
4777 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4778 setzoom (max
0.01 (conf
.zoom -. decr))
4780 | @minus
| @kpminus
->
4781 let ondone msg
= state
.text <- msg
in
4783 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4784 optentry state
.mode, ondone, true
4795 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4797 match conf
.columns
with
4798 | Csingle
_ | Cmulti
_ -> 1
4799 | Csplit
(n, _) -> n
4801 let h = state
.winh
-
4802 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4804 let zoom = zoomforh state
.winw
h (vscrollw ()) cols in
4805 if zoom > 0.0 && (key = 50 || zoom < 1.0)
4810 match conf
.fitmodel
with
4811 | FitWidth
-> FitProportional
4812 | FitProportional
-> FitPage
4813 | FitPage
-> FitWidth
4815 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4816 reqlayout conf
.angle
fm
4824 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4825 when not
ctrl -> (* 0..9 *)
4828 try int_of_string
s with exc
->
4829 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exc
;
4835 cbput state
.hists
.pag
(string_of_int
n);
4836 gotopage1 (n + conf
.pagebias
- 1) 0;
4839 let pageentry text key =
4840 match Char.unsafe_chr
key with
4841 | '
g'
-> TEdone
text
4842 | _ -> intentry text key
4844 let text = String.make
1 (Char.chr
key) in
4845 enttext (":", text, Some
(onhist state
.hists
.pag
),
4846 pageentry, ondone, true)
4849 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4850 reshape state
.winw state
.winh
;
4853 state
.bzoom
<- not state
.bzoom
;
4855 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4858 conf
.hlinks
<- not conf
.hlinks
;
4859 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4860 G.postRedisplay "toggle highlightlinks";
4863 if conf
.angle
mod 360 = 0
4865 state
.glinks
<- true;
4866 let mode = state
.mode in
4869 (":", E.s, None
, linknentry, linknact gotounder, false),
4871 state
.glinks
<- false;
4875 G.postRedisplay "view:linkent(F)"
4877 else impmsg "hint mode does not work under rotation"
4880 state
.glinks
<- true;
4881 let mode = state
.mode in
4882 state
.mode <- Textentry
(
4884 ":", E.s, None
, linknentry, linknact (fun under ->
4885 selstring (undertext under);
4889 state
.glinks
<- false;
4893 G.postRedisplay "view:linkent"
4896 begin match state
.autoscroll
with
4898 conf
.autoscrollstep
<- step
;
4899 state
.autoscroll
<- None
4901 if conf
.autoscrollstep
= 0
4902 then state
.autoscroll
<- Some
1
4903 else state
.autoscroll
<- Some conf
.autoscrollstep
4907 launchpath () (* XXX where do error messages go? *)
4910 setpresentationmode (not conf
.presentation
);
4911 showtext ' '
("presentation mode " ^
4912 if conf
.presentation
then "on" else "off");
4915 if List.mem
Wsi.Fullscreen state
.winstate
4916 then Wsi.reshape conf
.cwinw conf
.cwinh
4917 else Wsi.fullscreen
()
4920 search state
.searchpattern
false
4923 search state
.searchpattern
true
4926 begin match state
.layout with
4929 gotoghyll (getpagey
l.pageno)
4935 | @delete
| @kpdelete
-> (* delete *)
4939 showtext ' '
(describe_location ());
4942 begin match state
.layout with
4945 Wsi.reshape (l.pagew
+ vscrollw ()) l.pageh
;
4950 enterbookmarkmode
()
4958 | @e when Buffer.length state
.errmsgs
> 0 ->
4963 match state
.layout with
4968 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4971 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4975 showtext ' '
"Quick bookmark added";
4978 begin match state
.layout with
4980 let rect = getpdimrect
l.pagedimno
in
4984 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4985 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4987 (truncate
(rect.(1) -. rect.(0)),
4988 truncate
(rect.(3) -. rect.(0)))
4990 let w = truncate
((float w)*.conf
.zoom)
4991 and h = truncate
((float h)*.conf
.zoom) in
4994 state
.anchor <- getanchor
();
4995 Wsi.reshape (w + vscrollw ()) (h + conf
.interpagespace
)
4997 G.postRedisplay "z";
5002 | @x -> state
.roam
()
5005 reqlayout (conf
.angle
+
5006 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5010 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5012 G.postRedisplay "brightness";
5014 | @c when state
.mode = View
->
5019 let m = (wadjsb () + state
.winw
- state
.w) / 2 in
5021 gotoy_and_clear_text state
.y
5025 match state
.prevcolumns
with
5026 | None
-> (1, 0, 0), 1.0
5027 | Some
(columns
, z
) ->
5030 | Csplit
(c, _) -> -c, 0, 0
5031 | Cmulti
((c, a, b), _) -> c, a, b
5032 | Csingle
_ -> 1, 0, 0
5036 setcolumns View
c a b;
5039 | @down
| @up
when ctrl && Wsi.withshift mask
->
5040 let zoom, x = state
.prevzoom
in
5044 | @k
| @up
| @kpup
->
5045 begin match state
.autoscroll
with
5047 begin match state
.mode with
5048 | Birdseye beye
-> upbirdseye 1 beye
5053 then gotoy_and_clear_text (clamp ~
-(state
.winh
/2))
5055 if not
(Wsi.withshift mask
) && conf
.presentation
5057 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5061 setautoscrollspeed n false
5064 | @j
| @down
| @kpdown
->
5065 begin match state
.autoscroll
with
5067 begin match state
.mode with
5068 | Birdseye beye
-> downbirdseye 1 beye
5073 then gotoy_and_clear_text (clamp (state
.winh
/2))
5075 if not
(Wsi.withshift mask
) && conf
.presentation
5077 else gotoghyll1 true (clamp (conf
.scrollstep
))
5081 setautoscrollspeed n true
5084 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5090 else conf
.hscrollstep
5092 let dx = if key = @left || key = @kpleft
then dx else -dx in
5093 state
.x <- panbound (state
.x + dx);
5094 gotoy_and_clear_text state
.y
5097 G.postRedisplay "left/right"
5100 | @prior
| @kpprior
->
5104 match state
.layout with
5106 | l :: _ -> state
.y - l.pagey
5108 clamp (pgscale (-state
.winh
))
5112 | @next | @kpnext
->
5116 match List.rev state
.layout with
5118 | l :: _ -> getpagey
l.pageno
5120 clamp (pgscale state
.winh
)
5124 | @g | @home
| @kphome
->
5127 | @G
| @jend
| @kpend
->
5129 gotoghyll (clamp state
.maxy)
5131 | @right
| @kpright
when Wsi.withalt mask
->
5132 gotoghyll (getnav 1)
5133 | @left | @kpleft
when Wsi.withalt mask
->
5134 gotoghyll (getnav ~
-1)
5139 | @v when conf
.debug
->
5142 match getopaque l.pageno with
5145 let x0, y0, x1, y1 = pagebbox
opaque in
5146 let a,b = float x0, float y0 in
5147 let c,d = float x1, float y0 in
5148 let e,f = float x1, float y1 in
5149 let h,j
= float x0, float y1 in
5150 let rect = (a,b,c,d,e,f,h,j
) in
5152 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5153 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5155 G.postRedisplay "v";
5158 let mode = state
.mode in
5159 let cmd = ref E.s in
5160 let onleave = function
5161 | Cancel
-> state
.mode <- mode
5164 match getopaque l.pageno with
5165 | Some
opaque -> pipesel opaque !cmd
5166 | None
-> ()) state
.layout;
5170 cbput state
.hists
.sel
s;
5174 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5176 G.postRedisplay "|";
5177 state
.mode <- Textentry
(te, onleave);
5180 vlog "huh? %s" (Wsi.keyname
key)
5183 let linknavkeyboard key mask
linknav =
5184 let getpage pageno =
5185 let rec loop = function
5187 | l :: _ when l.pageno = pageno -> Some
l
5188 | _ :: rest
-> loop rest
5189 in loop state
.layout
5191 let doexact (pageno, n) =
5192 match getopaque pageno, getpage pageno with
5193 | Some
opaque, Some
l ->
5194 if key = @enter || key = @kpenter
5196 let under = getlink
opaque n in
5197 G.postRedisplay "link gotounder";
5204 Some
(findlink
opaque LDfirst
), -1
5207 Some
(findlink
opaque LDlast
), 1
5210 Some
(findlink
opaque (LDleft
n)), -1
5213 Some
(findlink
opaque (LDright
n)), 1
5216 Some
(findlink
opaque (LDup
n)), -1
5219 Some
(findlink
opaque (LDdown
n)), 1
5224 begin match findpwl
l.pageno dir with
5228 state
.mode <- LinkNav
(Ltgendir
dir);
5229 let y, h = getpageyh
pageno in
5232 then y + h - state
.winh
5237 begin match getopaque pageno, getpage pageno with
5238 | Some
opaque, Some
_ ->
5240 let ld = if dir > 0 then LDfirst
else LDlast
in
5243 begin match link with
5245 showlinktype (getlink
opaque m);
5246 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5247 G.postRedisplay "linknav jpage";
5248 | Lnotfound
-> notfound dir
5254 begin match opt with
5255 | Some Lnotfound
-> pwl l dir;
5256 | Some
(Lfound
m) ->
5260 let _, y0, _, y1 = getlinkrect
opaque m in
5262 then gotopage1 l.pageno y0
5264 let d = fstate
.fontsize
+ 1 in
5265 if y1 - l.pagey > l.pagevh - d
5266 then gotopage1 l.pageno (y1 - state
.winh
- hscrollh () + d)
5267 else G.postRedisplay "linknav";
5269 showlinktype (getlink
opaque m);
5270 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5273 | None
-> viewkeyboard key mask
5275 | _ -> viewkeyboard key mask
5280 G.postRedisplay "leave linknav"
5284 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5285 | Ltexact exact
-> doexact exact
5288 let keyboard key mask
=
5289 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5290 then wcmd "interrupt"
5291 else state
.uioh <- state
.uioh#
key key mask
5294 let birdseyekeyboard key mask
5295 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5297 match conf
.columns
with
5299 | Cmulti
((c, _, _), _) -> c
5300 | Csplit
_ -> failwith
"bird's eye split mode"
5302 let pgh layout = List.fold_left
5303 (fun m l -> max
l.pageh
m) state
.winh
layout in
5305 | @l when Wsi.withctrl mask
->
5306 let y, h = getpageyh
pageno in
5307 let top = (state
.winh
- h) / 2 in
5308 gotoy (max
0 (y - top))
5309 | @enter | @kpenter
-> leavebirdseye beye
false
5310 | @escape
-> leavebirdseye beye
true
5311 | @up
-> upbirdseye incr beye
5312 | @down
-> downbirdseye incr beye
5313 | @left -> upbirdseye 1 beye
5314 | @right
-> downbirdseye 1 beye
5317 begin match state
.layout with
5321 state
.mode <- Birdseye
(
5322 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5324 gotopage1 l.pageno 0;
5327 let layout = layout (state
.y-state
.winh
) (pgh state
.layout) in
5329 | [] -> gotoy (clamp (-state
.winh
))
5331 state
.mode <- Birdseye
(
5332 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5334 gotopage1 l.pageno 0
5337 | [] -> gotoy (clamp (-state
.winh
))
5341 begin match List.rev state
.layout with
5343 let layout = layout (state
.y + (pgh state
.layout)) state
.winh
in
5344 begin match layout with
5346 let incr = l.pageh
- l.pagevh in
5351 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5353 G.postRedisplay "birdseye pagedown";
5355 else gotoy (clamp (incr + conf
.interpagespace
*2));
5359 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5360 gotopage1 l.pageno 0;
5363 | [] -> gotoy (clamp state
.winh
)
5367 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5371 let pageno = state
.pagecount
- 1 in
5372 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5373 if not
(pagevisible state
.layout pageno)
5376 match List.rev state
.pdims
with
5378 | (_, _, h, _) :: _ -> h
5380 gotoy (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5381 else G.postRedisplay "birdseye end";
5383 | _ -> viewkeyboard key mask
5388 match state
.mode with
5389 | Textentry
_ -> scalecolor 0.4
5391 | View
-> scalecolor 1.0
5392 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5393 if l.pageno = hooverpageno
5396 if l.pageno = pageno
5398 let c = scalecolor 1.0 in
5400 GlDraw.line_width
3.0;
5401 let dispx = xadjsb () + l.pagedispx in
5403 (float (dispx-1)) (float (l.pagedispy-1))
5404 (float (dispx+l.pagevw+1))
5405 (float (l.pagedispy+l.pagevh+1))
5407 GlDraw.line_width
1.0;
5416 let postdrawpage l linkindexbase
=
5417 match getopaque l.pageno with
5419 if tileready l l.pagex
l.pagey
5421 let x = l.pagedispx - l.pagex
+ xadjsb ()
5422 and y = l.pagedispy - l.pagey in
5424 match conf
.columns
with
5425 | Csingle
_ | Cmulti
_ ->
5426 (if conf
.hlinks
then 1 else 0)
5428 && not
(isbirdseye state
.mode) then 2 else 0)
5432 match state
.mode with
5433 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5439 Hashtbl.find_all state
.prects
l.pageno |>
5440 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5441 postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
);
5446 let scrollindicator () =
5447 let sbw, ph
, sh = state
.uioh#
scrollph in
5448 let sbh, pw, sw = state
.uioh#scrollpw
in
5453 else ((state
.winw
- sbw), state
.winw
, 0)
5456 GlDraw.color (0.64, 0.64, 0.64);
5457 filledrect (float x0) 0. (float x1) (float state
.winh
);
5459 (float hx0
) (float (state
.winh
- sbh))
5460 (float (hx0
+ wadjsb () + state
.winw
)) (float state
.winh
)
5462 GlDraw.color (0.0, 0.0, 0.0);
5464 filledrect (float x0) ph
(float x1) (ph
+. sh);
5465 let pw = pw +. float hx0
in
5466 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5470 match state
.mstate
with
5471 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5474 | Msel
((x0, y0), (x1, y1)) ->
5475 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5476 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5477 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5478 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5481 let showrects = function [] -> () | rects
->
5483 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5484 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5486 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5488 if l.pageno = pageno
5490 let dx = float (l.pagedispx - l.pagex
) in
5491 let dy = float (l.pagedispy - l.pagey) in
5492 let r, g, b, alpha = c in
5493 GlDraw.color (r, g, b) ~
alpha;
5494 Raw.sets_float state
.vraw ~
pos:0
5499 GlArray.vertex `two state
.vraw
;
5500 GlArray.draw_arrays `triangle_strip ~
first:0 ~count
:4;
5509 GlClear.color (scalecolor2 conf
.bgcolor
);
5510 GlClear.clear
[`
color];
5511 List.iter
drawpage state
.layout;
5513 match state
.mode with
5514 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5515 begin match getopaque pageno with
5517 let dx = xadjsb () in
5518 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5519 let x0 = x0 + dx and x1 = x1 + dx in
5520 let color = (0.0, 0.0, 0.5, 0.5) in
5527 | None
-> state
.rects
5529 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5532 | View
-> state
.rects
5535 let rec postloop linkindexbase
= function
5537 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5538 postloop linkindexbase rest
5542 postloop 0 state
.layout;
5544 begin match state
.mstate
with
5545 | Mzoomrect
((x0, y0), (x1, y1)) ->
5547 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5548 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5549 filledrect (float x0) (float y0) (float x1) (float y1);
5553 | Mscrolly
| Mscrollx
5562 let zoomrect x y x1 y1 =
5565 and y0 = min
y y1 in
5566 gotoy (state
.y + y0);
5567 state
.anchor <- getanchor
();
5568 let zoom = (float state
.w) /. float (x1 - x0) in
5571 let adjw = wadjsb () + state
.winw
in
5573 then (adjw - state
.w) / 2
5576 match conf
.fitmodel
with
5577 | FitWidth
| FitProportional
-> simple ()
5579 match conf
.columns
with
5581 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5582 | Cmulti
_ | Csingle
_ -> simple ()
5584 state
.x <- (state
.x + margin) - x0;
5589 let annot inline
x y =
5590 match unproject x y with
5591 | Some
(opaque, n, ux
, uy
) ->
5593 addannot
opaque ux uy
text;
5594 wcmd "freepage %s" (~
> opaque);
5595 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5601 let ondone s = add s in
5602 let mode = state
.mode in
5603 state
.mode <- Textentry
(
5604 ("annotation: ", E.s, None
, textentry, ondone, true),
5605 fun _ -> state
.mode <- mode);
5608 G.postRedisplay "annot"
5610 add @@ getusertext E.s
5615 let g opaque l px py =
5616 match rectofblock
opaque px py with
5618 let x0 = a.(0) -. 20. in
5619 let x1 = a.(1) +. 20. in
5620 let y0 = a.(2) -. 20. in
5621 let zoom = (float state
.w) /. (x1 -. x0) in
5622 let pagey = getpagey
l.pageno in
5623 gotoy_and_clear_text (pagey + truncate
y0);
5624 state
.anchor <- getanchor
();
5625 let margin = (state
.w - l.pagew
)/2 in
5626 state
.x <- -truncate
x0 - margin;
5631 match conf
.columns
with
5633 impmsg "block zooming does not work properly in split columns mode"
5634 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5638 let winw = wadjsb () + state
.winw - 1 in
5639 let s = float x /. float winw in
5640 let destx = truncate
(float (state
.w + winw) *. s) in
5641 state
.x <- winw - destx;
5642 gotoy_and_clear_text state
.y;
5643 state
.mstate
<- Mscrollx
;
5647 let s = float y /. float state
.winh
in
5648 let desty = truncate
(float (state
.maxy - state
.winh
) *. s) in
5649 gotoy_and_clear_text desty;
5650 state
.mstate
<- Mscrolly
;
5653 let viewmulticlick clicks
x y mask
=
5654 let g opaque l px py =
5662 if markunder
opaque px py mark
5666 match getopaque l.pageno with
5668 | Some
opaque -> pipesel opaque cmd
5670 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5671 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5676 G.postRedisplay "viewmulticlick";
5677 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5681 match conf
.columns
with
5683 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5686 let viewmouse button down
x y mask
=
5688 | n when (n == 4 || n == 5) && not down
->
5689 if Wsi.withctrl mask
5691 match state
.mstate
with
5692 | Mzoom
(oldn
, i
) ->
5700 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5702 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5704 let zoom = conf
.zoom -. incr in
5706 state
.mstate
<- Mzoom
(n, 0);
5708 state
.mstate
<- Mzoom
(n, i
+1);
5710 else state
.mstate
<- Mzoom
(n, 0)
5714 | Mscrolly
| Mscrollx
5716 | Mnone
-> state
.mstate
<- Mzoom
(n, 0)
5719 match state
.autoscroll
with
5720 | Some step
-> setautoscrollspeed step
(n=4)
5722 if conf
.wheelbypage
|| conf
.presentation
5731 then -conf
.scrollstep
5732 else conf
.scrollstep
5734 let incr = incr * 2 in
5735 let y = clamp incr in
5736 gotoy_and_clear_text y
5739 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5741 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
);
5742 gotoy_and_clear_text state
.y
5744 | 1 when Wsi.withshift mask
->
5745 state
.mstate
<- Mnone
;
5748 match unproject x y with
5750 | Some
(_, pageno, ux
, uy
) ->
5751 let cmd = Printf.sprintf
5753 conf
.stcmd state
.path pageno ux uy
5755 match spawn
cmd [] with
5756 | (exception exn
) ->
5757 impmsg "execution of synctex command(%S) failed: %S"
5758 conf
.stcmd
@@ exntos exn
5762 | 1 when Wsi.withctrl mask
->
5765 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5766 state
.mstate
<- Mpan
(x, y)
5769 state
.mstate
<- Mnone
5774 if Wsi.withshift mask
5776 annot conf
.annotinline
x y;
5777 G.postRedisplay "addannot"
5781 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5782 state
.mstate
<- Mzoomrect
(p, p)
5785 match state
.mstate
with
5786 | Mzoomrect
((x0, y0), _) ->
5787 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5788 then zoomrect x0 y0 x y
5791 G.postRedisplay "kill accidental zoom rect";
5795 | Mscrolly
| Mscrollx
5801 | 1 when vscrollhit x ->
5804 let _, position, sh = state
.uioh#
scrollph in
5805 if y > truncate
position && y < truncate
(position +. sh)
5806 then state
.mstate
<- Mscrolly
5809 state
.mstate
<- Mnone
5811 | 1 when y > state
.winh
- hscrollh () ->
5814 let _, position, sw = state
.uioh#scrollpw
in
5815 if x > truncate
position && x < truncate
(position +. sw)
5816 then state
.mstate
<- Mscrollx
5819 state
.mstate
<- Mnone
5821 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5824 let dest = if down
then getunder x y else Unone
in
5825 begin match dest with
5828 | Uremote
_ | Uremotedest
_
5829 | Uunexpected
_ | Ulaunch
_ | Unamed
_ ->
5832 | Unone
when down
->
5833 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5834 state
.mstate
<- Mpan
(x, y);
5836 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5838 | Unone
| Utext
_ ->
5843 state
.mstate
<- Msel
((x, y), (x, y));
5844 G.postRedisplay "mouse select";
5848 match state
.mstate
with
5851 | Mzoom
_ | Mscrollx
| Mscrolly
->
5852 state
.mstate
<- Mnone
5854 | Mzoomrect
((x0, y0), _) ->
5858 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5859 state
.mstate
<- Mnone
5861 | Msel
((x0, y0), (x1, y1)) ->
5862 let rec loop = function
5866 let a0 = l.pagedispy in
5867 let a1 = a0 + l.pagevh in
5868 let b0 = l.pagedispx in
5869 let b1 = b0 + l.pagevw in
5870 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5871 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5875 match getopaque l.pageno with
5878 match Unix.pipe
() with
5879 | (exception exn
) ->
5880 impmsg "cannot create sel pipe: %s" @@
5884 Ne.clo fd
(fun msg
->
5885 dolog
"%s close failed: %s" what msg
)
5888 try spawn
cmd [r, 0; w, -1]
5890 dolog
"cannot execute %S: %s"
5897 G.postRedisplay "copysel";
5899 else clo "Msel pipe/w" w;
5900 clo "Msel pipe/r" r;
5902 dosel conf
.selcmd
();
5903 state
.roam
<- dosel conf
.paxcmd
;
5915 let birdseyemouse button down
x y mask
5916 (conf
, leftx
, _, hooverpageno
, anchor) =
5919 let rec loop = function
5922 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5923 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5925 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5931 | _ -> viewmouse button down
x y mask
5937 method key key mask
=
5938 begin match state
.mode with
5939 | Textentry
textentry -> textentrykeyboard key mask
textentry
5940 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5941 | View
-> viewkeyboard key mask
5942 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5946 method button button bstate
x y mask
=
5947 begin match state
.mode with
5949 | View
-> viewmouse button bstate
x y mask
5950 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
5955 method multiclick clicks
x y mask
=
5956 begin match state
.mode with
5958 | View
-> viewmulticlick clicks
x y mask
5965 begin match state
.mode with
5967 | View
| Birdseye
_ | LinkNav
_ ->
5968 match state
.mstate
with
5969 | Mzoom
_ | Mnone
-> ()
5974 state
.mstate
<- Mpan
(x, y);
5976 then state
.x <- panbound (state
.x + dx);
5978 gotoy_and_clear_text y
5981 state
.mstate
<- Msel
(a, (x, y));
5982 G.postRedisplay "motion select";
5985 let y = min state
.winh
(max
0 y) in
5989 let x = min state
.winw (max
0 x) in
5992 | Mzoomrect
(p0
, _) ->
5993 state
.mstate
<- Mzoomrect
(p0
, (x, y));
5994 G.postRedisplay "motion zoomrect";
5998 method pmotion
x y =
5999 begin match state
.mode with
6000 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6001 let rec loop = function
6003 if hooverpageno
!= -1
6005 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6006 G.postRedisplay "pmotion birdseye no hoover";
6009 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6010 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6012 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6013 G.postRedisplay "pmotion birdseye hoover";
6023 match state
.mstate
with
6024 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6032 let past, _, _ = !r in
6034 let delta = now -. past in
6037 else r := (now, x, y)
6041 method infochanged
_ = ()
6044 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6047 then 0.0, float state
.winh
6048 else scrollph state
.y maxy
6053 let winw = wadjsb () + state
.winw in
6054 let fwinw = float winw in
6056 let sw = fwinw /. float state
.w in
6057 let sw = fwinw *. sw in
6058 max
sw (float conf
.scrollh
)
6061 let maxx = state
.w + winw in
6062 let x = winw - state
.x in
6063 let percent = float x /. float maxx in
6064 (fwinw -. sw) *. percent
6066 hscrollh (), position, sw
6070 match state
.mode with
6071 | LinkNav
_ -> "links"
6072 | Textentry
_ -> "textentry"
6073 | Birdseye
_ -> "birdseye"
6076 findkeyhash conf
modename
6078 method eformsgs
= true
6079 method alwaysscrolly
= false
6082 let adderrmsg src msg
=
6083 Buffer.add_string state
.errmsgs msg
;
6084 state
.newerrmsgs
<- true;
6088 let adderrfmt src fmt
=
6089 Format.ksprintf
(fun s -> adderrmsg src s) fmt
;
6092 let addrect pageno r g b a x0 y0 x1 y1 =
6093 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6097 let cl = splitatspace cmds
in
6099 try Scanf.sscanf
s fmt
f
6101 adderrfmt "remote exec"
6102 "error processing '%S': %s\n" cmds
@@ exntos exn
6104 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6105 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6106 s pageno r g b a x0 y0 x1 y1;
6110 let _,w1,h1
,_ = getpagedim
pageno in
6111 let sw = float w1 /. float w
6112 and sh = float h1
/. float h in
6116 and y1s
= y1 *. sh in
6117 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6118 let color = (r, g, b, a) in
6119 if conf
.verbose
then debugrect rect;
6120 state
.rects <- (pageno, color, rect) :: state
.rects;
6125 | "reload" :: [] -> reload ()
6126 | "goto" :: args
:: [] ->
6127 scan args
"%u %f %f"
6129 let cmd, _ = state
.geomcmds
in
6131 then gotopagexy pageno x y
6134 gotopagexy pageno x y;
6137 state
.reprf
<- f state
.reprf
6139 | "goto1" :: args
:: [] -> scan args
"%u %f" gotopage
6140 | "gotor" :: args
:: [] ->
6142 (fun filename
pageno -> gotounder (Uremote
(filename
, pageno)))
6143 | "gotord" :: args
:: [] ->
6145 (fun filename
dest -> gotounder (Uremotedest
(filename
, dest)))
6146 | "rect" :: args
:: [] ->
6147 scan args
"%u %u %f %f %f %f"
6148 (fun pageno c x0 y0 x1 y1 ->
6149 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6150 rectx "rect" pageno color x0 y0 x1 y1;
6152 | "prect" :: args
:: [] ->
6153 scan args
"%u %f %f %f %f %f %f %f %f"
6154 (fun pageno r g b alpha x0 y0 x1 y1 ->
6155 addrect pageno r g b alpha x0 y0 x1 y1;
6156 G.postRedisplay "prect"
6158 | "pgoto" :: args
:: [] ->
6159 scan args
"%u %f %f"
6162 match getopaque pageno with
6163 | Some
opaque -> opaque
6166 pgoto optopaque pageno x y;
6167 let rec fixx = function
6170 if l.pageno = pageno
6172 state
.x <- state
.x - l.pagedispx;
6179 let ww = state
.winw in
6181 match conf
.columns
with
6182 | Csingle
_ | Csplit
_ -> 1
6183 | Cmulti
((n, _, _), _) -> n
6185 state
.winw <- state
.winw * mult;
6187 let res = layout state
.y state
.winh
in
6194 | "activatewin" :: [] -> Wsi.activatewin
()
6195 | "quit" :: [] -> raise Quit
6196 | "clearrects" :: [] ->
6197 Hashtbl.clear state
.prects
;
6198 G.postRedisplay "clearrects"
6200 adderrfmt "remote command"
6201 "error processing remote command: %S\n" cmds
;
6205 let scratch = Bytes.create
80 in
6206 let buf = Buffer.create
80 in
6208 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6209 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6212 if Buffer.length
buf > 0
6214 let s = Buffer.contents
buf in
6222 match Bytes.index_from
scratch ppos '
\n'
with
6223 | pos -> if pos >= n then -1 else pos
6224 | (exception Not_found
) -> -1
6228 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6229 let s = Buffer.contents
buf in
6235 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6241 let remoteopen path =
6242 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6244 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6249 let gcconfig = ref E.s in
6250 let trimcachepath = ref E.s in
6251 let rcmdpath = ref E.s in
6252 let pageno = ref None
in
6253 let rootwid = ref 0 in
6254 let openlast = ref false in
6255 let nofc = ref false in
6256 let doreap = ref false in
6257 selfexec := Sys.executable_name
;
6260 [("-p", Arg.String
(fun s -> state
.password <- s),
6261 "<password> Set password");
6265 Config.fontpath
:= s;
6266 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6268 "<path> Set path to the user interface font");
6272 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6273 Config.confpath
:= s),
6274 "<path> Set path to the configuration file");
6276 ("-last", Arg.Set
openlast, " Open last document");
6278 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6279 "<page-number> Jump to page");
6281 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6282 "<path> Set path to the trim cache file");
6284 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6285 "<named-destination> Set named destination");
6287 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6288 ("-cxack", Arg.Set
cxack, " Cut corners");
6290 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6291 "<path> Set path to the remote commands source");
6293 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6294 "<original-path> Set original path");
6296 ("-gc", Arg.Set_string
gcconfig,
6297 "<script-path> Collect garbage with the help of a script");
6299 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6301 ("-v", Arg.Unit
(fun () ->
6303 "%s\nconfiguration path: %s\n"
6307 exit
0), " Print version and exit");
6309 ("-embed", Arg.Set_int
rootwid,
6310 "<window-id> Embed into window")
6313 (fun s -> state
.path <- s)
6314 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6317 then selfexec := !selfexec ^
" -wtmode";
6319 let histmode = emptystr state
.path && not
!openlast in
6321 if not
(Config.load !openlast)
6322 then dolog
"failed to load configuration";
6323 begin match !pageno with
6324 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6328 if nonemptystr
!gcconfig
6331 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6332 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6335 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6336 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6338 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6343 let wsfd, winw, winh
= Wsi.init
(object (self)
6344 val mutable m_clicks
= 0
6345 val mutable m_click_x
= 0
6346 val mutable m_click_y
= 0
6347 val mutable m_lastclicktime
= infinity
6349 method private cleanup =
6350 state
.roam
<- noroam
;
6351 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6352 method expose
= G.postRedisplay"expose"
6356 | Wsi.Unobscured
-> "unobscured"
6357 | Wsi.PartiallyObscured
-> "partiallyobscured"
6358 | Wsi.FullyObscured
-> "fullyobscured"
6360 vlog "visibility change %s" name
6361 method display = display ()
6362 method map mapped
= vlog "mappped %b" mapped
6363 method reshape w h =
6366 method mouse
b d x y m =
6367 if d && canselect ()
6369 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6375 if abs
x - m_click_x
> 10
6376 || abs
y - m_click_y
> 10
6377 || abs_float
(t -. m_lastclicktime
) > 0.3
6379 m_clicks
<- m_clicks
+ 1;
6380 m_lastclicktime
<- t;
6384 G.postRedisplay "cleanup";
6385 state
.uioh <- state
.uioh#button
b d x y m;
6387 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6392 m_lastclicktime
<- infinity
;
6393 state
.uioh <- state
.uioh#button
b d x y m
6397 state
.uioh <- state
.uioh#button
b d x y m
6400 state
.mpos
<- (x, y);
6401 state
.uioh <- state
.uioh#motion
x y
6402 method pmotion
x y =
6403 state
.mpos
<- (x, y);
6404 state
.uioh <- state
.uioh#pmotion
x y
6406 let mascm = m land (
6407 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6410 let x = state
.x and y = state
.y in
6412 if x != state
.x || y != state
.y then self#
cleanup
6414 match state
.keystate
with
6416 let km = k
, mascm in
6419 let modehash = state
.uioh#
modehash in
6420 try Hashtbl.find modehash km
6422 try Hashtbl.find (findkeyhash conf
"global") km
6423 with Not_found
-> KMinsrt
(k
, m)
6425 | KMinsrt
(k
, m) -> keyboard k
m
6426 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6427 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6429 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6430 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6431 state
.keystate
<- KSnone
6432 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6433 state
.keystate
<- KSinto
(keys, insrt
)
6434 | KSinto
_ -> state
.keystate
<- KSnone
6437 state
.mpos
<- (x, y);
6438 state
.uioh <- state
.uioh#pmotion
x y
6439 method leave = state
.mpos
<- (-1, -1)
6440 method winstate wsl
= state
.winstate
<- wsl
6441 method quit
= raise Quit
6442 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6447 List.exists
GlMisc.check_extension
6448 [ "GL_ARB_texture_rectangle"
6449 ; "GL_EXT_texture_recangle"
6450 ; "GL_NV_texture_rectangle" ]
6452 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6455 let r = GlMisc.get_string `renderer
in
6456 let p = "Mesa DRI Intel(" in
6457 let l = String.length
p in
6458 String.length
r > l && String.sub
r 0 l = p
6461 defconf
.sliceheight
<- 1024;
6462 defconf
.texcount
<- 32;
6463 defconf
.usepbo
<- true;
6467 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6468 | (exception exn
) ->
6469 dolog
"socketpair failed: %s" @@ exntos exn
;
6477 setcheckers conf
.checkers
;
6480 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6481 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6482 !Config.fontpath
, !trimcachepath,
6483 GlMisc.check_extension
"GL_ARB_pixel_buffer_object",
6486 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6488 reshape ~firsttime
:true winw winh
;
6492 Wsi.settitle
"llpp (history)";
6496 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6497 opendoc state
.path state
.password;
6501 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6502 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6505 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6506 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6507 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6509 | _pid
, _status
-> reap ()
6511 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6515 if nonemptystr
!rcmdpath
6516 then remoteopen !rcmdpath
6521 let rec loop deadline
=
6527 let r = [state
.ss; state
.wsfd] in
6531 | Some fd
-> fd
:: r
6535 state
.redisplay
<- false;
6542 if deadline
= infinity
6544 else max
0.0 (deadline
-. now)
6549 try Unix.select
r [] [] timeout
6550 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6556 if state
.ghyll
== noghyll
6558 match state
.autoscroll
with
6559 | Some step
when step
!= 0 ->
6560 let y = state
.y + step
in
6564 else if y >= state
.maxy then 0 else y
6566 if state
.mode = View
6567 then gotoy_and_clear_text y
6571 else deadline
+. 0.01
6576 let rec checkfds = function
6578 | fd
:: rest
when fd
= state
.ss ->
6579 let cmd = readcmd state
.ss in
6583 | fd
:: rest
when fd
= state
.wsfd ->
6587 | fd
:: rest
when Some fd
= !optrfd ->
6588 begin match remote fd
with
6589 | None
-> optrfd := remoteopen !rcmdpath;
6590 | opt -> optrfd := opt
6595 dolog
"select returned unknown descriptor";
6601 if deadline
= infinity
6605 match state
.autoscroll
with
6606 | Some step
when step
!= 0 -> deadline1
6607 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6615 Config.save leavebirdseye;
6616 if hasunsavedchanges
()