6 external init
: Unix.file_descr
-> initparams
-> 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
98 | Textentry _
| View
| LinkNav _
-> false
101 let istextentry = function
102 | Textentry _
-> true
103 | Birdseye _
| View
| LinkNav _
-> false
106 let wtmode = ref false;;
107 let cxack = ref false;;
109 let pgscale h
= truncate
(float h
*. conf
.pgscale);;
112 if state
.uioh#alwaysscrolly
|| ((conf
.scrollb
land scrollbhv
!= 0)
113 && (state
.w
> state
.winw
))
119 if state
.uioh#alwaysscrolly
|| ((conf
.scrollb
land scrollbvv
!= 0)
120 && (state
.maxy
> state
.winh
))
128 else x
> state
.winw
- vscrollw ()
132 fstate
.fontsize
<- n
;
133 fstate
.wwidth
<- measurestr fstate
.fontsize
"w";
134 fstate
.maxrows
<- (state
.winh
- fstate
.fontsize
- 1) / (fstate
.fontsize
+ 1);
140 else Printf.kprintf ignore fmt
144 if emptystr conf
.pathlauncher
145 then dolog
"%s" state
.path
147 let command = Str.global_replace percentsre state
.path conf
.pathlauncher
in
148 match spawn
command [] with
151 dolog
"failed to execute `%s': %s" command @@ exntos exn
157 let postRedisplay who
=
158 vlog "redisplay for [%S]" who
;
159 state
.redisplay
<- true;
163 let getopaque pageno
=
164 try Some
(Hashtbl.find state
.pagemap
(pageno
, state
.gen
))
165 with Not_found
-> None
168 let pagetranslatepoint l x y
=
169 let dy = y
- l
.pagedispy
in
170 let y = dy + l
.pagey
in
171 let dx = x
- l
.pagedispx
in
172 let x = dx + l
.pagex
in
176 let onppundermouse g
x y d
=
179 begin match getopaque l
.pageno
with
181 let x0 = l
.pagedispx
in
182 let x1 = x0 + l
.pagevw
in
183 let y0 = l
.pagedispy
in
184 let y1 = y0 + l
.pagevh
in
185 if y >= y0 && y <= y1 && x >= x0 && x <= x1
187 let px, py
= pagetranslatepoint l
x y in
188 match g opaque l
px py
with
201 let g opaque l
px py
=
204 match rectofblock opaque
px py
with
205 | Some
[|x0;x1;y0;y1|] ->
206 let rect = (x0, y0, x1, y0, x1, y1, x0, y1) in
207 let color = (0.0, 0.0, 1.0 /. (l
.pageno
mod 3 |> float), 0.5) in
208 state
.rects
<- [l
.pageno
, color, rect];
209 G.postRedisplay "getunder";
212 let under = whatsunder opaque
px py
in
213 if under = Unone
then None
else Some
under
215 onppundermouse g x y Unone
220 match unproject opaque
x y with
221 | Some
(x, y) -> Some
(Some
(opaque
, l
.pageno
, x, y))
224 onppundermouse g x y None
;
228 state
.text
<- Printf.sprintf
"%c%s" c s
;
229 G.postRedisplay "showtext";
233 Format.ksprintf
(fun s
-> showtext '
!' s
) fmt
;
236 let pipesel opaque cmd
=
239 match Unix.pipe
() with
240 | (exception exn
) -> dolog
"pipesel cannot create pipe: %S" @@ exntos exn
;
242 let doclose what fd
=
243 Ne.clo fd
(fun msg
-> dolog
"%s close failed: %s" what msg
)
246 try spawn cmd
[r
, 0; w
, -1]
248 dolog
"cannot execute %S: %s" cmd
@@ exntos exn
;
254 G.postRedisplay "pipesel";
256 else doclose "pipesel pipe/w" w
;
257 doclose "pipesel pipe/r" r
;
261 let g opaque l
px py
=
262 if markunder opaque
px py conf
.paxmark
265 match getopaque l
.pageno
with
267 | Some opaque
-> pipesel opaque conf
.paxcmd
272 G.postRedisplay "paxunder";
273 if conf
.paxmark
= Mark_page
276 match getopaque l
.pageno
with
278 | Some opaque
-> clearmark opaque
) state
.layout
;
279 state
.roam
<- onppundermouse g x y (fun () -> impmsg "whoopsie daisy");
283 match Unix.pipe
() with
284 | (exception exn
) -> impmsg "pipe failed: %s" @@ exntos exn
287 Ne.clo fd
(fun msg
-> impmsg "failed to close %s: %s" cap msg
)
290 try spawn conf
.selcmd
[r
, 0; w
, -1]
292 impmsg "failed to execute %s: %s" conf
.selcmd
@@ exntos exn
;
298 let l = String.length s
in
299 let bytes = Bytes.unsafe_of_string s
in
300 let n = tempfailureretry
(Unix.write w
bytes 0) l in
302 then impmsg "failed to write %d characters to sel pipe, wrote %d"
305 impmsg "failed to write to sel pipe: %s" @@ exntos exn
308 clo "selstring pipe/r" r
;
309 clo "selstring pipe/w" w
;
312 let undertext = function
315 | Utext s
-> "font: " ^ s
316 | Uannotation
(opaque
, slinkindex
) ->
317 "annotation: " ^ getannotcontents opaque slinkindex
320 let updateunder x y =
321 match getunder x y with
322 | Unone
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
324 if conf
.underinfo
then showtext 'u'
("ri: " ^ uri
);
325 Wsi.setcursor
Wsi.CURSOR_INFO
327 if conf
.underinfo
then showtext '
f'
("ont: " ^ s
);
328 Wsi.setcursor
Wsi.CURSOR_TEXT
330 if conf
.underinfo
then showtext 'a'
"nnotation";
331 Wsi.setcursor
Wsi.CURSOR_INFO
334 let showlinktype under =
335 if conf
.underinfo
&& under != Unone
336 then showtext ' '
@@ undertext under
339 let intentry_with_suffix text key
=
341 if key
>= 32 && key
< 127
343 let c = Char.chr key
in
348 | 'k'
| 'm'
| '
g'
| 'K'
| 'M'
| 'G'
->
349 addchar
text @@ asciilower
c
351 state
.text <- Printf.sprintf
"invalid key (%d, `%c')" key
c;
354 state
.text <- Printf.sprintf
"invalid key %d" key
;
362 let b = Buffer.create
16 in
365 let b = Buffer.to_bytes
b in
366 wcmd state
.ss
b @@ Bytes.length
b
370 let nogeomcmds cmds
=
372 | s
, [] -> emptystr s
376 let layoutN ((columns
, coverA
, coverB
), b) x y sw sh
=
377 let rec fold accu
n =
378 if n = Array.length
b
381 let pdimno, dx, vy
, (_
, w
, h
, xoff
) = b.(n) in
384 || n = state
.pagecount
- coverB
385 || (n - coverA
) mod columns
= columns
- 1)
391 let pagey = max
0 (y - vy
) in
392 let pagedispy = if pagey > 0 then 0 else vy
- y in
393 let pagedispx, pagex
=
395 if n = coverA
- 1 || n = state
.pagecount
- coverB
396 then x + (sw
- w
) / 2
404 let vw = sw
- pagedispx in
405 let pw = w
- pagex
in
408 let pagevh = min
(h
- pagey) (sh
- pagedispy) in
409 if pagevw > 0 && pagevh > 0
420 ; pagedispx = pagedispx
421 ; pagedispy = pagedispy
433 if Array.length
b = 0
435 else List.rev
(fold [] (page_of_y
y))
438 let layoutS (columns
, b) x y sw sh
=
439 let rec fold accu n =
440 if n = Array.length
b
443 let pdimno, px, vy
, (_
, pagew
, pageh
, xoff
) = b.(n) in
451 let pagey = max
0 (y - vy
) in
452 let pagedispy = if pagey > 0 then 0 else vy
- y in
453 let pagedispx, pagex
=
467 let pagecolw = pagew
/columns
in
470 then pagedispx + ((sw
- pagecolw) / 2)
474 let vw = sw
- pagedispx in
475 let pw = pagew
- pagex
in
478 let pagevw = min
pagevw pagecolw in
479 let pagevh = min
(pageh
- pagey) (sh
- pagedispy) in
480 if pagevw > 0 && pagevh > 0
491 ; pagedispx = pagedispx
492 ; pagedispy = pagedispy
493 ; pagecol
= n mod columns
507 let layout x y sw sh
=
508 if nogeomcmds state
.geomcmds
510 match conf
.columns
with
511 | Csingle
b -> layoutN ((1, 0, 0), b) x y sw sh
512 | Cmulti
c -> layoutN c x y sw sh
513 | Csplit s
-> layoutS s
x y sw sh
518 let y = state
.y + incr
in
520 let y = min
y (state
.maxy
- (if conf
.maxhfit
then state
.winh
else 0)) in
525 let tilex = l.pagex
mod conf
.tilew
in
526 let tiley = l.pagey mod conf
.tileh
in
528 let col = l.pagex
/ conf
.tilew
in
529 let row = l.pagey / conf
.tileh
in
531 let rec rowloop row y0 dispy h
=
535 let dh = conf
.tileh
- y0 in
537 let rec colloop col x0 dispx w
=
541 let dw = conf
.tilew
- x0 in
543 f col row dispx dispy
x0 y0 dw dh;
544 colloop (col+1) 0 (dispx
+dw) (w
-dw)
547 colloop col tilex l.pagedispx l.pagevw;
548 rowloop (row+1) 0 (dispy
+dh) (h
-dh)
551 if l.pagevw > 0 && l.pagevh > 0
552 then rowloop row tiley l.pagedispy l.pagevh;
555 let gettileopaque l col row =
557 l.pageno
, state
.gen
, conf
.colorspace
, conf
.angle
, l.pagew
, l.pageh
, col, row
559 try Some
(Hashtbl.find state
.tilemap
key)
560 with Not_found
-> None
563 let puttileopaque l col row gen colorspace angle opaque size elapsed
=
564 let key = l.pageno
, gen
, colorspace
, angle
, l.pagew
, l.pageh
, col, row in
565 Hashtbl.add state
.tilemap
key (opaque
, size
, elapsed
)
568 let filledrect2 x0 y0 x1 y1 x2 y2 x3 y3
=
569 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x1; y1; x2
; y2
; x3
; y3
|];
570 GlArray.vertex `two state
.vraw
;
571 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
574 let filledrect1 x0 y0 x1 y1 = filledrect2 x0 y0 x0 y1 x1 y0 x1 y1;;
576 let filledrect x0 y0 x1 y1 =
577 GlArray.disable `texture_coord
;
578 filledrect1 x0 y0 x1 y1;
579 GlArray.enable `texture_coord
;
582 let linerect x0 y0 x1 y1 =
583 GlArray.disable `texture_coord
;
584 Raw.sets_float state
.vraw ~pos
:0 [| x0; y0; x0; y1; x1; y1; x1; y0 |];
585 GlArray.vertex `two state
.vraw
;
586 GlArray.draw_arrays `line_loop ~first
:0 ~count
:4;
587 GlArray.enable `texture_coord
;
590 let drawtiles l color =
593 let f col row x y tilex tiley w h
=
594 match gettileopaque l col row with
595 | Some
(opaque
, _
, t
) ->
596 let params = x, y, w
, h
, tilex, tiley in
598 then GlTex.env
(`mode `blend
);
599 drawtile
params opaque
;
601 then GlTex.env
(`mode `modulate
);
605 let s = Printf.sprintf
609 let w = measurestr fstate
.fontsize
s in
610 GlDraw.color (0.0, 0.0, 0.0);
611 filledrect (float (x-2))
614 (float (y + fstate
.fontsize
+ 2));
616 drawstring fstate
.fontsize
x (y + fstate
.fontsize
- 1) s;
623 let lw = state
.winw
- x in
626 let lh = state
.winh
- y in
630 then GlTex.env
(`mode `blend
);
631 begin match state
.checkerstexid
with
633 Gl.enable `texture_2d
;
634 GlTex.bind_texture ~target
:`texture_2d id
;
638 and y1 = float (y+h
) in
640 let tw = float w /. 16.0
641 and th
= float h
/. 16.0 in
642 let tx0 = float tilex /. 16.0
643 and ty0
= float tiley /. 16.0 in
645 and ty1
= ty0
+. th
in
646 Raw.sets_float state
.vraw ~pos
:0
647 [| x0; y0; x0; y1; x1; y0; x1; y1 |];
648 Raw.sets_float state
.traw ~pos
:0
649 [| tx0; ty0
; tx0; ty1
; tx1; ty0
; tx1; ty1
|];
650 GlArray.vertex `two state
.vraw
;
651 GlArray.tex_coord `two state
.traw
;
652 GlArray.draw_arrays `triangle_strip ~first
:0 ~count
:4;
653 Gl.disable `texture_2d
;
656 GlDraw.color (1.0, 1.0, 1.0);
657 filledrect (float x) (float y) (float (x+w)) (float (y+h
));
660 then GlTex.env
(`mode `modulate
);
661 if w > 128 && h
> fstate
.fontsize
+ 10
663 let c = if conf
.invert
then 1.0 else 0.0 in
664 GlDraw.color (c, c, c);
667 then (col*conf
.tilew
, row*conf
.tileh
)
670 drawstring2 fstate
.fontsize
x y "Loading %d [%d,%d]" l.pageno
c r
;
679 let pagevisible layout n = List.exists
(fun l -> l.pageno
= n) layout;;
681 let tilevisible1 l x y =
683 and ax1
= l.pagex
+ l.pagevw
685 and ay1
= l.pagey + l.pagevh in
689 let bx1 = min
(bx0 + conf
.tilew
) l.pagew
690 and by1
= min
(by0
+ conf
.tileh
) l.pageh
in
692 let rx0 = max
ax0 bx0
693 and ry0
= max ay0 by0
694 and rx1
= min ax1
bx1
695 and ry1
= min ay1 by1
in
697 let nonemptyintersection = rx1
> rx0 && ry1
> ry0
in
701 let tilevisible layout n x y =
702 let rec findpageinlayout m
= function
703 | l :: rest
when l.pageno
= n ->
704 tilevisible1 l x y || (
705 match conf
.columns
with
706 | Csplit
(c, _
) when c > m
-> findpageinlayout (m
+1) rest
711 | _
:: rest
-> findpageinlayout 0 rest
714 findpageinlayout 0 layout;
717 let tileready l x y =
718 tilevisible1 l x y &&
719 gettileopaque l (x/conf
.tilew
) (y/conf
.tileh
) != None
722 let tilepage n p
layout =
723 let rec loop = function
727 let f col row _ _ _ _ _ _
=
728 if state
.currently
= Idle
730 match gettileopaque l col row with
733 let x = col*conf
.tilew
734 and y = row*conf
.tileh
in
736 let w = l.pagew
- x in
740 let h = l.pageh
- y in
745 then getpbo
w h conf
.colorspace
748 wcmd "tile %s %d %d %d %d %s"
749 (~
> p
) x y w h (~
> pbo);
752 l, p
, conf
.colorspace
, conf
.angle
,
753 state
.gen
, col, row, conf
.tilew
, conf
.tileh
762 if nogeomcmds state
.geomcmds
766 let preloadlayout x y sw sh
=
767 let y = if y < sh
then 0 else y - sh
in
768 let x = min
0 (x + sw
) in
776 if state
.currently
!= Idle
781 begin match getopaque l.pageno
with
783 wcmd "page %d %d" l.pageno
l.pagedimno
;
784 state
.currently
<- Loading
(l, state
.gen
);
786 tilepage l.pageno opaque pages
;
791 if nogeomcmds state
.geomcmds
797 if conf
.preload && state
.currently
= Idle
798 then load (preloadlayout state
.x state
.y state
.winw state
.winh
);
801 let layoutready layout =
802 let rec fold all ls
=
805 let seen = ref false in
806 let allvisible = ref true in
807 let foo col row _ _ _ _ _ _
=
809 allvisible := !allvisible &&
810 begin match gettileopaque l col row with
816 fold (!seen && !allvisible) rest
819 let alltilesvisible = fold true layout in
824 let y = bound
y 0 state
.maxy
in
825 let y, layout, proceed
=
826 match conf
.maxwait
with
827 | Some time
when state
.ghyll
== noghyll
->
828 begin match state
.throttle
with
830 let layout = layout x y state
.winw state
.winh
in
831 let ready = layoutready layout in
835 state
.throttle
<- Some
(layout, y, now
());
837 else G.postRedisplay "gotoxy showall (None)";
839 | Some
(_
, _
, started
) ->
840 let dt = now
() -. started
in
843 state
.throttle
<- None
;
844 let layout = layout x y state
.winw state
.winh
in
846 G.postRedisplay "maxwait";
853 let layout = layout x y state
.winw state
.winh
in
854 if not
!wtmode || layoutready layout
855 then G.postRedisplay "gotoxy ready";
862 state
.layout <- layout;
863 begin match state
.mode
with
866 | Ltexact
(pageno
, linkno
) ->
867 let rec loop = function
869 state
.lnava
<- Some
(pageno
, linkno
);
870 state
.mode
<- LinkNav
(Ltgendir
0)
871 | l :: _
when l.pageno
= pageno
->
872 begin match getopaque pageno
with
873 | None
-> state
.mode
<- LinkNav
(Ltnotready
(pageno
, 0))
875 let x0, y0, x1, y1 = getlinkrect opaque linkno
in
876 if not
(x0 >= l.pagex
&& x1 <= l.pagex
+ l.pagevw
877 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
878 then state
.mode
<- LinkNav
(Ltgendir
0)
880 | _
:: rest
-> loop rest
883 | Ltnotready _
| Ltgendir _
-> ()
889 begin match state
.mode
with
890 | Birdseye
(conf
, leftx
, pageno
, hooverpageno
, anchor
) ->
891 if not
(pagevisible layout pageno
)
893 match state
.layout with
896 state
.mode
<- Birdseye
(
897 conf
, leftx
, l.pageno
, hooverpageno
, anchor
902 | Ltnotready
(_
, dir
)
905 let rec loop = function
908 match getopaque l.pageno
with
909 | None
-> Ltnotready
(l.pageno
, dir
)
914 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
916 if dir
> 0 then LDfirst
else LDlast
922 | Lnotfound
-> loop rest
924 showlinktype (getlink opaque
n);
925 Ltexact
(l.pageno
, n)
929 state
.mode
<- LinkNav
linknav
937 state
.ghyll
<- noghyll
;
940 let mx, my
= state
.mpos
in
945 let conttiling pageno opaque
=
946 tilepage pageno opaque
948 then preloadlayout state
.x state
.y state
.winw state
.winh
952 let gotoxy_and_clear_text x y =
953 if not conf
.verbose
then state
.text <- E.s;
957 let getanchory (n, top
, dtop
) =
958 let y, h = getpageyh
n in
961 let ips = calcips
h in
962 y + truncate
(top
*.float h -. dtop
*.float ips) + ips;
964 y + truncate
(top
*.float h -. dtop
*.float conf
.interpagespace
)
967 let gotoanchor anchor
=
968 gotoxy state
.x (getanchory anchor
);
972 cbput state
.hists
.nav
(getanchor
());
976 let anchor = cbgetc state
.hists
.nav dir
in
980 let gotoghyll1 single
y =
982 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
984 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
986 then s (float f /. float a
)
989 then 1.0 -. s ((float (f-b) /. float (n-b)))
995 let ins = float a
*. 0.5
996 and outs
= float (n-b) *. 0.5 in
998 ins +. outs
+. float ones
1000 let rec set nab
y sy
=
1001 let (_N
, _A
, _B
), y =
1004 let scl = if y > sy
then 2 else -2 in
1005 let _N, _
, _
= nab
in
1006 (_N,0,_N), y+conf
.scrollstep
*scl
1008 let sum = summa
_N _A _B
in
1009 let dy = float (y - sy
) in
1013 then state
.ghyll
<- noghyll
1016 let s = scroll n _N _A _B
in
1017 let y1 = y1 +. ((s *. dy) /. sum) in
1018 gotoxy_and_clear_text state
.x (truncate
y1);
1019 state
.ghyll
<- gf (n+1) y1;
1023 | Some
y'
when single
-> set nab
y' state
.y
1024 | Some
y'
-> set (_N/2, 1, 1) y' state
.y
1026 gf 0 (float state
.y)
1029 match conf
.ghyllscroll
with
1030 | Some nab
when not conf
.presentation
->
1031 if state
.ghyll
== noghyll
1032 then set nab
y state
.y
1033 else state
.ghyll
(Some
y)
1035 gotoxy_and_clear_text state
.x y
1038 let gotoghyll = gotoghyll1 false;;
1040 let gotopage n top
=
1041 let y, h = getpageyh
n in
1042 let y = y + (truncate
(top
*. float h)) in
1046 let gotopage1 n top
=
1047 let y = getpagey
n in
1052 let invalidate s f =
1053 state
.redisplay
<- false;
1058 match state
.geomcmds
with
1059 | ps
, [] when emptystr ps
->
1061 state
.geomcmds
<- s, [];
1064 state
.geomcmds
<- ps
, [s, f];
1066 | ps
, (s'
, _
) :: rest
when s'
= s ->
1067 state
.geomcmds
<- ps
, ((s, f) :: rest
);
1070 state
.geomcmds
<- ps
, ((s, f) :: cmds
);
1074 Hashtbl.iter
(fun _ opaque
->
1075 wcmd "freepage %s" (~
> opaque
);
1077 Hashtbl.clear state
.pagemap
;
1081 if not
(Queue.is_empty state
.tilelru
)
1083 Queue.iter
(fun (k
, p
, s) ->
1084 wcmd "freetile %s" (~
> p
);
1085 state
.memused
<- state
.memused
- s;
1086 Hashtbl.remove state
.tilemap k
;
1088 state
.uioh#infochanged Memused
;
1089 Queue.clear state
.tilelru
;
1095 let h = truncate
(float h*.conf
.zoom
) in
1096 let d = conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0) in
1100 let opendoc path password
=
1102 state
.password
<- password
;
1103 state
.gen
<- state
.gen
+ 1;
1104 state
.docinfo
<- [];
1105 state
.outlines
<- [||];
1108 setaalevel conf
.aalevel
;
1110 if emptystr state
.origin
1114 Wsi.settitle
("llpp " ^
(mbtoutf8
(Filename.basename
titlepath)));
1115 wcmd "open %d %d %d %s\000%s\000%s\000"
1116 (btod
!wtmode) (btod
!cxack) (btod conf
.usedoccss
)
1117 path password conf
.css
;
1118 invalidate "reqlayout"
1120 wcmd "reqlayout %d %d %d %s\000"
1121 conf
.angle
(FMTE.to_int conf
.fitmodel
)
1122 (stateh state
.winh
) state
.nameddest
1127 state
.anchor <- getanchor
();
1128 opendoc state
.path state
.password
;
1132 let c = c *. conf
.colorscale
in
1136 let scalecolor2 (r
, g, b) =
1137 (r
*. conf
.colorscale
, g *. conf
.colorscale
, b *. conf
.colorscale
);
1140 let docolumns columns
=
1143 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1144 let rec loop pageno
pdimno pdim
y ph pdims
=
1145 if pageno
= state
.pagecount
1148 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1150 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1151 pdimno+1, pdim
, rest
1155 let x = max
0 (((state
.winw
- w) / 2) - xoff
) in
1157 y + (if conf
.presentation
1158 then (if pageno
= 0 then calcips
h else calcips ph
+ calcips
h)
1159 else (if pageno
= 0 then 0 else conf
.interpagespace
)
1162 a.(pageno
) <- (pdimno, x, y, pdim
);
1163 loop (pageno
+1) pdimno pdim
(y + h) h pdims
1165 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 state
.pdims
;
1166 conf
.columns
<- Csingle
a;
1168 | Cmulti
((columns
, coverA
, coverB
), _
) ->
1169 let a = Array.make state
.pagecount
(-1, -1, -1, (-1, -1, -1, -1)) in
1170 let rec loop pageno
pdimno pdim
x y rowh pdims
=
1172 if m
= pageno
then () else
1173 let (pdimno, x, y, ((_
, _
, h, _
) as pdim
)) = a.(m
) in
1176 let y = y + (rowh
- h) / 2 in
1177 a.(m
) <- (pdimno, x, y, pdim
);
1181 if pageno
= state
.pagecount
1182 then fixrow (((pageno
- 1) / columns
) * columns
)
1184 let pdimno, ((_
, w, h, xoff
) as pdim
), pdims
=
1186 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1187 pdimno+1, pdim
, rest
1192 if pageno
= coverA
- 1 || pageno
= state
.pagecount
- coverB
1194 let x = (state
.winw
- w) / 2 in
1196 if conf
.presentation
then calcips
h else conf
.interpagespace
in
1197 x, y + ips + rowh
, h
1200 if (pageno
- coverA
) mod columns
= 0
1202 let x = max
0 (state
.winw
- state
.w) / 2 in
1204 if conf
.presentation
1206 let ips = calcips
h in
1207 y + (if pageno
= 0 then 0 else calcips rowh
+ ips)
1209 y + (if pageno
= 0 then 0 else conf
.interpagespace
)
1213 else x, y, max rowh
h
1217 if pageno
> 1 && (pageno
- coverA
) mod columns
= 0
1220 if pageno
= columns
&& conf
.presentation
1222 let ips = calcips rowh
in
1223 for i
= 0 to pred columns
1225 let (pdimno, x, y, pdim
) = a.(i
) in
1226 a.(i
) <- (pdimno, x, y+ips, pdim
)
1232 fixrow (pageno
- columns
);
1237 a.(pageno
) <- (pdimno, x, y, pdim
);
1238 let x = x + w + xoff
*2 + conf
.interpagespace
in
1239 loop (pageno
+1) pdimno pdim
x y rowh' pdims
1241 loop 0 ~
-1 (-1,-1,-1,-1) 0 0 0 state
.pdims
;
1242 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), a);
1245 let a = Array.make
(state
.pagecount
*c) (-1, -1, -1, (-1, -1, -1, -1)) in
1246 let rec loop pageno
pdimno pdim
y pdims
=
1247 if pageno
= state
.pagecount
1250 let pdimno, ((_
, w, h, _
) as pdim
), pdims
=
1252 | ((pageno'
, _
, _
, _
) as pdim
) :: rest
when pageno'
= pageno
->
1253 pdimno+1, pdim
, rest
1258 let rec loop1 n x y =
1259 if n = c then y else (
1260 a.(pageno
*c + n) <- (pdimno, x, y, pdim
);
1261 loop1 (n+1) (x+cw) (y + h + conf
.interpagespace
)
1264 let y = loop1 0 0 y in
1265 loop (pageno
+1) pdimno pdim
y pdims
1267 loop 0 ~
-1 (-1,-1,-1,-1) 0 state
.pdims
;
1268 conf
.columns
<- Csplit
(c, a);
1272 docolumns conf
.columns
;
1273 state
.maxy
<- calcheight
();
1274 if state
.reprf
== noreprf
1276 match state
.mode
with
1277 | Birdseye
(_
, _
, pageno
, _
, _
) ->
1278 let y, h = getpageyh pageno
in
1279 let top = (state
.winh
- h) / 2 in
1280 gotoxy state
.x (max
0 (y - top))
1284 let y = getanchory state
.anchor in
1285 let y = min
y (state
.maxy
- state
.winh
) in
1290 state
.reprf
<- noreprf
;
1294 let reshape ?
(firsttime
=false) w h =
1295 GlDraw.viewport ~
x:0 ~
y:0 ~
w ~
h;
1296 if not firsttime
&& nogeomcmds state
.geomcmds
1297 then state
.anchor <- getanchor
();
1300 let w = truncate
(float w *. conf
.zoom
) in
1303 setfontsize fstate
.fontsize
;
1304 GlMat.mode `modelview
;
1305 GlMat.load_identity
();
1307 GlMat.mode `projection
;
1308 GlMat.load_identity
();
1309 GlMat.rotate ~
x:1.0 ~angle
:180.0 ();
1310 GlMat.translate ~
x:~
-.1.0 ~
y:~
-.1.0 ();
1311 GlMat.scale3
(2.0 /. float state
.winw
, 2.0 /. float state
.winh
, 1.0);
1316 else float state
.x /. float state
.w
1318 invalidate "geometry"
1322 then state
.x <- truncate
(relx *. float w);
1324 match conf
.columns
with
1326 | Cmulti
((c, _
, _
), _
) -> (w - (c-1)*conf
.interpagespace
) / c
1327 | Csplit
(c, _
) -> w * c
1329 wcmd "geometry %d %d %d"
1330 w (stateh h) (FMTE.to_int conf
.fitmodel
)
1335 let len = String.length state
.text in
1336 let x0 = if conf
.leftscroll
then vscrollw () else 0 in
1339 match state
.mode
with
1340 | Textentry _
| View
| LinkNav _
->
1341 let h, _
, _
= state
.uioh#scrollpw
in
1346 filledrect x (float (state
.winh
- (fstate
.fontsize
+ 4) - hscrollh))
1347 (x+.w) (float (state
.winh
- hscrollh))
1350 let w = float (state
.winw
- 1 - vscrollw ()) in
1351 if state
.progress
>= 0.0 && state
.progress
< 1.0
1353 GlDraw.color (0.3, 0.3, 0.3);
1354 let w1 = w *. state
.progress
in
1356 GlDraw.color (0.0, 0.0, 0.0);
1357 rect (float x0+.w1) (float x0+.w-.w1)
1360 GlDraw.color (0.0, 0.0, 0.0);
1364 GlDraw.color (1.0, 1.0, 1.0);
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
1422 && colorspace
= conf
.colorspace
1423 && angle
= conf
.angle
1427 let x = col*conf
.tilew
1428 and y = row*conf
.tileh
in
1429 tilevisible (Lazy.force_val
layout) n x y
1431 then Queue.push lruitem state
.tilelru
1434 wcmd "freetile %s" (~
> p
);
1435 state
.memused
<- state
.memused
- s;
1436 state
.uioh#infochanged Memused
;
1437 Hashtbl.remove state
.tilemap k
;
1445 let onpagerect pageno
f =
1447 match conf
.columns
with
1448 | Cmulti
(_
, b) -> b
1450 | Csplit
(_
, b) -> b
1452 if pageno
>= 0 && pageno
< Array.length
b
1454 let (_
, _
, _
, (_
, w, h, _
)) = b.(pageno
) in
1458 let gotopagexy1 wtmode pageno
x y =
1459 let _,w1,h1
,leftx
= getpagedim pageno
in
1460 let top = y /. (float h1
) in
1461 let left = x /. (float w1) in
1462 let py, w, h = getpageywh pageno
in
1463 let wh = state
.winh
in
1464 let x = left *. (float w) in
1465 let x = leftx
+ state
.x + truncate
x in
1467 if x < 0 || x >= state
.winw
1471 let pdy = truncate
(top *. float h) in
1472 let y'
= py + pdy in
1473 let dy = y'
- state
.y in
1475 if x != state
.x || not
(dy > 0 && dy < wh)
1477 if conf
.presentation
1479 if abs
(py - y'
) > wh
1486 if state
.x != sx || state
.y != sy
1491 let ww = state
.winw
in
1493 and qy
= pdy / wh in
1495 and y = py + qy
* wh in
1496 let x = if -x + ww > w1 then -(w1-ww) else x
1497 and y'
= if y + wh > state
.maxy
then state
.maxy
- wh else y in
1499 if conf
.presentation
1501 if abs
(py - y'
) > wh
1510 gotoxy_and_clear_text x y;
1512 else gotoxy_and_clear_text state
.x state
.y;
1515 let gotopagexy wtmode pageno
x y =
1516 match state
.mode
with
1517 | Birdseye
_ -> gotopage pageno
0.0
1520 | LinkNav
_ -> gotopagexy1 wtmode pageno
x y
1523 let getpassword () =
1524 let passcmd = getenvwithdef
"LLPP_ASKPASS" conf
.passcmd in
1529 impmsg "error getting password: %s" s;
1530 dolog
"%s" s) passcmd;
1533 let pgoto opaque pageno
x y =
1534 let pdimno = getpdimno pageno
in
1535 let x, y = project opaque pageno
pdimno x y in
1536 gotopagexy false pageno
x y;
1540 (* dolog "%S" cmds; *)
1541 let spl = splitatchar cmds ' '
in
1543 try Scanf.sscanf
s fmt
f
1545 dolog
"error processing '%S': %s" cmds
@@ exntos exn
;
1548 let addoutline outline
=
1549 match state
.currently
with
1550 | Outlining outlines
->
1551 state
.currently
<- Outlining
(outline
:: outlines
)
1552 | Idle
-> state
.currently
<- Outlining
[outline
]
1555 dolog
"invalid outlining state";
1556 logcurrently state
.currently
1561 state
.uioh#infochanged Pdim
;
1563 | "clearrects", "" ->
1564 state
.rects
<- state
.rects1
;
1565 G.postRedisplay "clearrects";
1567 | "continue", args
->
1568 let n = scan args
"%u" (fun n -> n) in
1569 state
.pagecount
<- n;
1570 begin match state
.currently
with
1572 state
.currently
<- Idle
;
1573 state
.outlines
<- Array.of_list
(List.rev
l)
1579 let cur, cmds
= state
.geomcmds
in
1581 then failwith
"umpossible";
1583 begin match List.rev cmds
with
1585 state
.geomcmds
<- E.s, [];
1586 state
.throttle
<- None
;
1590 state
.geomcmds
<- s, List.rev rest
;
1592 if conf
.maxwait
= None
&& not
!wtmode
1593 then G.postRedisplay "continue";
1600 then showtext ' ' args
1603 Buffer.add_string state
.errmsgs args
;
1604 state
.newerrmsgs
<- true;
1605 G.postRedisplay "error message"
1607 | "progress", args
->
1608 let progress, text =
1611 f, String.sub args pos
(String.length args
- pos
))
1614 state
.progress <- progress;
1615 G.postRedisplay "progress"
1617 | "firstmatch", args
->
1618 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1619 scan args
"%u %d %f %f %f %f %f %f %f %f"
1620 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1621 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1623 let y = (getpagey
pageno) + truncate
y0 in
1631 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1632 state
.rects1
<- [pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)]
1635 let pageno, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
=
1636 scan args
"%u %d %f %f %f %f %f %f %f %f"
1637 (fun p
c x0 y0 x1 y1 x2 y2 x3 y3
->
1638 (p
, c, x0, y0, x1, y1, x2
, y2
, x3
, y3
))
1640 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
1642 (pageno, color, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) :: state
.rects1
1645 let pageopaques, t
= scan args
"%s %f" (fun p t
-> p
, t
) in
1646 let pageopaque = ~
< pageopaques in
1647 begin match state
.currently
with
1648 | Loading
(l, gen
) ->
1649 vlog "page %d took %f sec" l.pageno t
;
1650 Hashtbl.replace state
.pagemap
(l.pageno, gen
) pageopaque;
1651 begin match state
.throttle
with
1653 let preloadedpages =
1655 then preloadlayout state
.x state
.y state
.winw state
.winh
1660 List.fold_left
(fun s l -> IntSet.add
l.pageno s)
1661 IntSet.empty
preloadedpages
1664 Hashtbl.fold (fun ((pageno, _) as key) opaque
accu ->
1665 if not
(IntSet.mem
pageno set)
1667 wcmd "freepage %s" (~
> opaque
);
1673 List.iter
(Hashtbl.remove state
.pagemap
) evictedpages;
1676 state
.currently
<- Idle
;
1679 tilepage l.pageno pageopaque state
.layout;
1681 load preloadedpages;
1682 let visible = pagevisible state
.layout l.pageno in
1685 match state
.mode
with
1686 | LinkNav
(Ltnotready
(pageno, dir
)) ->
1687 if pageno = l.pageno
1692 then LDfirstvisible
(l.pagex
, l.pagey, dir
)
1694 if dir
> 0 then LDfirst
else LDlast
1697 findlink
pageopaque ld
1702 showlinktype (getlink
pageopaque n);
1703 state
.mode
<- LinkNav
(Ltexact
(l.pageno, n))
1705 | LinkNav
(Ltgendir
_)
1706 | LinkNav
(Ltexact
_)
1712 if visible && layoutready state
.layout
1714 G.postRedisplay "page";
1718 | Some
(layout, _, _) ->
1719 state
.currently
<- Idle
;
1720 tilepage l.pageno pageopaque layout;
1727 dolog
"Inconsistent loading state";
1728 logcurrently state
.currently
;
1733 let (x, y, opaques
, size
, t
) =
1734 scan args
"%u %u %s %u %f"
1735 (fun x y p size t
-> (x, y, p
, size
, t
))
1737 let opaque = ~
< opaques
in
1738 begin match state
.currently
with
1739 | Tiling
(l, pageopaque, cs
, angle
, gen
, col, row, tilew
, tileh
) ->
1740 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t
;
1743 if tilew
!= conf
.tilew
|| tileh
!= conf
.tileh
1745 wcmd "freetile %s" (~
> opaque);
1746 state
.currently
<- Idle
;
1750 puttileopaque l col row gen cs angle
opaque size t
;
1751 state
.memused
<- state
.memused
+ size
;
1752 state
.uioh#infochanged Memused
;
1754 Queue.push
((l.pageno, gen
, cs
, angle
, l.pagew
, l.pageh
, col, row),
1755 opaque, size
) state
.tilelru
;
1758 match state
.throttle
with
1759 | None
-> state
.layout
1760 | Some
(layout, _, _) -> layout
1763 state
.currently
<- Idle
;
1765 && conf
.colorspace
= cs
1766 && conf
.angle
= angle
1767 && tilevisible layout l.pageno x y
1768 then conttiling l.pageno pageopaque;
1770 begin match state
.throttle
with
1772 preload state
.layout;
1774 && conf
.colorspace
= cs
1775 && conf
.angle
= angle
1776 && tilevisible state
.layout l.pageno x y
1777 && (not
!wtmode || layoutready state
.layout)
1778 then G.postRedisplay "tile nothrottle";
1780 | Some
(layout, y, _) ->
1781 let ready = layoutready layout in
1785 state
.layout <- layout;
1786 state
.throttle
<- None
;
1787 G.postRedisplay "throttle";
1796 dolog
"Inconsistent tiling state";
1797 logcurrently state
.currently
;
1802 let (n, w, h, _) as pdim
=
1803 scan args
"%u %u %u %u" (fun n w h x -> n, w, h, x)
1806 match conf
.fitmodel
with
1808 | FitPage
| FitProportional
->
1809 match conf
.columns
with
1810 | Csplit
_ -> (n, w, h, 0)
1811 | Csingle
_ | Cmulti
_ -> pdim
1813 state
.pdims
<- pdim :: state
.pdims
;
1814 state
.uioh#infochanged Pdim
1817 let (l, n, t
, h, pos
) =
1818 scan args
"%u %u %d %u %n"
1819 (fun l n t
h pos
-> l, n, t
, h, pos
)
1821 let s = String.sub args pos
(String.length args
- pos
) in
1822 addoutline (s, l, Oanchor
(n, float t
/. float h, 0.0))
1825 let (l, len, pos
) = scan args
"%u %u %n" (fun l len pos
-> l, len, pos
) in
1826 let s = String.sub args pos
len in
1827 let pos2 = pos
+ len + 1 in
1828 let uri = String.sub args
pos2 (String.length args
- pos2) in
1829 addoutline (s, l, Ouri
uri)
1832 let (l, pos
) = scan args
"%u %n" (fun l pos
-> l, pos
) in
1833 let s = String.sub args pos
(String.length args
- pos
) in
1834 addoutline (s, l, Onone
)
1838 scan args
"%u %d %d" (fun n l t
-> n, l, t
)
1840 state
.reprf
<- (fun () -> gotopagexy !wtmode n (float l) (float t
))
1843 let pos = nindex args '
\t'
in
1847 if substratis args
0 "Title"
1849 let s = String.sub args
(pos+1) @@ String.length args
- pos - 1 in
1854 if substratis args
0 "CreationDate"
1856 if String.length args
>= pos + 7
1857 && args
.[pos+1] = 'D'
&& args
.[pos+2] = '
:'
1859 let b = Buffer.create
18 in
1860 Buffer.add_string
b "CreationDate\t";
1863 Buffer.add_substring
b args
(pos+p
+1) l;
1864 Buffer.add_char
b c;
1865 with exn
-> Buffer.add_string
b @@ exntos exn
1873 Buffer.add_char
b '
['
;
1874 Buffer.add_substring
b args
(pos+1)
1875 (String.length args
- pos - 1);
1876 Buffer.add_char
b '
]'
;
1883 state
.docinfo
<- (1, s) :: state
.docinfo
1886 state
.docinfo
<- List.rev state
.docinfo
;
1887 state
.uioh#infochanged Docinfo
1891 then Wsi.settitle
"Wrong password";
1892 let password = getpassword () in
1893 if emptystr
password
1894 then error
"document is password protected"
1895 else opendoc state
.path
password
1898 error
"unknown cmd `%S'" cmds
1903 let action = function
1904 | HCprev
-> cbget cb ~
-1
1905 | HCnext
-> cbget cb
1
1906 | HCfirst
-> cbget cb ~
-(cb
.rc)
1907 | HClast
-> cbget cb
(cb
.len - 1 - cb
.rc)
1908 and cancel
() = cb
.rc <- rc
1912 let search pattern forward
=
1913 match conf
.columns
with
1914 | Csplit
_ -> impmsg "searching does not work properly in split columns mode"
1917 if nonemptystr pattern
1920 match state
.layout with
1923 l.pageno, (l.pagey + if forward
then 0 else 0*l.pagevh)
1925 wcmd "search %d %d %d %d,%s\000"
1926 (btod conf
.icase
) pn py (btod forward
) pattern
;
1929 let intentry text key =
1931 if key >= 32 && key < 127
1933 let c = Char.chr
key in
1935 | '
0'
.. '
9'
-> addchar
text c
1937 state
.text <- Printf.sprintf
"invalid char (%d, `%c')" key c;
1940 state
.text <- Printf.sprintf
"invalid key (%d)" key;
1951 let l = String.length
s in
1952 let rec loop pos n =
1956 let m = Char.code
s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
1957 loop (pos+1) (n*26 + m)
1960 let rec loop n = function
1963 match getopaque l.pageno with
1964 | None
-> loop n rest
1966 let m = getlinkcount
opaque in
1969 let under = getlink
opaque n in
1972 else loop (n-m) rest
1974 loop n state
.layout;
1978 let linknentry text key =
1979 if key >= 32 && key < 127
1981 let text = addchar
text (Char.chr
key) in
1982 linknact (fun under -> state
.text <- undertext under) text;
1985 state
.text <- Printf.sprintf
"invalid key %d" key;
1990 let textentry text key =
1991 if Wsi.isspecialkey
key
1993 else TEcont
(text ^ toutf8
key)
1996 let reqlayout angle fitmodel
=
1997 match state
.throttle
with
1999 if nogeomcmds state
.geomcmds
2000 then state
.anchor <- getanchor
();
2001 conf
.angle
<- angle
mod 360;
2004 match state
.mode
with
2005 | LinkNav
_ -> state
.mode
<- View
2010 conf
.fitmodel
<- fitmodel
;
2014 wcmd "reqlayout %d %d %d"
2015 conf
.angle
(FMTE.to_int conf
.fitmodel
) (stateh state
.winh
)
2020 let settrim trimmargins trimfuzz
=
2021 if nogeomcmds state
.geomcmds
2022 then state
.anchor <- getanchor
();
2023 conf
.trimmargins
<- trimmargins
;
2024 conf
.trimfuzz
<- trimfuzz
;
2025 let x0, y0, x1, y1 = trimfuzz
in
2027 "settrim" (fun () ->
2028 wcmd "settrim %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1);
2033 match state
.throttle
with
2035 let zoom = max
0.0001 zoom in
2036 if zoom <> conf
.zoom
2038 state
.prevzoom
<- (conf
.zoom, state
.x);
2040 reshape state
.winw state
.winh
;
2041 state
.text <- Printf.sprintf
"zoom is now %-5.2f" (zoom *. 100.0);
2044 | Some
(layout, y, started
) ->
2046 match conf
.maxwait
with
2050 let dt = now
() -. started
in
2058 let pivotzoom ?
(vw=min state
.w state
.winw
)
2059 ?
(vh
=min
(state
.maxy
-state
.y) state
.winh
)
2060 ?
(x=vw/2) ?
(y=vh
/2) zoom =
2061 let w = float state
.w /. zoom in
2062 let hw = w /. 2.0 in
2063 let ratio = float vh
/. float vw in
2064 let hh = hw *. ratio in
2065 let x0 = if zoom < 1.0 then 0.0 else float x -. hw in
2066 let y0 = float y -. hh in
2067 gotoxy (state
.x - truncate
x0) (state
.y + truncate
y0);
2071 let pivotzoom ?
vw ?vh ?
x ?
y zoom =
2072 if nogeomcmds state
.geomcmds
then pivotzoom ?
vw ?vh ?
x ?
y zoom
2075 let setcolumns mode columns coverA coverB
=
2076 state
.prevcolumns
<- Some
(conf
.columns
, conf
.zoom);
2080 then impmsg "split mode doesn't work in bird's eye"
2082 conf
.columns
<- Csplit
(-columns
, E.a);
2090 conf
.columns
<- Csingle
E.a;
2095 conf
.columns
<- Cmulti
((columns
, coverA
, coverB
), E.a);
2099 reshape state
.winw state
.winh
;
2102 let resetmstate () =
2103 state
.mstate
<- Mnone
;
2104 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
2107 let enterbirdseye () =
2108 let zoom = float conf
.thumbw
/. float state
.winw
in
2109 let birdseyepageno =
2110 let cy = state
.winh
/ 2 in
2114 let rec fold best
= function
2117 let d = cy - (l.pagedispy + l.pagevh/2)
2118 and dbest
= cy - (best
.pagedispy + best
.pagevh/2) in
2119 if abs
d < abs dbest
2128 { conf
with zoom = conf
.zoom },
2129 state
.x, birdseyepageno, -1, getanchor
()
2133 conf
.presentation
<- false;
2134 conf
.interpagespace
<- 10;
2135 conf
.hlinks
<- false;
2136 conf
.fitmodel
<- FitPage
;
2138 conf
.maxwait
<- None
;
2140 match conf
.beyecolumns
with
2143 Cmulti
((c, 0, 0), E.a)
2144 | None
-> Csingle
E.a
2148 state
.text <- Printf.sprintf
"birds eye mode on (zoom %3.1f%%)"
2153 reshape state
.winw state
.winh
;
2156 let leavebirdseye (c, leftx
, pageno, _, anchor) goback
=
2158 conf
.zoom <- c.zoom;
2159 conf
.presentation
<- c.presentation
;
2160 conf
.interpagespace
<- c.interpagespace
;
2161 conf
.maxwait
<- c.maxwait
;
2162 conf
.hlinks
<- c.hlinks
;
2163 conf
.fitmodel
<- c.fitmodel
;
2164 conf
.beyecolumns
<- (
2165 match conf
.columns
with
2166 | Cmulti
((c, _, _), _) -> Some
c
2168 | Csplit
_ -> failwith
"leaving bird's eye split mode"
2171 match c.columns
with
2172 | Cmulti
(c, _) -> Cmulti
(c, E.a)
2173 | Csingle
_ -> Csingle
E.a
2174 | Csplit
(c, _) -> Csplit
(c, E.a)
2178 state
.text <- Printf.sprintf
"birds eye mode off (zoom %3.1f%%)"
2181 reshape state
.winw state
.winh
;
2182 state
.anchor <- if goback
then anchor else (pageno, 0.0, 1.0);
2186 let togglebirdseye () =
2187 match state
.mode
with
2188 | Birdseye vals
-> leavebirdseye vals
true
2189 | View
-> enterbirdseye ()
2190 | Textentry
_ | LinkNav
_ -> ()
2193 let upbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2194 let pageno = max
0 (pageno - incr
) in
2195 let rec loop = function
2196 | [] -> gotopage1 pageno 0
2197 | l :: _ when l.pageno = pageno ->
2198 if l.pagedispy >= 0 && l.pagey = 0
2199 then G.postRedisplay "upbirdseye"
2200 else gotopage1 pageno 0
2201 | _ :: rest
-> loop rest
2205 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor)
2208 let downbirdseye incr
(conf
, leftx
, pageno, hooverpageno
, anchor) =
2209 let pageno = min
(state
.pagecount
- 1) (pageno + incr
) in
2210 state
.mode
<- Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor);
2211 let rec loop = function
2213 let y, h = getpageyh
pageno in
2214 let dy = (y - state
.y) - (state
.winh
- h - conf
.interpagespace
) in
2215 gotoxy state
.x (clamp dy)
2216 | l :: _ when l.pageno = pageno ->
2217 if l.pagevh != l.pageh
2218 then gotoxy state
.x (clamp (l.pageh
- l.pagevh + conf
.interpagespace
))
2219 else G.postRedisplay "downbirdseye"
2220 | _ :: rest
-> loop rest
2226 let optentry mode
_ key =
2227 let btos b = if b then "on" else "off" in
2228 if key >= 32 && key < 127
2230 let c = Char.chr
key in
2234 try conf
.scrollstep
<- int_of_string
s with exn
->
2235 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2237 TEswitch
("scroll step: ", E.s, None
, intentry, ondone, true)
2242 conf
.autoscrollstep
<- boundastep state
.winh
(int_of_string
s);
2243 if state
.autoscroll
<> None
2244 then state
.autoscroll
<- Some conf
.autoscrollstep
2246 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2248 TEswitch
("auto scroll step: ", E.s, None
, intentry, ondone, true)
2253 let n, a, b = multicolumns_of_string
s in
2254 setcolumns mode
n a b;
2256 state
.text <- Printf.sprintf
"bad columns `%s': %s" s @@ exntos exn
2258 TEswitch
("columns: ", E.s, None
, textentry, ondone, true)
2263 let zoom = float (int_of_string
s) /. 100.0 in
2266 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2268 TEswitch
("zoom: ", E.s, None
, intentry, ondone, true)
2273 conf
.thumbw
<- bound
(int_of_string
s) 2 4096;
2275 Printf.sprintf
"thumbnail width is set to %d" conf
.thumbw
;
2276 begin match mode
with
2278 leavebirdseye beye
false;
2285 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2287 TEswitch
("thumbnail width: ", E.s, None
, intentry, ondone, true)
2291 match int_of_string
s with
2292 | angle
-> reqlayout angle conf
.fitmodel
2295 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2297 TEswitch
("rotation: ", E.s, None
, intentry, ondone, true)
2300 conf
.icase
<- not conf
.icase
;
2301 TEdone
("case insensitive search " ^
(btos conf
.icase
))
2304 conf
.preload <- not conf
.preload;
2305 gotoxy state
.x state
.y;
2306 TEdone
("preload " ^
(btos conf
.preload))
2309 conf
.verbose
<- not conf
.verbose
;
2310 TEdone
("verbose " ^
(btos conf
.verbose
))
2313 conf
.debug
<- not conf
.debug
;
2314 TEdone
("debug " ^
(btos conf
.debug
))
2317 conf
.maxhfit
<- not conf
.maxhfit
;
2318 state
.maxy
<- calcheight
();
2319 TEdone
("maxhfit " ^
(btos conf
.maxhfit
))
2322 conf
.crophack
<- not conf
.crophack
;
2323 TEdone
("crophack " ^
btos conf
.crophack
)
2327 match conf
.maxwait
with
2329 conf
.maxwait
<- Some infinity
;
2330 "always wait for page to complete"
2332 conf
.maxwait
<- None
;
2333 "show placeholder if page is not ready"
2338 conf
.underinfo
<- not conf
.underinfo
;
2339 TEdone
("underinfo " ^
btos conf
.underinfo
)
2342 conf
.savebmarks
<- not conf
.savebmarks
;
2343 TEdone
("persistent bookmarks " ^
btos conf
.savebmarks
)
2349 match state
.layout with
2354 conf
.interpagespace
<- int_of_string
s;
2355 docolumns conf
.columns
;
2356 state
.maxy
<- calcheight
();
2357 let y = getpagey
pageno in
2358 gotoxy state
.x (y + py)
2361 Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
2363 TEswitch
("vertical margin: ", E.s, None
, intentry, ondone, true)
2367 match conf
.fitmodel
with
2368 | FitProportional
-> FitWidth
2369 | FitWidth
| FitPage
-> FitProportional
2371 reqlayout conf
.angle
fm;
2372 TEdone
("proportional display " ^
btos (fm == FitProportional
))
2375 settrim (not conf
.trimmargins
) conf
.trimfuzz
;
2376 TEdone
("trim margins " ^
btos conf
.trimmargins
)
2379 conf
.invert
<- not conf
.invert
;
2380 TEdone
("invert colors " ^
btos conf
.invert
)
2384 cbput state
.hists
.sel
s;
2387 TEswitch
("selection command: ", E.s, Some
(onhist state
.hists
.sel
),
2388 textentry, ondone, true)
2392 then conf
.pax
<- Some
(ref (0.0, 0, 0))
2393 else conf
.pax
<- None
;
2394 TEdone
("PAX " ^
btos (conf
.pax
!= None
))
2397 state
.text <- Printf.sprintf
"bad option %d `%c'" key c;
2403 class type lvsource
=
2405 method getitemcount
: int
2406 method getitem
: int -> (string * int)
2407 method hasaction
: int -> bool
2415 method getactive
: int
2416 method getfirst
: int
2418 method getminfo
: (int * int) array
2421 class virtual lvsourcebase
= object
2422 val mutable m_active
= 0
2423 val mutable m_first
= 0
2424 val mutable m_pan
= 0
2425 method getactive
= m_active
2426 method getfirst
= m_first
2427 method getpan
= m_pan
2428 method getminfo
: (int * int) array
= E.a
2431 let textentrykeyboard
2432 key _mask
((c, text, opthist
, onkey
, ondone, cancelonempty
), onleave
) =
2434 let key = Wsi.keypadtodigitkey
key in
2436 state
.mode
<- Textentry
(te
, onleave
);
2438 G.postRedisplay "textentrykeyboard enttext";
2440 let histaction cmd
=
2443 | Some
(action, _) ->
2446 (c, action cmd
, opthist
, onkey
, ondone, cancelonempty
), onleave
2448 G.postRedisplay "textentry histaction"
2452 if emptystr
text && cancelonempty
2455 G.postRedisplay "textentrykeyboard after cancel";
2458 let s = withoutlastutf8
text in
2459 enttext (c, s, opthist
, onkey
, ondone, cancelonempty
)
2461 | @enter
| @kpenter
->
2464 G.postRedisplay "textentrykeyboard after confirm"
2466 | @up
| @kpup
-> histaction HCprev
2467 | @down
| @kpdown
-> histaction HCnext
2468 | @home
| @kphome
-> histaction HCfirst
2469 | @jend
| @kpend
-> histaction HClast
2474 begin match opthist
with
2476 | Some
(_, onhistcancel
) -> onhistcancel
()
2480 G.postRedisplay "textentrykeyboard after cancel2"
2483 enttext (c, E.s, opthist
, onkey
, ondone, cancelonempty
)
2486 | @delete
| @kpdelete
-> ()
2488 | _ when key != 0 && not
(Wsi.isspecialkey
key) ->
2489 begin match onkey
text key with
2493 G.postRedisplay "textentrykeyboard after confirm2";
2496 enttext (c, text, opthist
, onkey
, ondone, cancelonempty
);
2500 G.postRedisplay "textentrykeyboard after cancel3"
2503 state
.mode
<- Textentry
(te
, onleave
);
2504 G.postRedisplay "textentrykeyboard switch";
2508 vlog "unhandled key %s" (Wsi.keyname
key)
2511 let firstof first active
=
2512 if first
> active
|| abs
(first
- active
) > fstate
.maxrows
- 1
2513 then max
0 (active
- (fstate
.maxrows
/2))
2517 let calcfirst first active
=
2520 let rows = active
- first
in
2521 if rows > fstate
.maxrows
then active
- fstate
.maxrows
else first
2525 let scrollph y maxy
=
2526 let sh = float (maxy
+ state
.winh
) /. float state
.winh
in
2527 let sh = float state
.winh
/. sh in
2528 let sh = max
sh (float conf
.scrollh
) in
2530 let percent = float y /. float maxy
in
2531 let position = (float state
.winh
-. sh) *. percent in
2534 if position +. sh > float state
.winh
2535 then float state
.winh
-. sh
2541 let adderrmsg src msg
=
2542 Buffer.add_string state
.errmsgs msg
;
2543 state
.newerrmsgs
<- true;
2547 let adderrfmt src fmt
=
2548 Format.ksprintf
(fun s -> adderrmsg src
s) fmt
;
2551 let coe s = (s :> uioh
);;
2553 class listview ~zebra ~helpmode ~
(source
:lvsource
) ~trusted ~modehash
=
2555 val m_pan
= source#getpan
2556 val m_first
= source#getfirst
2557 val m_active
= source#getactive
2559 val m_prev_uioh
= state
.uioh
2561 method private elemunder
y =
2565 let n = y / (fstate
.fontsize
+1) in
2566 if m_first
+ n < source#getitemcount
2568 if source#hasaction
(m_first
+ n)
2569 then Some
(m_first
+ n)
2576 GlFunc.blend_func ~src
:`src_alpha ~dst
:`one_minus_src_alpha
;
2577 GlDraw.color (0., 0., 0.) ~alpha
:0.85;
2578 filledrect 0. 0. (float state
.winw
) (float state
.winh
);
2579 GlDraw.color (1., 1., 1.);
2580 Gl.enable `texture_2d
;
2581 let fs = fstate
.fontsize
in
2583 let hw = state
.winw
/3 in
2584 let ww = fstate
.wwidth
in
2585 let tabw = 17.0*.ww in
2586 let itemcount = source#getitemcount
in
2587 let minfo = source#getminfo
in
2591 GlMat.translate ~
x:(float conf
.scrollbw
) ();
2593 let x0 = 0.0 and x1 = float (state
.winw
- conf
.scrollbw
- 1) in
2595 if (row - m_first
) > fstate
.maxrows
2598 if row >= 0 && row < itemcount
2600 let (s, level
) = source#getitem
row in
2601 let y = (row - m_first
) * nfs in
2602 let x = 5.0 +. (float (level
+ m_pan
)) *. ww in
2605 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
2609 Gl.disable `texture_2d
;
2610 let alpha = if source#hasaction
row then 0.9 else 0.3 in
2611 GlDraw.color (1., 1., 1.) ~
alpha;
2612 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
2613 Gl.enable `texture_2d
;
2616 if zebra
&& row land 1 = 1
2620 GlDraw.color (c,c,c);
2621 let drawtabularstring s =
2623 let x'
= truncate
(x0 +. x) in
2624 let pos = nindex
s '
\000'
in
2626 then drawstring1 fs x'
(y+nfs) s
2628 let s1 = String.sub s 0 pos
2629 and s2
= String.sub s (pos+1) (String.length
s - pos - 1) in
2634 let s'
= withoutlastutf8
s in
2635 let s = s' ^
"@Uellipsis" in
2636 let w = measurestr
fs s in
2637 if float x'
+. w +. ww < float (hw + x'
)
2642 if float x'
+. ww +. measurestr
fs s1 > float (hw + x'
)
2646 ignore
(drawstring1 fs x'
(y+nfs) s1);
2647 drawstring1 fs (hw + x'
) (y+nfs) s2
2651 let x = if helpmode
&& row > 0 then x +. ww else x in
2652 let tabpos = nindex
s '
\t'
in
2655 let len = String.length
s - tabpos - 1 in
2656 let s1 = String.sub s 0 tabpos
2657 and s2
= String.sub s (tabpos + 1) len in
2658 let nx = drawstr x s1 in
2660 let x = x +. (max
tabw sw) in
2663 let len = String.length
s - 2 in
2664 if len > 0 && s.[0] = '
\xc2'
&& s.[1] = '
\xb7'
2666 let s = String.sub s 2 len in
2667 let x = if not helpmode
then x +. ww else x in
2668 GlDraw.color (1.2, 1.2, 1.2);
2669 let vinc = drawstring1 (fs+fs/4)
2670 (truncate
(x -. ww)) (y+nfs) s in
2671 GlDraw.color (1., 1., 1.);
2672 vinc +. (float fs *. 0.8)
2678 ignore
(drawtabularstring s);
2684 GlDraw.color (1.0, 1.0, 1.0) ~
alpha:0.5;
2687 if (row - m_first
) > fstate
.maxrows
2690 if row >= 0 && row < itemcount
2692 let (s, level
) = source#getitem
row in
2693 let pos0 = nindex
s '
\000'
in
2694 let y = (row - m_first
) * nfs in
2695 let x = float (level
+ m_pan
) *. ww in
2696 let (first
, last
) = minfo.(row) in
2698 if pos0 > 0 && first
> pos0
2699 then String.sub s (pos0+1) (first
-pos0-1)
2700 else String.sub s 0 first
2702 let suffix = String.sub s first
(last
- first
) in
2703 let w1 = measurestr fstate
.fontsize
prefix in
2704 let w2 = measurestr fstate
.fontsize
suffix in
2705 let x = x +. if conf
.leftscroll
then xadj else 5.0 in
2706 let x = if pos0 > 0 && first
> pos0 then x +. float hw else x in
2708 and y0 = float (y+2) in
2710 and y1 = float (y+fs+3) in
2711 filledrect x0 y0 x1 y1;
2716 Gl.disable `texture_2d
;
2717 if Array.length
minfo > 0 then loop m_first
;
2722 method updownlevel incr
=
2723 let len = source#getitemcount
in
2725 if m_active
>= 0 && m_active
< len
2726 then snd
(source#getitem m_active
)
2730 if i
= len then i
-1 else if i
= -1 then 0 else
2731 let _, l = source#getitem i
in
2732 if l != curlevel then i
else flow (i
+incr
)
2734 let active = flow m_active
in
2735 let first = calcfirst m_first
active in
2736 G.postRedisplay "outline updownlevel";
2737 {< m_active
= active; m_first
= first >}
2739 method private key1
key mask
=
2740 let set1 active first qsearch
=
2741 coe {< m_active
= active; m_first
= first; m_qsearch
= qsearch
>}
2743 let search active pattern incr
=
2744 let active = if active = -1 then m_first
else active in
2747 if n >= 0 && n < source#getitemcount
2749 let s, _ = source#getitem
n in
2750 match Str.search_forward re
s 0 with
2751 | (exception Not_found
) -> loop (n + incr
)
2758 let qpat = Str.quote pattern
in
2759 match Str.regexp_case_fold
qpat with
2762 adderrfmt "listview key1" "regexp_case_fold for `%S' failed: %S\n"
2763 qpat @@ Printexc.to_string exn
;
2766 let itemcount = source#getitemcount
in
2767 let find start incr
=
2769 if i
= -1 || i
= itemcount
2772 if source#hasaction i
2774 else find (i
+ incr
)
2779 let set active first =
2780 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2782 coe {< m_active
= active; m_first
= first; m_qsearch
= E.s >}
2785 let isvisible first n = n >= first && n - first <= fstate
.maxrows
in
2787 let incr1 = if incr
> 0 then 1 else -1 in
2788 if isvisible m_first m_active
2791 let next = m_active
+ incr
in
2793 if next < 0 || next >= itemcount
2795 else find next incr1
2797 if abs
(m_active
- next) > fstate
.maxrows
2803 let first = m_first
+ incr
in
2804 let first = bound
first 0 (itemcount - fstate
.maxrows
) in
2806 let next = m_active
+ incr
in
2807 let next = bound
next 0 (itemcount - 1) in
2814 if isvisible first next
2821 let first = min
next m_first
in
2823 if abs
(next - first) > fstate
.maxrows
2829 let first = m_first
+ incr
in
2830 let first = bound
first 0 (itemcount - 1) in
2832 let next = m_active
+ incr
in
2833 let next = bound
next 0 (itemcount - 1) in
2834 let next = find next incr1 in
2836 if next = -1 || abs
(m_active
- first) > fstate
.maxrows
2838 let active = if m_active
= -1 then next else m_active
in
2843 if isvisible first active
2849 G.postRedisplay "listview navigate";
2853 | (@r
|@s) when Wsi.withctrl mask
->
2854 let incr = if key = @r
then -1 else 1 in
2856 match search (m_active
+ incr) m_qsearch
incr with
2858 state
.text <- m_qsearch ^
" [not found]";
2861 state
.text <- m_qsearch
;
2862 active, firstof m_first
active
2864 G.postRedisplay "listview ctrl-r/s";
2865 set1 active first m_qsearch
;
2867 | @insert
when Wsi.withctrl mask
->
2868 if m_active
>= 0 && m_active
< source#getitemcount
2870 let s, _ = source#getitem m_active
in
2876 if emptystr m_qsearch
2879 let qsearch = withoutlastutf8 m_qsearch
in
2883 G.postRedisplay "listview empty qsearch";
2884 set1 m_active m_first
E.s;
2888 match search m_active
qsearch ~
-1 with
2890 state
.text <- qsearch ^
" [not found]";
2893 state
.text <- qsearch;
2894 active, firstof m_first
active
2896 G.postRedisplay "listview backspace qsearch";
2897 set1 active first qsearch
2900 | key when (key != 0 && not
(Wsi.isspecialkey
key)) ->
2901 let pattern = m_qsearch ^ toutf8
key in
2903 match search m_active
pattern 1 with
2905 state
.text <- pattern ^
" [not found]";
2908 state
.text <- pattern;
2909 active, firstof m_first
active
2911 G.postRedisplay "listview qsearch add";
2912 set1 active first pattern;
2916 if emptystr m_qsearch
2918 G.postRedisplay "list view escape";
2919 let mx, my
= state
.mpos
in
2923 source#exit ~uioh
:(coe self
)
2924 ~cancel
:true ~
active:m_active ~
first:m_first ~pan
:m_pan
2926 | None
-> m_prev_uioh
2931 G.postRedisplay "list view kill qsearch";
2932 coe {< m_qsearch
= E.s >}
2935 | @enter
| @kpenter
->
2937 let self = {< m_qsearch
= E.s >} in
2939 G.postRedisplay "listview enter";
2940 if m_active
>= 0 && m_active
< source#getitemcount
2942 source#exit ~uioh
:(coe self) ~cancel
:false
2943 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2946 source#exit ~uioh
:(coe self) ~cancel
:true
2947 ~
active:m_active ~
first:m_first ~pan
:m_pan
;
2950 begin match opt with
2951 | None
-> m_prev_uioh
2955 | @delete
| @kpdelete
->
2958 | @up
| @kpup
-> navigate ~
-1
2959 | @down
| @kpdown
-> navigate 1
2960 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows
)
2961 | @next | @kpnext
-> navigate fstate
.maxrows
2963 | @right
| @kpright
->
2965 G.postRedisplay "listview right";
2966 coe {< m_pan
= m_pan
- 1 >}
2968 | @left | @kpleft
->
2970 G.postRedisplay "listview left";
2971 coe {< m_pan
= m_pan
+ 1 >}
2973 | @home
| @kphome
->
2974 let active = find 0 1 in
2975 G.postRedisplay "listview home";
2979 let first = max
0 (itemcount - fstate
.maxrows
) in
2980 let active = find (itemcount - 1) ~
-1 in
2981 G.postRedisplay "listview end";
2984 | key when (key = 0 || Wsi.isspecialkey
key) ->
2988 dolog
"listview unknown key %#x" key; coe self
2990 method key key mask
=
2991 match state
.mode
with
2992 | Textentry te
-> textentrykeyboard key mask te
; coe self
2995 | LinkNav
_ -> self#key1
key mask
2997 method button button down
x y _ =
3000 | 1 when vscrollhit x ->
3001 G.postRedisplay "listview scroll";
3004 let _, position, sh = self#
scrollph in
3005 if y > truncate
position && y < truncate
(position +. sh)
3007 state
.mstate
<- Mscrolly
;
3011 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3012 let first = truncate
(s *. float source#getitemcount
) in
3013 let first = min source#getitemcount
first in
3014 Some
(coe {< m_first
= first; m_active
= first >})
3016 state
.mstate
<- Mnone
;
3020 begin match self#elemunder
y with
3022 G.postRedisplay "listview click";
3023 source#exit ~uioh
:(coe {< m_active
= n >})
3024 ~cancel
:false ~
active:n ~
first:m_first ~pan
:m_pan
3028 | n when (n == 4 || n == 5) && not down
->
3029 let len = source#getitemcount
in
3031 if n = 5 && m_first
+ fstate
.maxrows
>= len
3035 let first = m_first
+ (if n == 4 then -1 else 1) in
3036 bound
first 0 (len - 1)
3038 G.postRedisplay "listview wheel";
3039 Some
(coe {< m_first
= first >})
3040 | n when (n = 6 || n = 7) && not down
->
3041 let inc = if n = 7 then -1 else 1 in
3042 G.postRedisplay "listview hwheel";
3043 Some
(coe {< m_pan
= m_pan
+ inc >})
3048 | None
-> m_prev_uioh
3051 method multiclick
_ x y = self#button
1 true x y
3054 match state
.mstate
with
3056 let s = float (max
0 (y - conf
.scrollh
)) /. float state
.winh
in
3057 let first = truncate
(s *. float source#getitemcount
) in
3058 let first = min source#getitemcount
first in
3059 G.postRedisplay "listview motion";
3060 coe {< m_first
= first; m_active
= first >}
3068 method pmotion
x y =
3069 if x < state
.winw
- conf
.scrollbw
3072 match self#elemunder
y with
3073 | None
-> Wsi.setcursor
Wsi.CURSOR_INHERIT
; m_active
3074 | Some
n -> Wsi.setcursor
Wsi.CURSOR_INFO
; n
3078 then (G.postRedisplay "listview pmotion"; {< m_active
= n >})
3083 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
3087 method infochanged
_ = ()
3089 method scrollpw
= (0, 0.0, 0.0)
3091 let nfs = fstate
.fontsize
+ 1 in
3092 let y = m_first
* nfs in
3093 let itemcount = source#getitemcount
in
3094 let maxi = max
0 (itemcount - fstate
.maxrows
) in
3095 let maxy = maxi * nfs in
3096 let p, h = scrollph y maxy in
3099 method modehash
= modehash
3100 method eformsgs
= false
3101 method alwaysscrolly
= true
3104 class outlinelistview ~zebra ~source
=
3105 let settext autonarrow
s =
3108 let ss = source#statestr
in
3112 else "{" ^
ss ^
"} [" ^
s ^
"]"
3113 else state
.text <- s
3119 ~source
:(source
:> lvsource
)
3121 ~modehash
:(findkeyhash conf
"outline")
3124 val m_autonarrow
= false
3126 method! key key mask
=
3128 if emptystr state
.text
3130 else fstate
.maxrows - 2
3132 let calcfirst first active =
3135 let rows = active - first in
3136 if rows > maxrows then active - maxrows else first
3140 let active = m_active
+ incr in
3141 let active = bound
active 0 (source#getitemcount
- 1) in
3142 let first = calcfirst m_first
active in
3143 G.postRedisplay "outline navigate";
3144 coe {< m_active
= active; m_first
= first >}
3146 let navscroll first =
3148 let dist = m_active
- first in
3154 else first + maxrows
3157 G.postRedisplay "outline navscroll";
3158 coe {< m_first
= first; m_active
= active >}
3160 let ctrl = Wsi.withctrl mask
in
3165 then (source#denarrow
; E.s)
3167 let pattern = source#renarrow
in
3168 if nonemptystr m_qsearch
3169 then (source#narrow m_qsearch
; m_qsearch
)
3173 settext (not m_autonarrow
) text;
3174 G.postRedisplay "toggle auto narrowing";
3175 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= not m_autonarrow
>}
3177 | @slash
when emptystr m_qsearch
&& not m_autonarrow
->
3179 G.postRedisplay "toggle auto narrowing";
3180 coe {< m_first
= 0; m_active
= 0; m_autonarrow
= true >}
3183 source#narrow m_qsearch
;
3185 then source#add_narrow_pattern m_qsearch
;
3186 G.postRedisplay "outline ctrl-n";
3187 coe {< m_first
= 0; m_active
= 0 >}
3190 let active = source#calcactive
(getanchor
()) in
3191 let first = firstof m_first
active in
3192 G.postRedisplay "outline ctrl-s";
3193 coe {< m_first
= first; m_active
= active >}
3196 G.postRedisplay "outline ctrl-u";
3197 if m_autonarrow
&& nonemptystr m_qsearch
3199 ignore
(source#renarrow
);
3200 settext m_autonarrow
E.s;
3201 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3204 source#del_narrow_pattern
;
3205 let pattern = source#renarrow
in
3207 if emptystr
pattern then E.s else "Narrowed to " ^
pattern
3209 settext m_autonarrow
text;
3210 coe {< m_first
= 0; m_active
= 0; m_qsearch
= E.s >}
3214 let first = max
0 (m_active
- (fstate
.maxrows / 2)) in
3215 G.postRedisplay "outline ctrl-l";
3216 coe {< m_first
= first >}
3218 | @tab
when m_autonarrow
->
3219 if nonemptystr m_qsearch
3221 G.postRedisplay "outline list view tab";
3222 source#add_narrow_pattern m_qsearch
;
3224 coe {< m_qsearch
= E.s >}
3228 | @escape
when m_autonarrow
->
3229 if nonemptystr m_qsearch
3230 then source#add_narrow_pattern m_qsearch
;
3233 | @enter
| @kpenter
when m_autonarrow
->
3234 if nonemptystr m_qsearch
3235 then source#add_narrow_pattern m_qsearch
;
3238 | key when m_autonarrow
&& (not
(Wsi.isspecialkey
key)) ->
3239 let pattern = m_qsearch ^ toutf8
key in
3240 G.postRedisplay "outlinelistview autonarrow add";
3241 source#narrow
pattern;
3242 settext true pattern;
3243 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3245 | key when m_autonarrow
&& key = @backspace
->
3246 if emptystr m_qsearch
3249 let pattern = withoutlastutf8 m_qsearch
in
3250 G.postRedisplay "outlinelistview autonarrow backspace";
3251 ignore
(source#renarrow
);
3252 source#narrow
pattern;
3253 settext true pattern;
3254 coe {< m_first
= 0; m_active
= 0; m_qsearch
= pattern >}
3256 | @up
| @kpup
when ctrl ->
3257 navscroll (max
0 (m_first
- 1))
3259 | @down
| @kpdown
when ctrl ->
3260 navscroll (min
(source#getitemcount
- 1) (m_first
+ 1))
3262 | @up
| @kpup
-> navigate ~
-1
3263 | @down
| @kpdown
-> navigate 1
3264 | @prior
| @kpprior
-> navigate ~
-(fstate
.maxrows)
3265 | @next | @kpnext
-> navigate fstate
.maxrows
3267 | @right
| @kpright
->
3271 G.postRedisplay "outline ctrl right";
3272 {< m_pan
= m_pan
+ 1 >}
3274 else self#updownlevel
1
3278 | @left | @kpleft
->
3282 G.postRedisplay "outline ctrl left";
3283 {< m_pan
= m_pan
- 1 >}
3285 else self#updownlevel ~
-1
3289 | @home
| @kphome
->
3290 G.postRedisplay "outline home";
3291 coe {< m_first
= 0; m_active
= 0 >}
3294 let active = source#getitemcount
- 1 in
3295 let first = max
0 (active - fstate
.maxrows) in
3296 G.postRedisplay "outline end";
3297 coe {< m_active
= active; m_first
= first >}
3299 | _ -> super#
key key mask
3302 let genhistoutlines () =
3304 |> List.sort
(fun (_, c1
, _, _, _, _) (_, c2
, _, _, _, _) ->
3305 compare c2
.lastvisit c1
.lastvisit
)
3307 (fun ((path
, c, _, _, _, origin
) as hist
) ->
3308 let path = if nonemptystr origin
then origin
else path in
3309 let base = mbtoutf8
@@ Filename.basename
path in
3310 (base ^
"\000" ^
c.title
, 1, Ohistory hist
)
3315 let gotohist (path, c, bookmarks
, x, anchor, origin
) =
3316 Config.save
leavebirdseye;
3317 state
.anchor <- anchor;
3318 state
.bookmarks
<- bookmarks
;
3319 state
.origin
<- origin
;
3322 let x0, y0, x1, y1 = conf
.trimfuzz
in
3323 wcmd "trimset %d %d %d %d %d" (btod conf
.trimmargins
) x0 y0 x1 y1;
3324 reshape ~firsttime
:true state
.winw state
.winh
;
3325 opendoc path origin
;
3329 let makecheckers () =
3330 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3332 converted by Issac Trotts. July 25, 2002 *)
3333 let image = GlPix.create `ubyte ~format
:`luminance ~width
:2 ~height
:2 in
3334 Raw.sets_string
(GlPix.to_raw
image) ~
pos:0 "\255\200\200\255";
3335 let id = GlTex.gen_texture
() in
3336 GlTex.bind_texture ~target
:`texture_2d
id;
3337 GlPix.store
(`unpack_alignment
1);
3338 GlTex.image2d
image;
3339 List.iter
(GlTex.parameter ~target
:`texture_2d
)
3340 [ `mag_filter `nearest
; `min_filter `nearest
];
3344 let setcheckers enabled
=
3345 match state
.checkerstexid
with
3347 if enabled
then state
.checkerstexid
<- Some
(makecheckers ())
3349 | Some checkerstexid
->
3352 GlTex.delete_texture checkerstexid
;
3353 state
.checkerstexid
<- None
;
3357 let describe_location () =
3358 let fn = page_of_y state
.y in
3359 let ln = page_of_y
(state
.y + state
.winh
- 1) in
3360 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
3364 else (100. *. (float state
.y /. float maxy))
3368 Printf.sprintf
"page %d of %d [%.2f%%]"
3369 (fn+1) state
.pagecount
percent
3372 "pages %d-%d of %d [%.2f%%]"
3373 (fn+1) (ln+1) state
.pagecount
percent
3376 let setpresentationmode v
=
3377 let n = page_of_y state
.y in
3378 state
.anchor <- (n, 0.0, 1.0);
3379 conf
.presentation
<- v
;
3380 if conf
.fitmodel
= FitPage
3381 then reqlayout conf
.angle conf
.fitmodel
;
3385 let setbgcol (r
, g, b) =
3387 let r = r *. 255.0 |> truncate
3388 and g = g *. 255.0 |> truncate
3389 and b = b *. 255.0 |> truncate
in
3390 r lsl 16 |> (lor) (g lsl 8) |> (lor) b
3392 Wsi.setwinbgcol
col;
3396 let btos b = if b then "@Uradical" else E.s in
3397 let showextended = ref false in
3398 let leave mode
_ = state
.mode
<- mode
in
3401 val mutable m_l
= []
3402 val mutable m_a
= E.a
3403 val mutable m_prev_uioh
= nouioh
3404 val mutable m_prev_mode
= View
3406 inherit lvsourcebase
3408 method reset prev_mode prev_uioh
=
3409 m_a
<- Array.of_list
(List.rev m_l
);
3411 m_prev_mode
<- prev_mode
;
3412 m_prev_uioh
<- prev_uioh
;
3414 method int name get
set =
3420 try set (int_of_string
s)
3422 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3426 let te = name ^
": ", E.s, None
, intentry, ondone, true in
3427 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3431 method int_with_suffix name get
set =
3433 (name
, `intws get
, 1,
3437 try set (int_of_string_with_suffix
s)
3439 state
.text <- Printf.sprintf
"bad integer `%s': %s"
3444 name ^
": ", E.s, None
, intentry_with_suffix, ondone, true
3446 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3450 method bool ?
(offset
=1) ?
(btos=btos) name get
set =
3452 (name
, `
bool (btos, get
), offset
, Action
(
3459 method color name get
set =
3461 (name
, `
color get
, 1,
3464 let invalid = (nan
, nan
, nan
) in
3467 try color_of_string
s
3469 state
.text <- Printf.sprintf
"bad color `%s': %s"
3476 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3477 state
.text <- color_to_string
(get
());
3478 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3482 method string name get
set =
3484 (name
, `
string get
, 1,
3487 let ondone s = set s in
3488 let te = name ^
": ", E.s, None
, textentry, ondone, true in
3489 state
.mode
<- Textentry
(te, leave m_prev_mode
);
3493 method colorspace name get
set =
3495 (name
, `
string get
, 1,
3500 inherit lvsourcebase
3503 m_active
<- CSTE.to_int conf
.colorspace
;
3506 method getitemcount
=
3507 Array.length
CSTE.names
3510 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3511 ignore
(uioh
, first, pan
);
3512 if not cancel
then set active;
3514 method hasaction
_ = true
3518 let modehash = findkeyhash conf
"info" in
3519 coe (new listview ~zebra
:false ~helpmode
:false
3520 ~
source ~trusted
:true ~
modehash)
3523 method paxmark name get
set =
3525 (name
, `
string get
, 1,
3530 inherit lvsourcebase
3533 m_active
<- MTE.to_int conf
.paxmark
;
3536 method getitemcount
= Array.length
MTE.names
3537 method getitem
n = (MTE.names
.(n), 0)
3538 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3539 ignore
(uioh
, first, pan
);
3540 if not cancel
then set active;
3542 method hasaction
_ = true
3546 let modehash = findkeyhash conf
"info" in
3547 coe (new listview ~zebra
:false ~helpmode
:false
3548 ~
source ~trusted
:true ~
modehash)
3551 method fitmodel name get
set =
3553 (name
, `
string get
, 1,
3558 inherit lvsourcebase
3561 m_active
<- FMTE.to_int conf
.fitmodel
;
3564 method getitemcount
= Array.length
FMTE.names
3565 method getitem
n = (FMTE.names
.(n), 0)
3566 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3567 ignore
(uioh
, first, pan
);
3568 if not cancel
then set active;
3570 method hasaction
_ = true
3574 let modehash = findkeyhash conf
"info" in
3575 coe (new listview ~zebra
:false ~helpmode
:false
3576 ~
source ~trusted
:true ~
modehash)
3579 method caption
s offset
=
3580 m_l
<- (s, `empty
, offset
, Noaction
) :: m_l
3582 method caption2
s f offset
=
3583 m_l
<- (s, `
string f, offset
, Noaction
) :: m_l
3585 method getitemcount
= Array.length m_a
3588 let tostr = function
3589 | `
int f -> string_of_int
(f ())
3590 | `intws
f -> string_with_suffix_of_int
(f ())
3592 | `
color f -> color_to_string
(f ())
3593 | `
bool (btos, f) -> btos (f ())
3596 let name, t
, offset
, _ = m_a
.(n) in
3597 ((let s = tostr t
in
3599 then Printf.sprintf
"%s\t%s" name s
3603 method exit ~uioh ~cancel ~
active ~
first ~pan
=
3608 match m_a
.(active) with
3609 | _, _, _, Action
f -> f uioh
3610 | _, _, _, Noaction
-> uioh
3621 method hasaction
n =
3623 | _, _, _, Action
_ -> true
3624 | _, _, _, Noaction
-> false
3626 initializer m_active
<- 1
3629 let rec fillsrc prevmode prevuioh
=
3630 let sep () = src#caption
E.s 0 in
3631 let colorp name get
set =
3633 (fun () -> color_to_string
(get
()))
3636 let c = color_of_string
v in
3640 Printf.sprintf
"bad color `%s': %s" v @@ exntos exn
3643 let oldmode = state
.mode
in
3644 let birdseye = isbirdseye state
.mode
in
3646 src#caption
(if birdseye then "Setup (Bird's eye)" else "Setup") 0;
3648 src#
bool "presentation mode"
3649 (fun () -> conf
.presentation
)
3650 (fun v -> setpresentationmode v);
3652 src#
bool "ignore case in searches"
3653 (fun () -> conf
.icase
)
3654 (fun v -> conf
.icase
<- v);
3657 (fun () -> conf
.preload)
3658 (fun v -> conf
.preload <- v);
3660 src#
bool "highlight links"
3661 (fun () -> conf
.hlinks
)
3662 (fun v -> conf
.hlinks
<- v);
3664 src#
bool "under info"
3665 (fun () -> conf
.underinfo
)
3666 (fun v -> conf
.underinfo
<- v);
3668 src#
bool "persistent bookmarks"
3669 (fun () -> conf
.savebmarks
)
3670 (fun v -> conf
.savebmarks
<- v);
3672 src#fitmodel
"fit model"
3673 (fun () -> FMTE.to_string conf
.fitmodel
)
3674 (fun v -> reqlayout conf
.angle
(FMTE.of_int
v));
3676 src#
bool "trim margins"
3677 (fun () -> conf
.trimmargins
)
3678 (fun v -> settrim v conf
.trimfuzz
; fillsrc prevmode prevuioh
);
3680 src#
bool "persistent location"
3681 (fun () -> conf
.jumpback
)
3682 (fun v -> conf
.jumpback
<- v);
3685 src#
int "inter-page space"
3686 (fun () -> conf
.interpagespace
)
3688 conf
.interpagespace
<- n;
3689 docolumns conf
.columns
;
3691 match state
.layout with
3696 state
.maxy <- calcheight
();
3697 let y = getpagey
pageno in
3698 gotoxy state
.x (y + py)
3702 (fun () -> conf
.pagebias
)
3703 (fun v -> conf
.pagebias
<- v);
3705 src#
int "scroll step"
3706 (fun () -> conf
.scrollstep
)
3707 (fun n -> conf
.scrollstep
<- n);
3709 src#
int "horizontal scroll step"
3710 (fun () -> conf
.hscrollstep
)
3711 (fun v -> conf
.hscrollstep
<- v);
3713 src#
int "auto scroll step"
3715 match state
.autoscroll
with
3717 | _ -> conf
.autoscrollstep
)
3719 let n = boundastep state
.winh
n in
3720 if state
.autoscroll
<> None
3721 then state
.autoscroll
<- Some
n;
3722 conf
.autoscrollstep
<- n);
3725 (fun () -> truncate
(conf
.zoom *. 100.))
3726 (fun v -> pivotzoom ((float v) /. 100.));
3729 (fun () -> conf
.angle
)
3730 (fun v -> reqlayout v conf
.fitmodel
);
3732 src#
int "scroll bar width"
3733 (fun () -> conf
.scrollbw
)
3736 reshape state
.winw state
.winh
;
3739 src#
int "scroll handle height"
3740 (fun () -> conf
.scrollh
)
3741 (fun v -> conf
.scrollh
<- v;);
3743 src#
int "thumbnail width"
3744 (fun () -> conf
.thumbw
)
3746 conf
.thumbw
<- min
4096 v;
3749 leavebirdseye beye
false;
3756 let mode = state
.mode in
3757 src#
string "columns"
3759 match conf
.columns
with
3761 | Cmulti
(multi
, _) -> multicolumns_to_string multi
3762 | Csplit
(count
, _) -> "-" ^ string_of_int count
3765 let n, a, b = multicolumns_of_string
v in
3766 setcolumns mode n a b);
3769 src#caption
"Pixmap cache" 0;
3770 src#int_with_suffix
"size (advisory)"
3771 (fun () -> conf
.memlimit
)
3772 (fun v -> conf
.memlimit
<- v);
3776 Printf.sprintf
"%s bytes, %d tiles"
3777 (string_with_suffix_of_int state
.memused
)
3778 (Hashtbl.length state
.tilemap
)) 1;
3781 src#caption
"Layout" 0;
3782 src#caption2
"Dimension"
3784 Printf.sprintf
"%dx%d (virtual %dx%d)"
3785 state
.winw state
.winh
3790 src#caption2
"Position" (fun () ->
3791 Printf.sprintf
"%dx%d" state
.x state
.y
3794 src#caption2
"Position" (fun () -> describe_location ()) 1
3798 src#
bool ~offset
:0 ~
btos:(fun v -> if v then "(on)" else "(off)")
3799 "Save these parameters as global defaults at exit"
3800 (fun () -> conf
.bedefault
)
3801 (fun v -> conf
.bedefault
<- v)
3805 let btos b = if b then "@Ulguillemet" else "@Urguillemet" in
3806 src#
bool ~offset
:0 ~
btos "Extended parameters"
3807 (fun () -> !showextended)
3808 (fun v -> showextended := v; fillsrc prevmode prevuioh
);
3812 (fun () -> conf
.checkers
)
3813 (fun v -> conf
.checkers
<- v; setcheckers v);
3814 src#
bool "update cursor"
3815 (fun () -> conf
.updatecurs
)
3816 (fun v -> conf
.updatecurs
<- v);
3817 src#
bool "scroll-bar on the left"
3818 (fun () -> conf
.leftscroll
)
3819 (fun v -> conf
.leftscroll
<- v);
3821 (fun () -> conf
.verbose
)
3822 (fun v -> conf
.verbose
<- v);
3823 src#
bool "invert colors"
3824 (fun () -> conf
.invert
)
3825 (fun v -> conf
.invert
<- v);
3827 (fun () -> conf
.maxhfit
)
3828 (fun v -> conf
.maxhfit
<- v);
3830 (fun () -> conf
.pax
!= None
)
3833 then conf
.pax
<- Some
(ref (now
(), 0, 0))
3834 else conf
.pax
<- None
);
3835 src#
string "uri launcher"
3836 (fun () -> conf
.urilauncher
)
3837 (fun v -> conf
.urilauncher
<- v);
3838 src#
string "path launcher"
3839 (fun () -> conf
.pathlauncher
)
3840 (fun v -> conf
.pathlauncher
<- v);
3841 src#
string "tile size"
3842 (fun () -> Printf.sprintf
"%dx%d" conf
.tilew conf
.tileh
)
3845 let w, h = Scanf.sscanf
v "%dx%d" (fun w h -> w, h) in
3846 conf
.tilew
<- max
64 w;
3847 conf
.tileh
<- max
64 h;
3850 state
.text <- Printf.sprintf
"bad tile size `%s': %s"
3853 src#
int "texture count"
3854 (fun () -> conf
.texcount
)
3857 then conf
.texcount
<- v
3858 else impmsg "failed to set texture count please retry later"
3860 src#
int "slice height"
3861 (fun () -> conf
.sliceheight
)
3863 conf
.sliceheight
<- v;
3864 wcmd "sliceh %d" conf
.sliceheight
;
3866 src#
int "anti-aliasing level"
3867 (fun () -> conf
.aalevel
)
3869 conf
.aalevel
<- bound
v 0 8;
3870 state
.anchor <- getanchor
();
3871 opendoc state
.path state
.password;
3873 src#
string "page scroll scaling factor"
3874 (fun () -> string_of_float conf
.pgscale)
3877 let s = float_of_string
v in
3880 state
.text <- Printf.sprintf
3881 "bad page scroll scaling factor `%s': %s" v
3885 src#
int "ui font size"
3886 (fun () -> fstate
.fontsize
)
3887 (fun v -> setfontsize (bound
v 5 100));
3888 src#
int "hint font size"
3889 (fun () -> conf
.hfsize
)
3890 (fun v -> conf
.hfsize
<- bound
v 5 100);
3891 colorp "background color"
3892 (fun () -> conf
.bgcolor
)
3893 (fun v -> conf
.bgcolor
<- v; setbgcol v);
3894 src#
bool "crop hack"
3895 (fun () -> conf
.crophack
)
3896 (fun v -> conf
.crophack
<- v);
3897 src#
string "trim fuzz"
3898 (fun () -> irect_to_string conf
.trimfuzz
)
3901 conf
.trimfuzz
<- irect_of_string
v;
3903 then settrim true conf
.trimfuzz
;
3905 state
.text <- Printf.sprintf
"bad irect `%s': %s" v
3908 src#
string "throttle"
3910 match conf
.maxwait
with
3911 | None
-> "show place holder if page is not ready"
3914 then "wait for page to fully render"
3916 "wait " ^ string_of_float
time
3917 ^
" seconds before showing placeholder"
3921 let f = float_of_string
v in
3923 then conf
.maxwait
<- None
3924 else conf
.maxwait
<- Some
f
3926 state
.text <- Printf.sprintf
"bad time `%s': %s" v
3929 src#
string "ghyll scroll"
3931 match conf
.ghyllscroll
with
3933 | Some nab
-> ghyllscroll_to_string nab
3936 try conf
.ghyllscroll
<- ghyllscroll_of_string
v
3939 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v msg
3941 state
.text <- Printf.sprintf
"bad ghyll `%s': %s" v
3944 src#
string "selection command"
3945 (fun () -> conf
.selcmd
)
3946 (fun v -> conf
.selcmd
<- v);
3947 src#
string "synctex command"
3948 (fun () -> conf
.stcmd
)
3949 (fun v -> conf
.stcmd
<- v);
3950 src#
string "pax command"
3951 (fun () -> conf
.paxcmd
)
3952 (fun v -> conf
.paxcmd
<- v);
3953 src#
string "ask password command"
3954 (fun () -> conf
.passcmd)
3955 (fun v -> conf
.passcmd <- v);
3956 src#
string "save path command"
3957 (fun () -> conf
.savecmd
)
3958 (fun v -> conf
.savecmd
<- v);
3959 src#colorspace
"color space"
3960 (fun () -> CSTE.to_string conf
.colorspace
)
3962 conf
.colorspace
<- CSTE.of_int
v;
3966 src#paxmark
"pax mark method"
3967 (fun () -> MTE.to_string conf
.paxmark
)
3968 (fun v -> conf
.paxmark
<- MTE.of_int
v);
3969 if bousable
() && !opengl_has_pbo
3972 (fun () -> conf
.usepbo
)
3973 (fun v -> conf
.usepbo
<- v);
3974 src#
bool "mouse wheel scrolls pages"
3975 (fun () -> conf
.wheelbypage
)
3976 (fun v -> conf
.wheelbypage
<- v);
3977 src#
bool "open remote links in a new instance"
3978 (fun () -> conf
.riani
)
3979 (fun v -> conf
.riani
<- v);
3980 src#
bool "edit annotations inline"
3981 (fun () -> conf
.annotinline
)
3982 (fun v -> conf
.annotinline
<- v);
3983 src#
bool "coarse positioning in presentation mode"
3984 (fun () -> conf
.coarseprespos
)
3985 (fun v -> conf
.coarseprespos
<- v);
3986 src#
bool "use document css"
3987 (fun () -> conf
.usedoccss
)
3988 (fun v -> conf
.usedoccss
<- v)
3992 src#caption
"Document" 0;
3993 List.iter
(fun (_, s) -> src#caption
s 1) state
.docinfo
;
3994 src#caption2
"Pages"
3995 (fun () -> string_of_int state
.pagecount
) 1;
3996 src#caption2
"Dimensions"
3997 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
3998 if nonemptystr conf
.css
3999 then src#caption2
"CSS" (fun () -> conf
.css
) 1;
4003 src#caption
"Trimmed margins" 0;
4004 src#caption2
"Dimensions"
4005 (fun () -> string_of_int
(List.length state
.pdims
)) 1;
4009 src#caption
"OpenGL" 0;
4010 src#caption
(Printf.sprintf
"Vendor\t%s" (GlMisc.get_string `vendor
)) 1;
4011 src#caption
(Printf.sprintf
"Renderer\t%s" (GlMisc.get_string `renderer
)) 1;
4014 src#caption
"Location" 0;
4015 if nonemptystr state
.origin
4016 then src#caption
("Orign\t" ^ mbtoutf8 state
.origin
) 1;
4017 src#caption
("Path\t" ^ mbtoutf8 state
.path) 1;
4019 src#reset prevmode prevuioh
;
4024 let prevmode = state
.mode
4025 and prevuioh
= state
.uioh in
4026 fillsrc prevmode prevuioh
;
4027 let source = (src :> lvsource
) in
4028 let modehash = findkeyhash conf
"info" in
4031 inherit listview ~zebra
:false ~helpmode
:false
4032 ~
source ~trusted
:true ~
modehash as super
4033 val mutable m_prevmemused
= 0
4034 method! infochanged
= function
4036 if m_prevmemused
!= state
.memused
4038 m_prevmemused
<- state
.memused
;
4039 G.postRedisplay "memusedchanged";
4041 | Pdim
-> G.postRedisplay "pdimchanged"
4042 | Docinfo
-> fillsrc prevmode prevuioh
4044 method! key key mask
=
4045 if not
(Wsi.withctrl mask
)
4048 | @left | @kpleft
-> coe (self#updownlevel ~
-1)
4049 | @right
| @kpright
-> coe (self#updownlevel
1)
4050 | _ -> super#
key key mask
4051 else super#
key key mask
4053 G.postRedisplay "info";
4059 inherit lvsourcebase
4060 method getitemcount
= Array.length state
.help
4062 let s, l, _ = state
.help
.(n) in
4065 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4069 match state
.help
.(active) with
4070 | _, _, Action
f -> Some
(f uioh)
4071 | _, _, Noaction
-> Some
uioh
4080 method hasaction
n =
4081 match state
.help
.(n) with
4082 | _, _, Action
_ -> true
4083 | _, _, Noaction
-> false
4089 let modehash = findkeyhash conf
"help" in
4091 state
.uioh <- coe (new listview
4092 ~zebra
:false ~helpmode
:true
4093 ~
source ~trusted
:true ~
modehash);
4094 G.postRedisplay "help";
4100 inherit lvsourcebase
4101 val mutable m_items
= E.a
4103 method getitemcount
= 1 + Array.length m_items
4108 else m_items
.(n-1), 0
4110 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4115 then Buffer.clear state
.errmsgs
;
4122 method hasaction
n =
4126 state
.newerrmsgs
<- false;
4127 let l = Str.split newlinere
(Buffer.contents state
.errmsgs
) in
4128 m_items
<- Array.of_list
l
4137 let source = (msgsource :> lvsource
) in
4138 let modehash = findkeyhash conf
"listview" in
4141 inherit listview ~zebra
:false ~helpmode
:false
4142 ~
source ~trusted
:false ~
modehash as super
4145 then msgsource#reset
;
4148 G.postRedisplay "msgs";
4152 let editor = getenvwithdef
"EDITOR" E.s in
4156 let tmppath = Filename.temp_file
"llpp" "note" in
4159 let oc = open_out
tmppath in
4163 let execstr = editor ^
" " ^
tmppath in
4165 match spawn
execstr [] with
4166 | (exception exn
) ->
4167 impmsg "spawn(%S) failed: %s" execstr @@ exntos exn
;
4170 match Unix.waitpid
[] pid with
4171 | (exception exn
) ->
4172 impmsg "waitpid(%d) failed: %s" pid @@ exntos exn
;
4176 | Unix.WEXITED
0 -> filecontents
tmppath
4178 impmsg "editor process(%s) exited abnormally: %d" execstr n;
4180 | Unix.WSIGNALED
n ->
4181 impmsg "editor process(%s) was killed by signal %d" execstr n;
4183 | Unix.WSTOPPED
n ->
4184 impmsg "editor(%s) process was stopped by signal %d" execstr n;
4187 match Unix.unlink
tmppath with
4188 | (exception exn
) ->
4189 impmsg "failed to ulink %S: %s" tmppath @@ exntos exn
;
4194 let enterannotmode opaque slinkindex
=
4197 inherit lvsourcebase
4198 val mutable m_text
= E.s
4199 val mutable m_items
= E.a
4201 method getitemcount
= Array.length m_items
4204 let label, _func
= m_items
.(n) in
4207 method exit ~
uioh ~cancel ~
active ~
first ~pan
=
4208 ignore
(uioh, first, pan
);
4211 let _label, func
= m_items
.(active) in
4216 method hasaction
n = nonemptystr
@@ fst m_items
.(n)
4219 let rec split accu b i
=
4221 if p = String.length
s
4222 then (String.sub s b (p-b), unit) :: accu
4224 if (i
> 70 && s.[p] = ' '
) || s.[p] = '
\r'
|| s.[p] = '
\n'
4226 let ss = if i
= 0 then E.s else String.sub s b i
in
4227 split ((ss, unit)::accu) (p+1) 0
4232 wcmd "freepage %s" (~
> opaque);
4234 Hashtbl.fold (fun key opaque'
accu ->
4235 if opaque'
= opaque'
4236 then key :: accu else accu) state
.pagemap
[]
4238 List.iter
(Hashtbl.remove state
.pagemap
) keys;
4240 gotoxy state
.x state
.y
4243 delannot
opaque slinkindex
;
4246 let edit inline
() =
4251 modannot
opaque slinkindex
s;
4257 let mode = state
.mode in
4260 ("annotation: ", m_text
, None
, textentry, update, true),
4261 fun _ -> state
.mode <- mode);
4265 let s = getusertext m_text
in
4270 ( "[Copy]", fun () -> selstring m_text
)
4271 :: ("[Delete]", dele)
4272 :: ("[Edit]", edit conf
.annotinline
)
4274 :: split [] 0 0 |> List.rev
|> Array.of_list
4281 let s = getannotcontents
opaque slinkindex
in
4284 let source = (msgsource :> lvsource
) in
4285 let modehash = findkeyhash conf
"listview" in
4286 state
.uioh <- coe (object
4287 inherit listview ~zebra
:false ~helpmode
:false
4288 ~
source ~trusted
:false ~
modehash
4290 G.postRedisplay "enterannotmode";
4293 let gotoremote spec
=
4294 let filename, dest
= splitatchar spec '#'
in
4295 let getpath filename =
4297 if nonemptystr
filename
4299 if Filename.is_relative
filename
4301 let dir = Filename.dirname state
.path in
4303 if Filename.is_implicit
dir
4304 then Filename.concat
(Sys.getcwd
()) dir
4307 Filename.concat
dir filename
4311 if Sys.file_exists
path
4315 let path = getpath filename in
4319 let cmd = Lazy.force_val lcmd
in
4320 match spawn
cmd with
4322 | (exception exn
) ->
4323 dolog
"failed to execute `%s': %s" cmd @@ exntos exn
4325 let anchor = getanchor
() in
4326 let ranchor = state
.path, state
.password, anchor, state
.origin
in
4327 state
.origin
<- E.s;
4328 state
.ranchors
<- ranchor :: state
.ranchors
;
4331 if substratis spec
0 "page="
4333 match Scanf.sscanf spec
"page=%d" (fun n -> n) with
4335 state
.anchor <- (pageno, 0.0, 0.0);
4336 dospawn @@ lazy (Printf.sprintf
"%s -page %d %S" !selfexec pageno path);
4338 adderrfmt "error parsing remote destination" "page: %s" @@ exntos exn
4340 state
.nameddest
<- dest
;
4341 dospawn @@ lazy (!selfexec ^
" " ^
path ^
" -dest " ^ dest
)
4345 let gotounder = function
4346 | Ulinkuri
s when isexternallink
s ->
4347 if substratis
s 0 "file://"
4348 then gotoremote @@ String.sub s 7 (String.length
s - 7)
4351 let pageno, x, y = uritolocation
s in
4353 gotopagexy !wtmode pageno x y
4354 | Utext
_ | Unone
-> ()
4355 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
4358 let gotooutline (_, _, kind
) =
4362 let (pageno, y, _) = anchor in
4364 (if conf
.presentation
then (pageno, y, 1.0) else anchor)
4368 | Ouri
uri -> gotounder (Ulinkuri
uri)
4369 | Olaunch _cmd
-> failwith
"gotounder (Ulaunch cmd)"
4370 | Oremote _remote
-> failwith
"gotounder (Uremote remote)"
4371 | Ohistory hist
-> gotohist hist
4372 | Oremotedest _remotedest
-> failwith
"gotounder (Uremotedest remotedest)"
4375 class outlinesoucebase fetchoutlines
= object (self)
4376 inherit lvsourcebase
4377 val mutable m_items
= E.a
4378 val mutable m_minfo
= E.a
4379 val mutable m_orig_items
= E.a
4380 val mutable m_orig_minfo
= E.a
4381 val mutable m_narrow_patterns
= []
4382 val mutable m_gen
= -1
4384 method getitemcount
= Array.length m_items
4387 let s, n, _ = m_items
.(n) in
4390 method exit ~
(uioh:uioh) ~cancel ~
active ~
(first:int) ~pan
:
4392 ignore
(uioh, first);
4394 if m_narrow_patterns
= []
4395 then m_orig_items
, m_orig_minfo
4396 else m_items
, m_minfo
4403 gotooutline m_items
.(active);
4411 method hasaction
(_:int) = true
4414 if Array.length m_items
!= Array.length m_orig_items
4417 match m_narrow_patterns
with
4419 | many
-> String.concat
"@Uellipsis" (List.rev many
)
4421 "Narrowed to " ^
s ^
" (ctrl-u to restore)"
4425 match m_narrow_patterns
with
4428 | head
:: _ -> "@Uellipsis" ^ head
4430 method narrow
pattern =
4431 match Str.regexp_case_fold
pattern with
4432 | (exception _) -> ()
4434 let rec loop accu minfo n =
4437 m_items
<- Array.of_list
accu;
4438 m_minfo
<- Array.of_list
minfo;
4441 let (s, _, _) as o = m_items
.(n) in
4443 match Str.search_forward re
s 0 with
4444 | (exception Not_found
) -> accu, minfo
4445 | first -> o :: accu, (first, Str.match_end
()) :: minfo
4447 loop accu minfo (n-1)
4449 loop [] [] (Array.length m_items
- 1)
4451 method! getminfo
= m_minfo
4454 m_orig_items
<- fetchoutlines
();
4455 m_minfo
<- m_orig_minfo
;
4456 m_items
<- m_orig_items
4458 method add_narrow_pattern
pattern =
4459 m_narrow_patterns
<- pattern :: m_narrow_patterns
4461 method del_narrow_pattern
=
4462 match m_narrow_patterns
with
4463 | _ :: rest
-> m_narrow_patterns
<- rest
4468 match m_narrow_patterns
with
4469 | pattern :: [] -> self#narrow
pattern; pattern
4471 List.fold_left
(fun accu pattern ->
4472 self#narrow
pattern;
4473 pattern ^
"@Uellipsis" ^
accu) E.s list
4475 method calcactive
(_:anchor) = 0
4477 method reset
anchor items =
4478 if state
.gen
!= m_gen
4480 m_orig_items
<- items;
4482 m_narrow_patterns
<- [];
4484 m_orig_minfo
<- E.a;
4488 if items != m_orig_items
4490 m_orig_items
<- items;
4491 if m_narrow_patterns
== []
4492 then m_items
<- items;
4495 let active = self#calcactive
anchor in
4497 m_first
<- firstof m_first
active
4501 let outlinesource fetchoutlines
=
4503 inherit outlinesoucebase fetchoutlines
4504 method! calcactive
anchor =
4505 let rely = getanchory anchor in
4506 let rec loop n best bestd
=
4507 if n = Array.length m_items
4510 let _, _, kind
= m_items
.(n) in
4513 let orely = getanchory anchor in
4514 let d = abs
(orely - rely) in
4517 else loop (n+1) best bestd
4518 | Onone
| Oremote
_ | Olaunch
_
4519 | Oremotedest
_ | Ouri
_ | Ohistory
_ ->
4520 loop (n+1) best bestd
4526 let enteroutlinemode, enterbookmarkmode
, enterhistmode
=
4527 let mkselector sourcetype
=
4528 let fetchoutlines () =
4529 match sourcetype
with
4530 | `bookmarks
-> Array.of_list state
.bookmarks
4531 | `outlines
-> state
.outlines
4532 | `history
-> genhistoutlines ()
4535 if sourcetype
= `history
4536 then new outlinesoucebase
fetchoutlines
4537 else outlinesource fetchoutlines
4540 let outlines = fetchoutlines () in
4541 if Array.length
outlines = 0
4543 showtext ' ' errmsg
;
4547 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
4548 let anchor = getanchor
() in
4549 source#reset
anchor outlines;
4550 state
.text <- source#greetmsg
;
4552 coe (new outlinelistview ~zebra
:(sourcetype
=`history
) ~
source);
4553 G.postRedisplay "enter selector";
4556 let mkenter sourcetype errmsg
=
4557 let enter = mkselector sourcetype
in
4558 fun () -> enter errmsg
4560 mkenter `
outlines "document has no outline"
4561 , mkenter `bookmarks
"document has no bookmarks (yet)"
4562 , mkenter `history
"history is empty"
4565 let quickbookmark ?title
() =
4566 match state
.layout with
4572 let tm = Unix.localtime
(now
()) in
4574 "Quick (page %d) (bookmarked at %02d/%02d/%d %02d:%02d)"
4578 (tm.Unix.tm_year
+ 1900)
4581 | Some
title -> title
4583 state
.bookmarks
<- (title, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
4586 let setautoscrollspeed step goingdown
=
4587 let incr = max
1 ((abs step
) / 2) in
4588 let incr = if goingdown
then incr else -incr in
4589 let astep = boundastep state
.winh
(step
+ incr) in
4590 state
.autoscroll
<- Some
astep;
4594 match conf
.columns
with
4596 | Csingle
_ | Cmulti
_ -> state
.x != 0 || conf
.zoom > 1.0
4599 let panbound x = bound
x (-state
.w) state
.winw
;;
4601 let existsinrow pageno (columns
, coverA
, coverB
) p =
4602 let last = ((pageno - coverA
) mod columns
) + columns
in
4603 let rec any = function
4606 if l.pageno = coverA
- 1 || l.pageno = state
.pagecount
- coverB
4610 then (if l.pageno = last then false else any rest
)
4618 match state
.layout with
4620 let pageno = page_of_y state
.y in
4621 gotoghyll (getpagey
(pageno+1))
4623 match conf
.columns
with
4625 if conf
.presentation
&& rest
== [] && l.pageh
> l.pagey + l.pagevh
4627 let y = clamp (pgscale state
.winh
) in
4630 let pageno = min
(l.pageno+1) (state
.pagecount
-1) in
4631 gotoghyll (getpagey
pageno)
4632 | Cmulti
((c, _, _) as cl
, _) ->
4633 if conf
.presentation
4634 && (existsinrow l.pageno cl
4635 (fun l -> l.pageh
> l.pagey + l.pagevh))
4637 let y = clamp (pgscale state
.winh
) in
4640 let pageno = min
(l.pageno+c) (state
.pagecount
-1) in
4641 gotoghyll (getpagey
pageno)
4643 if l.pageno < state
.pagecount
- 1 || l.pagecol
< n - 1
4645 let pagey, pageh
= getpageyh
l.pageno in
4646 let pagey = pagey + pageh
* l.pagecol
in
4647 let ips = if l.pagecol
= 0 then 0 else conf
.interpagespace
in
4648 gotoghyll (pagey + pageh
+ ips)
4652 match state
.layout with
4654 let pageno = page_of_y state
.y in
4655 gotoghyll (getpagey
(pageno-1))
4657 match conf
.columns
with
4659 if conf
.presentation
&& l.pagey != 0
4661 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4663 let pageno = max
0 (l.pageno-1) in
4664 gotoghyll (getpagey
pageno)
4665 | Cmulti
((c, _, coverB
) as cl
, _) ->
4666 if conf
.presentation
&&
4667 (existsinrow l.pageno cl
(fun l -> l.pagey != 0))
4669 gotoghyll (clamp (pgscale ~
-(state
.winh
)))
4672 if l.pageno = state
.pagecount
- coverB
4676 let pageno = max
0 (l.pageno-decr) in
4677 gotoghyll (getpagey
pageno)
4685 let pageno = max
0 (l.pageno-1) in
4686 let pagey, pageh
= getpageyh
pageno in
4689 let pagey, pageh
= getpageyh
l.pageno in
4690 pagey + pageh
* (l.pagecol
-1) - conf
.interpagespace
4696 if emptystr conf
.savecmd
4697 then error
"don't know where to save modified document"
4699 let savecmd = Str.global_replace percentsre state
.path conf
.savecmd in
4702 (fun s -> error
"failed to obtain path to the saved copy: %s" s)
4707 let tmp = path ^
".tmp" in
4709 Unix.rename
tmp path;
4712 let viewkeyboard key mask
=
4714 let mode = state
.mode in
4715 state
.mode <- Textentry
(te, fun _ -> state
.mode <- mode);
4718 G.postRedisplay "view:enttext"
4720 let ctrl = Wsi.withctrl mask
in
4721 let key = Wsi.keypadtodigitkey
key in
4726 if hasunsavedchanges
()
4730 if conf
.angle
mod 360 = 0 && not
(isbirdseye state
.mode)
4733 match state
.lnava
with
4734 | None
-> LinkNav
(Ltgendir
0)
4735 | Some
pn -> LinkNav
(Ltexact
pn)
4737 gotoxy state
.x state
.y;
4739 else impmsg "keyboard link navigation does not work under rotation"
4742 begin match state
.mstate
with
4745 G.postRedisplay "kill rect";
4748 | Mscrolly
| Mscrollx
4751 begin match state
.mode with
4754 G.postRedisplay "esc leave linknav"
4758 match state
.ranchors
with
4760 | (path, password, anchor, origin
) :: rest
->
4761 state
.ranchors
<- rest
;
4762 state
.anchor <- anchor;
4763 state
.origin
<- origin
;
4764 state
.nameddest
<- E.s;
4765 opendoc path password
4770 gotoghyll (getnav ~
-1)
4781 Hashtbl.iter
(fun _ opaque ->
4783 Hashtbl.clear state
.prects
) state
.pagemap
;
4784 G.postRedisplay "dehighlight";
4786 | @slash
| @question
->
4787 let ondone isforw
s =
4788 cbput state
.hists
.pat
s;
4789 state
.searchpattern
<- s;
4792 let s = String.make
1 (Char.chr
key) in
4793 enttext (s, E.s, Some
(onhist state
.hists
.pat
),
4794 textentry, ondone (key = @slash
), true)
4796 | @plus
| @kpplus
| @equals
when ctrl ->
4797 let incr = if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01 in
4798 pivotzoom (conf
.zoom +. incr)
4800 | @plus
| @kpplus
->
4803 try int_of_string
s with exn
->
4804 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4810 state
.text <- "page bias is now " ^ string_of_int
n;
4813 enttext ("page bias: ", E.s, None
, intentry, ondone, true)
4815 | @minus
| @kpminus
when ctrl ->
4816 let decr = if conf
.zoom -. 0.1 < 0.1 then 0.01 else 0.1 in
4817 pivotzoom (max
0.01 (conf
.zoom -. decr))
4819 | @minus
| @kpminus
->
4820 let ondone msg
= state
.text <- msg
in
4822 "option [acfhilpstvxACFPRSZTISM]: ", E.s, None
,
4823 optentry state
.mode, ondone, true
4828 then gotoxy 0 state
.y
4831 | (@1 | @2) when ctrl && conf
.fitmodel
!= FitPage
-> (* ctrl-1/2 *)
4833 match conf
.columns
with
4834 | Csingle
_ | Cmulti
_ -> 1
4835 | Csplit
(n, _) -> n
4837 let h = state
.winh
-
4838 conf
.interpagespace
lsl (if conf
.presentation
then 1 else 0)
4840 let zoom = zoomforh state
.winw
h 0 cols in
4841 if zoom > 0.0 && (key = @2 || zoom < 1.0)
4846 match conf
.fitmodel
with
4847 | FitWidth
-> FitProportional
4848 | FitProportional
-> FitPage
4849 | FitPage
-> FitWidth
4851 state
.text <- "fit model: " ^
FMTE.to_string
fm;
4852 reqlayout conf
.angle
fm
4854 | @4 when ctrl -> (* ctrl-4 *)
4855 let zoom = getmaxw
() /. float state
.winw
in
4856 if zoom > 0.0 then setzoom zoom
4864 | (48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57)
4865 when not
ctrl -> (* 0..9 *)
4868 try int_of_string
s with exn
->
4869 state
.text <- Printf.sprintf
"bad integer `%s': %s" s @@ exntos exn
;
4875 cbput state
.hists
.pag
(string_of_int
n);
4876 gotopage1 (n + conf
.pagebias
- 1) 0;
4879 let pageentry text key =
4880 match Char.unsafe_chr
key with
4881 | '
g'
-> TEdone
text
4882 | _ -> intentry text key
4884 let text = String.make
1 (Char.chr
key) in
4885 enttext (":", text, Some
(onhist state
.hists
.pag
),
4886 pageentry, ondone, true)
4889 conf
.scrollb
<- if conf
.scrollb
= 0 then (scrollbvv
lor scrollbhv
) else 0;
4890 G.postRedisplay "toggle scrollbar";
4893 state
.bzoom
<- not state
.bzoom
;
4895 showtext ' '
("block zoom " ^
if state
.bzoom
then "on" else "off")
4898 conf
.hlinks
<- not conf
.hlinks
;
4899 state
.text <- "highlightlinks " ^
if conf
.hlinks
then "on" else "off";
4900 G.postRedisplay "toggle highlightlinks";
4903 if conf
.angle
mod 360 = 0
4905 state
.glinks
<- true;
4906 let mode = state
.mode in
4909 (":", E.s, None
, linknentry, linknact gotounder, false),
4911 state
.glinks
<- false;
4915 G.postRedisplay "view:linkent(F)"
4917 else impmsg "hint mode does not work under rotation"
4920 state
.glinks
<- true;
4921 let mode = state
.mode in
4925 ":", E.s, None
, linknentry, linknact (fun under ->
4926 selstring (undertext under);
4930 state
.glinks
<- false;
4934 G.postRedisplay "view:linkent"
4937 begin match state
.autoscroll
with
4939 conf
.autoscrollstep
<- step
;
4940 state
.autoscroll
<- None
4942 if conf
.autoscrollstep
= 0
4943 then state
.autoscroll
<- Some
1
4944 else state
.autoscroll
<- Some conf
.autoscrollstep
4948 launchpath () (* XXX where do error messages go? *)
4951 setpresentationmode (not conf
.presentation
);
4952 showtext ' '
("presentation mode " ^
4953 if conf
.presentation
then "on" else "off");
4956 if List.mem
Wsi.Fullscreen state
.winstate
4957 then Wsi.reshape conf
.cwinw conf
.cwinh
4958 else Wsi.fullscreen
()
4961 search state
.searchpattern
false
4964 search state
.searchpattern
true
4967 begin match state
.layout with
4970 gotoghyll (getpagey
l.pageno)
4976 | @delete
| @kpdelete
-> (* delete *)
4980 showtext ' '
(describe_location ());
4983 begin match state
.layout with
4986 Wsi.reshape l.pagew
l.pageh
;
4991 enterbookmarkmode
()
4999 | @e when Buffer.length state
.errmsgs
> 0 ->
5004 match state
.layout with
5009 (s, 0, Oanchor
(getanchor1
l)) :: state
.bookmarks
5012 enttext ("bookmark: ", E.s, None
, textentry, ondone, true)
5016 showtext ' '
"Quick bookmark added";
5019 begin match state
.layout with
5021 let rect = getpdimrect
l.pagedimno
in
5025 (truncate
(1.8 *. (rect.(1) -. rect.(0))),
5026 truncate
(1.2 *. (rect.(3) -. rect.(0))))
5028 (truncate
(rect.(1) -. rect.(0)),
5029 truncate
(rect.(3) -. rect.(0)))
5031 let w = truncate
((float w)*.conf
.zoom)
5032 and h = truncate
((float h)*.conf
.zoom) in
5035 state
.anchor <- getanchor
();
5036 Wsi.reshape w (h + conf
.interpagespace
)
5038 G.postRedisplay "z";
5043 | @x -> state
.roam
()
5046 reqlayout (conf
.angle
+
5047 (if key = @Gt
then 30 else -30)) conf
.fitmodel
5051 bound
(conf
.colorscale
+. (if key = 93 then 0.1 else -0.1)) 0.0 1.0
5053 G.postRedisplay "brightness";
5055 | @c when state
.mode = View
->
5060 let m = (state
.winw
- state
.w) / 2 in
5061 gotoxy_and_clear_text m state
.y
5065 match state
.prevcolumns
with
5066 | None
-> (1, 0, 0), 1.0
5067 | Some
(columns
, z
) ->
5070 | Csplit
(c, _) -> -c, 0, 0
5071 | Cmulti
((c, a, b), _) -> c, a, b
5072 | Csingle
_ -> 1, 0, 0
5076 setcolumns View
c a b;
5079 | @down
| @up
when ctrl && Wsi.withshift mask
->
5080 let zoom, x = state
.prevzoom
in
5084 | @k
| @up
| @kpup
->
5085 begin match state
.autoscroll
with
5087 begin match state
.mode with
5088 | Birdseye beye
-> upbirdseye 1 beye
5093 then gotoxy_and_clear_text state
.x (clamp ~
-(state
.winh
/2))
5095 if not
(Wsi.withshift mask
) && conf
.presentation
5097 else gotoghyll1 true (clamp (-conf
.scrollstep
))
5101 setautoscrollspeed n false
5104 | @j
| @down
| @kpdown
->
5105 begin match state
.autoscroll
with
5107 begin match state
.mode with
5108 | Birdseye beye
-> downbirdseye 1 beye
5113 then gotoxy_and_clear_text state
.x (clamp (state
.winh
/2))
5115 if not
(Wsi.withshift mask
) && conf
.presentation
5117 else gotoghyll1 true (clamp (conf
.scrollstep
))
5121 setautoscrollspeed n true
5124 | @left | @right
| @kpleft
| @kpright
when not
(Wsi.withalt mask
) ->
5130 else conf
.hscrollstep
5132 let dx = if key = @left || key = @kpleft
then dx else -dx in
5133 gotoxy_and_clear_text (panbound (state
.x + dx)) state
.y
5136 G.postRedisplay "left/right"
5139 | @prior
| @kpprior
->
5143 match state
.layout with
5145 | l :: _ -> state
.y - l.pagey
5147 clamp (pgscale (-state
.winh
))
5151 | @next | @kpnext
->
5155 match List.rev state
.layout with
5157 | l :: _ -> getpagey
l.pageno
5159 clamp (pgscale state
.winh
)
5163 | @g | @home
| @kphome
->
5166 | @G
| @jend
| @kpend
->
5168 gotoghyll (clamp state
.maxy)
5170 | @right
| @kpright
when Wsi.withalt mask
->
5171 gotoghyll (getnav 1)
5172 | @left | @kpleft
when Wsi.withalt mask
->
5173 gotoghyll (getnav ~
-1)
5178 | @v when conf
.debug
->
5181 match getopaque l.pageno with
5184 let x0, y0, x1, y1 = pagebbox
opaque in
5185 let rect = (float x0, float y0,
5188 float x0, float y1) in
5190 let color = (0.0, 0.0, 1.0 /. (l.pageno mod 3 |> float), 0.5) in
5191 state
.rects
<- (l.pageno, color, rect) :: state
.rects
;
5193 G.postRedisplay "v";
5196 let mode = state
.mode in
5197 let cmd = ref E.s in
5198 let onleave = function
5199 | Cancel
-> state
.mode <- mode
5202 match getopaque l.pageno with
5203 | Some
opaque -> pipesel opaque !cmd
5204 | None
-> ()) state
.layout;
5208 cbput state
.hists
.sel
s;
5212 "| ", !cmd, Some
(onhist state
.hists
.sel
), textentry, ondone, true
5214 G.postRedisplay "|";
5215 state
.mode <- Textentry
(te, onleave);
5218 vlog "huh? %s" (Wsi.keyname
key)
5221 let linknavkeyboard key mask
linknav =
5222 let getpage pageno =
5223 let rec loop = function
5225 | l :: _ when l.pageno = pageno -> Some
l
5226 | _ :: rest
-> loop rest
5227 in loop state
.layout
5229 let doexact (pageno, n) =
5230 match getopaque pageno, getpage pageno with
5231 | Some
opaque, Some
l ->
5232 if key = @enter || key = @kpenter
5234 let under = getlink
opaque n in
5235 G.postRedisplay "link gotounder";
5242 Some
(findlink
opaque LDfirst
), -1
5245 Some
(findlink
opaque LDlast
), 1
5248 Some
(findlink
opaque (LDleft
n)), -1
5251 Some
(findlink
opaque (LDright
n)), 1
5254 Some
(findlink
opaque (LDup
n)), -1
5257 Some
(findlink
opaque (LDdown
n)), 1
5262 begin match findpwl
l.pageno dir with
5266 state
.mode <- LinkNav
(Ltgendir
dir);
5267 let y, h = getpageyh
pageno in
5270 then y + h - state
.winh
5275 begin match getopaque pageno, getpage pageno with
5276 | Some
opaque, Some
_ ->
5278 let ld = if dir > 0 then LDfirst
else LDlast
in
5281 begin match link with
5283 showlinktype (getlink
opaque m);
5284 state
.mode <- LinkNav
(Ltexact
(pageno, m));
5285 G.postRedisplay "linknav jpage";
5286 | Lnotfound
-> notfound dir
5292 begin match opt with
5293 | Some Lnotfound
-> pwl l dir;
5294 | Some
(Lfound
m) ->
5298 let _, y0, _, y1 = getlinkrect
opaque m in
5300 then gotopage1 l.pageno y0
5302 let d = fstate
.fontsize
+ 1 in
5303 if y1 - l.pagey > l.pagevh - d
5304 then gotopage1 l.pageno (y1 - state
.winh
+ d)
5305 else G.postRedisplay "linknav";
5307 showlinktype (getlink
opaque m);
5308 state
.mode <- LinkNav
(Ltexact
(l.pageno, m));
5311 | None
-> viewkeyboard key mask
5313 | _ -> viewkeyboard key mask
5317 begin match linknav with
5318 | Ltexact pa
-> state
.lnava
<- Some pa
5319 | Ltgendir
_ | Ltnotready
_ -> ()
5322 G.postRedisplay "leave linknav"
5326 | Ltgendir
_ | Ltnotready
_ -> viewkeyboard key mask
5327 | Ltexact exact
-> doexact exact
5330 let keyboard key mask
=
5331 if (key = @g && Wsi.withctrl mask
) && not
(istextentry state
.mode)
5332 then wcmd "interrupt"
5333 else state
.uioh <- state
.uioh#
key key mask
5336 let birdseyekeyboard key mask
5337 ((oconf
, leftx
, pageno, hooverpageno
, anchor) as beye
) =
5339 match conf
.columns
with
5341 | Cmulti
((c, _, _), _) -> c
5342 | Csplit
_ -> failwith
"bird's eye split mode"
5344 let pgh layout = List.fold_left
5345 (fun m l -> max
l.pageh
m) state
.winh
layout in
5347 | @l when Wsi.withctrl mask
->
5348 let y, h = getpageyh
pageno in
5349 let top = (state
.winh
- h) / 2 in
5350 gotoxy state
.x (max
0 (y - top))
5351 | @enter | @kpenter
-> leavebirdseye beye
false
5352 | @escape
-> leavebirdseye beye
true
5353 | @up
-> upbirdseye incr beye
5354 | @down
-> downbirdseye incr beye
5355 | @left -> upbirdseye 1 beye
5356 | @right
-> downbirdseye 1 beye
5359 begin match state
.layout with
5363 state
.mode <- Birdseye
(
5364 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5366 gotopage1 l.pageno 0;
5369 let layout = layout state
.x (state
.y-state
.winh
)
5371 (pgh state
.layout) in
5373 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5375 state
.mode <- Birdseye
(
5376 oconf
, leftx
, l.pageno, hooverpageno
, anchor
5378 gotopage1 l.pageno 0
5381 | [] -> gotoxy state
.x (clamp (-state
.winh
))
5385 begin match List.rev state
.layout with
5387 let layout = layout state
.x
5388 (state
.y + (pgh state
.layout))
5389 state
.winw state
.winh
in
5390 begin match layout with
5392 let incr = l.pageh
- l.pagevh in
5397 oconf
, leftx
, state
.pagecount
- 1, hooverpageno
, anchor
5399 G.postRedisplay "birdseye pagedown";
5401 else gotoxy state
.x (clamp (incr + conf
.interpagespace
*2));
5405 Birdseye
(oconf
, leftx
, l.pageno, hooverpageno
, anchor);
5406 gotopage1 l.pageno 0;
5409 | [] -> gotoxy state
.x (clamp state
.winh
)
5413 state
.mode <- Birdseye
(oconf
, leftx
, 0, hooverpageno
, anchor);
5417 let pageno = state
.pagecount
- 1 in
5418 state
.mode <- Birdseye
(oconf
, leftx
, pageno, hooverpageno
, anchor);
5419 if not
(pagevisible state
.layout pageno)
5422 match List.rev state
.pdims
with
5424 | (_, _, h, _) :: _ -> h
5428 (max
0 (getpagey
pageno - (state
.winh
- h - conf
.interpagespace
)))
5429 else G.postRedisplay "birdseye end";
5431 | _ -> viewkeyboard key mask
5436 match state
.mode with
5437 | Textentry
_ -> scalecolor 0.4
5439 | View
-> scalecolor 1.0
5440 | Birdseye
(_, _, pageno, hooverpageno
, _) ->
5441 if l.pageno = hooverpageno
5444 if l.pageno = pageno
5446 let c = scalecolor 1.0 in
5448 GlDraw.line_width
3.0;
5449 let dispx = l.pagedispx in
5451 (float (dispx-1)) (float (l.pagedispy-1))
5452 (float (dispx+l.pagevw+1))
5453 (float (l.pagedispy+l.pagevh+1))
5455 GlDraw.line_width
1.0;
5464 let postdrawpage l linkindexbase
=
5465 match getopaque l.pageno with
5467 if tileready l l.pagex
l.pagey
5469 let x = l.pagedispx - l.pagex
5470 and y = l.pagedispy - l.pagey in
5472 match conf
.columns
with
5473 | Csingle
_ | Cmulti
_ ->
5474 (if conf
.hlinks
then 1 else 0)
5476 && not
(isbirdseye state
.mode) then 2 else 0)
5480 match state
.mode with
5481 | Textentry
((_, s, _, _, _, _), _) when state
.glinks
-> s
5487 Hashtbl.find_all state
.prects
l.pageno |>
5488 List.iter
(fun vals
-> drawprect
opaque x y vals
);
5489 let n = postprocess
opaque hlmask x y (linkindexbase
, s, conf
.hfsize
) in
5491 then (state
.redisplay
<- true; 0)
5497 let scrollindicator () =
5498 let sbw, ph
, sh = state
.uioh#
scrollph in
5499 let sbh, pw, sw = state
.uioh#scrollpw
in
5504 else ((state
.winw
- sbw), state
.winw
, 0)
5508 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5509 GlDraw.color (0.64, 0.64, 0.64) ~
alpha:0.7;
5510 filledrect (float x0) 0. (float x1) (float state
.winh
);
5512 (float hx0
) (float (state
.winh
- sbh))
5513 (float (hx0
+ state
.winw
)) (float state
.winh
)
5515 GlDraw.color (0.0, 0.0, 0.0) ~
alpha:0.7;
5517 filledrect (float x0) ph
(float x1) (ph
+. sh);
5518 let pw = pw +. float hx0
in
5519 filledrect pw (float (state
.winh
- sbh)) (pw +. sw) (float state
.winh
);
5524 match state
.mstate
with
5525 | Mnone
| Mscrolly
| Mscrollx
| Mpan
_ | Mzoom
_ | Mzoomrect
_ ->
5528 | Msel
((x0, y0), (x1, y1)) ->
5529 let identify opaque l px py = Some
(opaque, l.pageno, px, py) in
5530 let o0,n0
,px0
,py0
= onppundermouse identify x0 y0 (~
< E.s, -1, 0, 0) in
5531 let _o1,n1
,px1
,py1
= onppundermouse identify x1 y1 (~
< E.s, -1, 0, 0) in
5532 if n0
!= -1 && n0
= n1
then seltext
o0 (px0
, py0
, px1
, py1
);
5539 GlDraw.color (0.0, 0.0, 1.0) ~
alpha:0.5;
5540 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5542 (fun (pageno, c, (x0, y0, x1, y1, x2
, y2
, x3
, y3
)) ->
5544 if l.pageno = pageno
5546 let dx = float (l.pagedispx - l.pagex
) in
5547 let dy = float (l.pagedispy - l.pagey) in
5548 let r, g, b, alpha = c in
5549 GlDraw.color (r, g, b) ~
alpha;
5550 filledrect2 (x0+.dx) (y0+.dy)
5562 begin match conf
.columns
, state
.layout with
5563 | Csingle
_, _ :: _ ->
5564 GlDraw.color (scalecolor2 conf
.bgcolor
);
5566 List.fold_left
(fun y l ->
5569 let x1 = l.pagedispx in
5570 let y1 = (l.pagedispy + l.pagevh) in
5571 filledrect (float x0) (float y0) (float x1) (float y1);
5572 let x0 = x1 + l.pagevw in
5573 let x1 = state
.winw
in
5574 filledrect1 (float x0) (float y0) (float x1) (float y1);
5578 and x1 = state
.winw
in
5580 and y1 = l.pagedispy in
5581 filledrect1 (float x0) (float y0) (float x1) (float y1);
5583 l.pagedispy + l.pagevh) 0 state
.layout
5586 and x1 = state
.winw
in
5588 and y1 = state
.winh
in
5589 filledrect1 (float x0) (float y0) (float x1) (float y1)
5590 | (Cmulti
_ | Csplit
_), _ | Csingle
_, [] ->
5591 GlClear.color (scalecolor2 conf
.bgcolor
);
5592 GlClear.clear
[`
color];
5594 List.iter
drawpage state
.layout;
5596 match state
.mode with
5597 | LinkNav
(Ltexact
(pageno, linkno
)) ->
5598 begin match getopaque pageno with
5600 let x0, y0, x1, y1 = getlinkrect
opaque linkno
in
5601 let color = (0.0, 0.0, 0.5, 0.5) in
5608 | None
-> state
.rects
5610 | LinkNav
(Ltgendir
_) | LinkNav
(Ltnotready
_)
5613 | View
-> state
.rects
5616 let rec postloop linkindexbase
= function
5618 let linkindexbase = linkindexbase + postdrawpage l linkindexbase in
5619 postloop linkindexbase rest
5623 postloop 0 state
.layout;
5625 begin match state
.mstate
with
5626 | Mzoomrect
((x0, y0), (x1, y1)) ->
5628 GlDraw.color (0.3, 0.3, 0.3) ~
alpha:0.5;
5629 GlFunc.blend_func ~
src:`src_alpha ~dst
:`one_minus_src_alpha
;
5630 filledrect (float x0) (float y0) (float x1) (float y1);
5634 | Mscrolly
| Mscrollx
5643 let zoomrect x y x1 y1 =
5646 and y0 = min
y y1 in
5647 let zoom = (float state
.w) /. float (x1 - x0) in
5650 if state
.w < state
.winw
5651 then (state
.winw
- state
.w) / 2
5654 match conf
.fitmodel
with
5655 | FitWidth
| FitProportional
-> simple ()
5657 match conf
.columns
with
5659 onppundermouse (fun _ l _ _ -> Some
l.pagedispx) x0 y0 x0
5660 | Cmulti
_ | Csingle
_ -> simple ()
5662 gotoxy ((state
.x + margin) - x0) (state
.y + y0);
5663 state
.anchor <- getanchor
();
5668 let annot inline
x y =
5669 match unproject x y with
5670 | Some
(opaque, n, ux
, uy
) ->
5672 addannot
opaque ux uy
text;
5673 wcmd "freepage %s" (~
> opaque);
5674 Hashtbl.remove state
.pagemap
(n, state
.gen
);
5676 gotoxy state
.x state
.y
5680 let ondone s = add s in
5681 let mode = state
.mode in
5682 state
.mode <- Textentry
(
5683 ("annotation: ", E.s, None
, textentry, ondone, true),
5684 fun _ -> state
.mode <- mode);
5687 G.postRedisplay "annot"
5689 add @@ getusertext E.s
5694 let g opaque l px py =
5695 match rectofblock
opaque px py with
5697 let x0 = a.(0) -. 20. in
5698 let x1 = a.(1) +. 20. in
5699 let y0 = a.(2) -. 20. in
5700 let zoom = (float state
.w) /. (x1 -. x0) in
5701 let pagey = getpagey
l.pageno in
5702 let margin = (state
.w - l.pagew
)/2 in
5703 let nx = -truncate
x0 - margin in
5704 gotoxy_and_clear_text nx (pagey + truncate
y0);
5705 state
.anchor <- getanchor
();
5710 match conf
.columns
with
5712 impmsg "block zooming does not work properly in split columns mode"
5713 | Cmulti
_ | Csingle
_ -> onppundermouse g x y ()
5717 let winw = state
.winw - 1 in
5718 let s = float x /. float winw in
5719 let destx = truncate
(float (state
.w + winw) *. s) in
5720 gotoxy_and_clear_text (winw - destx) state
.y;
5721 state
.mstate
<- Mscrollx
;
5725 let s = float y /. float state
.winh
in
5726 let desty = truncate
(float (state
.maxy -
5727 (if conf
.maxhfit
then state
.winh
else 0))
5729 gotoxy_and_clear_text state
.x desty;
5730 state
.mstate
<- Mscrolly
;
5733 let viewmulticlick clicks
x y mask
=
5734 let g opaque l px py =
5742 if markunder
opaque px py mark
5746 match getopaque l.pageno with
5748 | Some
opaque -> pipesel opaque cmd
5750 state
.roam
<- (fun () -> dopipe conf
.paxcmd
);
5751 if not
(Wsi.withctrl mask
) then dopipe conf
.selcmd
;
5756 G.postRedisplay "viewmulticlick";
5757 onppundermouse g x y (fun () -> impmsg "nothing to select") ();
5761 match conf
.columns
with
5763 | Csingle
_ | Cmulti
_ -> conf
.angle
mod 360 = 0
5766 let viewmouse button down
x y mask
=
5768 | n when (n == 4 || n == 5) && not down
->
5769 if Wsi.withctrl mask
5771 match state
.mstate
with
5772 | Mzoom
(oldn
, i
, (ftx
, fty
)) ->
5775 then abs
(ftx
- x) > 5 || abs
(fty
- y) > 5
5785 if conf
.zoom +. 0.01 > 0.1 then 0.1 else 0.01
5787 if conf
.zoom -. 0.1 < 0.1 then -0.01 else -0.1
5789 let zoom = conf
.zoom -. incr in
5791 then pivotzoom ~
x ~
y zoom
5792 else pivotzoom zoom;
5793 state
.mstate
<- Mzoom
(n, 0, (x, y));
5795 state
.mstate
<- Mzoom
(n, i
+1, (ftx
, fty
));
5797 else state
.mstate
<- Mzoom
(n, 0, (ftx
, fty
))
5801 | Mscrolly
| Mscrollx
5803 | Mnone
-> state
.mstate
<- Mzoom
(n, 0, (0, 0))
5806 match state
.autoscroll
with
5807 | Some step
-> setautoscrollspeed step
(n=4)
5809 if conf
.wheelbypage
|| conf
.presentation
5818 then -conf
.scrollstep
5819 else conf
.scrollstep
5821 let incr = incr * 2 in
5822 let y = clamp incr in
5823 gotoxy_and_clear_text state
.x y
5826 | n when (n = 6 || n = 7) && not down
&& canpan () ->
5828 panbound (state
.x + (if n = 7 then -2 else 2) * conf
.hscrollstep
) in
5829 gotoxy_and_clear_text x state
.y
5831 | 1 when Wsi.withshift mask
->
5832 state
.mstate
<- Mnone
;
5835 match unproject x y with
5837 | Some
(_, pageno, ux
, uy
) ->
5838 let cmd = Printf.sprintf
5840 conf
.stcmd state
.path pageno ux uy
5842 match spawn
cmd [] with
5843 | (exception exn
) ->
5844 impmsg "execution of synctex command(%S) failed: %S"
5845 conf
.stcmd
@@ exntos exn
5849 | 1 when Wsi.withctrl mask
->
5852 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5853 state
.mstate
<- Mpan
(x, y)
5856 state
.mstate
<- Mnone
5861 if Wsi.withshift mask
5863 annot conf
.annotinline
x y;
5864 G.postRedisplay "addannot"
5868 Wsi.setcursor
Wsi.CURSOR_CYCLE
;
5869 state
.mstate
<- Mzoomrect
(p, p)
5872 match state
.mstate
with
5873 | Mzoomrect
((x0, y0), _) ->
5874 if abs
(x-x0) > 10 && abs
(y - y0) > 10
5875 then zoomrect x0 y0 x y
5878 G.postRedisplay "kill accidental zoom rect";
5882 | Mscrolly
| Mscrollx
5888 | 1 when vscrollhit x ->
5891 let _, position, sh = state
.uioh#
scrollph in
5892 if y > truncate
position && y < truncate
(position +. sh)
5893 then state
.mstate
<- Mscrolly
5896 state
.mstate
<- Mnone
5898 | 1 when y > state
.winh
- hscrollh () ->
5901 let _, position, sw = state
.uioh#scrollpw
in
5902 if x > truncate
position && x < truncate
(position +. sw)
5903 then state
.mstate
<- Mscrollx
5906 state
.mstate
<- Mnone
5908 | 1 when state
.bzoom
-> if not down
then zoomblock x y
5911 let dest = if down
then getunder x y else Unone
in
5912 begin match dest with
5916 | Unone
when down
->
5917 Wsi.setcursor
Wsi.CURSOR_FLEUR
;
5918 state
.mstate
<- Mpan
(x, y);
5920 | Uannotation
(opaque, slinkindex
) -> enterannotmode opaque slinkindex
5922 | Unone
| Utext
_ ->
5927 state
.mstate
<- Msel
((x, y), (x, y));
5928 G.postRedisplay "mouse select";
5932 match state
.mstate
with
5935 | Mzoom
_ | Mscrollx
| Mscrolly
->
5936 state
.mstate
<- Mnone
5938 | Mzoomrect
((x0, y0), _) ->
5942 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
5943 state
.mstate
<- Mnone
5945 | Msel
((x0, y0), (x1, y1)) ->
5946 let rec loop = function
5950 let a0 = l.pagedispy in
5951 let a1 = a0 + l.pagevh in
5952 let b0 = l.pagedispx in
5953 let b1 = b0 + l.pagevw in
5954 ((y0 >= a0 && y0 <= a1) || (y1 >= a0 && y1 <= a1))
5955 && ((x0 >= b0 && x0 <= b1) || (x1 >= b0 && x1 <= b1))
5959 match getopaque l.pageno with
5962 match Unix.pipe
() with
5963 | (exception exn
) ->
5964 impmsg "cannot create sel pipe: %s" @@
5968 Ne.clo fd
(fun msg
->
5969 dolog
"%s close failed: %s" what msg
)
5972 try spawn
cmd [r, 0; w, -1]
5974 dolog
"cannot execute %S: %s"
5981 G.postRedisplay "copysel";
5983 else clo "Msel pipe/w" w;
5984 clo "Msel pipe/r" r;
5986 dosel conf
.selcmd
();
5987 state
.roam
<- dosel conf
.paxcmd
;
5999 let birdseyemouse button down
x y mask
6000 (conf
, leftx
, _, hooverpageno
, anchor) =
6003 let rec loop = function
6006 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6007 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6009 leavebirdseye (conf
, leftx
, l.pageno, hooverpageno
, anchor) false;
6015 | _ -> viewmouse button down
x y mask
6021 method key key mask
=
6022 begin match state
.mode with
6023 | Textentry
textentry -> textentrykeyboard key mask
textentry
6024 | Birdseye
birdseye -> birdseyekeyboard key mask
birdseye
6025 | View
-> viewkeyboard key mask
6026 | LinkNav
linknav -> linknavkeyboard key mask
linknav
6030 method button button bstate
x y mask
=
6031 begin match state
.mode with
6033 | View
-> viewmouse button bstate
x y mask
6034 | Birdseye beye
-> birdseyemouse button bstate
x y mask beye
6039 method multiclick clicks
x y mask
=
6040 begin match state
.mode with
6042 | View
-> viewmulticlick clicks
x y mask
6049 begin match state
.mode with
6051 | View
| Birdseye
_ | LinkNav
_ ->
6052 match state
.mstate
with
6053 | Mzoom
_ | Mnone
-> ()
6058 state
.mstate
<- Mpan
(x, y);
6059 let x = if canpan () then panbound (state
.x + dx) else state
.x in
6061 gotoxy_and_clear_text x y
6064 state
.mstate
<- Msel
(a, (x, y));
6065 G.postRedisplay "motion select";
6068 let y = min state
.winh
(max
0 y) in
6072 let x = min state
.winw (max
0 x) in
6075 | Mzoomrect
(p0
, _) ->
6076 state
.mstate
<- Mzoomrect
(p0
, (x, y));
6077 G.postRedisplay "motion zoomrect";
6081 method pmotion
x y =
6082 begin match state
.mode with
6083 | Birdseye
(conf
, leftx
, pageno, hooverpageno
, anchor) ->
6084 let rec loop = function
6086 if hooverpageno
!= -1
6088 state
.mode <- Birdseye
(conf
, leftx
, pageno, -1, anchor);
6089 G.postRedisplay "pmotion birdseye no hoover";
6092 if y > l.pagedispy && y < l.pagedispy + l.pagevh
6093 && x > l.pagedispx && x < l.pagedispx + l.pagevw
6095 state
.mode <- Birdseye
(conf
, leftx
, pageno, l.pageno, anchor);
6096 G.postRedisplay "pmotion birdseye hoover";
6106 match state
.mstate
with
6107 | Mpan
_ | Msel
_ | Mzoom
_ | Mscrolly
| Mscrollx
| Mzoomrect
_ -> ()
6115 let past, _, _ = !r in
6117 let delta = now -. past in
6120 else r := (now, x, y)
6124 method infochanged
_ = ()
6127 let maxy = state
.maxy - (if conf
.maxhfit
then state
.winh
else 0) in
6130 then 0.0, float state
.winh
6131 else scrollph state
.y maxy
6136 let fwinw = float (state
.winw - vscrollw ()) in
6138 let sw = fwinw /. float state
.w in
6139 let sw = fwinw *. sw in
6140 max
sw (float conf
.scrollh
)
6143 let maxx = state
.w + state
.winw in
6144 let x = state
.winw - state
.x in
6145 let percent = float x /. float maxx in
6146 (fwinw -. sw) *. percent
6148 hscrollh (), position, sw
6152 match state
.mode with
6153 | LinkNav
_ -> "links"
6154 | Textentry
_ -> "textentry"
6155 | Birdseye
_ -> "birdseye"
6158 findkeyhash conf
modename
6160 method eformsgs
= true
6161 method alwaysscrolly
= false
6164 let addrect pageno r g b a x0 y0 x1 y1 =
6165 Hashtbl.add state
.prects
pageno [|r; g; b; a; x0; y0; x1; y1|];
6169 let cl = splitatchar cmds ' '
in
6171 try Scanf.sscanf
s fmt
f
6173 adderrfmt "remote exec"
6174 "error processing '%S': %s\n" cmds
@@ exntos exn
6176 let rectx s pageno (r, g, b, a) x0 y0 x1 y1 =
6177 vlog "%s page %d color (%f %f %f %f) x0,y0,x1,y1 = %f %f %f %f"
6178 s pageno r g b a x0 y0 x1 y1;
6182 let _,w1,h1
,_ = getpagedim
pageno in
6183 let sw = float w1 /. float w
6184 and sh = float h1
/. float h in
6188 and y1s
= y1 *. sh in
6189 let rect = (x0s,y0s
,x1s
,y0s
,x1s
,y1s
,x0s,y1s
) in
6190 let color = (r, g, b, a) in
6191 if conf
.verbose
then debugrect rect;
6192 state
.rects <- (pageno, color, rect) :: state
.rects;
6197 | "reload", "" -> reload ()
6199 scan args
"%u %f %f"
6201 let cmd, _ = state
.geomcmds
in
6203 then gotopagexy !wtmode pageno x y
6206 gotopagexy !wtmode pageno x y;
6209 state
.reprf
<- f state
.reprf
6211 | "goto1", args
-> scan args
"%u %f" gotopage
6214 (fun _filename _pageno
->
6215 failwith
"gotounder (Uremote (filename, pageno))")
6218 (fun _filename _dest
->
6219 failwith
"gotounder (Uremotedest (filename, dest))")
6221 scan args
"%u %u %f %f %f %f"
6222 (fun pageno c x0 y0 x1 y1 ->
6223 let color = (0.0, 0.0, 1.0 /. float c, 0.5) in
6224 rectx "rect" pageno color x0 y0 x1 y1;
6227 scan args
"%u %f %f %f %f %f %f %f %f"
6228 (fun pageno r g b alpha x0 y0 x1 y1 ->
6229 addrect pageno r g b alpha x0 y0 x1 y1;
6230 G.postRedisplay "prect"
6233 scan args
"%u %f %f"
6236 match getopaque pageno with
6237 | Some
opaque -> opaque
6240 pgoto optopaque pageno x y;
6241 let rec fixx = function
6244 if l.pageno = pageno
6245 then gotoxy (state
.x - l.pagedispx) state
.y
6250 match conf
.columns
with
6251 | Csingle
_ | Csplit
_ -> 1
6252 | Cmulti
((n, _, _), _) -> n
6254 layout 0 state
.y (state
.winw * mult) state
.winh
6258 | "activatewin", "" -> Wsi.activatewin
()
6259 | "quit", "" -> raise Quit
6262 let l = Config.keys_of_string
keys in
6263 List.iter
(fun (k
, m) -> keyboard k
m) l
6265 adderrfmt "error processing keys" "`%S': %s\n" cmds
@@ exntos exn
6267 | "clearrects", "" ->
6268 Hashtbl.clear state
.prects
;
6269 G.postRedisplay "clearrects"
6271 adderrfmt "remote command"
6272 "error processing remote command: %S\n" cmds
;
6276 let scratch = Bytes.create
80 in
6277 let buf = Buffer.create
80 in
6279 match tempfailureretry
(Unix.read fd
scratch 0) 80 with
6280 | (exception Unix.Unix_error
(Unix.EAGAIN
, _, _)) -> None
6283 if Buffer.length
buf > 0
6285 let s = Buffer.contents
buf in
6293 match Bytes.index_from
scratch ppos '
\n'
with
6294 | pos -> if pos >= n then -1 else pos
6295 | (exception Not_found
) -> -1
6299 Buffer.add_subbytes
buf scratch ppos
(nlpos-ppos
);
6300 let s = Buffer.contents
buf in
6306 Buffer.add_subbytes
buf scratch ppos
(n-ppos
);
6312 let remoteopen path =
6313 try Some
(Unix.openfile
path [Unix.O_NONBLOCK
; Unix.O_RDONLY
] 0o0)
6315 adderrfmt "remoteopen" "error opening %S: %s" path @@ exntos exn
;
6320 let gcconfig = ref E.s in
6321 let trimcachepath = ref E.s in
6322 let rcmdpath = ref E.s in
6323 let pageno = ref None
in
6324 let rootwid = ref 0 in
6325 let openlast = ref false in
6326 let nofc = ref false in
6327 let doreap = ref false in
6328 let csspath = ref None
in
6329 selfexec := Sys.executable_name
;
6332 [("-p", Arg.String
(fun s -> state
.password <- s),
6333 "<password> Set password");
6337 Config.fontpath
:= s;
6338 selfexec := !selfexec ^
" -f " ^
Filename.quote
s;
6340 "<path> Set path to the user interface font");
6344 selfexec := !selfexec ^
" -c " ^
Filename.quote
s;
6345 Config.confpath
:= s),
6346 "<path> Set path to the configuration file");
6348 ("-last", Arg.Set
openlast, " Open last document");
6350 ("-page", Arg.Int
(fun pageno1
-> pageno := Some
(pageno1
-1)),
6351 "<page-number> Jump to page");
6353 ("-tcf", Arg.String
(fun s -> trimcachepath := s),
6354 "<path> Set path to the trim cache file");
6356 ("-dest", Arg.String
(fun s -> state
.nameddest
<- s),
6357 "<named-destination> Set named destination");
6359 ("-wtmode", Arg.Set
wtmode, " Operate in wt mode");
6360 ("-cxack", Arg.Set
cxack, " Cut corners");
6362 ("-remote", Arg.String
(fun s -> rcmdpath := s),
6363 "<path> Set path to the remote commands source");
6365 ("-origin", Arg.String
(fun s -> state
.origin
<- s),
6366 "<original-path> Set original path");
6368 ("-gc", Arg.Set_string
gcconfig,
6369 "<script-path> Collect garbage with the help of a script");
6371 ("-nofc", Arg.Set
nofc, " Do not use fontconfig");
6373 ("-v", Arg.Unit
(fun () ->
6375 "%s\nconfiguration path: %s\n"
6379 exit
0), " Print version and exit");
6381 ("-css", Arg.String
(fun s -> csspath := Some
s),
6382 "<css-path> Style sheet to use for EPUB/HTML");
6384 ("-embed", Arg.Set_int
rootwid,
6385 "<window-id> Embed into window")
6388 (fun s -> state
.path <- s)
6389 ("Usage: " ^
Sys.argv
.(0) ^
" [options] some.pdf\nOptions:");
6392 then selfexec := !selfexec ^
" -wtmode";
6394 let histmode = emptystr state
.path && not
!openlast in
6396 if not
(Config.load !openlast)
6397 then dolog
"failed to load configuration";
6399 begin match !pageno with
6400 | Some
pageno -> state
.anchor <- (pageno, 0.0, 0.0)
6404 if nonemptystr
!gcconfig
6407 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6408 | (exception exn
) -> error
"socketpair for gc failed: %s" @@ exntos exn
6411 match spawn
!gcconfig [(c, 0); (c, 1); (s, -1)] with
6412 | (exception exn
) -> error
"failed to execute gc script: %s" @@ exntos exn
6414 Ne.clo c @@ (fun s -> error
"failed to close gc fd %s" s);
6421 val mutable m_clicks
= 0
6422 val mutable m_click_x
= 0
6423 val mutable m_click_y
= 0
6424 val mutable m_lastclicktime
= infinity
6426 method private cleanup =
6427 state
.roam
<- noroam
;
6428 Hashtbl.iter
(fun _ opaque -> clearmark
opaque) state
.pagemap
6429 method expose
= G.postRedisplay "expose"
6433 | Wsi.Unobscured
-> "unobscured"
6434 | Wsi.PartiallyObscured
-> "partiallyobscured"
6435 | Wsi.FullyObscured
-> "fullyobscured"
6437 vlog "visibility change %s" name
6438 method display = display ()
6439 method map mapped
= vlog "mapped %b" mapped
6440 method reshape w h =
6443 method mouse
b d x y m =
6444 if d && canselect ()
6446 (* http://blogs.msdn.com/b/oldnewthing/archive/2004/10/18/243925.aspx *)
6452 if abs
x - m_click_x
> 10
6453 || abs
y - m_click_y
> 10
6454 || abs_float
(t -. m_lastclicktime
) > 0.3
6456 m_clicks
<- m_clicks
+ 1;
6457 m_lastclicktime
<- t;
6461 G.postRedisplay "cleanup";
6462 state
.uioh <- state
.uioh#button
b d x y m;
6464 else state
.uioh <- state
.uioh#multiclick m_clicks
x y m
6469 m_lastclicktime
<- infinity
;
6470 state
.uioh <- state
.uioh#button
b d x y m
6474 state
.uioh <- state
.uioh#button
b d x y m
6477 state
.mpos
<- (x, y);
6478 state
.uioh <- state
.uioh#motion
x y
6479 method pmotion
x y =
6480 state
.mpos
<- (x, y);
6481 state
.uioh <- state
.uioh#pmotion
x y
6483 let mascm = m land (
6484 Wsi.altmask
+ Wsi.shiftmask
+ Wsi.ctrlmask
+ Wsi.metamask
6487 let x = state
.x and y = state
.y in
6489 if x != state
.x || y != state
.y then self#
cleanup
6491 match state
.keystate
with
6493 let km = k
, mascm in
6496 let modehash = state
.uioh#
modehash in
6497 try Hashtbl.find modehash km
6499 try Hashtbl.find (findkeyhash conf
"global") km
6500 with Not_found
-> KMinsrt
(k
, m)
6502 | KMinsrt
(k
, m) -> keyboard k
m
6503 | KMinsrl
l -> List.iter
(fun (k
, m) -> keyboard k
m) l
6504 | KMmulti
(l, r) -> state
.keystate
<- KSinto
(l, r)
6506 | KSinto
((k'
, m'
) :: [], insrt
) when k'
=k
&& m'
land mascm = m'
->
6507 List.iter
(fun (k
, m) -> keyboard k
m) insrt
;
6508 state
.keystate
<- KSnone
6509 | KSinto
((k'
, m'
) :: keys, insrt
) when k'
=k
&& m'
land mascm = m'
->
6510 state
.keystate
<- KSinto
(keys, insrt
)
6511 | KSinto
_ -> state
.keystate
<- KSnone
6514 state
.mpos
<- (x, y);
6515 state
.uioh <- state
.uioh#pmotion
x y
6516 method leave = state
.mpos
<- (-1, -1)
6517 method winstate wsl
= state
.winstate
<- wsl
6518 method quit
= raise Quit
6521 let wsfd, winw, winh
= Wsi.init
mu !rootwid conf
.cwinw conf
.cwinh platform
in
6523 setbgcol conf
.bgcolor
;
6526 if not
@@ List.exists
GlMisc.check_extension
6527 [ "GL_ARB_texture_rectangle"
6528 ; "GL_EXT_texture_recangle"
6529 ; "GL_NV_texture_rectangle" ]
6530 then (dolog
"OpenGL does not suppport rectangular textures"; exit
1);
6532 if substratis
(GlMisc.get_string `renderer
) 0 "Mesa DRI Intel("
6534 defconf
.sliceheight
<- 1024;
6535 defconf
.texcount
<- 32;
6536 defconf
.usepbo
<- true;
6540 match Unix.socketpair
Unix.PF_UNIX
Unix.SOCK_STREAM
0 with
6541 | (exception exn
) ->
6542 dolog
"socketpair failed: %s" @@ exntos exn
;
6550 setcheckers conf
.checkers
;
6552 opengl_has_pbo := GlMisc.check_extension
"GL_ARB_pixel_buffer_object";
6554 begin match !csspath with
6556 | Some
"" -> conf
.css
<- E.s
6558 let css = filecontents
path in
6559 let l = String.length
css in
6561 if substratis
css (l-2) "\r\n"
6562 then String.sub css 0 (l-2)
6563 else (if css.[l-1] = '
\n'
6564 then String.sub css 0 (l-1)
6568 conf
.angle
, conf
.fitmodel
, (conf
.trimmargins
, conf
.trimfuzz
),
6569 conf
.texcount
, conf
.sliceheight
, conf
.mustoresize
, conf
.colorspace
,
6570 !Config.fontpath
, !trimcachepath, !opengl_has_pbo, not
!nofc
6572 List.iter
GlArray.enable
[`texture_coord
; `vertex
];
6574 reshape ~firsttime
:true winw winh
;
6578 Wsi.settitle
"llpp (history)";
6582 state
.text <- "Opening " ^
(mbtoutf8 state
.path);
6583 opendoc state
.path state
.password;
6587 Wsi.setcursor
Wsi.CURSOR_INHERIT
;
6588 Sys.set_signal
Sys.sighup
(Sys.Signal_handle
(fun _ -> reload ()));
6591 match Unix.waitpid
[Unix.WNOHANG
] ~
-1 with
6592 | (exception (Unix.Unix_error
(Unix.ECHILD
, _, _))) -> ()
6593 | (exception exn
) -> dolog
"Unix.waitpid: %s" @@ exntos exn
6595 | _pid
, _status
-> reap ()
6597 Sys.set_signal
Sys.sigchld
(Sys.Signal_handle
(fun _ -> doreap := true));
6601 if nonemptystr
!rcmdpath
6602 then remoteopen !rcmdpath
6607 let rec loop deadline
=
6613 let r = [state
.ss; state
.wsfd] in
6617 | Some fd
-> fd
:: r
6621 state
.redisplay
<- false;
6628 if deadline
= infinity
6630 else max
0.0 (deadline
-. now)
6635 try Unix.select
r [] [] timeout
6636 with Unix.Unix_error
(Unix.EINTR
, _, _) -> [], [], []
6642 if state
.ghyll
== noghyll
6644 match state
.autoscroll
with
6645 | Some step
when step
!= 0 ->
6646 let y = state
.y + step
in
6647 let fy = if conf
.maxhfit
then state
.winh
else 0 in
6650 then state
.maxy - fy
6651 else if y >= state
.maxy - fy then 0 else y
6653 if state
.mode = View
6654 then gotoxy_and_clear_text state
.x y
6655 else gotoxy state
.x y;
6658 else deadline
+. 0.01
6663 let rec checkfds = function
6665 | fd
:: rest
when fd
= state
.ss ->
6666 let cmd = rcmd state
.ss in
6670 | fd
:: rest
when fd
= state
.wsfd ->
6674 | fd
:: rest
when Some fd
= !optrfd ->
6675 begin match remote fd
with
6676 | None
-> optrfd := remoteopen !rcmdpath;
6677 | opt -> optrfd := opt
6682 dolog
"select returned unknown descriptor";
6688 if deadline
= infinity
6692 match state
.autoscroll
with
6693 | Some step
when step
!= 0 -> deadline1
6694 | _ -> if state
.ghyll
== noghyll
then infinity
else deadline1
6699 match loop infinity
with
6701 Config.save leavebirdseye;
6702 if hasunsavedchanges
()
6704 | _ -> error
"umpossible - infinity reached"