6 external init
: Unix.file_descr
-> params
-> unit = "ml_init";;
7 external seltext
: opaque
-> (int * int * int * int) -> unit = "ml_seltext";;
8 external hassel
: opaque
-> bool = "ml_hassel";;
9 external copysel
: Unix.file_descr
-> opaque
-> unit = "ml_copysel";;
10 external getpdimrect
: int -> float array
= "ml_getpdimrect";;
11 external whatsunder
: opaque
-> int -> int -> under
= "ml_whatsunder";;
12 external markunder
: opaque
-> int -> int -> mark
-> bool = "ml_markunder";;
13 external clearmark
: opaque
-> unit = "ml_clearmark";;
14 external zoomforh
: int -> int -> int -> int -> float = "ml_zoom_for_height";;
15 external getmaxw
: unit -> float = "ml_getmaxw";;
16 external drawstr
: int -> int -> int -> string -> float = "ml_draw_string";;
17 external measurestr
: int -> string -> float = "ml_measure_string";;
18 external postprocess
:
19 opaque
-> int -> int -> int -> (int * string * int) -> int
21 external pagebbox
: opaque
-> (int * int * int * int) = "ml_getpagebox";;
22 external setaalevel
: int -> unit = "ml_setaalevel";;
23 external realloctexts
: int -> bool = "ml_realloctexts";;
24 external findlink
: opaque
-> linkdir
-> link
= "ml_findlink";;
25 external getlink
: opaque
-> int -> under
= "ml_getlink";;
26 external getlinkrect
: opaque
-> int -> irect
= "ml_getlinkrect";;
27 external getlinkcount
: opaque
-> int = "ml_getlinkcount";;
28 external findpwl
: int -> int -> pagewithlinks
= "ml_find_page_with_links";;
29 external getpbo
: width
-> height
-> colorspace
-> opaque
= "ml_getpbo";;
30 external freepbo
: opaque
-> unit = "ml_freepbo";;
31 external unmappbo
: opaque
-> unit = "ml_unmappbo";;
32 external bousable
: unit -> bool = "ml_bo_usable";;
33 external unproject
: opaque
-> int -> int -> (int * int) option
35 external project
: opaque
-> int -> int -> float -> float -> (float * float)
37 external drawtile
: tileparams
-> opaque
-> unit = "ml_drawtile";;
38 external rectofblock
: opaque
-> int -> int -> float array
option
40 external begintiles
: unit -> unit = "ml_begintiles";;
41 external endtiles
: unit -> unit = "ml_endtiles";;
42 external addannot
: opaque
-> int -> int -> string -> unit = "ml_addannot";;
43 external modannot
: opaque
-> slinkindex
-> string -> unit = "ml_modannot";;
44 external delannot
: opaque
-> slinkindex
-> unit = "ml_delannot";;
45 external hasunsavedchanges
: unit -> bool = "ml_hasunsavedchanges";;
46 external savedoc
: string -> unit = "ml_savedoc";;
47 external getannotcontents
: opaque
-> slinkindex
-> string
48 = "ml_getannotcontents";;
49 external drawprect
: opaque
-> int -> int -> float array
-> unit =
51 external wcmd
: Unix.file_descr
-> bytes
-> int -> unit = "ml_wcmd";;
52 external rcmd
: Unix.file_descr
-> string = "ml_rcmd";;
53 external uritolocation
: string -> (pageno
* float * float)
54 = "ml_uritolocation";;
55 external isexternallink
: string -> bool = "ml_isexternallink";;
57 let selfexec = ref E.s
;;
58 let opengl_has_pbo = ref false;;
60 let drawstring size x y s
=
62 Gl.enable `texture_2d
;
63 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
64 ignore
(drawstr size x y s
);
66 Gl.disable `texture_2d
;
69 let drawstring1 size x y s
=
73 let drawstring2 size x y fmt
=
74 Printf.kprintf
(drawstring size
(x
+1) (y
+size
+1)) fmt
78 dolog
"l %d dim=%d {" l
.pageno l
.pagedimno
;
79 dolog
" WxH %dx%d" l
.pagew l
.pageh
;
80 dolog
" vWxH %dx%d" l
.pagevw l
.pagevh
;
81 dolog
" pagex,y %d,%d" l
.pagex l
.pagey
;
82 dolog
" dispx,y %d,%d" l
.pagedispx l
.pagedispy
;
83 dolog
" column %d" l
.pagecol
;
87 let debugrect (x0
, y0
, x1
, y1
, x2
, y2
, x3
, y3
) =
89 dolog
" x0,y0=(% f, % f)" x0 y0
;
90 dolog
" x1,y1=(% f, % f)" x1 y1
;
91 dolog
" x2,y2=(% f, % f)" x2 y2
;
92 dolog
" x3,y3=(% f, % f)" x3 y3
;
96 let isbirdseye = function
103 let istextentry = function
104 | Textentry _
-> true
110 let wtmode = ref false;;
111 let cxack = ref false;;
113 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
116 if state
.uioh#alwaysscrolly
|| ((conf
.scrollb
land scrollbhv
!= 0)
117 && (state
.w
> state
.winw
))
123 if state
.uioh#alwaysscrolly
|| ((conf
.scrollb
land scrollbvv
!= 0)
124 && (state
.maxy
> state
.winh
))
132 else x
> state
.winw
- vscrollw ()
136 fstate
.fontsize
<- n
;
137 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
138 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
144 else Printf.kprintf ignore fmt
148 if emptystr conf
.pathlauncher
149 then dolog
"%s" state
.path
151 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
152 match spawn
command [] with
155 dolog
"failed to execute `%s': %s" command @@ exntos exn
161 let postRedisplay who
=
162 vlog "redisplay for [%S]" who
;
163 state
.redisplay
<- true;
167 let getopaque pageno
=
168 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
169 with Not_found
-> None
172 let pagetranslatepoint l x y
=
173 let dy = y
- l
.pagedispy
in
174 let y = dy + l
.pagey
in
175 let dx = x
- l
.pagedispx
in
176 let x = dx + l
.pagex
in
180 let onppundermouse g
x y d
=
183 begin match getopaque l
.pageno
with
185 let x0 = l
.pagedispx
in
186 let x1 = x0 + l
.pagevw
in
187 let y0 = l
.pagedispy
in
188 let y1 = y0 + l
.pagevh
in
189 if y >= y0 && y <= y1 && x >= x0 && x <= x1
191 let px, py
= pagetranslatepoint l
x y in
192 match g opaque l
px py
with
205 let g opaque l
px py
=
208 match rectofblock opaque
px py
with
209 | Some
[|x0;x1;y0;y1|] ->
210 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
211 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
212 state
.rects
<- [l
.pageno
, color, rect];
213 G.postRedisplay "getunder";
216 let under = whatsunder opaque
px py
in
217 if under = Unone
then None
else Some
under
219 onppundermouse g x y Unone
224 match unproject opaque
x y with
225 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
228 onppundermouse g x y None
;
232 state
.text
<- Printf.sprintf
"%c%s" c s
;
233 G.postRedisplay "showtext";
237 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
240 let pipesel opaque cmd
=
243 match Unix.pipe
() with
244 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
246 let doclose what fd
=
247 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
250 try spawn cmd
[r
, 0; w
, -1]
252 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
258 G.postRedisplay "pipesel";
260 else doclose "pipesel pipe/w" w
;
261 doclose "pipesel pipe/r" r
;
265 let g opaque l
px py
=
266 if markunder opaque
px py conf
.paxmark
269 match getopaque l
.pageno
with
271 | Some opaque
-> pipesel opaque conf
.paxcmd
276 G.postRedisplay "paxunder";
277 if conf
.paxmark
= Mark_page
280 match getopaque l
.pageno
with
282 | Some opaque
-> clearmark opaque
) state
.layout
;
283 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
287 match Unix.pipe
() with
288 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
291 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
294 try spawn conf
.selcmd
[r
, 0; w
, -1]
296 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
302 let l = String.length s
in
303 let bytes = Bytes.unsafe_of_string s
in
304 let n = tempfailureretry
(Unix.write w
bytes 0) l in
306 then impmsg "failed to write %d characters to sel pipe, wrote %d"
309 impmsg "failed to write to sel pipe: %s" @@ exntos exn
312 clo "selstring pipe/r" r
;
313 clo "selstring pipe/w" w
;
316 let undertext = function
319 | Utext s
-> "font: " ^ s
320 | Uannotation
(opaque
, slinkindex
) ->
321 "annotation: " ^ getannotcontents opaque slinkindex
324 let updateunder x y =
325 match getunder x y with
326 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
328 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
329 Wsi.setcursor
Wsi.CURSOR_INFO
331 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
332 Wsi.setcursor
Wsi.CURSOR_TEXT
334 if conf
.underinfo
then showtext 'a'
"nnotation";
335 Wsi.setcursor
Wsi.CURSOR_INFO
338 let showlinktype under =
339 if conf
.underinfo
&& under != Unone
340 then showtext ' '
@@ undertext under
343 let intentry_with_suffix text key
=
345 if key
>= 32 && key
< 127
347 let c = Char.chr key
in
352 | 'k'
| 'm'
| '
g'
| 'K'
| 'M'
| 'G'
->
353 addchar
text @@ asciilower
c
355 state
.text <- Printf.sprintf
"invalid key (%d, `%c')" key
c;
358 state
.text <- Printf.sprintf
"invalid key %d" key
;
366 let b = Buffer.create
16 in
367 Buffer.add_string
b "llll";
370 let b = Buffer.to_bytes
b in
371 wcmd state
.ss
b @@ Bytes.length
b
375 let nogeomcmds cmds
=
377 | s
, [] -> emptystr s
381 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
382 let rec fold accu
n =
383 if n = Array.length
b
386 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
389 || n = state
.pagecount
- coverB
390 || (n - coverA
) mod columns
= columns
- 1)
396 let pagey = max
0 (y - vy
) in
397 let pagedispy = if pagey > 0 then 0 else vy
- y in
398 let pagedispx, pagex
=
400 if n = coverA
- 1 || n = state
.pagecount
- coverB
401 then x + (sw
- w
) / 2
409 let vw = sw
- pagedispx in
410 let pw = w
- pagex
in
413 let pagevh = min
(h
- pagey) (sh
- pagedispy) in
414 if pagevw > 0 && pagevh > 0
425 ; pagedispx = pagedispx
426 ; pagedispy = pagedispy
438 if Array.length
b = 0
440 else List.rev
(fold [] (page_of_y
y))
443 let layoutS (columns
, b) x y sw sh
=
444 let rec fold accu n =
445 if n = Array.length
b
448 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
456 let pagey = max
0 (y - vy
) in
457 let pagedispy = if pagey > 0 then 0 else vy
- y in
458 let pagedispx, pagex
=
472 let pagecolw = pagew
/columns
in
475 then pagedispx + ((sw
- pagecolw) / 2)
479 let vw = sw
- pagedispx in
480 let pw = pagew
- pagex
in
483 let pagevw = min
pagevw pagecolw in
484 let pagevh = min
(pageh
- pagey) (sh
- pagedispy) in
485 if pagevw > 0 && pagevh > 0
496 ; pagedispx = pagedispx
497 ; pagedispy = pagedispy
498 ; pagecol
= n mod columns
512 let layout x y sw sh
=
513 if nogeomcmds state
.geomcmds
515 match conf
.columns
with
516 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw sh
517 | Cmulti
c -> layoutN c x y sw sh
518 | Csplit s
-> layoutS s
x y sw sh
523 let y = state
.y + incr
in
525 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
530 let tilex = l.pagex
mod conf
.tilew
in
531 let tiley = l.pagey mod conf
.tileh
in
533 let col = l.pagex
/ conf
.tilew
in
534 let row = l.pagey / conf
.tileh
in
536 let rec rowloop row y0 dispy h
=
540 let dh = conf
.tileh
- y0 in
542 let rec colloop col x0 dispx w
=
546 let dw = conf
.tilew
- x0 in
548 f col row dispx dispy
x0 y0 dw dh;
549 colloop (col+1) 0 (dispx
+dw) (w
-dw)
552 colloop col tilex l.pagedispx l.pagevw;
553 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
556 if l.pagevw > 0 && l.pagevh > 0
557 then rowloop row tiley l.pagedispy l.pagevh;
560 let gettileopaque l col row =
562 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
564 try Some
(Hashtbl.find state
.tilemap
key)
565 with Not_found
-> None
568 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
569 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
570 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
573 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3
=
574 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x1; y1; x2
; y2
; x3
; y3
|];
575 GlArray.vertex `two state
.vraw
;
576 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
579 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
581 let filledrect x0 y0 x1 y1 =
582 GlArray.disable `texture_coord
;
583 filledrect1 x0 y0 x1 y1;
584 GlArray.enable `texture_coord
;
587 let linerect x0 y0 x1 y1 =
588 GlArray.disable `texture_coord
;
589 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
590 GlArray.vertex `two state
.vraw
;
591 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
592 GlArray.enable `texture_coord
;
595 let drawtiles l color =
598 let f col row x y tilex tiley w h
=
599 match gettileopaque l col row with
600 | Some
(opaque
, _
, t
) ->
601 let params = x, y, w
, h
, tilex, tiley in
603 then GlTex.env
(`mode `blend
);
604 drawtile
params opaque
;
606 then GlTex.env
(`mode `modulate
);
610 let s = Printf.sprintf
614 let w = measurestr fstate
.fontsize
s in
615 GlDraw.color (0.0, 0.0, 0.0);
616 filledrect (float (x-2))
619 (float (y + fstate
.fontsize
+ 2));
621 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
628 let lw = state
.winw
- x in
631 let lh = state
.winh
- y in
635 then GlTex.env
(`mode `blend
);
636 begin match state
.checkerstexid
with
638 Gl.enable `texture_2d
;
639 GlTex.bind_texture ~target
:`texture_2d id
;
643 and y1 = float (y+h
) in
645 let tw = float w /. 16.0
646 and th
= float h
/. 16.0 in
647 let tx0 = float tilex /. 16.0
648 and ty0
= float tiley /. 16.0 in
650 and ty1
= ty0
+. th
in
651 Raw.sets_float state
.vraw ~pos
:0
652 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
653 Raw.sets_float state
.traw ~pos
:0
654 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
655 GlArray.vertex `two state
.vraw
;
656 GlArray.tex_coord `two state
.traw
;
657 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
658 Gl.disable `texture_2d
;
661 GlDraw.color (1.0, 1.0, 1.0);
662 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
665 then GlTex.env
(`mode `modulate
);
666 if w > 128 && h
> fstate
.fontsize
+ 10
668 let c = if conf
.invert
then 1.0 else 0.0 in
669 GlDraw.color (c, c, c);
672 then (col*conf
.tilew
, row*conf
.tileh
)
675 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
684 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
686 let tilevisible1 l x y =
688 and ax1
= l.pagex
+ l.pagevw
690 and ay1
= l.pagey + l.pagevh in
694 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
695 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
697 let rx0 = max
ax0 bx0
698 and ry0
= max ay0 by0
699 and rx1
= min ax1
bx1
700 and ry1
= min ay1 by1
in
702 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
706 let tilevisible layout n x y =
707 let rec findpageinlayout m
= function
708 | l :: rest
when l.pageno
= n ->
709 tilevisible1 l x y || (
710 match conf
.columns
with
711 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
716 | _
:: rest
-> findpageinlayout 0 rest
719 findpageinlayout 0 layout;
722 let tileready l x y =
723 tilevisible1 l x y &&
724 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
727 let tilepage n p
layout =
728 let rec loop = function
732 let f col row _ _ _ _ _ _
=
733 if state
.currently
= Idle
735 match gettileopaque l col row with
738 let x = col*conf
.tilew
739 and y = row*conf
.tileh
in
741 let w = l.pagew
- x in
745 let h = l.pageh
- y in
750 then getpbo
w h conf
.colorspace
753 wcmd "tile %s %d %d %d %d %s"
754 (~
> p
) x y w h (~
> pbo);
757 l, p
, conf
.colorspace
, conf
.angle
,
758 state
.gen
, col, row, conf
.tilew
, conf
.tileh
767 if nogeomcmds state
.geomcmds
771 let preloadlayout x y sw sh
=
772 let y = if y < sh
then 0 else y - sh
in
773 let x = min
0 (x + sw
) in
781 if state
.currently
!= Idle
786 begin match getopaque l.pageno
with
788 wcmd "page %d %d" l.pageno
l.pagedimno
;
789 state
.currently
<- Loading
(l, state
.gen
);
791 tilepage l.pageno opaque pages
;
796 if nogeomcmds state
.geomcmds
802 if conf
.preload && state
.currently
= Idle
803 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
806 let layoutready layout =
807 let rec fold all ls
=
810 let seen = ref false in
811 let allvisible = ref true in
812 let foo col row _ _ _ _ _ _
=
814 allvisible := !allvisible &&
815 begin match gettileopaque l col row with
821 fold (!seen && !allvisible) rest
824 let alltilesvisible = fold true layout in
829 let y = bound
y 0 state
.maxy
in
830 let y, layout, proceed
=
831 match conf
.maxwait
with
832 | Some time
when state
.ghyll
== noghyll
->
833 begin match state
.throttle
with
835 let layout = layout x y state
.winw state
.winh
in
836 let ready = layoutready layout in
840 state
.throttle
<- Some
(layout, y, now
());
842 else G.postRedisplay "gotoxy showall (None)";
844 | Some
(_
, _
, started
) ->
845 let dt = now
() -. started
in
848 state
.throttle
<- None
;
849 let layout = layout x y state
.winw state
.winh
in
851 G.postRedisplay "maxwait";
858 let layout = layout x y state
.winw state
.winh
in
859 if not
!wtmode || layoutready layout
860 then G.postRedisplay "gotoxy ready";
867 state
.layout <- layout;
868 begin match state
.mode
with
871 | Ltexact
(pageno
, linkno
) ->
872 let rec loop = function
874 state
.mode
<- LinkNav
(Ltgendir
0)
875 | l :: _
when l.pageno
= pageno
->
876 begin match getopaque pageno
with
877 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
879 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
880 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
881 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
882 then state
.mode
<- LinkNav
(Ltgendir
0)
884 | _
:: rest
-> loop rest
887 | Ltnotready _
| Ltgendir _
-> ()
893 begin match state
.mode
with
894 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
895 if not
(pagevisible layout pageno
)
897 match state
.layout with
900 state
.mode
<- Birdseye
(
901 conf
, leftx
, l.pageno
, hooverpageno
, anchor
906 | Ltnotready
(_
, dir
)
909 let rec loop = function
912 match getopaque l.pageno
with
913 | None
-> Ltnotready
(l.pageno
, dir
)
918 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
920 if dir
> 0 then LDfirst
else LDlast
926 | Lnotfound
-> loop rest
928 showlinktype (getlink opaque
n);
929 Ltexact
(l.pageno
, n)
933 state
.mode
<- LinkNav
linknav
941 state
.ghyll
<- noghyll
;
944 let mx, my
= state
.mpos
in
949 let conttiling pageno opaque
=
950 tilepage pageno opaque
952 then preloadlayout state
.x state
.y state
.winw state
.winh
956 let gotoxy_and_clear_text x y =
957 if not conf
.verbose
then state
.text <- E.s;
961 let getanchory (n, top
, dtop
) =
962 let y, h = getpageyh
n in
965 let ips = calcips
h in
966 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
968 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
971 let gotoanchor anchor
=
972 gotoxy state
.x (getanchory anchor
);
976 cbput state
.hists
.nav
(getanchor
());
980 let anchor = cbgetc state
.hists
.nav dir
in
984 let gotoghyll1 single
y =
986 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
988 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
990 then s (float f /. float a
)
993 then 1.0 -. s ((float (f-b) /. float (n-b)))
999 let ins = float a
*. 0.5
1000 and outs
= float (n-b) *. 0.5 in
1002 ins +. outs
+. float ones
1004 let rec set nab
y sy
=
1005 let (_N
, _A
, _B
), y =
1008 let scl = if y > sy
then 2 else -2 in
1009 let _N, _
, _
= nab
in
1010 (_N,0,_N), y+conf
.scrollstep
*scl
1012 let sum = summa
_N _A _B
in
1013 let dy = float (y - sy
) in
1017 then state
.ghyll
<- noghyll
1020 let s = scroll n _N _A _B
in
1021 let y1 = y1 +. ((s *. dy) /. sum) in
1022 gotoxy_and_clear_text state
.x (truncate
y1);
1023 state
.ghyll
<- gf (n+1) y1;
1027 | Some
y'
when single
-> set nab
y' state
.y
1028 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1030 gf 0 (float state
.y)
1033 match conf
.ghyllscroll
with
1034 | Some nab
when not conf
.presentation
->
1035 if state
.ghyll
== noghyll
1036 then set nab
y state
.y
1037 else state
.ghyll
(Some
y)
1039 gotoxy_and_clear_text state
.x y
1042 let gotoghyll = gotoghyll1 false;;
1044 let gotopage n top
=
1045 let y, h = getpageyh
n in
1046 let y = y + (truncate
(top
*. float h)) in
1050 let gotopage1 n top
=
1051 let y = getpagey
n in
1056 let invalidate s f =
1057 state
.redisplay
<- false;
1062 match state
.geomcmds
with
1063 | ps
, [] when emptystr ps
->
1065 state
.geomcmds
<- s, [];
1068 state
.geomcmds
<- ps
, [s, f];
1070 | ps
, (s'
, _
) :: rest
when s'
= s ->
1071 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1074 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1078 Hashtbl.iter
(fun _ opaque
->
1079 wcmd "freepage %s" (~
> opaque
);
1081 Hashtbl.clear state
.pagemap
;
1085 if not
(Queue.is_empty state
.tilelru
)
1087 Queue.iter
(fun (k
, p
, s) ->
1088 wcmd "freetile %s" (~
> p
);
1089 state
.memused
<- state
.memused
- s;
1090 Hashtbl.remove state
.tilemap k
;
1092 state
.uioh#infochanged Memused
;
1093 Queue.clear state
.tilelru
;
1099 let h = truncate
(float h*.conf
.zoom
) in
1100 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1104 let opendoc path password
=
1106 state
.password
<- password
;
1107 state
.gen
<- state
.gen
+ 1;
1108 state
.docinfo
<- [];
1109 state
.outlines
<- [||];
1112 setaalevel conf
.aalevel
;
1114 if emptystr state
.origin
1118 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1119 wcmd "open %d %d %s\000%s\000" (btod
!wtmode) (btod
!cxack) path password
;
1120 invalidate "reqlayout"
1122 wcmd "reqlayout %d %d %d %s\000"
1123 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1124 (stateh state
.winh
) state
.nameddest
1129 state
.anchor <- getanchor
();
1130 opendoc state
.path state
.password
;
1134 let c = c *. conf
.colorscale
in
1138 let scalecolor2 (r
, g, b) =
1139 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1142 let docolumns columns
=
1145 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1146 let rec loop pageno
pdimno pdim
y ph pdims
=
1147 if pageno
= state
.pagecount
1150 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1152 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1153 pdimno+1, pdim
, rest
1157 let x = max
0 (((state
.winw
- w) / 2) - xoff
) in
1159 (if conf
.presentation
1160 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1161 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1164 a.(pageno
) <- (pdimno, x, y, pdim
);
1165 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1167 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1168 conf
.columns
<- Csingle
a;
1170 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1171 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1172 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1173 let rec fixrow m
= if m
= pageno
then () else
1174 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1177 let y = y + (rowh
- h) / 2 in
1178 a.(m
) <- (pdimno, x, y, pdim
);
1182 if pageno
= state
.pagecount
1183 then fixrow (((pageno
- 1) / columns
) * columns
)
1185 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1187 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1188 pdimno+1, pdim
, rest
1193 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1195 let x = (state
.winw
- w) / 2 in
1197 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1198 x, y + ips + rowh
, h
1201 if (pageno
- coverA
) mod columns
= 0
1203 let x = max
0 (state
.winw
- state
.w) / 2 in
1205 if conf
.presentation
1207 let ips = calcips
h in
1208 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1210 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1214 else x, y, max rowh
h
1218 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1221 if pageno
= columns
&& conf
.presentation
1223 let ips = calcips rowh
in
1224 for i
= 0 to pred columns
1226 let (pdimno, x, y, pdim
) = a.(i
) in
1227 a.(i
) <- (pdimno, x, y+ips, pdim
)
1233 fixrow (pageno
- columns
);
1238 a.(pageno
) <- (pdimno, x, y, pdim
);
1239 let x = x + w + xoff
*2 + conf
.interpagespace
in
1240 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1242 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1243 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1246 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1247 let rec loop pageno
pdimno pdim
y pdims
=
1248 if pageno
= state
.pagecount
1251 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1253 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1254 pdimno+1, pdim
, rest
1259 let rec loop1 n x y =
1260 if n = c then y else (
1261 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1262 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1265 let y = loop1 0 0 y in
1266 loop (pageno
+1) pdimno pdim
y pdims
1268 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1269 conf
.columns
<- Csplit
(c, a);
1273 docolumns conf
.columns
;
1274 state
.maxy
<- calcheight
();
1275 if state
.reprf
== noreprf
1277 match state
.mode
with
1278 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1279 let y, h = getpageyh pageno
in
1280 let top = (state
.winh
- h) / 2 in
1281 gotoxy state
.x (max
0 (y - top))
1285 let y = getanchory state
.anchor in
1286 let y = min
y (state
.maxy
- state
.winh
) in
1291 state
.reprf
<- noreprf
;
1295 let reshape ?
(firsttime
=false) w h =
1296 GlDraw.viewport ~
x:0 ~
y:0 ~
w ~
h;
1297 if not firsttime
&& nogeomcmds state
.geomcmds
1298 then state
.anchor <- getanchor
();
1301 let w = truncate
(float w *. conf
.zoom
) in
1304 setfontsize fstate
.fontsize
;
1305 GlMat.mode `modelview
;
1306 GlMat.load_identity
();
1308 GlMat.mode `projection
;
1309 GlMat.load_identity
();
1310 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1311 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1312 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1317 else float state
.x /. float state
.w
1319 invalidate "geometry"
1323 then state
.x <- truncate
(relx *. float w);
1325 match conf
.columns
with
1327 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1328 | Csplit
(c, _
) -> w * c
1330 wcmd "geometry %d %d %d"
1331 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1336 let len = String.length state
.text in
1337 let x0 = if conf
.leftscroll
then vscrollw () else 0 in
1340 match state
.mode
with
1341 | Textentry _
| View
| LinkNav _
->
1342 let h, _
, _
= state
.uioh#scrollpw
in
1347 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1348 (x+.w) (float (state
.winh
- hscrollh))
1351 let w = float (state
.winw
- 1 - vscrollw ()) in
1352 if state
.progress
>= 0.0 && state
.progress
< 1.0
1354 GlDraw.color (0.3, 0.3, 0.3);
1355 let w1 = w *. state
.progress
in
1357 GlDraw.color (0.0, 0.0, 0.0);
1358 rect (float x0+.w1) (float x0+.w-.w1)
1361 GlDraw.color (0.0, 0.0, 0.0);
1365 GlDraw.color (1.0, 1.0, 1.0);
1366 drawstring fstate
.fontsize
1367 (if conf
.leftscroll
then x0 + 2 else x0 + if len > 0 then 8 else 2)
1368 (state
.winh
- hscrollh - 5) s;
1371 match state
.mode
with
1372 | Textentry
((prefix
, text, _
, _
, _
, _
), _
) ->
1376 Printf.sprintf
"%s%s_ [%s]" prefix
text state
.text
1378 Printf.sprintf
"%s%s_" prefix
text
1384 | LinkNav _
-> state
.text
1389 if not
(istextentry state
.mode
) && state
.uioh#eformsgs
1391 let s1 = "(press 'e' to review error messasges)" in
1392 if nonemptystr
s then s ^
" " ^
s1 else s1
1402 let len = Queue.length state
.tilelru
in
1404 match state
.throttle
with
1407 then preloadlayout state
.x state
.y state
.winw state
.winh
1409 | Some
(layout, _
, _
) ->
1413 if state
.memused
<= conf
.memlimit
1418 let (k
, p
, s) as lruitem
= Queue.pop state
.tilelru
in
1419 let n, gen
, colorspace
, angle
, pagew
, pageh
, col, row = k
in
1420 let (_
, pw, ph
, _
) = getpagedim
n in
1423 && colorspace
= conf
.colorspace
1424 && angle
= conf
.angle
1428 let x = col*conf
.tilew
1429 and y = row*conf
.tileh
in
1430 tilevisible (Lazy.force_val
layout) n x y
1432 then Queue.push lruitem state
.tilelru
1435 wcmd "freetile %s" (~
> p
);
1436 state
.memused
<- state
.memused
- s;
1437 state
.uioh#infochanged Memused
;
1438 Hashtbl.remove state
.tilemap k
;
1446 let onpagerect pageno
f =
1448 match conf
.columns
with
1449 | Cmulti
(_
, b) -> b
1451 | Csplit
(_
, b) -> b
1453 if pageno
>= 0 && pageno
< Array.length
b
1455 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1459 let gotopagexy1 wtmode pageno
x y =
1460 let _,w1,h1
,leftx
= getpagedim pageno
in
1461 let top = y /. (float h1
) in
1462 let left = x /. (float w1) in
1463 let py, w, h = getpageywh pageno
in
1464 let wh = state
.winh
in
1465 let x = left *. (float w) in
1466 let x = leftx
+ state
.x + truncate
x in
1468 if x < 0 || x >= state
.winw
1472 let pdy = truncate
(top *. float h) in
1473 let y'
= py + pdy in
1474 let dy = y'
- state
.y in
1476 if x != state
.x || not
(dy > 0 && dy < wh)
1478 if conf
.presentation
1480 if abs
(py - y'
) > wh
1487 if state
.x != sx || state
.y != sy
1492 let ww = state
.winw
in
1494 and qy
= pdy / wh in
1496 and y = py + qy
* wh in
1497 let x = if -x + ww > w1 then -(w1-ww) else x
1498 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1500 if conf
.presentation
1502 if abs
(py - y'
) > wh
1511 gotoxy_and_clear_text x y;
1513 else gotoxy_and_clear_text state
.x state
.y;
1516 let gotopagexy wtmode pageno
x y =
1517 match state
.mode
with
1518 | Birdseye
_ -> gotopage pageno
0.0
1521 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1524 let getpassword () =
1525 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1530 impmsg "error getting password: %s" s;
1531 dolog
"%s" s) passcmd;
1534 let pgoto opaque pageno
x y =
1535 let pdimno = getpdimno pageno
in
1536 let x, y = project opaque pageno
pdimno x y in
1537 gotopagexy false pageno
x y;
1541 (* dolog "%S" cmds; *)
1542 let spl = splitatchar cmds ' '
in
1544 try Scanf.sscanf
s fmt
f
1546 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1549 let addoutline outline
=
1550 match state
.currently
with
1551 | Outlining outlines
->
1552 state
.currently
<- Outlining
(outline
:: outlines
)
1553 | Idle
-> state
.currently
<- Outlining
[outline
]
1556 dolog
"invalid outlining state";
1557 logcurrently state
.currently
1561 state
.uioh#infochanged Pdim
;
1564 | "clearrects", "" ->
1565 state
.rects
<- state
.rects1
;
1566 G.postRedisplay "clearrects";
1568 | "continue", args
->
1569 let n = scan args
"%u" (fun n -> n) in
1570 state
.pagecount
<- n;
1571 begin match state
.currently
with
1573 state
.currently
<- Idle
;
1574 state
.outlines
<- Array.of_list
(List.rev
l)
1580 let cur, cmds
= state
.geomcmds
in
1582 then failwith
"umpossible";
1584 begin match List.rev cmds
with
1586 state
.geomcmds
<- E.s, [];
1587 state
.throttle
<- None
;
1591 state
.geomcmds
<- s, List.rev rest
;
1593 if conf
.maxwait
= None
&& not
!wtmode
1594 then G.postRedisplay "continue";
1601 then showtext ' ' args
1604 Buffer.add_string state
.errmsgs args
;
1605 state
.newerrmsgs
<- true;
1606 G.postRedisplay "error message"
1608 | "progress", args
->
1609 let progress, text =
1612 f, String.sub args pos
(String.length args
- pos
))
1615 state
.progress <- progress;
1616 G.postRedisplay "progress"
1618 | "firstmatch", args
->
1619 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1620 scan args
"%u %d %f %f %f %f %f %f %f %f"
1621 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1622 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1624 let y = (getpagey
pageno) + truncate
y0 in
1632 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1633 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1636 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1637 scan args
"%u %d %f %f %f %f %f %f %f %f"
1638 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1639 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1641 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1643 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1646 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1647 let pageopaque = ~
< pageopaques in
1648 begin match state
.currently
with
1649 | Loading
(l, gen
) ->
1650 vlog "page %d took %f sec" l.pageno t
;
1651 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1652 begin match state
.throttle
with
1654 let preloadedpages =
1656 then preloadlayout state
.x state
.y state
.winw state
.winh
1661 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1662 IntSet.empty
preloadedpages
1665 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1666 if not
(IntSet.mem
pageno set)
1668 wcmd "freepage %s" (~
> opaque
);
1674 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1677 state
.currently
<- Idle
;
1680 tilepage l.pageno pageopaque state
.layout;
1682 load preloadedpages;
1683 let visible = pagevisible state
.layout l.pageno in
1686 match state
.mode
with
1687 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1688 if pageno = l.pageno
1693 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1695 if dir
> 0 then LDfirst
else LDlast
1698 findlink
pageopaque ld
1703 showlinktype (getlink
pageopaque n);
1704 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1706 | LinkNav
(Ltgendir
_)
1707 | LinkNav
(Ltexact
_)
1713 if visible && layoutready state
.layout
1715 G.postRedisplay "page";
1719 | Some
(layout, _, _) ->
1720 state
.currently
<- Idle
;
1721 tilepage l.pageno pageopaque layout;
1728 dolog
"Inconsistent loading state";
1729 logcurrently state
.currently
;
1734 let (x, y, opaques
, size
, t
) =
1735 scan args
"%u %u %s %u %f"
1736 (fun x y p size t
-> (x, y, p
, size
, t
))
1738 let opaque = ~
< opaques
in
1739 begin match state
.currently
with
1740 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1741 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1744 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1746 wcmd "freetile %s" (~
> opaque);
1747 state
.currently
<- Idle
;
1751 puttileopaque l col row gen cs angle
opaque size t
;
1752 state
.memused
<- state
.memused
+ size
;
1753 state
.uioh#infochanged Memused
;
1755 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1756 opaque, size
) state
.tilelru
;
1759 match state
.throttle
with
1760 | None
-> state
.layout
1761 | Some
(layout, _, _) -> layout
1764 state
.currently
<- Idle
;
1766 && conf
.colorspace
= cs
1767 && conf
.angle
= angle
1768 && tilevisible layout l.pageno x y
1769 then conttiling l.pageno pageopaque;
1771 begin match state
.throttle
with
1773 preload state
.layout;
1775 && conf
.colorspace
= cs
1776 && conf
.angle
= angle
1777 && tilevisible state
.layout l.pageno x y
1778 && (not
!wtmode || layoutready state
.layout)
1779 then G.postRedisplay "tile nothrottle";
1781 | Some
(layout, y, _) ->
1782 let ready = layoutready layout in
1786 state
.layout <- layout;
1787 state
.throttle
<- None
;
1788 G.postRedisplay "throttle";
1797 dolog
"Inconsistent tiling state";
1798 logcurrently state
.currently
;
1803 let (n, w, h, _) as pdim
=
1804 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1807 match conf
.fitmodel
with
1809 | FitPage
| FitProportional
->
1810 match conf
.columns
with
1811 | Csplit
_ -> (n, w, h, 0)
1812 | Csingle
_ | Cmulti
_ -> pdim
1814 state
.uioh#infochanged Pdim
;
1815 state
.pdims
<- pdim :: state
.pdims
1818 let (l, n, t
, h, pos
) =
1819 scan args
"%u %u %d %u %n"
1820 (fun l n t
h pos
-> l, n, t
, h, pos
)
1822 let s = String.sub args pos
(String.length args
- pos
) in
1823 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1826 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1827 let s = String.sub args pos
len in
1828 let pos2 = pos
+ len + 1 in
1829 let uri = String.sub args
pos2 (String.length args
- pos2) in
1830 addoutline (s, l, Ouri
uri)
1833 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1834 let s = String.sub args pos
(String.length args
- pos
) in
1835 addoutline (s, l, Onone
)
1839 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1841 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1844 let pos = nindex args '
\t'
in
1848 if substratis args
0 "Title"
1850 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1855 if substratis args
0 "CreationDate"
1857 if String.length args
>= pos + 7
1858 && args
.[pos+1] = 'D'
&& args
.[pos+2] = '
:'
1860 let b = Buffer.create
18 in
1861 Buffer.add_string
b "CreationDate\t";
1864 Buffer.add_substring
b args
(pos+p
+1) l;
1865 Buffer.add_char
b c;
1866 with exn
-> Buffer.add_string
b @@ Printexc.to_string exn
1874 Buffer.add_char
b '
['
;
1875 Buffer.add_substring
b args
(pos+1)
1876 (String.length args
- pos - 1);
1877 Buffer.add_char
b '
]'
;
1884 state
.docinfo
<- (1, s) :: state
.docinfo
1887 state
.uioh#infochanged Docinfo
;
1888 state
.docinfo
<- List.rev state
.docinfo
1892 then Wsi.settitle
"Wrong password";
1893 let password = getpassword () in
1894 if emptystr
password
1895 then error
"document is password protected"
1896 else opendoc state
.path
password
1899 error
"unknown cmd `%S'" cmds
1904 let action = function
1905 | HCprev
-> cbget cb ~
-1
1906 | HCnext
-> cbget cb
1
1907 | HCfirst
-> cbget cb ~
-(cb
.rc)
1908 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1909 and cancel
() = cb
.rc <- rc
1913 let search pattern forward
=
1914 match conf
.columns
with
1915 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1918 if nonemptystr pattern
1921 match state
.layout with
1924 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1926 wcmd "search %d %d %d %d,%s\000"
1927 (btod conf
.icase
) pn py (btod forward
) pattern
;
1930 let intentry text key =
1932 if key >= 32 && key < 127
1934 let c = Char.chr
key in
1936 | '
0'
.. '
9'
-> addchar
text c
1938 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1941 state
.text <- Printf.sprintf
"invalid key (%d)" key;
1952 let l = String.length
s in
1953 let rec loop pos n = if pos = l then n else
1954 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1955 loop (pos+1) (n*26 + m)
1958 let rec loop n = function
1961 match getopaque l.pageno with
1962 | None
-> loop n rest
1964 let m = getlinkcount
opaque in
1967 let under = getlink
opaque n in
1970 else loop (n-m) rest
1972 loop n state
.layout;
1976 let linknentry text key =
1977 if key >= 32 && key < 127
1979 let text = addchar
text (Char.chr
key) in
1980 linknact (fun under -> state
.text <- undertext under) text;
1983 state
.text <- Printf.sprintf
"invalid key %d" key;
1988 let textentry text key =
1989 if Wsi.isspecialkey
key
1991 else TEcont
(text ^ toutf8
key)
1994 let reqlayout angle fitmodel
=
1995 match state
.throttle
with
1997 if nogeomcmds state
.geomcmds
1998 then state
.anchor <- getanchor
();
1999 conf
.angle
<- angle
mod 360;
2002 match state
.mode
with
2003 | LinkNav
_ -> state
.mode
<- View
2008 conf
.fitmodel
<- fitmodel
;
2009 invalidate "reqlayout"
2011 wcmd "reqlayout %d %d %d"
2012 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2017 let settrim trimmargins trimfuzz
=
2018 if nogeomcmds state
.geomcmds
2019 then state
.anchor <- getanchor
();
2020 conf
.trimmargins
<- trimmargins
;
2021 conf
.trimfuzz
<- trimfuzz
;
2022 let x0, y0, x1, y1 = trimfuzz
in
2023 invalidate "settrim"
2025 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2030 match state
.throttle
with
2032 let zoom = max
0.0001 zoom in
2033 if zoom <> conf
.zoom
2035 state
.prevzoom
<- (conf
.zoom, state
.x);
2037 reshape state
.winw state
.winh
;
2038 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2041 | Some
(layout, y, started
) ->
2043 match conf
.maxwait
with
2047 let dt = now
() -. started
in
2055 let pivotzoom ?
(vw=min state
.w state
.winw
)
2056 ?
(vh
=min
(state
.maxy
-state
.y) state
.winh
)
2057 ?
(x=vw/2) ?
(y=vh
/2) zoom =
2058 let w = float state
.w /. zoom in
2059 let hw = w /. 2.0 in
2060 let ratio = float vh
/. float vw in
2061 let hh = hw *. ratio in
2062 let x0 = if zoom < 1.0 then 0.0 else float x -. hw in
2063 let y0 = float y -. hh in
2064 gotoxy (state
.x - truncate
x0) (state
.y + truncate
y0);
2068 let pivotzoom ?
vw ?vh ?
x ?
y zoom =
2069 if nogeomcmds state
.geomcmds
then pivotzoom ?
vw ?vh ?
x ?
y zoom
2072 let setcolumns mode columns coverA coverB
=
2073 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2077 then impmsg "split mode doesn't work in bird's eye"
2079 conf
.columns
<- Csplit
(-columns
, E.a);
2087 conf
.columns
<- Csingle
E.a;
2092 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2096 reshape state
.winw state
.winh
;
2099 let resetmstate () =
2100 state
.mstate
<- Mnone
;
2101 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2104 let enterbirdseye () =
2105 let zoom = float conf
.thumbw
/. float state
.winw
in
2106 let birdseyepageno =
2107 let cy = state
.winh
/ 2 in
2111 let rec fold best
= function
2114 let d = cy - (l.pagedispy + l.pagevh/2)
2115 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2116 if abs
d < abs dbest
2123 state
.mode
<- Birdseye
(
2124 { conf
with zoom = conf
.zoom }, state
.x, birdseyepageno, -1, getanchor
()
2128 conf
.presentation
<- false;
2129 conf
.interpagespace
<- 10;
2130 conf
.hlinks
<- false;
2131 conf
.fitmodel
<- FitPage
;
2133 conf
.maxwait
<- None
;
2135 match conf
.beyecolumns
with
2138 Cmulti
((c, 0, 0), E.a)
2139 | None
-> Csingle
E.a
2143 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2148 reshape state
.winw state
.winh
;
2151 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2153 conf
.zoom <- c.zoom;
2154 conf
.presentation
<- c.presentation
;
2155 conf
.interpagespace
<- c.interpagespace
;
2156 conf
.maxwait
<- c.maxwait
;
2157 conf
.hlinks
<- c.hlinks
;
2158 conf
.fitmodel
<- c.fitmodel
;
2159 conf
.beyecolumns
<- (
2160 match conf
.columns
with
2161 | Cmulti
((c, _, _), _) -> Some
c
2163 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2166 match c.columns
with
2167 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2168 | Csingle
_ -> Csingle
E.a
2169 | Csplit
(c, _) -> Csplit
(c, E.a)
2173 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2176 reshape state
.winw state
.winh
;
2177 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2181 let togglebirdseye () =
2182 match state
.mode
with
2183 | Birdseye vals
-> leavebirdseye vals
true
2184 | View
-> enterbirdseye ()
2189 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2190 let pageno = max
0 (pageno - incr
) in
2191 let rec loop = function
2192 | [] -> gotopage1 pageno 0
2193 | l :: _ when l.pageno = pageno ->
2194 if l.pagedispy >= 0 && l.pagey = 0
2195 then G.postRedisplay "upbirdseye"
2196 else gotopage1 pageno 0
2197 | _ :: rest
-> loop rest
2201 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2204 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2205 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2206 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2207 let rec loop = function
2209 let y, h = getpageyh
pageno in
2210 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2211 gotoxy state
.x (clamp dy)
2212 | l :: _ when l.pageno = pageno ->
2213 if l.pagevh != l.pageh
2214 then gotoxy state
.x (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2215 else G.postRedisplay "downbirdseye"
2216 | _ :: rest
-> loop rest
2222 let optentry mode
_ key =
2223 let btos b = if b then "on" else "off" in
2224 if key >= 32 && key < 127
2226 let c = Char.chr
key in
2230 try conf
.scrollstep
<- int_of_string
s with exn
->
2231 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2233 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2238 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2239 if state
.autoscroll
<> None
2240 then state
.autoscroll
<- Some conf
.autoscrollstep
2242 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2244 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2249 let n, a, b = multicolumns_of_string
s in
2250 setcolumns mode
n a b;
2252 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exn
2254 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2259 let zoom = float (int_of_string
s) /. 100.0 in
2262 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2264 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2269 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2271 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2272 begin match mode
with
2274 leavebirdseye beye
false;
2281 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2283 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2287 match int_of_string
s with
2288 | angle
-> reqlayout angle conf
.fitmodel
2291 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2293 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2296 conf
.icase
<- not conf
.icase
;
2297 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2300 conf
.preload <- not conf
.preload;
2301 gotoxy state
.x state
.y;
2302 TEdone
("preload " ^
(btos conf
.preload))
2305 conf
.verbose
<- not conf
.verbose
;
2306 TEdone
("verbose " ^
(btos conf
.verbose
))
2309 conf
.debug
<- not conf
.debug
;
2310 TEdone
("debug " ^
(btos conf
.debug
))
2313 conf
.maxhfit
<- not conf
.maxhfit
;
2314 state
.maxy
<- calcheight
();
2315 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2318 conf
.crophack
<- not conf
.crophack
;
2319 TEdone
("crophack " ^
btos conf
.crophack
)
2323 match conf
.maxwait
with
2325 conf
.maxwait
<- Some infinity
;
2326 "always wait for page to complete"
2328 conf
.maxwait
<- None
;
2329 "show placeholder if page is not ready"
2334 conf
.underinfo
<- not conf
.underinfo
;
2335 TEdone
("underinfo " ^
btos conf
.underinfo
)
2338 conf
.savebmarks
<- not conf
.savebmarks
;
2339 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2345 match state
.layout with
2350 conf
.interpagespace
<- int_of_string
s;
2351 docolumns conf
.columns
;
2352 state
.maxy
<- calcheight
();
2353 let y = getpagey
pageno in
2354 gotoxy state
.x (y + py)
2356 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2358 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2362 match conf
.fitmodel
with
2363 | FitProportional
-> FitWidth
2364 | FitWidth
| FitPage
-> FitProportional
2366 reqlayout conf
.angle
fm;
2367 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2370 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2371 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2374 conf
.invert
<- not conf
.invert
;
2375 TEdone
("invert colors " ^
btos conf
.invert
)
2379 cbput state
.hists
.sel
s;
2382 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2383 textentry, ondone, true)
2387 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2388 else conf
.pax
<- None
;
2389 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2392 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2398 class type lvsource
= object
2399 method getitemcount
: int
2400 method getitem
: int -> (string * int)
2401 method hasaction
: int -> bool
2409 method getactive
: int
2410 method getfirst
: int
2412 method getminfo
: (int * int) array
2415 class virtual lvsourcebase
= object
2416 val mutable m_active
= 0
2417 val mutable m_first
= 0
2418 val mutable m_pan
= 0
2419 method getactive
= m_active
2420 method getfirst
= m_first
2421 method getpan
= m_pan
2422 method getminfo
: (int * int) array
= E.a
2425 let textentrykeyboard
2426 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2428 let key = Wsi.keypadtodigitkey
key in
2430 state
.mode
<- Textentry
(te
, onleave
);
2432 G.postRedisplay "textentrykeyboard enttext";
2434 let histaction cmd
=
2437 | Some
(action, _) ->
2438 state
.mode
<- Textentry
(
2439 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2441 G.postRedisplay "textentry histaction"
2445 if emptystr
text && cancelonempty
2448 G.postRedisplay "textentrykeyboard after cancel";
2451 let s = withoutlastutf8
text in
2452 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2454 | @enter
| @kpenter
->
2457 G.postRedisplay "textentrykeyboard after confirm"
2459 | @up
| @kpup
-> histaction HCprev
2460 | @down
| @kpdown
-> histaction HCnext
2461 | @home
| @kphome
-> histaction HCfirst
2462 | @jend
| @kpend
-> histaction HClast
2467 begin match opthist
with
2469 | Some
(_, onhistcancel
) -> onhistcancel
()
2473 G.postRedisplay "textentrykeyboard after cancel2"
2476 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2479 | @delete
| @kpdelete
-> ()
2481 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2482 begin match onkey
text key with
2486 G.postRedisplay "textentrykeyboard after confirm2";
2489 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2493 G.postRedisplay "textentrykeyboard after cancel3"
2496 state
.mode
<- Textentry
(te
, onleave
);
2497 G.postRedisplay "textentrykeyboard switch";
2501 vlog "unhandled key %s" (Wsi.keyname
key)
2504 let firstof first active
=
2505 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2506 then max
0 (active
- (fstate
.maxrows
/2))
2510 let calcfirst first active
=
2513 let rows = active
- first
in
2514 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2518 let scrollph y maxy
=
2519 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2520 let sh = float state
.winh
/. sh in
2521 let sh = max
sh (float conf
.scrollh
) in
2523 let percent = float y /. float maxy
in
2524 let position = (float state
.winh
-. sh) *. percent in
2527 if position +. sh > float state
.winh
2528 then float state
.winh
-. sh
2534 let adderrmsg src msg
=
2535 Buffer.add_string state
.errmsgs msg
;
2536 state
.newerrmsgs
<- true;
2540 let adderrfmt src fmt
=
2541 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2544 let coe s = (s :> uioh
);;
2546 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2548 val m_pan
= source#getpan
2549 val m_first
= source#getfirst
2550 val m_active
= source#getactive
2552 val m_prev_uioh
= state
.uioh
2554 method private elemunder
y =
2558 let n = y / (fstate
.fontsize
+1) in
2559 if m_first
+ n < source#getitemcount
2561 if source#hasaction
(m_first
+ n)
2562 then Some
(m_first
+ n)
2569 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2570 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2571 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2572 GlDraw.color (1., 1., 1.);
2573 Gl.enable `texture_2d
;
2574 let fs = fstate
.fontsize
in
2576 let hw = state
.winw
/3 in
2577 let ww = fstate
.wwidth
in
2578 let tabw = 17.0*.ww in
2579 let itemcount = source#getitemcount
in
2580 let minfo = source#getminfo
in
2584 GlMat.translate ~
x:(float conf
.scrollbw
) ();
2586 let x0 = 0.0 and x1 = float (state
.winw
- conf
.scrollbw
- 1) in
2588 if (row - m_first
) > fstate
.maxrows
2591 if row >= 0 && row < itemcount
2593 let (s, level
) = source#getitem
row in
2594 let y = (row - m_first
) * nfs in
2595 let x = 5.0 +. (float (level
+ m_pan
)) *. ww in
2598 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2602 Gl.disable `texture_2d
;
2603 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2604 GlDraw.color (1., 1., 1.) ~
alpha;
2605 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2606 Gl.enable `texture_2d
;
2609 if zebra
&& row land 1 = 1
2613 GlDraw.color (c,c,c);
2614 let drawtabularstring s =
2616 let x'
= truncate
(x0 +. x) in
2617 let pos = nindex
s '
\000'
in
2619 then drawstring1 fs x'
(y+nfs) s
2621 let s1 = String.sub s 0 pos
2622 and s2
= String.sub s (pos+1) (String.length
s - pos - 1) in
2627 let s'
= withoutlastutf8
s in
2628 let s = s' ^
"@Uellipsis" in
2629 let w = measurestr
fs s in
2630 if float x'
+. w +. ww < float (hw + x'
)
2635 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2639 ignore
(drawstring1 fs x'
(y+nfs) s1);
2640 drawstring1 fs (hw + x'
) (y+nfs) s2
2644 let x = if helpmode
&& row > 0 then x +. ww else x in
2645 let tabpos = nindex
s '
\t'
in
2648 let len = String.length
s - tabpos - 1 in
2649 let s1 = String.sub s 0 tabpos
2650 and s2
= String.sub s (tabpos + 1) len in
2651 let nx = drawstr x s1 in
2653 let x = x +. (max
tabw sw) in
2656 let len = String.length
s - 2 in
2657 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2659 let s = String.sub s 2 len in
2660 let x = if not helpmode
then x +. ww else x in
2661 GlDraw.color (1.2, 1.2, 1.2);
2662 let vinc = drawstring1 (fs+fs/4)
2663 (truncate
(x -. ww)) (y+nfs) s in
2664 GlDraw.color (1., 1., 1.);
2665 vinc +. (float fs *. 0.8)
2671 ignore
(drawtabularstring s);
2677 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2680 if (row - m_first
) > fstate
.maxrows
2683 if row >= 0 && row < itemcount
2685 let (s, level
) = source#getitem
row in
2686 let pos0 = nindex
s '
\000'
in
2687 let y = (row - m_first
) * nfs in
2688 let x = float (level
+ m_pan
) *. ww in
2689 let (first
, last
) = minfo.(row) in
2691 if pos0 > 0 && first
> pos0
2692 then String.sub s (pos0+1) (first
-pos0-1)
2693 else String.sub s 0 first
2695 let suffix = String.sub s first
(last
- first
) in
2696 let w1 = measurestr fstate
.fontsize
prefix in
2697 let w2 = measurestr fstate
.fontsize
suffix in
2698 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2699 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2701 and y0 = float (y+2) in
2703 and y1 = float (y+fs+3) in
2704 filledrect x0 y0 x1 y1;
2709 Gl.disable `texture_2d
;
2710 if Array.length
minfo > 0 then loop m_first
;
2715 method updownlevel incr
=
2716 let len = source#getitemcount
in
2718 if m_active
>= 0 && m_active
< len
2719 then snd
(source#getitem m_active
)
2723 if i
= len then i
-1 else if i
= -1 then 0 else
2724 let _, l = source#getitem i
in
2725 if l != curlevel then i
else flow (i
+incr
)
2727 let active = flow m_active
in
2728 let first = calcfirst m_first
active in
2729 G.postRedisplay "outline updownlevel";
2730 {< m_active
= active; m_first
= first >}
2732 method private key1
key mask
=
2733 let set1 active first qsearch
=
2734 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2736 let search active pattern incr
=
2737 let active = if active = -1 then m_first
else active in
2740 if n >= 0 && n < source#getitemcount
2742 let s, _ = source#getitem
n in
2743 match Str.search_forward re
s 0 with
2744 | (exception Not_found
) -> loop (n + incr
)
2751 let qpat = Str.quote pattern
in
2752 match Str.regexp_case_fold
qpat with
2755 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2756 qpat @@ Printexc.to_string exn
;
2759 let itemcount = source#getitemcount
in
2760 let find start incr
=
2762 if i
= -1 || i
= itemcount
2765 if source#hasaction i
2767 else find (i
+ incr
)
2772 let set active first =
2773 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2775 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2778 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2780 let incr1 = if incr
> 0 then 1 else -1 in
2781 if isvisible m_first m_active
2784 let next = m_active
+ incr
in
2786 if next < 0 || next >= itemcount
2788 else find next incr1
2790 if abs
(m_active
- next) > fstate
.maxrows
2796 let first = m_first
+ incr
in
2797 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2799 let next = m_active
+ incr
in
2800 let next = bound
next 0 (itemcount - 1) in
2807 if isvisible first next
2814 let first = min
next m_first
in
2816 if abs
(next - first) > fstate
.maxrows
2822 let first = m_first
+ incr
in
2823 let first = bound
first 0 (itemcount - 1) in
2825 let next = m_active
+ incr
in
2826 let next = bound
next 0 (itemcount - 1) in
2827 let next = find next incr1 in
2829 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2831 let active = if m_active
= -1 then next else m_active
in
2836 if isvisible first active
2842 G.postRedisplay "listview navigate";
2846 | (@r
|@s) when Wsi.withctrl mask
->
2847 let incr = if key = @r
then -1 else 1 in
2849 match search (m_active
+ incr) m_qsearch
incr with
2851 state
.text <- m_qsearch ^
" [not found]";
2854 state
.text <- m_qsearch
;
2855 active, firstof m_first
active
2857 G.postRedisplay "listview ctrl-r/s";
2858 set1 active first m_qsearch
;
2860 | @insert
when Wsi.withctrl mask
->
2861 if m_active
>= 0 && m_active
< source#getitemcount
2863 let s, _ = source#getitem m_active
in
2869 if emptystr m_qsearch
2872 let qsearch = withoutlastutf8 m_qsearch
in
2876 G.postRedisplay "listview empty qsearch";
2877 set1 m_active m_first
E.s;
2881 match search m_active
qsearch ~
-1 with
2883 state
.text <- qsearch ^
" [not found]";
2886 state
.text <- qsearch;
2887 active, firstof m_first
active
2889 G.postRedisplay "listview backspace qsearch";
2890 set1 active first qsearch
2893 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2894 let pattern = m_qsearch ^ toutf8
key in
2896 match search m_active
pattern 1 with
2898 state
.text <- pattern ^
" [not found]";
2901 state
.text <- pattern;
2902 active, firstof m_first
active
2904 G.postRedisplay "listview qsearch add";
2905 set1 active first pattern;
2909 if emptystr m_qsearch
2911 G.postRedisplay "list view escape";
2912 let mx, my
= state
.mpos
in
2916 source#exit ~uioh
:(coe self
)
2917 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2919 | None
-> m_prev_uioh
2924 G.postRedisplay "list view kill qsearch";
2925 coe {< m_qsearch
= E.s >}
2928 | @enter
| @kpenter
->
2930 let self = {< m_qsearch
= E.s >} in
2932 G.postRedisplay "listview enter";
2933 if m_active
>= 0 && m_active
< source#getitemcount
2935 source#exit ~uioh
:(coe self) ~cancel
:false
2936 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2939 source#exit ~uioh
:(coe self) ~cancel
:true
2940 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2943 begin match opt with
2944 | None
-> m_prev_uioh
2948 | @delete
| @kpdelete
->
2951 | @up
| @kpup
-> navigate ~
-1
2952 | @down
| @kpdown
-> navigate 1
2953 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2954 | @next | @kpnext
-> navigate fstate
.maxrows
2956 | @right
| @kpright
->
2958 G.postRedisplay "listview right";
2959 coe {< m_pan
= m_pan
- 1 >}
2961 | @left | @kpleft
->
2963 G.postRedisplay "listview left";
2964 coe {< m_pan
= m_pan
+ 1 >}
2966 | @home
| @kphome
->
2967 let active = find 0 1 in
2968 G.postRedisplay "listview home";
2972 let first = max
0 (itemcount - fstate
.maxrows
) in
2973 let active = find (itemcount - 1) ~
-1 in
2974 G.postRedisplay "listview end";
2977 | key when (key = 0 || Wsi.isspecialkey
key) ->
2981 dolog
"listview unknown key %#x" key; coe self
2983 method key key mask
=
2984 match state
.mode
with
2985 | Textentry te
-> textentrykeyboard key mask te
; coe self
2988 | LinkNav
_ -> self#key1
key mask
2990 method button button down
x y _ =
2993 | 1 when vscrollhit x ->
2994 G.postRedisplay "listview scroll";
2997 let _, position, sh = self#
scrollph in
2998 if y > truncate
position && y < truncate
(position +. sh)
3000 state
.mstate
<- Mscrolly
;
3004 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3005 let first = truncate
(s *. float source#getitemcount
) in
3006 let first = min source#getitemcount
first in
3007 Some
(coe {< m_first
= first; m_active
= first >})
3009 state
.mstate
<- Mnone
;
3013 begin match self#elemunder
y with
3015 G.postRedisplay "listview click";
3016 source#exit ~uioh
:(coe {< m_active
= n >})
3017 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3021 | n when (n == 4 || n == 5) && not down
->
3022 let len = source#getitemcount
in
3024 if n = 5 && m_first
+ fstate
.maxrows
>= len
3028 let first = m_first
+ (if n == 4 then -1 else 1) in
3029 bound
first 0 (len - 1)
3031 G.postRedisplay "listview wheel";
3032 Some
(coe {< m_first
= first >})
3033 | n when (n = 6 || n = 7) && not down
->
3034 let inc = if n = 7 then -1 else 1 in
3035 G.postRedisplay "listview hwheel";
3036 Some
(coe {< m_pan
= m_pan
+ inc >})
3041 | None
-> m_prev_uioh
3044 method multiclick
_ x y = self#button
1 true x y
3047 match state
.mstate
with
3049 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3050 let first = truncate
(s *. float source#getitemcount
) in
3051 let first = min source#getitemcount
first in
3052 G.postRedisplay "listview motion";
3053 coe {< m_first
= first; m_active
= first >}
3061 method pmotion
x y =
3062 if x < state
.winw
- conf
.scrollbw
3065 match self#elemunder
y with
3066 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3067 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3071 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3076 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3080 method infochanged
_ = ()
3082 method scrollpw
= (0, 0.0, 0.0)
3084 let nfs = fstate
.fontsize
+ 1 in
3085 let y = m_first
* nfs in
3086 let itemcount = source#getitemcount
in
3087 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3088 let maxy = maxi * nfs in
3089 let p, h = scrollph y maxy in
3092 method modehash
= modehash
3093 method eformsgs
= false
3094 method alwaysscrolly
= true
3097 class outlinelistview ~zebra ~source
=
3098 let settext autonarrow
s =
3101 let ss = source#statestr
in
3105 else "{" ^
ss ^
"} [" ^
s ^
"]"
3106 else state
.text <- s
3112 ~source
:(source
:> lvsource
)
3114 ~modehash
:(findkeyhash conf
"outline")
3117 val m_autonarrow
= false
3119 method! key key mask
=
3121 if emptystr state
.text
3123 else fstate
.maxrows - 2
3125 let calcfirst first active =
3128 let rows = active - first in
3129 if rows > maxrows then active - maxrows else first
3133 let active = m_active
+ incr in
3134 let active = bound
active 0 (source#getitemcount
- 1) in
3135 let first = calcfirst m_first
active in
3136 G.postRedisplay "outline navigate";
3137 coe {< m_active
= active; m_first
= first >}
3139 let navscroll first =
3141 let dist = m_active
- first in
3147 else first + maxrows
3150 G.postRedisplay "outline navscroll";
3151 coe {< m_first
= first; m_active
= active >}
3153 let ctrl = Wsi.withctrl mask
in
3158 then (source#denarrow
; E.s)
3160 let pattern = source#renarrow
in
3161 if nonemptystr m_qsearch
3162 then (source#narrow m_qsearch
; m_qsearch
)
3166 settext (not m_autonarrow
) text;
3167 G.postRedisplay "toggle auto narrowing";
3168 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3170 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3172 G.postRedisplay "toggle auto narrowing";
3173 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3176 source#narrow m_qsearch
;
3178 then source#add_narrow_pattern m_qsearch
;
3179 G.postRedisplay "outline ctrl-n";
3180 coe {< m_first
= 0; m_active
= 0 >}
3183 let active = source#calcactive
(getanchor
()) in
3184 let first = firstof m_first
active in
3185 G.postRedisplay "outline ctrl-s";
3186 coe {< m_first
= first; m_active
= active >}
3189 G.postRedisplay "outline ctrl-u";
3190 if m_autonarrow
&& nonemptystr m_qsearch
3192 ignore
(source#renarrow
);
3193 settext m_autonarrow
E.s;
3194 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3197 source#del_narrow_pattern
;
3198 let pattern = source#renarrow
in
3200 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3202 settext m_autonarrow
text;
3203 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3207 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3208 G.postRedisplay "outline ctrl-l";
3209 coe {< m_first
= first >}
3211 | @tab
when m_autonarrow
->
3212 if nonemptystr m_qsearch
3214 G.postRedisplay "outline list view tab";
3215 source#add_narrow_pattern m_qsearch
;
3217 coe {< m_qsearch
= E.s >}
3221 | @escape
when m_autonarrow
->
3222 if nonemptystr m_qsearch
3223 then source#add_narrow_pattern m_qsearch
;
3226 | @enter
| @kpenter
when m_autonarrow
->
3227 if nonemptystr m_qsearch
3228 then source#add_narrow_pattern m_qsearch
;
3231 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3232 let pattern = m_qsearch ^ toutf8
key in
3233 G.postRedisplay "outlinelistview autonarrow add";
3234 source#narrow
pattern;
3235 settext true pattern;
3236 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3238 | key when m_autonarrow
&& key = @backspace
->
3239 if emptystr m_qsearch
3242 let pattern = withoutlastutf8 m_qsearch
in
3243 G.postRedisplay "outlinelistview autonarrow backspace";
3244 ignore
(source#renarrow
);
3245 source#narrow
pattern;
3246 settext true pattern;
3247 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3249 | @up
| @kpup
when ctrl ->
3250 navscroll (max
0 (m_first
- 1))
3252 | @down
| @kpdown
when ctrl ->
3253 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3255 | @up
| @kpup
-> navigate ~
-1
3256 | @down
| @kpdown
-> navigate 1
3257 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3258 | @next | @kpnext
-> navigate fstate
.maxrows
3260 | @right
| @kpright
->
3264 G.postRedisplay "outline ctrl right";
3265 {< m_pan
= m_pan
+ 1 >}
3267 else self#updownlevel
1
3271 | @left | @kpleft
->
3275 G.postRedisplay "outline ctrl left";
3276 {< m_pan
= m_pan
- 1 >}
3278 else self#updownlevel ~
-1
3282 | @home
| @kphome
->
3283 G.postRedisplay "outline home";
3284 coe {< m_first
= 0; m_active
= 0 >}
3287 let active = source#getitemcount
- 1 in
3288 let first = max
0 (active - fstate
.maxrows) in
3289 G.postRedisplay "outline end";
3290 coe {< m_active
= active; m_first
= first >}
3292 | _ -> super#
key key mask
3295 let genhistoutlines () =
3297 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3298 compare c2
.lastvisit c1
.lastvisit
)
3300 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3301 let path = if nonemptystr origin
then origin
else path in
3302 let base = mbtoutf8
@@ Filename.basename
path in
3303 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3308 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3309 Config.save
leavebirdseye;
3310 state
.anchor <- anchor;
3311 state
.bookmarks
<- bookmarks
;
3312 state
.origin
<- origin
;
3315 let x0, y0, x1, y1 = conf
.trimfuzz
in
3316 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3317 reshape ~firsttime
:true state
.winw state
.winh
;
3318 opendoc path origin
;
3322 let makecheckers () =
3323 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3325 converted by Issac Trotts. July 25, 2002 *)
3326 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3327 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3328 let id = GlTex.gen_texture
() in
3329 GlTex.bind_texture ~target
:`texture_2d
id;
3330 GlPix.store
(`unpack_alignment
1);
3331 GlTex.image2d
image;
3332 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3333 [ `mag_filter `nearest
; `min_filter `nearest
];
3337 let setcheckers enabled
=
3338 match state
.checkerstexid
with
3340 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3342 | Some checkerstexid
->
3345 GlTex.delete_texture checkerstexid
;
3346 state
.checkerstexid
<- None
;
3350 let describe_location () =
3351 let fn = page_of_y state
.y in
3352 let ln = page_of_y
(state
.y + state
.winh
- 1) in
3353 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3357 else (100. *. (float state
.y /. float maxy))
3361 Printf.sprintf
"page %d of %d [%.2f%%]"
3362 (fn+1) state
.pagecount
percent
3365 "pages %d-%d of %d [%.2f%%]"
3366 (fn+1) (ln+1) state
.pagecount
percent
3369 let setpresentationmode v
=
3370 let n = page_of_y state
.y in
3371 state
.anchor <- (n, 0.0, 1.0);
3372 conf
.presentation
<- v
;
3373 if conf
.fitmodel
= FitPage
3374 then reqlayout conf
.angle conf
.fitmodel
;
3378 let setbgcol (r
, g, b) =
3380 let r = r *. 255.0 |> truncate
3381 and g = g *. 255.0 |> truncate
3382 and b = b *. 255.0 |> truncate
in
3383 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3385 Wsi.setwinbgcol
col;
3389 let btos b = if b then "@Uradical" else E.s in
3390 let showextended = ref false in
3391 let leave mode
_ = state
.mode
<- mode
in
3394 val mutable m_l
= []
3395 val mutable m_a
= E.a
3396 val mutable m_prev_uioh
= nouioh
3397 val mutable m_prev_mode
= View
3399 inherit lvsourcebase
3401 method reset prev_mode prev_uioh
=
3402 m_a
<- Array.of_list
(List.rev m_l
);
3404 m_prev_mode
<- prev_mode
;
3405 m_prev_uioh
<- prev_uioh
;
3407 method int name get
set =
3409 (name
, `
int get
, 1, Action
(
3412 try set (int_of_string
s)
3414 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3418 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3419 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3423 method int_with_suffix name get
set =
3425 (name
, `intws get
, 1, Action
(
3428 try set (int_of_string_with_suffix
s)
3430 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3435 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3437 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3441 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3443 (name
, `
bool (btos, get
), offset
, Action
(
3450 method color name get
set =
3452 (name
, `
color get
, 1, Action
(
3454 let invalid = (nan
, nan
, nan
) in
3457 try color_of_string
s
3459 state
.text <- Printf.sprintf
"bad color `%s': %s"
3466 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3467 state
.text <- color_to_string
(get
());
3468 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3472 method string name get
set =
3474 (name
, `
string get
, 1, Action
(
3476 let ondone s = set s in
3477 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method colorspace name get
set =
3484 (name
, `
string get
, 1, Action
(
3488 inherit lvsourcebase
3491 m_active
<- CSTE.to_int conf
.colorspace
;
3494 method getitemcount
=
3495 Array.length
CSTE.names
3498 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3499 ignore
(uioh
, first, pan
);
3500 if not cancel
then set active;
3502 method hasaction
_ = true
3506 let modehash = findkeyhash conf
"info" in
3507 coe (new listview ~zebra
:false ~helpmode
:false
3508 ~
source ~trusted
:true ~
modehash)
3511 method paxmark name get
set =
3513 (name
, `
string get
, 1, Action
(
3517 inherit lvsourcebase
3520 m_active
<- MTE.to_int conf
.paxmark
;
3523 method getitemcount
= Array.length
MTE.names
3524 method getitem
n = (MTE.names
.(n), 0)
3525 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3526 ignore
(uioh
, first, pan
);
3527 if not cancel
then set active;
3529 method hasaction
_ = true
3533 let modehash = findkeyhash conf
"info" in
3534 coe (new listview ~zebra
:false ~helpmode
:false
3535 ~
source ~trusted
:true ~
modehash)
3538 method fitmodel name get
set =
3540 (name
, `
string get
, 1, Action
(
3544 inherit lvsourcebase
3547 m_active
<- FMTE.to_int conf
.fitmodel
;
3550 method getitemcount
= Array.length
FMTE.names
3551 method getitem
n = (FMTE.names
.(n), 0)
3552 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3553 ignore
(uioh
, first, pan
);
3554 if not cancel
then set active;
3556 method hasaction
_ = true
3560 let modehash = findkeyhash conf
"info" in
3561 coe (new listview ~zebra
:false ~helpmode
:false
3562 ~
source ~trusted
:true ~
modehash)
3565 method caption
s offset
=
3566 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3568 method caption2
s f offset
=
3569 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3571 method getitemcount
= Array.length m_a
3574 let tostr = function
3575 | `
int f -> string_of_int
(f ())
3576 | `intws
f -> string_with_suffix_of_int
(f ())
3578 | `
color f -> color_to_string
(f ())
3579 | `
bool (btos, f) -> btos (f ())
3582 let name, t
, offset
, _ = m_a
.(n) in
3583 ((let s = tostr t
in
3585 then Printf.sprintf
"%s\t%s" name s
3589 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3594 match m_a
.(active) with
3595 | _, _, _, Action
f -> f uioh
3596 | _, _, _, Noaction
-> uioh
3607 method hasaction
n =
3609 | _, _, _, Action
_ -> true
3610 | _, _, _, Noaction
-> false
3612 initializer m_active
<- 1
3615 let rec fillsrc prevmode prevuioh
=
3616 let sep () = src#caption
E.s 0 in
3617 let colorp name get
set =
3619 (fun () -> color_to_string
(get
()))
3622 let c = color_of_string
v in
3625 state
.text <- Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3628 let oldmode = state
.mode
in
3629 let birdseye = isbirdseye state
.mode
in
3631 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3633 src#
bool "presentation mode"
3634 (fun () -> conf
.presentation
)
3635 (fun v -> setpresentationmode v);
3637 src#
bool "ignore case in searches"
3638 (fun () -> conf
.icase
)
3639 (fun v -> conf
.icase
<- v);
3642 (fun () -> conf
.preload)
3643 (fun v -> conf
.preload <- v);
3645 src#
bool "highlight links"
3646 (fun () -> conf
.hlinks
)
3647 (fun v -> conf
.hlinks
<- v);
3649 src#
bool "under info"
3650 (fun () -> conf
.underinfo
)
3651 (fun v -> conf
.underinfo
<- v);
3653 src#
bool "persistent bookmarks"
3654 (fun () -> conf
.savebmarks
)
3655 (fun v -> conf
.savebmarks
<- v);
3657 src#fitmodel
"fit model"
3658 (fun () -> FMTE.to_string conf
.fitmodel
)
3659 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3661 src#
bool "trim margins"
3662 (fun () -> conf
.trimmargins
)
3663 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3665 src#
bool "persistent location"
3666 (fun () -> conf
.jumpback
)
3667 (fun v -> conf
.jumpback
<- v);
3670 src#
int "inter-page space"
3671 (fun () -> conf
.interpagespace
)
3673 conf
.interpagespace
<- n;
3674 docolumns conf
.columns
;
3676 match state
.layout with
3681 state
.maxy <- calcheight
();
3682 let y = getpagey
pageno in
3683 gotoxy state
.x (y + py)
3687 (fun () -> conf
.pagebias
)
3688 (fun v -> conf
.pagebias
<- v);
3690 src#
int "scroll step"
3691 (fun () -> conf
.scrollstep
)
3692 (fun n -> conf
.scrollstep
<- n);
3694 src#
int "horizontal scroll step"
3695 (fun () -> conf
.hscrollstep
)
3696 (fun v -> conf
.hscrollstep
<- v);
3698 src#
int "auto scroll step"
3700 match state
.autoscroll
with
3702 | _ -> conf
.autoscrollstep
)
3704 let n = boundastep state
.winh
n in
3705 if state
.autoscroll
<> None
3706 then state
.autoscroll
<- Some
n;
3707 conf
.autoscrollstep
<- n);
3710 (fun () -> truncate
(conf
.zoom *. 100.))
3711 (fun v -> pivotzoom ((float v) /. 100.));
3714 (fun () -> conf
.angle
)
3715 (fun v -> reqlayout v conf
.fitmodel
);
3717 src#
int "scroll bar width"
3718 (fun () -> conf
.scrollbw
)
3721 reshape state
.winw state
.winh
;
3724 src#
int "scroll handle height"
3725 (fun () -> conf
.scrollh
)
3726 (fun v -> conf
.scrollh
<- v;);
3728 src#
int "thumbnail width"
3729 (fun () -> conf
.thumbw
)
3731 conf
.thumbw
<- min
4096 v;
3734 leavebirdseye beye
false;
3741 let mode = state
.mode in
3742 src#
string "columns"
3744 match conf
.columns
with
3746 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3747 | Csplit
(count
, _) -> "-" ^ string_of_int count
3750 let n, a, b = multicolumns_of_string
v in
3751 setcolumns mode n a b);
3754 src#caption
"Pixmap cache" 0;
3755 src#int_with_suffix
"size (advisory)"
3756 (fun () -> conf
.memlimit
)
3757 (fun v -> conf
.memlimit
<- v);
3760 (fun () -> Printf.sprintf
"%s bytes, %d tiles"
3761 (string_with_suffix_of_int state
.memused
)
3762 (Hashtbl.length state
.tilemap
)) 1;
3765 src#caption
"Layout" 0;
3766 src#caption2
"Dimension"
3768 Printf.sprintf
"%dx%d (virtual %dx%d)"
3769 state
.winw state
.winh
3774 src#caption2
"Position" (fun () ->
3775 Printf.sprintf
"%dx%d" state
.x state
.y
3778 src#caption2
"Position" (fun () -> describe_location ()) 1
3782 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3783 "Save these parameters as global defaults at exit"
3784 (fun () -> conf
.bedefault
)
3785 (fun v -> conf
.bedefault
<- v)
3789 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3790 src#
bool ~offset
:0 ~
btos "Extended parameters"
3791 (fun () -> !showextended)
3792 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3796 (fun () -> conf
.checkers
)
3797 (fun v -> conf
.checkers
<- v; setcheckers v);
3798 src#
bool "update cursor"
3799 (fun () -> conf
.updatecurs
)
3800 (fun v -> conf
.updatecurs
<- v);
3801 src#
bool "scroll-bar on the left"
3802 (fun () -> conf
.leftscroll
)
3803 (fun v -> conf
.leftscroll
<- v);
3805 (fun () -> conf
.verbose
)
3806 (fun v -> conf
.verbose
<- v);
3807 src#
bool "invert colors"
3808 (fun () -> conf
.invert
)
3809 (fun v -> conf
.invert
<- v);
3811 (fun () -> conf
.maxhfit
)
3812 (fun v -> conf
.maxhfit
<- v);
3814 (fun () -> conf
.pax
!= None
)
3817 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3818 else conf
.pax
<- None
);
3819 src#
string "uri launcher"
3820 (fun () -> conf
.urilauncher
)
3821 (fun v -> conf
.urilauncher
<- v);
3822 src#
string "path launcher"
3823 (fun () -> conf
.pathlauncher
)
3824 (fun v -> conf
.pathlauncher
<- v);
3825 src#
string "tile size"
3826 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3829 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3830 conf
.tilew
<- max
64 w;
3831 conf
.tileh
<- max
64 h;
3834 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3837 src#
int "texture count"
3838 (fun () -> conf
.texcount
)
3841 then conf
.texcount
<- v
3842 else impmsg "failed to set texture count please retry later"
3844 src#
int "slice height"
3845 (fun () -> conf
.sliceheight
)
3847 conf
.sliceheight
<- v;
3848 wcmd "sliceh %d" conf
.sliceheight
;
3850 src#
int "anti-aliasing level"
3851 (fun () -> conf
.aalevel
)
3853 conf
.aalevel
<- bound
v 0 8;
3854 state
.anchor <- getanchor
();
3855 opendoc state
.path state
.password;
3857 src#
string "page scroll scaling factor"
3858 (fun () -> string_of_float conf
.pgscale)
3861 let s = float_of_string
v in
3864 state
.text <- Printf.sprintf
3865 "bad page scroll scaling factor `%s': %s" v @@ exntos exn
3868 src#
int "ui font size"
3869 (fun () -> fstate
.fontsize
)
3870 (fun v -> setfontsize (bound
v 5 100));
3871 src#
int "hint font size"
3872 (fun () -> conf
.hfsize
)
3873 (fun v -> conf
.hfsize
<- bound
v 5 100);
3874 colorp "background color"
3875 (fun () -> conf
.bgcolor
)
3876 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3877 src#
bool "crop hack"
3878 (fun () -> conf
.crophack
)
3879 (fun v -> conf
.crophack
<- v);
3880 src#
string "trim fuzz"
3881 (fun () -> irect_to_string conf
.trimfuzz
)
3884 conf
.trimfuzz
<- irect_of_string
v;
3886 then settrim true conf
.trimfuzz
;
3888 state
.text <- Printf.sprintf
"bad irect `%s': %s" v @@ exntos exn
3890 src#
string "throttle"
3892 match conf
.maxwait
with
3893 | None
-> "show place holder if page is not ready"
3896 then "wait for page to fully render"
3898 "wait " ^ string_of_float
time
3899 ^
" seconds before showing placeholder"
3903 let f = float_of_string
v in
3905 then conf
.maxwait
<- None
3906 else conf
.maxwait
<- Some
f
3908 state
.text <- Printf.sprintf
"bad time `%s': %s" v @@ exntos exn
3910 src#
string "ghyll scroll"
3912 match conf
.ghyllscroll
with
3914 | Some nab
-> ghyllscroll_to_string nab
3917 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3920 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3922 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v @@ exntos exn
3924 src#
string "selection command"
3925 (fun () -> conf
.selcmd
)
3926 (fun v -> conf
.selcmd
<- v);
3927 src#
string "synctex command"
3928 (fun () -> conf
.stcmd
)
3929 (fun v -> conf
.stcmd
<- v);
3930 src#
string "pax command"
3931 (fun () -> conf
.paxcmd
)
3932 (fun v -> conf
.paxcmd
<- v);
3933 src#
string "ask password command"
3934 (fun () -> conf
.passcmd)
3935 (fun v -> conf
.passcmd <- v);
3936 src#
string "save path command"
3937 (fun () -> conf
.savecmd
)
3938 (fun v -> conf
.savecmd
<- v);
3939 src#colorspace
"color space"
3940 (fun () -> CSTE.to_string conf
.colorspace
)
3942 conf
.colorspace
<- CSTE.of_int
v;
3946 src#paxmark
"pax mark method"
3947 (fun () -> MTE.to_string conf
.paxmark
)
3948 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3949 if bousable
() && !opengl_has_pbo
3952 (fun () -> conf
.usepbo
)
3953 (fun v -> conf
.usepbo
<- v);
3954 src#
bool "mouse wheel scrolls pages"
3955 (fun () -> conf
.wheelbypage
)
3956 (fun v -> conf
.wheelbypage
<- v);
3957 src#
bool "open remote links in a new instance"
3958 (fun () -> conf
.riani
)
3959 (fun v -> conf
.riani
<- v);
3960 src#
bool "edit annotations inline"
3961 (fun () -> conf
.annotinline
)
3962 (fun v -> conf
.annotinline
<- v);
3963 src#
bool "coarse positioning in presentation mode"
3964 (fun () -> conf
.coarseprespos
)
3965 (fun v -> conf
.coarseprespos
<- v);
3969 src#caption
"Document" 0;
3970 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3971 src#caption2
"Pages"
3972 (fun () -> string_of_int state
.pagecount
) 1;
3973 src#caption2
"Dimensions"
3974 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3978 src#caption
"Trimmed margins" 0;
3979 src#caption2
"Dimensions"
3980 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3984 src#caption
"OpenGL" 0;
3985 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
3986 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
3989 src#caption
"Location" 0;
3990 if nonemptystr state
.origin
3991 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
3992 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
3994 src#reset prevmode prevuioh
;
3999 let prevmode = state
.mode
4000 and prevuioh
= state
.uioh in
4001 fillsrc prevmode prevuioh
;
4002 let source = (src :> lvsource
) in
4003 let modehash = findkeyhash conf
"info" in
4004 state
.uioh <- coe (object (self)
4005 inherit listview ~zebra
:false ~helpmode
:false
4006 ~
source ~trusted
:true ~
modehash as super
4007 val mutable m_prevmemused
= 0
4008 method! infochanged
= function
4010 if m_prevmemused
!= state
.memused
4012 m_prevmemused
<- state
.memused
;
4013 G.postRedisplay "memusedchanged";
4015 | Pdim
-> G.postRedisplay "pdimchanged"
4016 | Docinfo
-> fillsrc prevmode prevuioh
4018 method! key key mask
=
4019 if not
(Wsi.withctrl mask
)
4022 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4023 | @right
| @kpright
-> coe (self#updownlevel
1)
4024 | _ -> super#
key key mask
4025 else super#
key key mask
4027 G.postRedisplay "info";
4033 inherit lvsourcebase
4034 method getitemcount
= Array.length state
.help
4036 let s, l, _ = state
.help
.(n) in
4039 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4043 match state
.help
.(active) with
4044 | _, _, Action
f -> Some
(f uioh)
4045 | _, _, Noaction
-> Some
uioh
4054 method hasaction
n =
4055 match state
.help
.(n) with
4056 | _, _, Action
_ -> true
4057 | _, _, Noaction
-> false
4063 let modehash = findkeyhash conf
"help" in
4065 state
.uioh <- coe (new listview
4066 ~zebra
:false ~helpmode
:true
4067 ~
source ~trusted
:true ~
modehash);
4068 G.postRedisplay "help";
4074 inherit lvsourcebase
4075 val mutable m_items
= E.a
4077 method getitemcount
= 1 + Array.length m_items
4082 else m_items
.(n-1), 0
4084 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4089 then Buffer.clear state
.errmsgs
;
4096 method hasaction
n =
4100 state
.newerrmsgs
<- false;
4101 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4102 m_items
<- Array.of_list
l
4111 let source = (msgsource :> lvsource
) in
4112 let modehash = findkeyhash conf
"listview" in
4113 state
.uioh <- coe (object
4114 inherit listview ~zebra
:false ~helpmode
:false
4115 ~
source ~trusted
:false ~
modehash as super
4118 then msgsource#reset
;
4121 G.postRedisplay "msgs";
4125 let editor = getenvwithdef
"EDITOR" E.s in
4129 let tmppath = Filename.temp_file
"llpp" "note" in
4132 let oc = open_out
tmppath in
4136 let execstr = editor ^
" " ^
tmppath in
4138 match spawn
execstr [] with
4139 | (exception exn
) ->
4140 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4143 match Unix.waitpid
[] pid with
4144 | (exception exn
) ->
4145 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4149 | Unix.WEXITED
0 -> filecontents
tmppath
4151 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4153 | Unix.WSIGNALED
n ->
4154 impmsg "editor process(%s) was killed by signal %d" execstr n;
4156 | Unix.WSTOPPED
n ->
4157 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4160 match Unix.unlink
tmppath with
4161 | (exception exn
) ->
4162 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4167 let enterannotmode opaque slinkindex
=
4170 inherit lvsourcebase
4171 val mutable m_text
= E.s
4172 val mutable m_items
= E.a
4174 method getitemcount
= Array.length m_items
4177 let label, _func
= m_items
.(n) in
4180 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4181 ignore
(uioh, first, pan
);
4184 let _label, func
= m_items
.(active) in
4189 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4192 let rec split accu b i
=
4194 if p = String.length
s
4195 then (String.sub s b (p-b), unit) :: accu
4197 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4199 let ss = if i
= 0 then E.s else String.sub s b i
in
4200 split ((ss, unit)::accu) (p+1) 0
4205 wcmd "freepage %s" (~
> opaque);
4207 Hashtbl.fold (fun key opaque'
accu ->
4208 if opaque'
= opaque'
4209 then key :: accu else accu) state
.pagemap
[]
4211 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4213 gotoxy state
.x state
.y
4216 delannot
opaque slinkindex
;
4219 let edit inline
() =
4224 modannot
opaque slinkindex
s;
4230 let mode = state
.mode in
4233 ("annotation: ", m_text
, None
, textentry, update, true),
4234 fun _ -> state
.mode <- mode);
4238 let s = getusertext m_text
in
4243 ( "[Copy]", fun () -> selstring m_text
)
4244 :: ("[Delete]", dele)
4245 :: ("[Edit]", edit conf
.annotinline
)
4247 :: split [] 0 0 |> List.rev
|> Array.of_list
4254 let s = getannotcontents
opaque slinkindex
in
4257 let source = (msgsource :> lvsource
) in
4258 let modehash = findkeyhash conf
"listview" in
4259 state
.uioh <- coe (object
4260 inherit listview ~zebra
:false ~helpmode
:false
4261 ~
source ~trusted
:false ~
modehash
4263 G.postRedisplay "enterannotmode";
4266 let gotoremote spec
=
4267 let filename, dest
= splitatchar spec '#'
in
4268 let getpath filename =
4270 if nonemptystr
filename
4272 if Filename.is_relative
filename
4274 let dir = Filename.dirname state
.path in
4276 if Filename.is_implicit
dir
4277 then Filename.concat
(Sys.getcwd
()) dir
4280 Filename.concat
dir filename
4284 if Sys.file_exists
path
4288 let path = getpath filename in
4292 let cmd = Lazy.force_val lcmd
in
4293 match spawn
cmd with
4295 | (exception exn
) ->
4296 dolog
"failed to execute `%s': %s" cmd @@ 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
.ranchors
<- ranchor :: state
.ranchors
;
4304 if substratis spec
0 "page="
4306 match Scanf.sscanf spec
"page=%d" (fun n -> n) with
4308 state
.anchor <- (pageno, 0.0, 0.0);
4309 dospawn @@ lazy (Printf.sprintf
"%s -page %d %S" !selfexec pageno path);
4311 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
4313 state
.nameddest
<- dest
;
4314 dospawn @@ lazy (!selfexec ^
" " ^
path ^
" -dest " ^ dest
)
4318 let gotounder = function
4319 | Ulinkuri
s when isexternallink
s ->
4320 if substratis
s 0 "file://"
4321 then gotoremote @@ String.sub s 7 (String.length
s - 7)
4324 let pageno, x, y = uritolocation
s in
4326 gotopagexy !wtmode pageno x y
4327 | Utext
_ | Unone
-> ()
4328 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4331 let gotooutline (_, _, kind
) =
4335 let (pageno, y, _) = anchor in
4337 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4341 | Ouri
uri -> gotounder (Ulinkuri
uri)
4342 | Olaunch _cmd
-> failwith
"gotounder (Ulaunch cmd)"
4343 | Oremote _remote
-> failwith
"gotounder (Uremote remote)"
4344 | Ohistory hist
-> gotohist hist
4345 | Oremotedest _remotedest
-> failwith
"gotounder (Uremotedest remotedest)"
4348 class outlinesoucebase fetchoutlines
= object (self)
4349 inherit lvsourcebase
4350 val mutable m_items
= E.a
4351 val mutable m_minfo
= E.a
4352 val mutable m_orig_items
= E.a
4353 val mutable m_orig_minfo
= E.a
4354 val mutable m_narrow_patterns
= []
4355 val mutable m_gen
= -1
4357 method getitemcount
= Array.length m_items
4360 let s, n, _ = m_items
.(n) in
4363 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4365 ignore
(uioh, first);
4367 if m_narrow_patterns
= []
4368 then m_orig_items
, m_orig_minfo
4369 else m_items
, m_minfo
4376 gotooutline m_items
.(active);
4384 method hasaction
(_:int) = true
4387 if Array.length m_items
!= Array.length m_orig_items
4390 match m_narrow_patterns
with
4392 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4394 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4398 match m_narrow_patterns
with
4401 | head
:: _ -> "@Uellipsis" ^ head
4403 method narrow
pattern =
4404 match Str.regexp_case_fold
pattern with
4405 | (exception _) -> ()
4407 let rec loop accu minfo n =
4410 m_items
<- Array.of_list
accu;
4411 m_minfo
<- Array.of_list
minfo;
4414 let (s, _, _) as o = m_items
.(n) in
4416 match Str.search_forward re
s 0 with
4417 | (exception Not_found
) -> accu, minfo
4418 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4420 loop accu minfo (n-1)
4422 loop [] [] (Array.length m_items
- 1)
4424 method! getminfo
= m_minfo
4427 m_orig_items
<- fetchoutlines
();
4428 m_minfo
<- m_orig_minfo
;
4429 m_items
<- m_orig_items
4431 method add_narrow_pattern
pattern =
4432 m_narrow_patterns
<- pattern :: m_narrow_patterns
4434 method del_narrow_pattern
=
4435 match m_narrow_patterns
with
4436 | _ :: rest
-> m_narrow_patterns
<- rest
4441 match m_narrow_patterns
with
4442 | pattern :: [] -> self#narrow
pattern; pattern
4444 List.fold_left
(fun accu pattern ->
4445 self#narrow
pattern;
4446 pattern ^
"@Uellipsis" ^
accu) E.s list
4448 method calcactive
(_:anchor) = 0
4450 method reset
anchor items =
4451 if state
.gen
!= m_gen
4453 m_orig_items
<- items;
4455 m_narrow_patterns
<- [];
4457 m_orig_minfo
<- E.a;
4461 if items != m_orig_items
4463 m_orig_items
<- items;
4464 if m_narrow_patterns
== []
4465 then m_items
<- items;
4468 let active = self#calcactive
anchor in
4470 m_first
<- firstof m_first
active
4474 let outlinesource fetchoutlines
=
4476 inherit outlinesoucebase fetchoutlines
4477 method! calcactive
anchor =
4478 let rely = getanchory anchor in
4479 let rec loop n best bestd
=
4480 if n = Array.length m_items
4483 let _, _, kind
= m_items
.(n) in
4486 let orely = getanchory anchor in
4487 let d = abs
(orely - rely) in
4490 else loop (n+1) best bestd
4491 | Onone
| Oremote
_ | Olaunch
_
4492 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4493 loop (n+1) best bestd
4499 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4500 let mkselector sourcetype
=
4501 let fetchoutlines () =
4502 match sourcetype
with
4503 | `bookmarks
-> Array.of_list state
.bookmarks
4504 | `outlines
-> state
.outlines
4505 | `history
-> genhistoutlines ()
4508 if sourcetype
= `history
4509 then new outlinesoucebase
fetchoutlines
4510 else outlinesource fetchoutlines
4513 let outlines = fetchoutlines () in
4514 if Array.length
outlines = 0
4516 showtext ' ' errmsg
;
4520 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4521 let anchor = getanchor
() in
4522 source#reset
anchor outlines;
4523 state
.text <- source#greetmsg
;
4525 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4526 G.postRedisplay "enter selector";
4529 let mkenter sourcetype errmsg
=
4530 let enter = mkselector sourcetype
in
4531 fun () -> enter errmsg
4533 mkenter `
outlines "document has no outline"
4534 , mkenter `bookmarks
"document has no bookmarks (yet)"
4535 , mkenter `history
"history is empty"
4538 let quickbookmark ?title
() =
4539 match state
.layout with
4545 let tm = Unix.localtime
(now
()) in
4547 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4551 (tm.Unix.tm_year
+ 1900)
4554 | Some
title -> title
4556 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4559 let setautoscrollspeed step goingdown
=
4560 let incr = max
1 ((abs step
) / 2) in
4561 let incr = if goingdown
then incr else -incr in
4562 let astep = boundastep state
.winh
(step
+ incr) in
4563 state
.autoscroll
<- Some
astep;
4567 match conf
.columns
with
4569 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4572 let panbound x = bound
x (-state
.w) state
.winw
;;
4574 let existsinrow pageno (columns
, coverA
, coverB
) p =
4575 let last = ((pageno - coverA
) mod columns
) + columns
in
4576 let rec any = function
4579 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4583 then (if l.pageno = last then false else any rest
)
4591 match state
.layout with
4593 let pageno = page_of_y state
.y in
4594 gotoghyll (getpagey
(pageno+1))
4596 match conf
.columns
with
4598 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4600 let y = clamp (pgscale state
.winh
) in
4603 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4604 gotoghyll (getpagey
pageno)
4605 | Cmulti
((c, _, _) as cl
, _) ->
4606 if conf
.presentation
4607 && (existsinrow l.pageno cl
4608 (fun l -> l.pageh
> l.pagey + l.pagevh))
4610 let y = clamp (pgscale state
.winh
) in
4613 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4614 gotoghyll (getpagey
pageno)
4616 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4618 let pagey, pageh
= getpageyh
l.pageno in
4619 let pagey = pagey + pageh
* l.pagecol
in
4620 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4621 gotoghyll (pagey + pageh
+ ips)
4625 match state
.layout with
4627 let pageno = page_of_y state
.y in
4628 gotoghyll (getpagey
(pageno-1))
4630 match conf
.columns
with
4632 if conf
.presentation
&& l.pagey != 0
4634 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4636 let pageno = max
0 (l.pageno-1) in
4637 gotoghyll (getpagey
pageno)
4638 | Cmulti
((c, _, coverB
) as cl
, _) ->
4639 if conf
.presentation
&&
4640 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4642 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4645 if l.pageno = state
.pagecount
- coverB
4649 let pageno = max
0 (l.pageno-decr) in
4650 gotoghyll (getpagey
pageno)
4658 let pageno = max
0 (l.pageno-1) in
4659 let pagey, pageh
= getpageyh
pageno in
4662 let pagey, pageh
= getpageyh
l.pageno in
4663 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4669 if emptystr conf
.savecmd
4670 then error
"don't know where to save modified document"
4672 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4675 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4680 let tmp = path ^
".tmp" in
4682 Unix.rename
tmp path;
4685 let viewkeyboard key mask
=
4687 let mode = state
.mode in
4688 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4691 G.postRedisplay "view:enttext"
4693 let ctrl = Wsi.withctrl mask
in
4694 let key = Wsi.keypadtodigitkey
key in
4699 if hasunsavedchanges
()
4703 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4705 state
.mode <- LinkNav
(Ltgendir
0);
4706 gotoxy state
.x state
.y;
4708 else impmsg "keyboard link navigation does not work under rotation"
4711 begin match state
.mstate
with
4714 G.postRedisplay "kill rect";
4717 | Mscrolly
| Mscrollx
4720 begin match state
.mode with
4723 G.postRedisplay "esc leave linknav"
4727 match state
.ranchors
with
4729 | (path, password, anchor, origin
) :: rest
->
4730 state
.ranchors
<- rest
;
4731 state
.anchor <- anchor;
4732 state
.origin
<- origin
;
4733 state
.nameddest
<- E.s;
4734 opendoc path password
4739 gotoghyll (getnav ~
-1)
4750 Hashtbl.iter
(fun _ opaque ->
4752 Hashtbl.clear state
.prects
) state
.pagemap
;
4753 G.postRedisplay "dehighlight";
4755 | @slash
| @question
->
4756 let ondone isforw
s =
4757 cbput state
.hists
.pat
s;
4758 state
.searchpattern
<- s;
4761 let s = String.make
1 (Char.chr
key) in
4762 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4763 textentry, ondone (key = @slash
), true)
4765 | @plus
| @kpplus
| @equals
when ctrl ->
4766 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4767 pivotzoom (conf
.zoom +. incr)
4769 | @plus
| @kpplus
->
4772 try int_of_string
s with exn
->
4773 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4779 state
.text <- "page bias is now " ^ string_of_int
n;
4782 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4784 | @minus
| @kpminus
when ctrl ->
4785 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4786 pivotzoom (max
0.01 (conf
.zoom -. decr))
4788 | @minus
| @kpminus
->
4789 let ondone msg
= state
.text <- msg
in
4791 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4792 optentry state
.mode, ondone, true
4797 then gotoxy 0 state
.y
4800 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4802 match conf
.columns
with
4803 | Csingle
_ | Cmulti
_ -> 1
4804 | Csplit
(n, _) -> n
4806 let h = state
.winh
-
4807 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4809 let zoom = zoomforh state
.winw
h 0 cols in
4810 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4815 match conf
.fitmodel
with
4816 | FitWidth
-> FitProportional
4817 | FitProportional
-> FitPage
4818 | FitPage
-> FitWidth
4820 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4821 reqlayout conf
.angle
fm
4823 | @4 when ctrl -> (* ctrl-4 *)
4824 let zoom = getmaxw
() /. float state
.winw
in
4825 if zoom > 0.0 then setzoom zoom
4833 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4834 when not
ctrl -> (* 0..9 *)
4837 try int_of_string
s with exn
->
4838 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4844 cbput state
.hists
.pag
(string_of_int
n);
4845 gotopage1 (n + conf
.pagebias
- 1) 0;
4848 let pageentry text key =
4849 match Char.unsafe_chr
key with
4850 | '
g'
-> TEdone
text
4851 | _ -> intentry text key
4853 let text = String.make
1 (Char.chr
key) in
4854 enttext (":", text, Some
(onhist state
.hists
.pag
),
4855 pageentry, ondone, true)
4858 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4859 G.postRedisplay "toggle scrollbar";
4862 state
.bzoom
<- not state
.bzoom
;
4864 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4867 conf
.hlinks
<- not conf
.hlinks
;
4868 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4869 G.postRedisplay "toggle highlightlinks";
4872 if conf
.angle
mod 360 = 0
4874 state
.glinks
<- true;
4875 let mode = state
.mode in
4878 (":", E.s, None
, linknentry, linknact gotounder, false),
4880 state
.glinks
<- false;
4884 G.postRedisplay "view:linkent(F)"
4886 else impmsg "hint mode does not work under rotation"
4889 state
.glinks
<- true;
4890 let mode = state
.mode in
4891 state
.mode <- Textentry
(
4893 ":", E.s, None
, linknentry, linknact (fun under ->
4894 selstring (undertext under);
4898 state
.glinks
<- false;
4902 G.postRedisplay "view:linkent"
4905 begin match state
.autoscroll
with
4907 conf
.autoscrollstep
<- step
;
4908 state
.autoscroll
<- None
4910 if conf
.autoscrollstep
= 0
4911 then state
.autoscroll
<- Some
1
4912 else state
.autoscroll
<- Some conf
.autoscrollstep
4916 launchpath () (* XXX where do error messages go? *)
4919 setpresentationmode (not conf
.presentation
);
4920 showtext ' '
("presentation mode " ^
4921 if conf
.presentation
then "on" else "off");
4924 if List.mem
Wsi.Fullscreen state
.winstate
4925 then Wsi.reshape conf
.cwinw conf
.cwinh
4926 else Wsi.fullscreen
()
4929 search state
.searchpattern
false
4932 search state
.searchpattern
true
4935 begin match state
.layout with
4938 gotoghyll (getpagey
l.pageno)
4944 | @delete
| @kpdelete
-> (* delete *)
4948 showtext ' '
(describe_location ());
4951 begin match state
.layout with
4954 Wsi.reshape l.pagew
l.pageh
;
4959 enterbookmarkmode
()
4967 | @e when Buffer.length state
.errmsgs
> 0 ->
4972 match state
.layout with
4977 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4980 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
4984 showtext ' '
"Quick bookmark added";
4987 begin match state
.layout with
4989 let rect = getpdimrect
l.pagedimno
in
4993 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
4994 truncate
(1.2 *. (rect.(3) -. rect.(0))))
4996 (truncate
(rect.(1) -. rect.(0)),
4997 truncate
(rect.(3) -. rect.(0)))
4999 let w = truncate
((float w)*.conf
.zoom)
5000 and h = truncate
((float h)*.conf
.zoom) in
5003 state
.anchor <- getanchor
();
5004 Wsi.reshape w (h + conf
.interpagespace
)
5006 G.postRedisplay "z";
5011 | @x -> state
.roam
()
5014 reqlayout (conf
.angle
+
5015 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5019 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5021 G.postRedisplay "brightness";
5023 | @c when state
.mode = View
->
5028 let m = (state
.winw
- state
.w) / 2 in
5029 gotoxy_and_clear_text m state
.y
5033 match state
.prevcolumns
with
5034 | None
-> (1, 0, 0), 1.0
5035 | Some
(columns
, z
) ->
5038 | Csplit
(c, _) -> -c, 0, 0
5039 | Cmulti
((c, a, b), _) -> c, a, b
5040 | Csingle
_ -> 1, 0, 0
5044 setcolumns View
c a b;
5047 | @down
| @up
when ctrl && Wsi.withshift mask
->
5048 let zoom, x = state
.prevzoom
in
5052 | @k
| @up
| @kpup
->
5053 begin match state
.autoscroll
with
5055 begin match state
.mode with
5056 | Birdseye beye
-> upbirdseye 1 beye
5061 then gotoxy_and_clear_text state
.x (clamp ~
-(state
.winh
/2))
5063 if not
(Wsi.withshift mask
) && conf
.presentation
5065 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5069 setautoscrollspeed n false
5072 | @j
| @down
| @kpdown
->
5073 begin match state
.autoscroll
with
5075 begin match state
.mode with
5076 | Birdseye beye
-> downbirdseye 1 beye
5081 then gotoxy_and_clear_text state
.x (clamp (state
.winh
/2))
5083 if not
(Wsi.withshift mask
) && conf
.presentation
5085 else gotoghyll1 true (clamp (conf
.scrollstep
))
5089 setautoscrollspeed n true
5092 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5098 else conf
.hscrollstep
5100 let dx = if key = @left || key = @kpleft
then dx else -dx in
5101 gotoxy_and_clear_text (panbound (state
.x + dx)) state
.y
5104 G.postRedisplay "left/right"
5107 | @prior
| @kpprior
->
5111 match state
.layout with
5113 | l :: _ -> state
.y - l.pagey
5115 clamp (pgscale (-state
.winh
))
5119 | @next | @kpnext
->
5123 match List.rev state
.layout with
5125 | l :: _ -> getpagey
l.pageno
5127 clamp (pgscale state
.winh
)
5131 | @g | @home
| @kphome
->
5134 | @G
| @jend
| @kpend
->
5136 gotoghyll (clamp state
.maxy)
5138 | @right
| @kpright
when Wsi.withalt mask
->
5139 gotoghyll (getnav 1)
5140 | @left | @kpleft
when Wsi.withalt mask
->
5141 gotoghyll (getnav ~
-1)
5146 | @v when conf
.debug
->
5149 match getopaque l.pageno with
5152 let x0, y0, x1, y1 = pagebbox
opaque in
5153 let rect = (float x0, float y0,
5156 float x0, float y1) in
5158 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5159 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5161 G.postRedisplay "v";
5164 let mode = state
.mode in
5165 let cmd = ref E.s in
5166 let onleave = function
5167 | Cancel
-> state
.mode <- mode
5170 match getopaque l.pageno with
5171 | Some
opaque -> pipesel opaque !cmd
5172 | None
-> ()) state
.layout;
5176 cbput state
.hists
.sel
s;
5180 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5182 G.postRedisplay "|";
5183 state
.mode <- Textentry
(te, onleave);
5186 vlog "huh? %s" (Wsi.keyname
key)
5189 let linknavkeyboard key mask
linknav =
5190 let getpage pageno =
5191 let rec loop = function
5193 | l :: _ when l.pageno = pageno -> Some
l
5194 | _ :: rest
-> loop rest
5195 in loop state
.layout
5197 let doexact (pageno, n) =
5198 match getopaque pageno, getpage pageno with
5199 | Some
opaque, Some
l ->
5200 if key = @enter || key = @kpenter
5202 let under = getlink
opaque n in
5203 G.postRedisplay "link gotounder";
5210 Some
(findlink
opaque LDfirst
), -1
5213 Some
(findlink
opaque LDlast
), 1
5216 Some
(findlink
opaque (LDleft
n)), -1
5219 Some
(findlink
opaque (LDright
n)), 1
5222 Some
(findlink
opaque (LDup
n)), -1
5225 Some
(findlink
opaque (LDdown
n)), 1
5230 begin match findpwl
l.pageno dir with
5234 state
.mode <- LinkNav
(Ltgendir
dir);
5235 let y, h = getpageyh
pageno in
5238 then y + h - state
.winh
5243 begin match getopaque pageno, getpage pageno with
5244 | Some
opaque, Some
_ ->
5246 let ld = if dir > 0 then LDfirst
else LDlast
in
5249 begin match link with
5251 showlinktype (getlink
opaque m);
5252 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5253 G.postRedisplay "linknav jpage";
5254 | Lnotfound
-> notfound dir
5260 begin match opt with
5261 | Some Lnotfound
-> pwl l dir;
5262 | Some
(Lfound
m) ->
5266 let _, y0, _, y1 = getlinkrect
opaque m in
5268 then gotopage1 l.pageno y0
5270 let d = fstate
.fontsize
+ 1 in
5271 if y1 - l.pagey > l.pagevh - d
5272 then gotopage1 l.pageno (y1 - state
.winh
+ d)
5273 else G.postRedisplay "linknav";
5275 showlinktype (getlink
opaque m);
5276 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5279 | None
-> viewkeyboard key mask
5281 | _ -> viewkeyboard key mask
5286 G.postRedisplay "leave linknav"
5290 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5291 | Ltexact exact
-> doexact exact
5294 let keyboard key mask
=
5295 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5296 then wcmd "interrupt"
5297 else state
.uioh <- state
.uioh#
key key mask
5300 let birdseyekeyboard key mask
5301 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5303 match conf
.columns
with
5305 | Cmulti
((c, _, _), _) -> c
5306 | Csplit
_ -> failwith
"bird's eye split mode"
5308 let pgh layout = List.fold_left
5309 (fun m l -> max
l.pageh
m) state
.winh
layout in
5311 | @l when Wsi.withctrl mask
->
5312 let y, h = getpageyh
pageno in
5313 let top = (state
.winh
- h) / 2 in
5314 gotoxy state
.x (max
0 (y - top))
5315 | @enter | @kpenter
-> leavebirdseye beye
false
5316 | @escape
-> leavebirdseye beye
true
5317 | @up
-> upbirdseye incr beye
5318 | @down
-> downbirdseye incr beye
5319 | @left -> upbirdseye 1 beye
5320 | @right
-> downbirdseye 1 beye
5323 begin match state
.layout with
5327 state
.mode <- Birdseye
(
5328 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5330 gotopage1 l.pageno 0;
5333 let layout = layout state
.x (state
.y-state
.winh
)
5335 (pgh state
.layout) in
5337 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5339 state
.mode <- Birdseye
(
5340 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5342 gotopage1 l.pageno 0
5345 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5349 begin match List.rev state
.layout with
5351 let layout = layout state
.x
5352 (state
.y + (pgh state
.layout))
5353 state
.winw state
.winh
in
5354 begin match layout with
5356 let incr = l.pageh
- l.pagevh in
5361 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5363 G.postRedisplay "birdseye pagedown";
5365 else gotoxy state
.x (clamp (incr + conf
.interpagespace
*2));
5369 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5370 gotopage1 l.pageno 0;
5373 | [] -> gotoxy state
.x (clamp state
.winh
)
5377 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5381 let pageno = state
.pagecount
- 1 in
5382 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5383 if not
(pagevisible state
.layout pageno)
5386 match List.rev state
.pdims
with
5388 | (_, _, h, _) :: _ -> h
5392 (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5393 else G.postRedisplay "birdseye end";
5395 | _ -> viewkeyboard key mask
5400 match state
.mode with
5401 | Textentry
_ -> scalecolor 0.4
5403 | View
-> scalecolor 1.0
5404 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5405 if l.pageno = hooverpageno
5408 if l.pageno = pageno
5410 let c = scalecolor 1.0 in
5412 GlDraw.line_width
3.0;
5413 let dispx = l.pagedispx in
5415 (float (dispx-1)) (float (l.pagedispy-1))
5416 (float (dispx+l.pagevw+1))
5417 (float (l.pagedispy+l.pagevh+1))
5419 GlDraw.line_width
1.0;
5428 let postdrawpage l linkindexbase
=
5429 match getopaque l.pageno with
5431 if tileready l l.pagex
l.pagey
5433 let x = l.pagedispx - l.pagex
5434 and y = l.pagedispy - l.pagey in
5436 match conf
.columns
with
5437 | Csingle
_ | Cmulti
_ ->
5438 (if conf
.hlinks
then 1 else 0)
5440 && not
(isbirdseye state
.mode) then 2 else 0)
5444 match state
.mode with
5445 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5451 Hashtbl.find_all state
.prects
l.pageno |>
5452 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5453 let n = postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
) in
5455 then (state
.redisplay
<- true; 0)
5461 let scrollindicator () =
5462 let sbw, ph
, sh = state
.uioh#
scrollph in
5463 let sbh, pw, sw = state
.uioh#scrollpw
in
5468 else ((state
.winw
- sbw), state
.winw
, 0)
5472 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5473 GlDraw.color (0.64, 0.64, 0.64) ~
alpha:0.7;
5474 filledrect (float x0) 0. (float x1) (float state
.winh
);
5476 (float hx0
) (float (state
.winh
- sbh))
5477 (float (hx0
+ state
.winw
)) (float state
.winh
)
5479 GlDraw.color (0.0, 0.0, 0.0) ~
alpha:0.7;
5481 filledrect (float x0) ph
(float x1) (ph
+. sh);
5482 let pw = pw +. float hx0
in
5483 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5488 match state
.mstate
with
5489 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5492 | Msel
((x0, y0), (x1, y1)) ->
5493 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5494 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5495 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5496 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5499 let showrects = function [] -> () | rects
->
5501 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5502 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5504 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5506 if l.pageno = pageno
5508 let dx = float (l.pagedispx - l.pagex
) in
5509 let dy = float (l.pagedispy - l.pagey) in
5510 let r, g, b, alpha = c in
5511 GlDraw.color (r, g, b) ~
alpha;
5512 filledrect2 (x0+.dx) (y0+.dy)
5524 begin match conf
.columns
, state
.layout with
5525 | Csingle
_, _ :: _ ->
5526 GlDraw.color (scalecolor2 conf
.bgcolor
);
5528 List.fold_left
(fun y l ->
5531 let x1 = l.pagedispx in
5532 let y1 = (l.pagedispy + l.pagevh) in
5533 filledrect (float x0) (float y0) (float x1) (float y1);
5534 let x0 = x1 + l.pagevw in
5535 let x1 = state
.winw
in
5536 filledrect1 (float x0) (float y0) (float x1) (float y1);
5540 and x1 = state
.winw
in
5542 and y1 = l.pagedispy in
5543 filledrect1 (float x0) (float y0) (float x1) (float y1);
5545 l.pagedispy + l.pagevh) 0 state
.layout
5548 and x1 = state
.winw
in
5550 and y1 = state
.winh
in
5551 filledrect1 (float x0) (float y0) (float x1) (float y1)
5552 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5553 GlClear.color (scalecolor2 conf
.bgcolor
);
5554 GlClear.clear
[`
color];
5556 List.iter
drawpage state
.layout;
5558 match state
.mode with
5559 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5560 begin match getopaque pageno with
5562 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5563 let color = (0.0, 0.0, 0.5, 0.5) in
5570 | None
-> state
.rects
5572 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5575 | View
-> state
.rects
5578 let rec postloop linkindexbase
= function
5580 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5581 postloop linkindexbase rest
5585 postloop 0 state
.layout;
5587 begin match state
.mstate
with
5588 | Mzoomrect
((x0, y0), (x1, y1)) ->
5590 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5591 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5592 filledrect (float x0) (float y0) (float x1) (float y1);
5596 | Mscrolly
| Mscrollx
5605 let zoomrect x y x1 y1 =
5608 and y0 = min
y y1 in
5609 let zoom = (float state
.w) /. float (x1 - x0) in
5612 if state
.w < state
.winw
5613 then (state
.winw
- state
.w) / 2
5616 match conf
.fitmodel
with
5617 | FitWidth
| FitProportional
-> simple ()
5619 match conf
.columns
with
5621 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5622 | Cmulti
_ | Csingle
_ -> simple ()
5624 gotoxy ((state
.x + margin) - x0) (state
.y + y0);
5625 state
.anchor <- getanchor
();
5630 let annot inline
x y =
5631 match unproject x y with
5632 | Some
(opaque, n, ux
, uy
) ->
5634 addannot
opaque ux uy
text;
5635 wcmd "freepage %s" (~
> opaque);
5636 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5638 gotoxy state
.x state
.y
5642 let ondone s = add s in
5643 let mode = state
.mode in
5644 state
.mode <- Textentry
(
5645 ("annotation: ", E.s, None
, textentry, ondone, true),
5646 fun _ -> state
.mode <- mode);
5649 G.postRedisplay "annot"
5651 add @@ getusertext E.s
5656 let g opaque l px py =
5657 match rectofblock
opaque px py with
5659 let x0 = a.(0) -. 20. in
5660 let x1 = a.(1) +. 20. in
5661 let y0 = a.(2) -. 20. in
5662 let zoom = (float state
.w) /. (x1 -. x0) in
5663 let pagey = getpagey
l.pageno in
5664 let margin = (state
.w - l.pagew
)/2 in
5665 let nx = -truncate
x0 - margin in
5666 gotoxy_and_clear_text nx (pagey + truncate
y0);
5667 state
.anchor <- getanchor
();
5672 match conf
.columns
with
5674 impmsg "block zooming does not work properly in split columns mode"
5675 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5679 let winw = state
.winw - 1 in
5680 let s = float x /. float winw in
5681 let destx = truncate
(float (state
.w + winw) *. s) in
5682 gotoxy_and_clear_text (winw - destx) state
.y;
5683 state
.mstate
<- Mscrollx
;
5687 let s = float y /. float state
.winh
in
5688 let desty = truncate
(float (state
.maxy -
5689 (if conf
.maxhfit
then state
.winh
else 0))
5691 gotoxy_and_clear_text state
.x desty;
5692 state
.mstate
<- Mscrolly
;
5695 let viewmulticlick clicks
x y mask
=
5696 let g opaque l px py =
5704 if markunder
opaque px py mark
5708 match getopaque l.pageno with
5710 | Some
opaque -> pipesel opaque cmd
5712 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5713 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5718 G.postRedisplay "viewmulticlick";
5719 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5723 match conf
.columns
with
5725 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5728 let viewmouse button down
x y mask
=
5730 | n when (n == 4 || n == 5) && not down
->
5731 if Wsi.withctrl mask
5733 match state
.mstate
with
5734 | Mzoom
(oldn
, i
, (ftx
, fty
)) ->
5737 then abs
(ftx
- x) > 5 || abs
(fty
- y) > 5
5747 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5749 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5751 let zoom = conf
.zoom -. incr in
5753 then pivotzoom ~
x ~
y zoom
5754 else pivotzoom zoom;
5755 state
.mstate
<- Mzoom
(n, 0, (x, y));
5757 state
.mstate
<- Mzoom
(n, i
+1, (ftx
, fty
));
5759 else state
.mstate
<- Mzoom
(n, 0, (ftx
, fty
))
5763 | Mscrolly
| Mscrollx
5765 | Mnone
-> state
.mstate
<- Mzoom
(n, 0, (0, 0))
5768 match state
.autoscroll
with
5769 | Some step
-> setautoscrollspeed step
(n=4)
5771 if conf
.wheelbypage
|| conf
.presentation
5780 then -conf
.scrollstep
5781 else conf
.scrollstep
5783 let incr = incr * 2 in
5784 let y = clamp incr in
5785 gotoxy_and_clear_text state
.x y
5788 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5790 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
) in
5791 gotoxy_and_clear_text x state
.y
5793 | 1 when Wsi.withshift mask
->
5794 state
.mstate
<- Mnone
;
5797 match unproject x y with
5799 | Some
(_, pageno, ux
, uy
) ->
5800 let cmd = Printf.sprintf
5802 conf
.stcmd state
.path pageno ux uy
5804 match spawn
cmd [] with
5805 | (exception exn
) ->
5806 impmsg "execution of synctex command(%S) failed: %S"
5807 conf
.stcmd
@@ exntos exn
5811 | 1 when Wsi.withctrl mask
->
5814 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5815 state
.mstate
<- Mpan
(x, y)
5818 state
.mstate
<- Mnone
5823 if Wsi.withshift mask
5825 annot conf
.annotinline
x y;
5826 G.postRedisplay "addannot"
5830 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5831 state
.mstate
<- Mzoomrect
(p, p)
5834 match state
.mstate
with
5835 | Mzoomrect
((x0, y0), _) ->
5836 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5837 then zoomrect x0 y0 x y
5840 G.postRedisplay "kill accidental zoom rect";
5844 | Mscrolly
| Mscrollx
5850 | 1 when vscrollhit x ->
5853 let _, position, sh = state
.uioh#
scrollph in
5854 if y > truncate
position && y < truncate
(position +. sh)
5855 then state
.mstate
<- Mscrolly
5858 state
.mstate
<- Mnone
5860 | 1 when y > state
.winh
- hscrollh () ->
5863 let _, position, sw = state
.uioh#scrollpw
in
5864 if x > truncate
position && x < truncate
(position +. sw)
5865 then state
.mstate
<- Mscrollx
5868 state
.mstate
<- Mnone
5870 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5873 let dest = if down
then getunder x y else Unone
in
5874 begin match dest with
5878 | Unone
when down
->
5879 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5880 state
.mstate
<- Mpan
(x, y);
5882 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5884 | Unone
| Utext
_ ->
5889 state
.mstate
<- Msel
((x, y), (x, y));
5890 G.postRedisplay "mouse select";
5894 match state
.mstate
with
5897 | Mzoom
_ | Mscrollx
| Mscrolly
->
5898 state
.mstate
<- Mnone
5900 | Mzoomrect
((x0, y0), _) ->
5904 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5905 state
.mstate
<- Mnone
5907 | Msel
((x0, y0), (x1, y1)) ->
5908 let rec loop = function
5912 let a0 = l.pagedispy in
5913 let a1 = a0 + l.pagevh in
5914 let b0 = l.pagedispx in
5915 let b1 = b0 + l.pagevw in
5916 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5917 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5921 match getopaque l.pageno with
5924 match Unix.pipe
() with
5925 | (exception exn
) ->
5926 impmsg "cannot create sel pipe: %s" @@
5930 Ne.clo fd
(fun msg
->
5931 dolog
"%s close failed: %s" what msg
)
5934 try spawn
cmd [r, 0; w, -1]
5936 dolog
"cannot execute %S: %s"
5943 G.postRedisplay "copysel";
5945 else clo "Msel pipe/w" w;
5946 clo "Msel pipe/r" r;
5948 dosel conf
.selcmd
();
5949 state
.roam
<- dosel conf
.paxcmd
;
5961 let birdseyemouse button down
x y mask
5962 (conf
, leftx
, _, hooverpageno
, anchor) =
5965 let rec loop = function
5968 if y > l.pagedispy && y < l.pagedispy + l.pagevh
5969 && x > l.pagedispx && x < l.pagedispx + l.pagevw
5971 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
5977 | _ -> viewmouse button down
x y mask
5983 method key key mask
=
5984 begin match state
.mode with
5985 | Textentry
textentry -> textentrykeyboard key mask
textentry
5986 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
5987 | View
-> viewkeyboard key mask
5988 | LinkNav
linknav -> linknavkeyboard key mask
linknav
5992 method button button bstate
x y mask
=
5993 begin match state
.mode with
5995 | View
-> viewmouse button bstate
x y mask
5996 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6001 method multiclick clicks
x y mask
=
6002 begin match state
.mode with
6004 | View
-> viewmulticlick clicks
x y mask
6011 begin match state
.mode with
6013 | View
| Birdseye
_ | LinkNav
_ ->
6014 match state
.mstate
with
6015 | Mzoom
_ | Mnone
-> ()
6020 state
.mstate
<- Mpan
(x, y);
6021 let x = if canpan () then panbound (state
.x + dx) else state
.x in
6023 gotoxy_and_clear_text x y
6026 state
.mstate
<- Msel
(a, (x, y));
6027 G.postRedisplay "motion select";
6030 let y = min state
.winh
(max
0 y) in
6034 let x = min state
.winw (max
0 x) in
6037 | Mzoomrect
(p0
, _) ->
6038 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6039 G.postRedisplay "motion zoomrect";
6043 method pmotion
x y =
6044 begin match state
.mode with
6045 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6046 let rec loop = function
6048 if hooverpageno
!= -1
6050 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6051 G.postRedisplay "pmotion birdseye no hoover";
6054 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6055 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6057 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6058 G.postRedisplay "pmotion birdseye hoover";
6068 match state
.mstate
with
6069 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6077 let past, _, _ = !r in
6079 let delta = now -. past in
6082 else r := (now, x, y)
6086 method infochanged
_ = ()
6089 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6092 then 0.0, float state
.winh
6093 else scrollph state
.y maxy
6098 let fwinw = float (state
.winw - vscrollw ()) in
6100 let sw = fwinw /. float state
.w in
6101 let sw = fwinw *. sw in
6102 max
sw (float conf
.scrollh
)
6105 let maxx = state
.w + state
.winw in
6106 let x = state
.winw - state
.x in
6107 let percent = float x /. float maxx in
6108 (fwinw -. sw) *. percent
6110 hscrollh (), position, sw
6114 match state
.mode with
6115 | LinkNav
_ -> "links"
6116 | Textentry
_ -> "textentry"
6117 | Birdseye
_ -> "birdseye"
6120 findkeyhash conf
modename
6122 method eformsgs
= true
6123 method alwaysscrolly
= false
6126 let addrect pageno r g b a x0 y0 x1 y1 =
6127 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6131 let cl = splitatchar cmds ' '
in
6133 try Scanf.sscanf
s fmt
f
6135 adderrfmt "remote exec"
6136 "error processing '%S': %s\n" cmds
@@ exntos exn
6138 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6139 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6140 s pageno r g b a x0 y0 x1 y1;
6144 let _,w1,h1
,_ = getpagedim
pageno in
6145 let sw = float w1 /. float w
6146 and sh = float h1
/. float h in
6150 and y1s
= y1 *. sh in
6151 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6152 let color = (r, g, b, a) in
6153 if conf
.verbose
then debugrect rect;
6154 state
.rects <- (pageno, color, rect) :: state
.rects;
6159 | "reload", "" -> reload ()
6161 scan args
"%u %f %f"
6163 let cmd, _ = state
.geomcmds
in
6165 then gotopagexy !wtmode pageno x y
6168 gotopagexy !wtmode pageno x y;
6171 state
.reprf
<- f state
.reprf
6173 | "goto1", args
-> scan args
"%u %f" gotopage
6176 (fun _filename _pageno
->
6177 failwith
"gotounder (Uremote (filename, pageno))")
6180 (fun _filename _dest
->
6181 failwith
"gotounder (Uremotedest (filename, dest))")
6183 scan args
"%u %u %f %f %f %f"
6184 (fun pageno c x0 y0 x1 y1 ->
6185 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6186 rectx "rect" pageno color x0 y0 x1 y1;
6189 scan args
"%u %f %f %f %f %f %f %f %f"
6190 (fun pageno r g b alpha x0 y0 x1 y1 ->
6191 addrect pageno r g b alpha x0 y0 x1 y1;
6192 G.postRedisplay "prect"
6195 scan args
"%u %f %f"
6198 match getopaque pageno with
6199 | Some
opaque -> opaque
6202 pgoto optopaque pageno x y;
6203 let rec fixx = function
6206 if l.pageno = pageno
6207 then gotoxy (state
.x - l.pagedispx) state
.y
6212 match conf
.columns
with
6213 | Csingle
_ | Csplit
_ -> 1
6214 | Cmulti
((n, _, _), _) -> n
6216 layout 0 state
.y (state
.winw * mult) state
.winh
6220 | "activatewin", "" -> Wsi.activatewin
()
6221 | "quit", "" -> raise Quit
6224 let l = Config.keys_of_string
keys in
6225 List.iter
(fun (k
, m) -> keyboard k
m) l
6227 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6229 | "clearrects", "" ->
6230 Hashtbl.clear state
.prects
;
6231 G.postRedisplay "clearrects"
6233 adderrfmt "remote command"
6234 "error processing remote command: %S\n" cmds
;
6238 let scratch = Bytes.create
80 in
6239 let buf = Buffer.create
80 in
6241 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6242 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6245 if Buffer.length
buf > 0
6247 let s = Buffer.contents
buf in
6255 match Bytes.index_from
scratch ppos '
\n'
with
6256 | pos -> if pos >= n then -1 else pos
6257 | (exception Not_found
) -> -1
6261 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6262 let s = Buffer.contents
buf in
6268 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6274 let remoteopen path =
6275 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6277 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6282 let gcconfig = ref E.s in
6283 let trimcachepath = ref E.s in
6284 let rcmdpath = ref E.s in
6285 let pageno = ref None
in
6286 let rootwid = ref 0 in
6287 let openlast = ref false in
6288 let nofc = ref false in
6289 let doreap = ref false in
6290 selfexec := Sys.executable_name
;
6293 [("-p", Arg.String
(fun s -> state
.password <- s),
6294 "<password> Set password");
6298 Config.fontpath
:= s;
6299 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6301 "<path> Set path to the user interface font");
6305 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6306 Config.confpath
:= s),
6307 "<path> Set path to the configuration file");
6309 ("-last", Arg.Set
openlast, " Open last document");
6311 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6312 "<page-number> Jump to page");
6314 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6315 "<path> Set path to the trim cache file");
6317 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6318 "<named-destination> Set named destination");
6320 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6321 ("-cxack", Arg.Set
cxack, " Cut corners");
6323 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6324 "<path> Set path to the remote commands source");
6326 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6327 "<original-path> Set original path");
6329 ("-gc", Arg.Set_string
gcconfig,
6330 "<script-path> Collect garbage with the help of a script");
6332 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6334 ("-v", Arg.Unit
(fun () ->
6336 "%s\nconfiguration path: %s\n"
6340 exit
0), " Print version and exit");
6342 ("-embed", Arg.Set_int
rootwid,
6343 "<window-id> Embed into window")
6346 (fun s -> state
.path <- s)
6347 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:")
6350 then selfexec := !selfexec ^
" -wtmode";
6352 let histmode = emptystr state
.path && not
!openlast in
6354 if not
(Config.load !openlast)
6355 then dolog
"failed to load configuration";
6357 begin match !pageno with
6358 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6362 if nonemptystr
!gcconfig
6365 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6366 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6369 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6370 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6372 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6377 let wsfd, winw, winh
= Wsi.init
(object (self)
6378 val mutable m_clicks
= 0
6379 val mutable m_click_x
= 0
6380 val mutable m_click_y
= 0
6381 val mutable m_lastclicktime
= infinity
6383 method private cleanup =
6384 state
.roam
<- noroam
;
6385 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6386 method expose
= G.postRedisplay "expose"
6390 | Wsi.Unobscured
-> "unobscured"
6391 | Wsi.PartiallyObscured
-> "partiallyobscured"
6392 | Wsi.FullyObscured
-> "fullyobscured"
6394 vlog "visibility change %s" name
6395 method display = display ()
6396 method map mapped
= vlog "mapped %b" mapped
6397 method reshape w h =
6400 method mouse
b d x y m =
6401 if d && canselect ()
6403 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6409 if abs
x - m_click_x
> 10
6410 || abs
y - m_click_y
> 10
6411 || abs_float
(t -. m_lastclicktime
) > 0.3
6413 m_clicks
<- m_clicks
+ 1;
6414 m_lastclicktime
<- t;
6418 G.postRedisplay "cleanup";
6419 state
.uioh <- state
.uioh#button
b d x y m;
6421 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6426 m_lastclicktime
<- infinity
;
6427 state
.uioh <- state
.uioh#button
b d x y m
6431 state
.uioh <- state
.uioh#button
b d x y m
6434 state
.mpos
<- (x, y);
6435 state
.uioh <- state
.uioh#motion
x y
6436 method pmotion
x y =
6437 state
.mpos
<- (x, y);
6438 state
.uioh <- state
.uioh#pmotion
x y
6440 let mascm = m land (
6441 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6444 let x = state
.x and y = state
.y in
6446 if x != state
.x || y != state
.y then self#
cleanup
6448 match state
.keystate
with
6450 let km = k
, mascm in
6453 let modehash = state
.uioh#
modehash in
6454 try Hashtbl.find modehash km
6456 try Hashtbl.find (findkeyhash conf
"global") km
6457 with Not_found
-> KMinsrt
(k
, m)
6459 | KMinsrt
(k
, m) -> keyboard k
m
6460 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6461 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6463 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6464 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6465 state
.keystate
<- KSnone
6466 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6467 state
.keystate
<- KSinto
(keys, insrt
)
6468 | KSinto
_ -> state
.keystate
<- KSnone
6471 state
.mpos
<- (x, y);
6472 state
.uioh <- state
.uioh#pmotion
x y
6473 method leave = state
.mpos
<- (-1, -1)
6474 method winstate wsl
= state
.winstate
<- wsl
6475 method quit
= raise Quit
6476 end) !rootwid conf
.cwinw conf
.cwinh platform
in
6478 setbgcol conf
.bgcolor
;
6482 List.exists
GlMisc.check_extension
6483 [ "GL_ARB_texture_rectangle"
6484 ; "GL_EXT_texture_recangle"
6485 ; "GL_NV_texture_rectangle" ]
6487 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6490 let r = GlMisc.get_string `renderer
in
6491 let p = "Mesa DRI Intel(" in
6492 let l = String.length
p in
6493 String.length
r > l && String.sub r 0 l = p
6496 defconf
.sliceheight
<- 1024;
6497 defconf
.texcount
<- 32;
6498 defconf
.usepbo
<- true;
6502 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6503 | (exception exn
) ->
6504 dolog
"socketpair failed: %s" @@ exntos exn
;
6512 setcheckers conf
.checkers
;
6514 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6517 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6518 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6519 !Config.fontpath
, !trimcachepath,
6523 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6525 reshape ~firsttime
:true winw winh
;
6529 Wsi.settitle
"llpp (history)";
6533 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6534 opendoc state
.path state
.password;
6538 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6539 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6542 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6543 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6544 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6546 | _pid
, _status
-> reap ()
6548 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6552 if nonemptystr
!rcmdpath
6553 then remoteopen !rcmdpath
6558 let rec loop deadline
=
6564 let r = [state
.ss; state
.wsfd] in
6568 | Some fd
-> fd
:: r
6572 state
.redisplay
<- false;
6579 if deadline
= infinity
6581 else max
0.0 (deadline
-. now)
6586 try Unix.select
r [] [] timeout
6587 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6593 if state
.ghyll
== noghyll
6595 match state
.autoscroll
with
6596 | Some step
when step
!= 0 ->
6597 let y = state
.y + step
in
6598 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6601 then state
.maxy - fy
6602 else if y >= state
.maxy - fy then 0 else y
6604 if state
.mode = View
6605 then gotoxy_and_clear_text state
.x y
6606 else gotoxy state
.x y;
6609 else deadline
+. 0.01
6614 let rec checkfds = function
6616 | fd
:: rest
when fd
= state
.ss ->
6617 let cmd = rcmd state
.ss in
6621 | fd
:: rest
when fd
= state
.wsfd ->
6625 | fd
:: rest
when Some fd
= !optrfd ->
6626 begin match remote fd
with
6627 | None
-> optrfd := remoteopen !rcmdpath;
6628 | opt -> optrfd := opt
6633 dolog
"select returned unknown descriptor";
6639 if deadline
= infinity
6643 match state
.autoscroll
with
6644 | Some step
when step
!= 0 -> deadline1
6645 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6653 Config.save leavebirdseye;
6654 if hasunsavedchanges
()