Consistency
[llpp.git] / main.ml
blobfab4165725791737d9aa1f873aeb9a87292ed94d
1 open Utils;;
3 exception Quit;;
5 type under =
6 | Unone
7 | Ulinkuri of string
8 | Ulinkgoto of (int * int)
9 | Utext of facename
10 | Uunexpected of string
11 | Ulaunch of string
12 | Unamed of string
13 | Uremote of (string * int)
14 and facename = string;;
16 type params = (angle * proportional * trimparams
17 * texcount * sliceheight * memsize
18 * colorspace * fontpath * trimcachepath
19 * haspbo)
20 and pageno = int
21 and width = int
22 and height = int
23 and leftx = int
24 and opaque = string
25 and recttype = int
26 and pixmapsize = int
27 and angle = int
28 and proportional = bool
29 and trimmargins = bool
30 and interpagespace = int
31 and texcount = int
32 and sliceheight = int
33 and gen = int
34 and top = float
35 and dtop = float
36 and fontpath = string
37 and trimcachepath = string
38 and memsize = int
39 and aalevel = int
40 and irect = (int * int * int * int)
41 and trimparams = (trimmargins * irect)
42 and colorspace = | Rgb | Bgr | Gray
43 and haspbo = bool
46 type x = int
47 and y = int
48 and tilex = int
49 and tiley = int
50 and tileparams = (x * y * width * height * tilex * tiley)
53 type link =
54 | Lnotfound
55 | Lfound of int
56 and linkdir =
57 | LDfirst
58 | LDlast
59 | LDfirstvisible of (int * int * int)
60 | LDleft of int
61 | LDright of int
62 | LDdown of int
63 | LDup of int
66 type pagewithlinks =
67 | Pwlnotfound
68 | Pwl of int
71 type keymap =
72 | KMinsrt of key
73 | KMinsrl of key list
74 | KMmulti of key list * key list
75 and key = int * int
76 and keyhash = (key, keymap) Hashtbl.t
77 and keystate =
78 | KSnone
79 | KSinto of (key list * key list)
82 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
83 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
85 type pipe = (Unix.file_descr * Unix.file_descr);;
87 external init : pipe -> params -> unit = "ml_init";;
88 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
89 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
90 external getpdimrect : int -> float array = "ml_getpdimrect";;
91 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
92 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
93 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
94 external measurestr : int -> string -> float = "ml_measure_string";;
95 external postprocess :
96 opaque -> int -> int -> int -> (int * string * int) -> int
97 = "ml_postprocess";;
98 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
99 external platform : unit -> platform = "ml_platform";;
100 external setaalevel : int -> unit = "ml_setaalevel";;
101 external realloctexts : int -> bool = "ml_realloctexts";;
102 external findlink : opaque -> linkdir -> link = "ml_findlink";;
103 external getlink : opaque -> int -> under = "ml_getlink";;
104 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
105 external getlinkcount : opaque -> int = "ml_getlinkcount";;
106 external findpwl : int -> int -> pagewithlinks = "ml_find_page_with_links"
107 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
108 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
109 external freepbo : string -> unit = "ml_freepbo";;
110 external unmappbo : string -> unit = "ml_unmappbo";;
111 external pbousable : unit -> bool = "ml_pbo_usable";;
112 external unproject : opaque -> int -> int -> (int * int) option
113 = "ml_unproject";;
114 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
116 let platform_to_string = function
117 | Punknown -> "unknown"
118 | Plinux -> "Linux"
119 | Posx -> "OSX"
120 | Psun -> "Sun"
121 | Pfreebsd -> "FreeBSD"
122 | Pdragonflybsd -> "DragonflyBSD"
123 | Popenbsd -> "OpenBSD"
124 | Pnetbsd -> "NetBSD"
125 | Pcygwin -> "Cygwin"
128 let platform = platform ();;
130 let now = Unix.gettimeofday;;
132 let popen cmd fda =
133 if platform = Pcygwin
134 then (
135 let sh = "/bin/sh" in
136 let args = [|sh; "-c"; cmd|] in
137 let rec std si so se = function
138 | [] -> si, so, se
139 | (fd, 0) :: rest -> std fd so se rest
140 | (fd, -1) :: rest ->
141 Unix.set_close_on_exec fd;
142 std si so se rest
143 | (_, n) :: _ ->
144 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
146 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
147 ignore (Unix.create_process sh args si so se)
149 else popen cmd fda;
152 type mpos = int * int
153 and mstate =
154 | Msel of (mpos * mpos)
155 | Mpan of mpos
156 | Mscrolly | Mscrollx
157 | Mzoom of (int * int)
158 | Mzoomrect of (mpos * mpos)
159 | Mnone
162 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
163 and onkey = string -> int -> te
164 and ondone = string -> unit
165 and histcancel = unit -> unit
166 and onhist = ((histcmd -> string) * histcancel)
167 and histcmd = HCnext | HCprev | HCfirst | HClast
168 and cancelonempty = bool
169 and te =
170 | TEstop
171 | TEdone of string
172 | TEcont of string
173 | TEswitch of textentry
176 type 'a circbuf =
177 { store : 'a array
178 ; mutable rc : int
179 ; mutable wc : int
180 ; mutable len : int
184 let bound v minv maxv =
185 max minv (min maxv v);
188 let cbnew n v =
189 { store = Array.create n v
190 ; rc = 0
191 ; wc = 0
192 ; len = 0
196 let cbcap b = Array.length b.store;;
198 let cbput b v =
199 let cap = cbcap b in
200 b.store.(b.wc) <- v;
201 b.wc <- (b.wc + 1) mod cap;
202 b.rc <- b.wc;
203 b.len <- min (b.len + 1) cap;
206 let cbempty b = b.len = 0;;
208 let cbgetg b circular dir =
209 if cbempty b
210 then b.store.(0)
211 else
212 let rc = b.rc + dir in
213 let rc =
214 if circular
215 then (
216 if rc = -1
217 then b.len-1
218 else (
219 if rc >= b.len
220 then 0
221 else rc
224 else bound rc 0 (b.len-1)
226 b.rc <- rc;
227 b.store.(rc);
230 let cbget b = cbgetg b false;;
231 let cbgetc b = cbgetg b true;;
233 let drawstring size x y s =
234 Gl.enable `blend;
235 Gl.enable `texture_2d;
236 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
237 ignore (drawstr size x y s);
238 Gl.disable `blend;
239 Gl.disable `texture_2d;
242 let drawstring1 size x y s =
243 drawstr size x y s;
246 let drawstring2 size x y fmt =
247 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
250 type page =
251 { pageno : int
252 ; pagedimno : int
253 ; pagew : int
254 ; pageh : int
255 ; pagex : int
256 ; pagey : int
257 ; pagevw : int
258 ; pagevh : int
259 ; pagedispx : int
260 ; pagedispy : int
261 ; pagecol : int
265 let debugl l =
266 dolog "l %d dim=%d {" l.pageno l.pagedimno;
267 dolog " WxH %dx%d" l.pagew l.pageh;
268 dolog " vWxH %dx%d" l.pagevw l.pagevh;
269 dolog " pagex,y %d,%d" l.pagex l.pagey;
270 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
271 dolog " column %d" l.pagecol;
272 dolog "}";
275 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
276 dolog "rect {";
277 dolog " x0,y0=(% f, % f)" x0 y0;
278 dolog " x1,y1=(% f, % f)" x1 y1;
279 dolog " x2,y2=(% f, % f)" x2 y2;
280 dolog " x3,y3=(% f, % f)" x3 y3;
281 dolog "}";
284 type multicolumns = multicol * pagegeom
285 and singlecolumn = pagegeom
286 and splitcolumns = columncount * pagegeom
287 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
288 and multicol = columncount * covercount * covercount
289 and pdimno = int
290 and columncount = int
291 and covercount = int;;
293 type conf =
294 { mutable scrollbw : int
295 ; mutable scrollh : int
296 ; mutable icase : bool
297 ; mutable preload : bool
298 ; mutable pagebias : int
299 ; mutable verbose : bool
300 ; mutable debug : bool
301 ; mutable scrollstep : int
302 ; mutable hscrollstep : int
303 ; mutable maxhfit : bool
304 ; mutable crophack : bool
305 ; mutable autoscrollstep : int
306 ; mutable maxwait : float option
307 ; mutable hlinks : bool
308 ; mutable underinfo : bool
309 ; mutable interpagespace : interpagespace
310 ; mutable zoom : float
311 ; mutable presentation : bool
312 ; mutable angle : angle
313 ; mutable cwinw : int
314 ; mutable cwinh : int
315 ; mutable savebmarks : bool
316 ; mutable proportional : proportional
317 ; mutable trimmargins : trimmargins
318 ; mutable trimfuzz : irect
319 ; mutable memlimit : memsize
320 ; mutable texcount : texcount
321 ; mutable sliceheight : sliceheight
322 ; mutable thumbw : width
323 ; mutable jumpback : bool
324 ; mutable bgcolor : float * float * float
325 ; mutable bedefault : bool
326 ; mutable scrollbarinpm : bool
327 ; mutable tilew : int
328 ; mutable tileh : int
329 ; mutable mustoresize : memsize
330 ; mutable checkers : bool
331 ; mutable aalevel : int
332 ; mutable urilauncher : string
333 ; mutable pathlauncher : string
334 ; mutable colorspace : colorspace
335 ; mutable invert : bool
336 ; mutable colorscale : float
337 ; mutable redirectstderr : bool
338 ; mutable ghyllscroll : (int * int * int) option
339 ; mutable columns : columns
340 ; mutable beyecolumns : columncount option
341 ; mutable selcmd : string
342 ; mutable updatecurs : bool
343 ; mutable keyhashes : (string * keyhash) list
344 ; mutable hfsize : int
345 ; mutable pgscale : float
346 ; mutable usepbo : bool
347 ; mutable wheelbypage : bool
348 ; mutable stcmd : string
350 and columns =
351 | Csingle of singlecolumn
352 | Cmulti of multicolumns
353 | Csplit of splitcolumns
356 type anchor = pageno * top * dtop;;
358 type outline = string * int * anchor;;
360 type rect = float * float * float * float * float * float * float * float;;
362 type tile = opaque * pixmapsize * elapsed
363 and elapsed = float;;
364 type pagemapkey = pageno * gen;;
365 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
366 and row = int
367 and col = int;;
369 let emptyanchor = (0, 0.0, 0.0);;
371 type infochange = | Memused | Docinfo | Pdim;;
373 class type uioh = object
374 method display : unit
375 method key : int -> int -> uioh
376 method button : int -> bool -> int -> int -> int -> uioh
377 method motion : int -> int -> uioh
378 method pmotion : int -> int -> uioh
379 method infochanged : infochange -> unit
380 method scrollpw : (int * float * float)
381 method scrollph : (int * float * float)
382 method modehash : keyhash
383 end;;
385 type mode =
386 | Birdseye of (conf * leftx * pageno * pageno * anchor)
387 | Textentry of (textentry * onleave)
388 | View
389 | LinkNav of linktarget
390 and onleave = leavetextentrystatus -> unit
391 and leavetextentrystatus = | Cancel | Confirm
392 and helpitem = string * int * action
393 and action =
394 | Noaction
395 | Action of (uioh -> uioh)
396 and linktarget =
397 | Ltexact of (pageno * int)
398 | Ltgendir of int
401 let isbirdseye = function Birdseye _ -> true | _ -> false;;
402 let istextentry = function Textentry _ -> true | _ -> false;;
404 type currently =
405 | Idle
406 | Loading of (page * gen)
407 | Tiling of (
408 page * opaque * colorspace * angle * gen * col * row * width * height
410 | Outlining of outline list
413 let emptykeyhash = Hashtbl.create 0;;
414 let nouioh : uioh = object (self)
415 method display = ()
416 method key _ _ = self
417 method button _ _ _ _ _ = self
418 method motion _ _ = self
419 method pmotion _ _ = self
420 method infochanged _ = ()
421 method scrollpw = (0, nan, nan)
422 method scrollph = (0, nan, nan)
423 method modehash = emptykeyhash
424 end;;
426 type state =
427 { mutable sr : Unix.file_descr
428 ; mutable sw : Unix.file_descr
429 ; mutable wsfd : Unix.file_descr
430 ; mutable errfd : Unix.file_descr option
431 ; mutable stderr : Unix.file_descr
432 ; mutable errmsgs : Buffer.t
433 ; mutable newerrmsgs : bool
434 ; mutable w : int
435 ; mutable x : int
436 ; mutable y : int
437 ; mutable scrollw : int
438 ; mutable hscrollh : int
439 ; mutable anchor : anchor
440 ; mutable ranchors : (string * string * anchor) list
441 ; mutable maxy : int
442 ; mutable layout : page list
443 ; pagemap : (pagemapkey, opaque) Hashtbl.t
444 ; tilemap : (tilemapkey, tile) Hashtbl.t
445 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
446 ; mutable pdims : (pageno * width * height * leftx) list
447 ; mutable pagecount : int
448 ; mutable currently : currently
449 ; mutable mstate : mstate
450 ; mutable searchpattern : string
451 ; mutable rects : (pageno * recttype * rect) list
452 ; mutable rects1 : (pageno * recttype * rect) list
453 ; mutable text : string
454 ; mutable winstate : Wsi.winstate list
455 ; mutable mode : mode
456 ; mutable uioh : uioh
457 ; mutable outlines : outline array
458 ; mutable bookmarks : outline list
459 ; mutable path : string
460 ; mutable password : string
461 ; mutable nameddest : string
462 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
463 ; mutable memused : memsize
464 ; mutable gen : gen
465 ; mutable throttle : (page list * int * float) option
466 ; mutable autoscroll : int option
467 ; mutable ghyll : (int option -> unit)
468 ; mutable help : helpitem array
469 ; mutable docinfo : (int * string) list
470 ; mutable texid : GlTex.texture_id option
471 ; hists : hists
472 ; mutable prevzoom : float
473 ; mutable progress : float
474 ; mutable redisplay : bool
475 ; mutable mpos : mpos
476 ; mutable keystate : keystate
477 ; mutable glinks : bool
478 ; mutable prevcolumns : (columns * float) option
479 ; mutable winw : int
480 ; mutable winh : int
481 ; mutable reprf : (unit -> unit)
483 and hists =
484 { pat : string circbuf
485 ; pag : string circbuf
486 ; nav : anchor circbuf
487 ; sel : string circbuf
491 let defconf =
492 { scrollbw = 7
493 ; scrollh = 12
494 ; icase = true
495 ; preload = true
496 ; pagebias = 0
497 ; verbose = false
498 ; debug = false
499 ; scrollstep = 24
500 ; hscrollstep = 24
501 ; maxhfit = true
502 ; crophack = false
503 ; autoscrollstep = 2
504 ; maxwait = None
505 ; hlinks = false
506 ; underinfo = false
507 ; interpagespace = 2
508 ; zoom = 1.0
509 ; presentation = false
510 ; angle = 0
511 ; cwinw = 900
512 ; cwinh = 900
513 ; savebmarks = true
514 ; proportional = true
515 ; trimmargins = false
516 ; trimfuzz = (0,0,0,0)
517 ; memlimit = 32 lsl 20
518 ; texcount = 256
519 ; sliceheight = 24
520 ; thumbw = 76
521 ; jumpback = true
522 ; bgcolor = (0.5, 0.5, 0.5)
523 ; bedefault = false
524 ; scrollbarinpm = true
525 ; tilew = 2048
526 ; tileh = 2048
527 ; mustoresize = 256 lsl 20
528 ; checkers = true
529 ; aalevel = 8
530 ; urilauncher =
531 (match platform with
532 | Plinux | Pfreebsd | Pdragonflybsd
533 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
534 | Posx -> "open \"%s\""
535 | Pcygwin -> "cygstart \"%s\""
536 | Punknown -> "echo %s")
537 ; pathlauncher = "lp \"%s\""
538 ; selcmd =
539 (match platform with
540 | Plinux | Pfreebsd | Pdragonflybsd
541 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
542 | Posx -> "pbcopy"
543 | Pcygwin -> "wsel"
544 | Punknown -> "cat")
545 ; colorspace = Rgb
546 ; invert = false
547 ; colorscale = 1.0
548 ; redirectstderr = false
549 ; ghyllscroll = None
550 ; columns = Csingle [||]
551 ; beyecolumns = None
552 ; updatecurs = false
553 ; hfsize = 12
554 ; pgscale = 1.0
555 ; usepbo = false
556 ; wheelbypage = false
557 ; stcmd = "echo SyncTex"
558 ; keyhashes =
559 let mk n = (n, Hashtbl.create 1) in
560 [ mk "global"
561 ; mk "info"
562 ; mk "help"
563 ; mk "outline"
564 ; mk "listview"
565 ; mk "birdseye"
566 ; mk "textentry"
567 ; mk "links"
568 ; mk "view"
573 let wtmode = ref false;;
575 let findkeyhash c name =
576 try List.assoc name c.keyhashes
577 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
580 let conf = { defconf with angle = defconf.angle };;
582 let pgscale h = truncate (float h *. conf.pgscale);;
584 type fontstate =
585 { mutable fontsize : int
586 ; mutable wwidth : float
587 ; mutable maxrows : int
591 let fstate =
592 { fontsize = 14
593 ; wwidth = nan
594 ; maxrows = -1
598 let geturl s =
599 let colonpos = try String.index s ':' with Not_found -> -1 in
600 let len = String.length s in
601 if colonpos >= 0 && colonpos + 3 < len
602 then (
603 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
604 then
605 let schemestartpos =
606 try String.rindex_from s colonpos ' '
607 with Not_found -> -1
609 let scheme =
610 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
612 match scheme with
613 | "http" | "ftp" | "mailto" ->
614 let epos =
615 try String.index_from s colonpos ' '
616 with Not_found -> len
618 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
619 | _ -> ""
620 else ""
622 else ""
625 let gotouri uri =
626 if String.length conf.urilauncher = 0
627 then print_endline uri
628 else (
629 let url = geturl uri in
630 if String.length url = 0
631 then print_endline uri
632 else
633 let re = Str.regexp "%s" in
634 let command = Str.global_replace re url conf.urilauncher in
635 try popen command []
636 with exn ->
637 Printf.eprintf
638 "failed to execute `%s': %s\n" command (exntos exn);
639 flush stderr;
643 let version () =
644 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
645 (platform_to_string platform) Sys.word_size Sys.ocaml_version
648 let makehelp () =
649 let strings = version () :: "" :: Help.keys in
650 Array.of_list (
651 List.map (fun s ->
652 let url = geturl s in
653 if String.length url > 0
654 then (s, 0, Action (fun u -> gotouri url; u))
655 else (s, 0, Noaction)
656 ) strings);
659 let noghyll _ = ();;
660 let firstgeomcmds = "", [];;
661 let noreprf () = ();;
663 let state =
664 { sr = Unix.stdin
665 ; sw = Unix.stdin
666 ; wsfd = Unix.stdin
667 ; errfd = None
668 ; stderr = Unix.stderr
669 ; errmsgs = Buffer.create 0
670 ; newerrmsgs = false
671 ; x = 0
672 ; y = 0
673 ; w = 0
674 ; scrollw = 0
675 ; hscrollh = 0
676 ; anchor = emptyanchor
677 ; ranchors = []
678 ; layout = []
679 ; maxy = max_int
680 ; tilelru = Queue.create ()
681 ; pagemap = Hashtbl.create 10
682 ; tilemap = Hashtbl.create 10
683 ; pdims = []
684 ; pagecount = 0
685 ; currently = Idle
686 ; mstate = Mnone
687 ; rects = []
688 ; rects1 = []
689 ; text = ""
690 ; mode = View
691 ; winstate = []
692 ; searchpattern = ""
693 ; outlines = [||]
694 ; bookmarks = []
695 ; path = ""
696 ; password = ""
697 ; nameddest = ""
698 ; geomcmds = firstgeomcmds
699 ; hists =
700 { nav = cbnew 10 emptyanchor
701 ; pat = cbnew 10 ""
702 ; pag = cbnew 10 ""
703 ; sel = cbnew 10 ""
705 ; memused = 0
706 ; gen = 0
707 ; throttle = None
708 ; autoscroll = None
709 ; ghyll = noghyll
710 ; help = makehelp ()
711 ; docinfo = []
712 ; texid = None
713 ; prevzoom = 1.0
714 ; progress = -1.0
715 ; uioh = nouioh
716 ; redisplay = true
717 ; mpos = (-1, -1)
718 ; keystate = KSnone
719 ; glinks = false
720 ; prevcolumns = None
721 ; winw = -1
722 ; winh = -1
723 ; reprf = noreprf
727 let setfontsize n =
728 fstate.fontsize <- n;
729 fstate.wwidth <- measurestr fstate.fontsize "w";
730 fstate.maxrows <- (state.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
733 let vlog fmt =
734 if conf.verbose
735 then
736 Printf.kprintf prerr_endline fmt
737 else
738 Printf.kprintf ignore fmt
741 let launchpath () =
742 if String.length conf.pathlauncher = 0
743 then print_endline state.path
744 else (
745 let re = Str.regexp "%s" in
746 let command = Str.global_replace re state.path conf.pathlauncher in
747 try popen command []
748 with exn ->
749 Printf.eprintf "failed to execute `%s': %s\n" command (exntos exn);
750 flush stderr;
754 module Ne = struct
755 type 'a t = | Res of 'a | Exn of exn;;
757 let pipe () =
758 try Res (Unix.pipe ())
759 with exn -> Exn exn
762 let clo fd f =
763 try tempfailureretry Unix.close fd
764 with exn -> f (exntos exn)
767 let dup fd =
768 try Res (tempfailureretry Unix.dup fd)
769 with exn -> Exn exn
772 let dup2 fd1 fd2 =
773 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
774 with exn -> Exn exn
776 end;;
778 let redirectstderr () =
779 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
780 if conf.redirectstderr
781 then
782 match Ne.pipe () with
783 | Ne.Exn exn ->
784 dolog "failed to create stderr redirection pipes: %s" (exntos exn)
786 | Ne.Res (r, w) ->
787 begin match Ne.dup Unix.stderr with
788 | Ne.Exn exn ->
789 dolog "failed to dup stderr: %s" (exntos exn);
790 Ne.clo r (clofail "pipe/r");
791 Ne.clo w (clofail "pipe/w");
793 | Ne.Res dupstderr ->
794 begin match Ne.dup2 w Unix.stderr with
795 | Ne.Exn exn ->
796 dolog "failed to dup2 to stderr: %s" (exntos exn);
797 Ne.clo dupstderr (clofail "stderr duplicate");
798 Ne.clo r (clofail "redir pipe/r");
799 Ne.clo w (clofail "redir pipe/w");
801 | Ne.Res () ->
802 state.stderr <- dupstderr;
803 state.errfd <- Some r;
804 end;
806 else (
807 state.newerrmsgs <- false;
808 begin match state.errfd with
809 | Some fd ->
810 begin match Ne.dup2 state.stderr Unix.stderr with
811 | Ne.Exn exn ->
812 dolog "failed to dup2 original stderr: %s" (exntos exn)
813 | Ne.Res () ->
814 Ne.clo fd (clofail "dup of stderr");
815 state.errfd <- None;
816 end;
817 | None -> ()
818 end;
819 prerr_string (Buffer.contents state.errmsgs);
820 flush stderr;
821 Buffer.clear state.errmsgs;
825 module G =
826 struct
827 let postRedisplay who =
828 if conf.verbose
829 then prerr_endline ("redisplay for " ^ who);
830 state.redisplay <- true;
832 end;;
834 let getopaque pageno =
835 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
836 with Not_found -> None
839 let putopaque pageno opaque =
840 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
843 let pagetranslatepoint l x y =
844 let dy = y - l.pagedispy in
845 let y = dy + l.pagey in
846 let dx = x - l.pagedispx in
847 let x = dx + l.pagex in
848 (x, y);
851 let onppundermouse g x y d =
852 let rec f = function
853 | l :: rest ->
854 begin match getopaque l.pageno with
855 | Some opaque ->
856 let x0 = l.pagedispx in
857 let x1 = x0 + l.pagevw in
858 let y0 = l.pagedispy in
859 let y1 = y0 + l.pagevh in
860 if y >= y0 && y <= y1 && x >= x0 && x <= x1
861 then
862 let px, py = pagetranslatepoint l x y in
863 match g opaque l px py with
864 | Some res -> res
865 | None -> f rest
866 else f rest
867 | _ ->
868 f rest
870 | [] -> d
872 f state.layout
875 let getunder x y =
876 let g opaque _ px py =
877 match whatsunder opaque px py with
878 | Unone -> None
879 | under -> Some under
881 onppundermouse g x y Unone
884 let unproject x y =
885 let g opaque l x y =
886 match unproject opaque x y with
887 | Some (x, y) -> Some (Some (l.pageno, x, y))
888 | None -> None
890 onppundermouse g x y None;
893 let showtext c s =
894 state.text <- Printf.sprintf "%c%s" c s;
895 G.postRedisplay "showtext";
898 let undertext = function
899 | Unone -> "none"
900 | Ulinkuri s -> s
901 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
902 | Utext s -> "font: " ^ s
903 | Uunexpected s -> "unexpected: " ^ s
904 | Ulaunch s -> "launch: " ^ s
905 | Unamed s -> "named: " ^ s
906 | Uremote (filename, pageno) ->
907 Printf.sprintf "%s: page %d" filename (pageno+1)
910 let updateunder x y =
911 match getunder x y with
912 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
913 | Ulinkuri uri ->
914 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
915 Wsi.setcursor Wsi.CURSOR_INFO
916 | Ulinkgoto (pageno, _) ->
917 if conf.underinfo
918 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
919 Wsi.setcursor Wsi.CURSOR_INFO
920 | Utext s ->
921 if conf.underinfo then showtext 'f' ("ont: " ^ s);
922 Wsi.setcursor Wsi.CURSOR_TEXT
923 | Uunexpected s ->
924 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
925 Wsi.setcursor Wsi.CURSOR_INHERIT
926 | Ulaunch s ->
927 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
928 Wsi.setcursor Wsi.CURSOR_INHERIT
929 | Unamed s ->
930 if conf.underinfo then showtext 'n' ("amed: " ^ s);
931 Wsi.setcursor Wsi.CURSOR_INHERIT
932 | Uremote (filename, pageno) ->
933 if conf.underinfo then showtext 'r'
934 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
935 Wsi.setcursor Wsi.CURSOR_INFO
938 let showlinktype under =
939 if conf.underinfo
940 then
941 match under with
942 | Unone -> ()
943 | under ->
944 let s = undertext under in
945 showtext ' ' s
948 let addchar s c =
949 let b = Buffer.create (String.length s + 1) in
950 Buffer.add_string b s;
951 Buffer.add_char b c;
952 Buffer.contents b;
955 let colorspace_of_string s =
956 match String.lowercase s with
957 | "rgb" -> Rgb
958 | "bgr" -> Bgr
959 | "gray" -> Gray
960 | _ -> failwith "invalid colorspace"
963 let int_of_colorspace = function
964 | Rgb -> 0
965 | Bgr -> 1
966 | Gray -> 2
969 let colorspace_of_int = function
970 | 0 -> Rgb
971 | 1 -> Bgr
972 | 2 -> Gray
973 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
976 let colorspace_to_string = function
977 | Rgb -> "rgb"
978 | Bgr -> "bgr"
979 | Gray -> "gray"
982 let intentry_with_suffix text key =
983 let c =
984 if key >= 32 && key < 127
985 then Char.chr key
986 else '\000'
988 match Char.lowercase c with
989 | '0' .. '9' ->
990 let text = addchar text c in
991 TEcont text
993 | 'k' | 'm' | 'g' ->
994 let text = addchar text c in
995 TEcont text
997 | _ ->
998 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
999 TEcont text
1002 let multicolumns_to_string (n, a, b) =
1003 if a = 0 && b = 0
1004 then Printf.sprintf "%d" n
1005 else Printf.sprintf "%d,%d,%d" n a b;
1008 let multicolumns_of_string s =
1010 (int_of_string s, 0, 0)
1011 with _ ->
1012 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
1013 if a > 1 || b > 1
1014 then failwith "subtly broken"; (n, a, b)
1018 let readcmd fd =
1019 let s = "xxxx" in
1020 let n = tempfailureretry (Unix.read fd s 0) 4 in
1021 if n != 4 then failwith "incomplete read(len)";
1022 let len = 0
1023 lor (Char.code s.[0] lsl 24)
1024 lor (Char.code s.[1] lsl 16)
1025 lor (Char.code s.[2] lsl 8)
1026 lor (Char.code s.[3] lsl 0)
1028 let s = String.create len in
1029 let n = tempfailureretry (Unix.read fd s 0) len in
1030 if n != len then failwith "incomplete read(data)";
1034 let btod b = if b then 1 else 0;;
1036 let wcmd fmt =
1037 let b = Buffer.create 16 in
1038 Buffer.add_string b "llll";
1039 Printf.kbprintf
1040 (fun b ->
1041 let s = Buffer.contents b in
1042 let n = String.length s in
1043 let len = n - 4 in
1044 (* dolog "wcmd %S" (String.sub s 4 len); *)
1045 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1046 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1047 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1048 s.[3] <- Char.chr (len land 0xff);
1049 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1050 if n' != n then failwith "write failed";
1051 ) b fmt;
1054 let calcips h =
1055 let d = state.winh - h in
1056 max conf.interpagespace ((d + 1) / 2)
1059 let rowyh (c, coverA, coverB) b n =
1060 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1061 then
1062 let _, _, vy, (_, _, h, _) = b.(n) in
1063 (vy, h)
1064 else
1065 let n' = n - coverA in
1066 let d = n' mod c in
1067 let s = n - d in
1068 let e = min state.pagecount (s + c) in
1069 let rec find m miny maxh = if m = e then miny, maxh else
1070 let _, _, y, (_, _, h, _) = b.(m) in
1071 let miny = min miny y in
1072 let maxh = max maxh h in
1073 find (m+1) miny maxh
1074 in find s max_int 0
1077 let calcheight () =
1078 match conf.columns with
1079 | Cmulti ((_, _, _) as cl, b) ->
1080 if Array.length b > 0
1081 then
1082 let y, h = rowyh cl b (Array.length b - 1) in
1083 y + h + (if conf.presentation then calcips h else 0)
1084 else 0
1085 | Csingle b ->
1086 if Array.length b > 0
1087 then
1088 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1089 y + h + (if conf.presentation then calcips h else 0)
1090 else 0
1091 | Csplit (_, b) ->
1092 if Array.length b > 0
1093 then
1094 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1095 y + h
1096 else 0
1099 let getpageyh pageno =
1100 let pageno = bound pageno 0 (state.pagecount-1) in
1101 match conf.columns with
1102 | Csingle b ->
1103 if Array.length b = 0
1104 then 0, 0
1105 else
1106 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1107 let y =
1108 if conf.presentation
1109 then y - calcips h
1110 else y
1112 y, h
1113 | Cmulti (cl, b) ->
1114 if Array.length b = 0
1115 then 0, 0
1116 else
1117 let y, h = rowyh cl b pageno in
1118 let y =
1119 if conf.presentation
1120 then y - calcips h
1121 else y
1123 y, h
1124 | Csplit (c, b) ->
1125 if Array.length b = 0
1126 then 0, 0
1127 else
1128 let n = pageno*c in
1129 let (_, _, y, (_, _, h, _)) = b.(n) in
1130 y, h
1133 let getpagedim pageno =
1134 let rec f ppdim l =
1135 match l with
1136 | (n, _, _, _) as pdim :: rest ->
1137 if n >= pageno
1138 then (if n = pageno then pdim else ppdim)
1139 else f pdim rest
1141 | [] -> ppdim
1143 f (-1, -1, -1, -1) state.pdims
1146 let getpagey pageno = fst (getpageyh pageno);;
1148 let nogeomcmds cmds =
1149 match cmds with
1150 | s, [] -> String.length s = 0
1151 | _ -> false
1154 let page_of_y y =
1155 let ((c, coverA, coverB) as cl), b =
1156 match conf.columns with
1157 | Csingle b -> (1, 0, 0), b
1158 | Cmulti (c, b) -> c, b
1159 | Csplit (_, b) -> (1, 0, 0), b
1161 if Array.length b = 0
1162 then -1
1163 else
1164 let rec bsearch nmin nmax =
1165 if nmin > nmax
1166 then bound nmin 0 (state.pagecount-1)
1167 else
1168 let n = (nmax + nmin) / 2 in
1169 let vy, h = rowyh cl b n in
1170 let y0, y1 =
1171 if conf.presentation
1172 then
1173 let ips = calcips h in
1174 let y0 = vy - ips in
1175 let y1 = vy + h + ips in
1176 y0, y1
1177 else (
1178 if n = 0
1179 then 0, vy + h + conf.interpagespace
1180 else
1181 let y0 = vy - conf.interpagespace in
1182 y0, y0 + h + conf.interpagespace
1185 if y >= y0 && y < y1
1186 then (
1187 if c = 1
1188 then n
1189 else (
1190 if n > coverA
1191 then
1192 if n < state.pagecount - coverB
1193 then ((n-coverA)/c)*c + coverA
1194 else n
1195 else n
1198 else (
1199 if y > y0
1200 then bsearch (n+1) nmax
1201 else bsearch nmin (n-1)
1204 let r = bsearch 0 (state.pagecount-1) in
1208 let layoutN ((columns, coverA, coverB), b) y sh =
1209 let sh = sh - state.hscrollh in
1210 let rec fold accu n =
1211 if n = Array.length b
1212 then accu
1213 else
1214 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1215 if (vy - y) > sh &&
1216 (n = coverA - 1
1217 || n = state.pagecount - coverB
1218 || (n - coverA) mod columns = columns - 1)
1219 then accu
1220 else
1221 let accu =
1222 if vy + h > y
1223 then
1224 let pagey = max 0 (y - vy) in
1225 let pagedispy = if pagey > 0 then 0 else vy - y in
1226 let pagedispx, pagex =
1227 let pdx =
1228 if n = coverA - 1 || n = state.pagecount - coverB
1229 then state.x + (state.winw - state.scrollw - w) / 2
1230 else dx + xoff + state.x
1232 if pdx < 0
1233 then 0, -pdx
1234 else pdx, 0
1236 let pagevw =
1237 let vw = state.winw - state.scrollw - pagedispx in
1238 let pw = w - pagex in
1239 min vw pw
1241 let pagevh = min (h - pagey) (sh - pagedispy) in
1242 if pagevw > 0 && pagevh > 0
1243 then
1244 let e =
1245 { pageno = n
1246 ; pagedimno = pdimno
1247 ; pagew = w
1248 ; pageh = h
1249 ; pagex = pagex
1250 ; pagey = pagey
1251 ; pagevw = pagevw
1252 ; pagevh = pagevh
1253 ; pagedispx = pagedispx
1254 ; pagedispy = pagedispy
1255 ; pagecol = 0
1258 e :: accu
1259 else
1260 accu
1261 else
1262 accu
1264 fold accu (n+1)
1266 List.rev (fold [] (page_of_y y));
1269 let layoutS (columns, b) y sh =
1270 let sh = sh - state.hscrollh in
1271 let rec fold accu n =
1272 if n = Array.length b
1273 then accu
1274 else
1275 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1276 if (vy - y) > sh
1277 then accu
1278 else
1279 let accu =
1280 if vy + pageh > y
1281 then
1282 let x = xoff + state.x in
1283 let pagey = max 0 (y - vy) in
1284 let pagedispy = if pagey > 0 then 0 else vy - y in
1285 let pagedispx, pagex =
1286 if px = 0
1287 then (
1288 if x < 0
1289 then 0, -x
1290 else x, 0
1292 else (
1293 let px = px - x in
1294 if px < 0
1295 then -px, 0
1296 else 0, px
1299 let pagecolw = pagew/columns in
1300 let pagedispx =
1301 if pagecolw < state.winw
1302 then pagedispx + ((state.winw - state.scrollw - pagecolw) / 2)
1303 else pagedispx
1305 let pagevw =
1306 let vw = state.winw - pagedispx - state.scrollw in
1307 let pw = pagew - pagex in
1308 min vw pw
1310 let pagevw = min pagevw pagecolw in
1311 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1312 if pagevw > 0 && pagevh > 0
1313 then
1314 let e =
1315 { pageno = n/columns
1316 ; pagedimno = pdimno
1317 ; pagew = pagew
1318 ; pageh = pageh
1319 ; pagex = pagex
1320 ; pagey = pagey
1321 ; pagevw = pagevw
1322 ; pagevh = pagevh
1323 ; pagedispx = pagedispx
1324 ; pagedispy = pagedispy
1325 ; pagecol = n mod columns
1328 e :: accu
1329 else
1330 accu
1331 else
1332 accu
1334 fold accu (n+1)
1336 List.rev (fold [] 0)
1339 let layout y sh =
1340 if nogeomcmds state.geomcmds
1341 then
1342 match conf.columns with
1343 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1344 | Cmulti c -> layoutN c y sh
1345 | Csplit s -> layoutS s y sh
1346 else []
1349 let clamp incr =
1350 let y = state.y + incr in
1351 let y = max 0 y in
1352 let y = min y (state.maxy - (if conf.maxhfit then state.winh else 0)) in
1356 let itertiles l f =
1357 let tilex = l.pagex mod conf.tilew in
1358 let tiley = l.pagey mod conf.tileh in
1360 let col = l.pagex / conf.tilew in
1361 let row = l.pagey / conf.tileh in
1363 let rec rowloop row y0 dispy h =
1364 if h = 0
1365 then ()
1366 else (
1367 let dh = conf.tileh - y0 in
1368 let dh = min h dh in
1369 let rec colloop col x0 dispx w =
1370 if w = 0
1371 then ()
1372 else (
1373 let dw = conf.tilew - x0 in
1374 let dw = min w dw in
1376 f col row dispx dispy x0 y0 dw dh;
1377 colloop (col+1) 0 (dispx+dw) (w-dw)
1380 colloop col tilex l.pagedispx l.pagevw;
1381 rowloop (row+1) 0 (dispy+dh) (h-dh)
1384 if l.pagevw > 0 && l.pagevh > 0
1385 then rowloop row tiley l.pagedispy l.pagevh;
1388 let gettileopaque l col row =
1389 let key =
1390 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1392 try Some (Hashtbl.find state.tilemap key)
1393 with Not_found -> None
1396 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1397 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1398 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1401 let drawtiles l color =
1402 GlDraw.color color;
1403 let f col row x y tilex tiley w h =
1404 match gettileopaque l col row with
1405 | Some (opaque, _, t) ->
1406 let params = x, y, w, h, tilex, tiley in
1407 if conf.invert
1408 then (
1409 Gl.enable `blend;
1410 GlFunc.blend_func `zero `one_minus_src_color;
1412 drawtile params opaque;
1413 if conf.invert
1414 then Gl.disable `blend;
1415 if conf.debug
1416 then (
1417 let s = Printf.sprintf
1418 "%d[%d,%d] %f sec"
1419 l.pageno col row t
1421 let w = measurestr fstate.fontsize s in
1422 GlMisc.push_attrib [`current];
1423 GlDraw.color (0.0, 0.0, 0.0);
1424 GlDraw.rect
1425 (float (x-2), float (y-2))
1426 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1427 GlDraw.color (1.0, 1.0, 1.0);
1428 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1429 GlMisc.pop_attrib ();
1432 | _ ->
1433 let w =
1434 let lw = state.winw - state.scrollw - x in
1435 min lw w
1436 and h =
1437 let lh = state.winh - y in
1438 min lh h
1440 begin match state.texid with
1441 | Some id ->
1442 Gl.enable `texture_2d;
1443 GlTex.bind_texture `texture_2d id;
1444 let x0 = float x
1445 and y0 = float y
1446 and x1 = float (x+w)
1447 and y1 = float (y+h) in
1449 let tw = float w /. 16.0
1450 and th = float h /. 16.0 in
1451 let tx0 = float tilex /. 16.0
1452 and ty0 = float tiley /. 16.0 in
1453 let tx1 = tx0 +. tw
1454 and ty1 = ty0 +. th in
1455 GlDraw.begins `quads;
1456 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1457 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1458 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1459 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1460 GlDraw.ends ();
1462 Gl.disable `texture_2d;
1463 | None ->
1464 GlDraw.color (1.0, 1.0, 1.0);
1465 GlDraw.rect
1466 (float x, float y)
1467 (float (x+w), float (y+h));
1468 end;
1469 if w > 128 && h > fstate.fontsize + 10
1470 then (
1471 GlDraw.color (0.0, 0.0, 0.0);
1472 let c, r =
1473 if conf.verbose
1474 then (col*conf.tilew, row*conf.tileh)
1475 else col, row
1477 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1479 GlDraw.color color;
1481 itertiles l f
1484 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1486 let tilevisible1 l x y =
1487 let ax0 = l.pagex
1488 and ax1 = l.pagex + l.pagevw
1489 and ay0 = l.pagey
1490 and ay1 = l.pagey + l.pagevh in
1492 let bx0 = x
1493 and by0 = y in
1494 let bx1 = min (bx0 + conf.tilew) l.pagew
1495 and by1 = min (by0 + conf.tileh) l.pageh in
1497 let rx0 = max ax0 bx0
1498 and ry0 = max ay0 by0
1499 and rx1 = min ax1 bx1
1500 and ry1 = min ay1 by1 in
1502 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1503 nonemptyintersection
1506 let tilevisible layout n x y =
1507 let rec findpageinlayout m = function
1508 | l :: rest when l.pageno = n ->
1509 tilevisible1 l x y || (
1510 match conf.columns with
1511 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1512 | _ -> false
1514 | _ :: rest -> findpageinlayout 0 rest
1515 | [] -> false
1517 findpageinlayout 0 layout;
1520 let tileready l x y =
1521 tilevisible1 l x y &&
1522 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1525 let tilepage n p layout =
1526 let rec loop = function
1527 | l :: rest ->
1528 if l.pageno = n
1529 then
1530 let f col row _ _ _ _ _ _ =
1531 if state.currently = Idle
1532 then
1533 match gettileopaque l col row with
1534 | Some _ -> ()
1535 | None ->
1536 let x = col*conf.tilew
1537 and y = row*conf.tileh in
1538 let w =
1539 let w = l.pagew - x in
1540 min w conf.tilew
1542 let h =
1543 let h = l.pageh - y in
1544 min h conf.tileh
1546 let pbo =
1547 if conf.usepbo
1548 then getpbo w h conf.colorspace
1549 else "0"
1551 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1552 state.currently <-
1553 Tiling (
1554 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1555 conf.tilew, conf.tileh
1558 itertiles l f;
1559 else
1560 loop rest
1562 | [] -> ()
1564 if nogeomcmds state.geomcmds
1565 then loop layout;
1568 let preloadlayout y =
1569 let y = if y < state.winh then 0 else y - state.winh in
1570 let h = state.winh*3 in
1571 layout y h;
1574 let load pages =
1575 let rec loop pages =
1576 if state.currently != Idle
1577 then ()
1578 else
1579 match pages with
1580 | l :: rest ->
1581 begin match getopaque l.pageno with
1582 | None ->
1583 wcmd "page %d %d" l.pageno l.pagedimno;
1584 state.currently <- Loading (l, state.gen);
1585 | Some opaque ->
1586 tilepage l.pageno opaque pages;
1587 loop rest
1588 end;
1589 | _ -> ()
1591 if nogeomcmds state.geomcmds
1592 then loop pages
1595 let preload pages =
1596 load pages;
1597 if conf.preload && state.currently = Idle
1598 then load (preloadlayout state.y);
1601 let layoutready layout =
1602 let rec fold all ls =
1603 all && match ls with
1604 | l :: rest ->
1605 let seen = ref false in
1606 let allvisible = ref true in
1607 let foo col row _ _ _ _ _ _ =
1608 seen := true;
1609 allvisible := !allvisible &&
1610 begin match gettileopaque l col row with
1611 | Some _ -> true
1612 | None -> false
1615 itertiles l foo;
1616 fold (!seen && !allvisible) rest
1617 | [] -> true
1619 let alltilesvisible = fold true layout in
1620 alltilesvisible;
1623 let gotoy y =
1624 let y = bound y 0 state.maxy in
1625 let y, layout, proceed =
1626 match conf.maxwait with
1627 | Some time when state.ghyll == noghyll ->
1628 begin match state.throttle with
1629 | None ->
1630 let layout = layout y state.winh in
1631 let ready = layoutready layout in
1632 if not ready
1633 then (
1634 load layout;
1635 state.throttle <- Some (layout, y, now ());
1637 else G.postRedisplay "gotoy showall (None)";
1638 y, layout, ready
1639 | Some (_, _, started) ->
1640 let dt = now () -. started in
1641 if dt > time
1642 then (
1643 state.throttle <- None;
1644 let layout = layout y state.winh in
1645 load layout;
1646 G.postRedisplay "maxwait";
1647 y, layout, true
1649 else -1, [], false
1652 | _ ->
1653 let layout = layout y state.winh in
1654 if not !wtmode || layoutready layout
1655 then G.postRedisplay "gotoy ready";
1656 y, layout, true
1658 if proceed
1659 then (
1660 state.y <- y;
1661 state.layout <- layout;
1662 begin match state.mode with
1663 | LinkNav (Ltexact (pageno, linkno)) ->
1664 let rec loop = function
1665 | [] ->
1666 state.mode <- LinkNav (Ltgendir 0)
1667 | l :: _ when l.pageno = pageno ->
1668 begin match getopaque pageno with
1669 | None ->
1670 state.mode <- LinkNav (Ltgendir 0)
1671 | Some opaque ->
1672 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1673 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1674 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1675 then state.mode <- LinkNav (Ltgendir 0)
1677 | _ :: rest -> loop rest
1679 loop layout
1680 | _ -> ()
1681 end;
1682 begin match state.mode with
1683 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1684 if not (pagevisible layout pageno)
1685 then (
1686 match state.layout with
1687 | [] -> ()
1688 | l :: _ ->
1689 state.mode <- Birdseye (
1690 conf, leftx, l.pageno, hooverpageno, anchor
1693 | LinkNav (Ltgendir dir as lt) ->
1694 let linknav =
1695 let rec loop = function
1696 | [] -> lt
1697 | l :: rest ->
1698 match getopaque l.pageno with
1699 | None -> loop rest
1700 | Some opaque ->
1701 let link =
1702 let ld =
1703 if dir = 0
1704 then LDfirstvisible (l.pagex, l.pagey, dir)
1705 else (
1706 if dir > 0 then LDfirst else LDlast
1709 findlink opaque ld
1711 match link with
1712 | Lnotfound -> loop rest
1713 | Lfound n ->
1714 showlinktype (getlink opaque n);
1715 Ltexact (l.pageno, n)
1717 loop state.layout
1719 state.mode <- LinkNav linknav
1720 | _ -> ()
1721 end;
1722 preload layout;
1724 state.ghyll <- noghyll;
1725 if conf.updatecurs
1726 then (
1727 let mx, my = state.mpos in
1728 updateunder mx my;
1732 let conttiling pageno opaque =
1733 tilepage pageno opaque
1734 (if conf.preload then preloadlayout state.y else state.layout)
1737 let gotoy_and_clear_text y =
1738 if not conf.verbose then state.text <- "";
1739 gotoy y;
1742 let getanchor1 l =
1743 let top =
1744 let coloff = l.pagecol * l.pageh in
1745 float (l.pagey + coloff) /. float l.pageh
1747 let dtop =
1748 if l.pagedispy = 0
1749 then
1751 else
1752 if conf.presentation
1753 then float l.pagedispy /. float (calcips l.pageh)
1754 else float l.pagedispy /. float conf.interpagespace
1756 (l.pageno, top, dtop)
1759 let getanchor () =
1760 match state.layout with
1761 | l :: _ -> getanchor1 l
1762 | [] ->
1763 let n = page_of_y state.y in
1764 if n = -1
1765 then state.anchor
1766 else
1767 let y, h = getpageyh n in
1768 let dy = y - state.y in
1769 let dtop =
1770 if conf.presentation
1771 then
1772 let ips = calcips h in
1773 float (dy + ips) /. float ips
1774 else
1775 float dy /. float conf.interpagespace
1777 (n, 0.0, dtop)
1780 let getanchory (n, top, dtop) =
1781 let y, h = getpageyh n in
1782 if conf.presentation
1783 then
1784 let ips = calcips h in
1785 y + truncate (top*.float h -. dtop*.float ips) + ips;
1786 else
1787 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1790 let gotoanchor anchor =
1791 gotoy (getanchory anchor);
1794 let addnav () =
1795 cbput state.hists.nav (getanchor ());
1798 let getnav dir =
1799 let anchor = cbgetc state.hists.nav dir in
1800 getanchory anchor;
1803 let gotoghyll y =
1804 let scroll f n a b =
1805 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1806 let snake f a b =
1807 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1808 if f < a
1809 then s (float f /. float a)
1810 else (
1811 if f > b
1812 then 1.0 -. s ((float (f-b) /. float (n-b)))
1813 else 1.0
1816 snake f a b
1817 and summa f n a b =
1818 (* courtesy:
1819 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1820 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1821 let iv1 = iv f in
1822 let ins = float a *. iv1
1823 and outs = float (n-b) *. iv1 in
1824 let ones = b - a in
1825 ins +. outs +. float ones
1827 let rec set (_N, _A, _B) y sy =
1828 let sum = summa 1.0 _N _A _B in
1829 let dy = float (y - sy) in
1830 state.ghyll <- (
1831 let rec gf n y1 o =
1832 if n >= _N
1833 then state.ghyll <- noghyll
1834 else
1835 let go n =
1836 let s = scroll n _N _A _B in
1837 let y1 = y1 +. ((s *. dy) /. sum) in
1838 gotoy_and_clear_text (truncate y1);
1839 state.ghyll <- gf (n+1) y1;
1841 match o with
1842 | None -> go n
1843 | Some y' -> set (_N/2, 1, 1) y' state.y
1845 gf 0 (float state.y)
1848 match conf.ghyllscroll with
1849 | None ->
1850 gotoy_and_clear_text y
1851 | Some nab ->
1852 if state.ghyll == noghyll
1853 then set nab y state.y
1854 else state.ghyll (Some y)
1857 let gotopage n top =
1858 let y, h = getpageyh n in
1859 let y = y + (truncate (top *. float h)) in
1860 gotoghyll y
1863 let gotopage1 n top =
1864 let y = getpagey n in
1865 let y = y + top in
1866 gotoghyll y
1869 let invalidate s f =
1870 state.layout <- [];
1871 state.pdims <- [];
1872 state.rects <- [];
1873 state.rects1 <- [];
1874 match state.geomcmds with
1875 | ps, [] when String.length ps = 0 ->
1876 f ();
1877 state.geomcmds <- s, [];
1879 | ps, [] ->
1880 state.geomcmds <- ps, [s, f];
1882 | ps, (s', _) :: rest when s' = s ->
1883 state.geomcmds <- ps, ((s, f) :: rest);
1885 | ps, cmds ->
1886 state.geomcmds <- ps, ((s, f) :: cmds);
1889 let flushpages () =
1890 Hashtbl.iter (fun _ opaque ->
1891 wcmd "freepage %s" opaque;
1892 ) state.pagemap;
1893 Hashtbl.clear state.pagemap;
1896 let flushtiles () =
1897 if not (Queue.is_empty state.tilelru)
1898 then (
1899 Queue.iter (fun (k, p, s) ->
1900 wcmd "freetile %s" p;
1901 state.memused <- state.memused - s;
1902 Hashtbl.remove state.tilemap k;
1903 ) state.tilelru;
1904 state.uioh#infochanged Memused;
1905 Queue.clear state.tilelru;
1907 load state.layout;
1910 let opendoc path password =
1911 state.path <- path;
1912 state.password <- password;
1913 state.gen <- state.gen + 1;
1914 state.docinfo <- [];
1916 flushpages ();
1917 setaalevel conf.aalevel;
1918 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename path)));
1919 wcmd "open %d %s\000%s\000" (btod !wtmode) path password;
1920 invalidate "reqlayout"
1921 (fun () ->
1922 wcmd "reqlayout %d %d %s\000"
1923 conf.angle (btod conf.proportional) state.nameddest;
1927 let reload () =
1928 state.anchor <- getanchor ();
1929 opendoc state.path state.password;
1932 let scalecolor c =
1933 let c = c *. conf.colorscale in
1934 (c, c, c);
1937 let scalecolor2 (r, g, b) =
1938 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1941 let docolumns = function
1942 | Csingle _ ->
1943 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1944 let rec loop pageno pdimno pdim y ph pdims =
1945 if pageno = state.pagecount
1946 then ()
1947 else
1948 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1949 match pdims with
1950 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1951 pdimno+1, pdim, rest
1952 | _ ->
1953 pdimno, pdim, pdims
1955 let x = max 0 (((state.winw - state.scrollw - w) / 2) - xoff) in
1956 let y = y +
1957 (if conf.presentation
1958 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1959 else (if pageno = 0 then 0 else conf.interpagespace)
1962 a.(pageno) <- (pdimno, x, y, pdim);
1963 loop (pageno+1) pdimno pdim (y + h) h pdims
1965 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1966 conf.columns <- Csingle a;
1968 | Cmulti ((columns, coverA, coverB), _) ->
1969 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1970 let rec loop pageno pdimno pdim x y rowh pdims =
1971 let rec fixrow m = if m = pageno then () else
1972 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1973 if h < rowh
1974 then (
1975 let y = y + (rowh - h) / 2 in
1976 a.(m) <- (pdimno, x, y, pdim);
1978 fixrow (m+1)
1980 if pageno = state.pagecount
1981 then fixrow (((pageno - 1) / columns) * columns)
1982 else
1983 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1984 match pdims with
1985 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1986 pdimno+1, pdim, rest
1987 | _ ->
1988 pdimno, pdim, pdims
1990 let x, y, rowh' =
1991 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1992 then (
1993 let x = (state.winw - state.scrollw - w) / 2 in
1994 let ips =
1995 if conf.presentation then calcips h else conf.interpagespace in
1996 x, y + ips + rowh, h
1998 else (
1999 if (pageno - coverA) mod columns = 0
2000 then (
2001 let x = max 0 (state.winw - state.scrollw - state.w) / 2 in
2002 let y =
2003 if conf.presentation
2004 then
2005 let ips = calcips h in
2006 y + (if pageno = 0 then 0 else calcips rowh + ips)
2007 else
2008 y + (if pageno = 0 then 0 else conf.interpagespace)
2010 x, y + rowh, h
2012 else x, y, max rowh h
2015 let y =
2016 if pageno > 1 && (pageno - coverA) mod columns = 0
2017 then (
2018 let y =
2019 if pageno = columns && conf.presentation
2020 then (
2021 let ips = calcips rowh in
2022 for i = 0 to pred columns
2024 let (pdimno, x, y, pdim) = a.(i) in
2025 a.(i) <- (pdimno, x, y+ips, pdim)
2026 done;
2027 y+ips;
2029 else y
2031 fixrow (pageno - columns);
2034 else y
2036 a.(pageno) <- (pdimno, x, y, pdim);
2037 let x = x + w + xoff*2 + conf.interpagespace in
2038 loop (pageno+1) pdimno pdim x y rowh' pdims
2040 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2041 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2043 | Csplit (c, _) ->
2044 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2045 let rec loop pageno pdimno pdim y pdims =
2046 if pageno = state.pagecount
2047 then ()
2048 else
2049 let pdimno, ((_, w, h, _) as pdim), pdims =
2050 match pdims with
2051 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2052 pdimno+1, pdim, rest
2053 | _ ->
2054 pdimno, pdim, pdims
2056 let cw = w / c in
2057 let rec loop1 n x y =
2058 if n = c then y else (
2059 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2060 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2063 let y = loop1 0 0 y in
2064 loop (pageno+1) pdimno pdim y pdims
2066 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2067 conf.columns <- Csplit (c, a);
2070 let represent () =
2071 docolumns conf.columns;
2072 state.maxy <- calcheight ();
2073 state.hscrollh <-
2074 if state.x = 0 && state.w <= state.winw - state.scrollw
2075 then 0
2076 else state.scrollw
2078 if state.reprf == noreprf
2079 then (
2080 match state.mode with
2081 | Birdseye (_, _, pageno, _, _) ->
2082 let y, h = getpageyh pageno in
2083 let top = (state.winh - h) / 2 in
2084 gotoy (max 0 (y - top))
2085 | _ -> gotoanchor state.anchor
2087 else (
2088 state.reprf ();
2089 state.reprf <- noreprf;
2093 let reshape w h =
2094 GlDraw.viewport 0 0 w h;
2095 let firsttime = state.geomcmds == firstgeomcmds in
2096 if not firsttime && nogeomcmds state.geomcmds
2097 then state.anchor <- getanchor ();
2099 state.winw <- w;
2100 let w = truncate (float w *. conf.zoom) - state.scrollw in
2101 let w = max w 2 in
2102 state.winh <- h;
2103 setfontsize fstate.fontsize;
2104 GlMat.mode `modelview;
2105 GlMat.load_identity ();
2107 GlMat.mode `projection;
2108 GlMat.load_identity ();
2109 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2110 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2111 GlMat.scale3 (2.0 /. float state.winw, 2.0 /. float state.winh, 1.0);
2113 let relx =
2114 if conf.zoom <= 1.0
2115 then 0.0
2116 else float state.x /. float state.w
2118 invalidate "geometry"
2119 (fun () ->
2120 state.w <- w;
2121 if not firsttime
2122 then state.x <- truncate (relx *. float w);
2123 let w =
2124 match conf.columns with
2125 | Csingle _ -> w
2126 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2127 | Csplit (c, _) -> w * c
2129 wcmd "geometry %d %d" w h);
2132 let enttext () =
2133 let len = String.length state.text in
2134 let drawstring s =
2135 let hscrollh =
2136 match state.mode with
2137 | Textentry _
2138 | View ->
2139 let h, _, _ = state.uioh#scrollpw in
2141 | _ -> 0
2143 let rect x w =
2144 GlDraw.rect
2145 (x, float (state.winh - (fstate.fontsize + 4) - hscrollh))
2146 (x+.w, float (state.winh - hscrollh))
2149 let w = float (state.winw - state.scrollw - 1) in
2150 if state.progress >= 0.0 && state.progress < 1.0
2151 then (
2152 GlDraw.color (0.3, 0.3, 0.3);
2153 let w1 = w *. state.progress in
2154 rect 0.0 w1;
2155 GlDraw.color (0.0, 0.0, 0.0);
2156 rect w1 (w-.w1)
2158 else (
2159 GlDraw.color (0.0, 0.0, 0.0);
2160 rect 0.0 w;
2163 GlDraw.color (1.0, 1.0, 1.0);
2164 drawstring fstate.fontsize
2165 (if len > 0 then 8 else 2) (state.winh - hscrollh - 5) s;
2167 let s =
2168 match state.mode with
2169 | Textentry ((prefix, text, _, _, _, _), _) ->
2170 let s =
2171 if len > 0
2172 then
2173 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2174 else
2175 Printf.sprintf "%s%s_" prefix text
2179 | _ -> state.text
2181 let s =
2182 if state.newerrmsgs
2183 then (
2184 if not (istextentry state.mode)
2185 then
2186 let s1 = "(press 'e' to review error messasges)" in
2187 if String.length s > 0 then s ^ " " ^ s1 else s1
2188 else s
2190 else s
2192 if String.length s > 0
2193 then drawstring s
2196 let gctiles () =
2197 let len = Queue.length state.tilelru in
2198 let layout = lazy (
2199 match state.throttle with
2200 | None ->
2201 if conf.preload
2202 then preloadlayout state.y
2203 else state.layout
2204 | Some (layout, _, _) ->
2205 layout
2206 ) in
2207 let rec loop qpos =
2208 if state.memused <= conf.memlimit
2209 then ()
2210 else (
2211 if qpos < len
2212 then
2213 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2214 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2215 let (_, pw, ph, _) = getpagedim n in
2217 gen = state.gen
2218 && colorspace = conf.colorspace
2219 && angle = conf.angle
2220 && pagew = pw
2221 && pageh = ph
2222 && (
2223 let x = col*conf.tilew
2224 and y = row*conf.tileh in
2225 tilevisible (Lazy.force_val layout) n x y
2227 then Queue.push lruitem state.tilelru
2228 else (
2229 freepbo p;
2230 wcmd "freetile %s" p;
2231 state.memused <- state.memused - s;
2232 state.uioh#infochanged Memused;
2233 Hashtbl.remove state.tilemap k;
2235 loop (qpos+1)
2238 loop 0
2241 let logcurrently = function
2242 | Idle -> dolog "Idle"
2243 | Loading (l, gen) ->
2244 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2245 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2246 dolog
2247 "Tiling %d[%d,%d] page=%s cs=%s angle"
2248 l.pageno col row pageopaque
2249 (colorspace_to_string colorspace)
2251 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2252 angle gen conf.angle state.gen
2253 tilew tileh
2254 conf.tilew conf.tileh
2256 | Outlining _ ->
2257 dolog "outlining"
2260 let splitatspace =
2261 let r = Str.regexp " " in
2262 fun s -> Str.bounded_split r s 2;
2265 let onpagerect pageno f =
2266 let b =
2267 match conf.columns with
2268 | Cmulti (_, b) -> b
2269 | Csingle b -> b
2270 | Csplit (_, b) -> b
2272 if pageno >= 0 && pageno < Array.length b
2273 then
2274 let (pdimno, _, _, (_, _, _, _)) = b.(pageno) in
2275 let r = getpdimrect pdimno in
2276 f (r.(1)-.r.(0)) (r.(3)-.r.(2))
2279 let gotopagexy1 pageno x y =
2280 onpagerect pageno (fun w h ->
2281 let top = y /. h in
2282 let _,w1,_,leftx = getpagedim pageno in
2283 let wh = state.winh - state.hscrollh in
2284 let sw = float w1 /. w in
2285 let x = sw *. x in
2286 let x = leftx + state.x + truncate x in
2287 let sx =
2288 if x < 0 || x >= state.winw - state.scrollw
2289 then state.x - x
2290 else state.x
2292 let py, h = getpageyh pageno in
2293 let y' = py + truncate (top *. float h) in
2294 let dy = y' - state.y in
2295 let sy =
2296 if x != state.x || not (dy > 0 && dy < wh)
2297 then (
2298 if conf.presentation
2299 then
2300 if abs (py - y') > wh
2301 then y'
2302 else py
2303 else y';
2305 else state.y
2307 if state.x != sx || state.y != sy
2308 then (
2309 let x, y =
2310 if !wtmode
2311 then (
2312 let ww = state.winw - state.scrollw in
2313 let qx = sx / ww
2314 and qy = sy / wh in
2315 let x = qx * ww
2316 and y = qy * wh in
2317 let x = if -x + ww > w1 then -(w1-ww) else x
2318 and y' = if y + wh > state.maxy then state.maxy - wh else y in
2319 let y =
2320 if conf.presentation
2321 then
2322 if abs (py - y') > wh
2323 then y'
2324 else py
2325 else y';
2327 (x, y)
2329 else (sx, sy)
2331 state.x <- x;
2332 state.hscrollh <-
2333 if x = 0 && state.w <= state.winw - state.scrollw
2334 then 0
2335 else state.scrollw
2337 gotoy_and_clear_text y;
2339 else gotoy_and_clear_text state.y;
2343 let gotopagexy pageno x y =
2344 match state.mode with
2345 | Birdseye _ -> gotopage pageno 0.0
2346 | _ -> gotopagexy1 pageno x y
2349 let act cmds =
2350 (* dolog "%S" cmds; *)
2351 let cl = splitatspace cmds in
2352 let scan s fmt f =
2353 try Scanf.sscanf s fmt f
2354 with exn ->
2355 dolog "error processing '%S': %s" cmds (exntos exn);
2356 exit 1
2358 match cl with
2359 | "clear" :: [] ->
2360 state.uioh#infochanged Pdim;
2361 state.pdims <- [];
2363 | "clearrects" :: [] ->
2364 state.rects <- state.rects1;
2365 G.postRedisplay "clearrects";
2367 | "continue" :: args :: [] ->
2368 let n = scan args "%u" (fun n -> n) in
2369 state.pagecount <- n;
2370 begin match state.currently with
2371 | Outlining l ->
2372 state.currently <- Idle;
2373 state.outlines <- Array.of_list (List.rev l)
2374 | _ -> ()
2375 end;
2377 let cur, cmds = state.geomcmds in
2378 if String.length cur = 0
2379 then failwith "umpossible";
2381 begin match List.rev cmds with
2382 | [] ->
2383 state.geomcmds <- "", [];
2384 represent ();
2385 | (s, f) :: rest ->
2386 f ();
2387 state.geomcmds <- s, List.rev rest;
2388 end;
2389 if conf.maxwait = None && not !wtmode
2390 then G.postRedisplay "continue";
2392 | "title" :: args :: [] ->
2393 Wsi.settitle args
2395 | "msg" :: args :: [] ->
2396 showtext ' ' args
2398 | "vmsg" :: args :: [] ->
2399 if conf.verbose
2400 then showtext ' ' args
2402 | "emsg" :: args :: [] ->
2403 Buffer.add_string state.errmsgs args;
2404 state.newerrmsgs <- true;
2405 G.postRedisplay "error message"
2407 | "progress" :: args :: [] ->
2408 let progress, text =
2409 scan args "%f %n"
2410 (fun f pos ->
2411 f, String.sub args pos (String.length args - pos))
2413 state.text <- text;
2414 state.progress <- progress;
2415 G.postRedisplay "progress"
2417 | "firstmatch" :: args :: [] ->
2418 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2419 scan args "%u %d %f %f %f %f %f %f %f %f"
2420 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2421 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2423 let y = (getpagey pageno) + truncate y0 in
2424 addnav ();
2425 gotoy y;
2426 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2428 | "match" :: args :: [] ->
2429 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2430 scan args "%u %d %f %f %f %f %f %f %f %f"
2431 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2432 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2434 state.rects1 <-
2435 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2437 | "page" :: args :: [] ->
2438 let pageopaque, t = scan args "%s %f" (fun p t -> p, t) in
2439 begin match state.currently with
2440 | Loading (l, gen) ->
2441 vlog "page %d took %f sec" l.pageno t;
2442 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2443 begin match state.throttle with
2444 | None ->
2445 let preloadedpages =
2446 if conf.preload
2447 then preloadlayout state.y
2448 else state.layout
2450 let evict () =
2451 let module IntSet =
2452 Set.Make (struct type t = int let compare = (-) end) in
2453 let set =
2454 List.fold_left (fun s l -> IntSet.add l.pageno s)
2455 IntSet.empty preloadedpages
2457 let evictedpages =
2458 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2459 if not (IntSet.mem pageno set)
2460 then (
2461 wcmd "freepage %s" opaque;
2462 key :: accu
2464 else accu
2465 ) state.pagemap []
2467 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2469 evict ();
2470 state.currently <- Idle;
2471 if gen = state.gen
2472 then (
2473 tilepage l.pageno pageopaque state.layout;
2474 load state.layout;
2475 load preloadedpages;
2476 if pagevisible state.layout l.pageno
2477 && layoutready state.layout
2478 then G.postRedisplay "page";
2481 | Some (layout, _, _) ->
2482 state.currently <- Idle;
2483 tilepage l.pageno pageopaque layout;
2484 load state.layout
2485 end;
2487 | _ ->
2488 dolog "Inconsistent loading state";
2489 logcurrently state.currently;
2490 exit 1
2493 | "tile" :: args :: [] ->
2494 let (x, y, opaque, size, t) =
2495 scan args "%u %u %s %u %f"
2496 (fun x y p size t -> (x, y, p, size, t))
2498 begin match state.currently with
2499 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2500 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2502 unmappbo opaque;
2503 if tilew != conf.tilew || tileh != conf.tileh
2504 then (
2505 wcmd "freetile %s" opaque;
2506 state.currently <- Idle;
2507 load state.layout;
2509 else (
2510 puttileopaque l col row gen cs angle opaque size t;
2511 state.memused <- state.memused + size;
2512 state.uioh#infochanged Memused;
2513 gctiles ();
2514 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2515 opaque, size) state.tilelru;
2517 let layout =
2518 match state.throttle with
2519 | None -> state.layout
2520 | Some (layout, _, _) -> layout
2523 state.currently <- Idle;
2524 if gen = state.gen
2525 && conf.colorspace = cs
2526 && conf.angle = angle
2527 && tilevisible layout l.pageno x y
2528 then conttiling l.pageno pageopaque;
2530 begin match state.throttle with
2531 | None ->
2532 preload state.layout;
2533 if gen = state.gen
2534 && conf.colorspace = cs
2535 && conf.angle = angle
2536 && tilevisible state.layout l.pageno x y
2537 && (not !wtmode || layoutready state.layout)
2538 then G.postRedisplay "tile nothrottle";
2540 | Some (layout, y, _) ->
2541 let ready = layoutready layout in
2542 if ready
2543 then (
2544 state.y <- y;
2545 state.layout <- layout;
2546 state.throttle <- None;
2547 G.postRedisplay "throttle";
2549 else load layout;
2550 end;
2553 | _ ->
2554 dolog "Inconsistent tiling state";
2555 logcurrently state.currently;
2556 exit 1
2559 | "pdim" :: args :: [] ->
2560 let pdim =
2561 scan args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2563 state.uioh#infochanged Pdim;
2564 state.pdims <- pdim :: state.pdims
2566 | "o" :: args :: [] ->
2567 let (l, n, t, h, pos) =
2568 scan args "%u %u %d %u %n"
2569 (fun l n t h pos -> l, n, t, h, pos)
2571 let s = String.sub args pos (String.length args - pos) in
2572 let outline = (s, l, (n, float t /. float h, 0.0)) in
2573 begin match state.currently with
2574 | Outlining outlines ->
2575 state.currently <- Outlining (outline :: outlines)
2576 | Idle ->
2577 state.currently <- Outlining [outline]
2578 | currently ->
2579 dolog "invalid outlining state";
2580 logcurrently currently
2583 | "a" :: args :: [] ->
2584 let (n, l, t) =
2585 scan args "%u %d %d" (fun n l t -> n, l, t)
2587 state.reprf <- (fun () -> gotopagexy n (float l) (float t))
2589 | "info" :: args :: [] ->
2590 state.docinfo <- (1, args) :: state.docinfo
2592 | "infoend" :: [] ->
2593 state.uioh#infochanged Docinfo;
2594 state.docinfo <- List.rev state.docinfo
2596 | _ ->
2597 failwith (Printf.sprintf "unknown cmd `%S'" cmds)
2600 let onhist cb =
2601 let rc = cb.rc in
2602 let action = function
2603 | HCprev -> cbget cb ~-1
2604 | HCnext -> cbget cb 1
2605 | HCfirst -> cbget cb ~-(cb.rc)
2606 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2607 and cancel () = cb.rc <- rc
2608 in (action, cancel)
2611 let search pattern forward =
2612 if String.length pattern > 0
2613 then
2614 let pn, py =
2615 match state.layout with
2616 | [] -> 0, 0
2617 | l :: _ ->
2618 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2620 wcmd "search %d %d %d %d,%s\000"
2621 (btod conf.icase) pn py (btod forward) pattern;
2624 let intentry text key =
2625 let c =
2626 if key >= 32 && key < 127
2627 then Char.chr key
2628 else '\000'
2630 match c with
2631 | '0' .. '9' ->
2632 let text = addchar text c in
2633 TEcont text
2635 | _ ->
2636 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2637 TEcont text
2640 let linknentry text key =
2641 let c =
2642 if key >= 32 && key < 127
2643 then Char.chr key
2644 else '\000'
2646 match c with
2647 | 'a' .. 'z' ->
2648 let text = addchar text c in
2649 TEcont text
2651 | _ ->
2652 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2653 TEcont text
2656 let linkndone f s =
2657 if String.length s > 0
2658 then (
2659 let n =
2660 let l = String.length s in
2661 let rec loop pos n = if pos = l then n else
2662 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2663 loop (pos+1) (n*26 + m)
2664 in loop 0 0
2666 let rec loop n = function
2667 | [] -> ()
2668 | l :: rest ->
2669 match getopaque l.pageno with
2670 | None -> loop n rest
2671 | Some opaque ->
2672 let m = getlinkcount opaque in
2673 if n < m
2674 then (
2675 let under = getlink opaque n in
2676 f under
2678 else loop (n-m) rest
2680 loop n state.layout;
2684 let textentry text key =
2685 if key land 0xff00 = 0xff00
2686 then TEcont text
2687 else TEcont (text ^ toutf8 key)
2690 let reqlayout angle proportional =
2691 match state.throttle with
2692 | None ->
2693 if nogeomcmds state.geomcmds
2694 then state.anchor <- getanchor ();
2695 conf.angle <- angle mod 360;
2696 if conf.angle != 0
2697 then (
2698 match state.mode with
2699 | LinkNav _ -> state.mode <- View
2700 | _ -> ()
2702 conf.proportional <- proportional;
2703 invalidate "reqlayout"
2704 (fun () -> wcmd "reqlayout %d %d" conf.angle (btod proportional));
2705 | _ -> ()
2708 let settrim trimmargins trimfuzz =
2709 if nogeomcmds state.geomcmds
2710 then state.anchor <- getanchor ();
2711 conf.trimmargins <- trimmargins;
2712 conf.trimfuzz <- trimfuzz;
2713 let x0, y0, x1, y1 = trimfuzz in
2714 invalidate "settrim"
2715 (fun () ->
2716 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2717 flushpages ();
2720 let setzoom zoom =
2721 match state.throttle with
2722 | None ->
2723 let zoom = max 0.01 zoom in
2724 if zoom <> conf.zoom
2725 then (
2726 state.prevzoom <- conf.zoom;
2727 conf.zoom <- zoom;
2728 reshape state.winw state.winh;
2729 state.text <- Printf.sprintf "zoom is now %-5.1f" (zoom *. 100.0);
2732 | Some (layout, y, started) ->
2733 let time =
2734 match conf.maxwait with
2735 | None -> 0.0
2736 | Some t -> t
2738 let dt = now () -. started in
2739 if dt > time
2740 then (
2741 state.y <- y;
2742 load layout;
2746 let setcolumns mode columns coverA coverB =
2747 state.prevcolumns <- Some (conf.columns, conf.zoom);
2748 if columns < 0
2749 then (
2750 if isbirdseye mode
2751 then showtext '!' "split mode doesn't work in bird's eye"
2752 else (
2753 conf.columns <- Csplit (-columns, [||]);
2754 state.x <- 0;
2755 conf.zoom <- 1.0;
2758 else (
2759 if columns < 2
2760 then (
2761 conf.columns <- Csingle [||];
2762 state.x <- 0;
2763 setzoom 1.0;
2765 else (
2766 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2767 conf.zoom <- 1.0;
2770 reshape state.winw state.winh;
2773 let enterbirdseye () =
2774 let zoom = float conf.thumbw /. float state.winw in
2775 let birdseyepageno =
2776 let cy = state.winh / 2 in
2777 let fold = function
2778 | [] -> 0
2779 | l :: rest ->
2780 let rec fold best = function
2781 | [] -> best.pageno
2782 | l :: rest ->
2783 let d = cy - (l.pagedispy + l.pagevh/2)
2784 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2785 if abs d < abs dbest
2786 then fold l rest
2787 else best.pageno
2788 in fold l rest
2790 fold state.layout
2792 state.mode <- Birdseye (
2793 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2795 conf.zoom <- zoom;
2796 conf.presentation <- false;
2797 conf.interpagespace <- 10;
2798 conf.hlinks <- false;
2799 state.x <- 0;
2800 state.mstate <- Mnone;
2801 conf.maxwait <- None;
2802 conf.columns <- (
2803 match conf.beyecolumns with
2804 | Some c ->
2805 conf.zoom <- 1.0;
2806 Cmulti ((c, 0, 0), [||])
2807 | None -> Csingle [||]
2809 Wsi.setcursor Wsi.CURSOR_INHERIT;
2810 if conf.verbose
2811 then
2812 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2813 (100.0*.zoom)
2814 else
2815 state.text <- ""
2817 reshape state.winw state.winh;
2820 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2821 state.mode <- View;
2822 conf.zoom <- c.zoom;
2823 conf.presentation <- c.presentation;
2824 conf.interpagespace <- c.interpagespace;
2825 conf.maxwait <- c.maxwait;
2826 conf.hlinks <- c.hlinks;
2827 conf.beyecolumns <- (
2828 match conf.columns with
2829 | Cmulti ((c, _, _), _) -> Some c
2830 | Csingle _ -> None
2831 | Csplit _ -> failwith "leaving bird's eye split mode"
2833 conf.columns <- (
2834 match c.columns with
2835 | Cmulti (c, _) -> Cmulti (c, [||])
2836 | Csingle _ -> Csingle [||]
2837 | Csplit (c, _) -> Csplit (c, [||])
2839 state.x <- leftx;
2840 if conf.verbose
2841 then
2842 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2843 (100.0*.conf.zoom)
2845 reshape state.winw state.winh;
2846 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2849 let togglebirdseye () =
2850 match state.mode with
2851 | Birdseye vals -> leavebirdseye vals true
2852 | View -> enterbirdseye ()
2853 | _ -> ()
2856 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2857 let pageno = max 0 (pageno - incr) in
2858 let rec loop = function
2859 | [] -> gotopage1 pageno 0
2860 | l :: _ when l.pageno = pageno ->
2861 if l.pagedispy >= 0 && l.pagey = 0
2862 then G.postRedisplay "upbirdseye"
2863 else gotopage1 pageno 0
2864 | _ :: rest -> loop rest
2866 loop state.layout;
2867 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2870 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2871 let pageno = min (state.pagecount - 1) (pageno + incr) in
2872 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2873 let rec loop = function
2874 | [] ->
2875 let y, h = getpageyh pageno in
2876 let dy = (y - state.y) - (state.winh - h - conf.interpagespace) in
2877 gotoy (clamp dy)
2878 | l :: _ when l.pageno = pageno ->
2879 if l.pagevh != l.pageh
2880 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2881 else G.postRedisplay "downbirdseye"
2882 | _ :: rest -> loop rest
2884 loop state.layout
2887 let optentry mode _ key =
2888 let btos b = if b then "on" else "off" in
2889 if key >= 32 && key < 127
2890 then
2891 let c = Char.chr key in
2892 match c with
2893 | 's' ->
2894 let ondone s =
2895 try conf.scrollstep <- int_of_string s with exc ->
2896 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2898 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
2900 | 'A' ->
2901 let ondone s =
2903 conf.autoscrollstep <- int_of_string s;
2904 if state.autoscroll <> None
2905 then state.autoscroll <- Some conf.autoscrollstep
2906 with exc ->
2907 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2909 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
2911 | 'C' ->
2912 let ondone s =
2914 let n, a, b = multicolumns_of_string s in
2915 setcolumns mode n a b;
2916 with exc ->
2917 state.text <- Printf.sprintf "bad columns `%s': %s" s (exntos exc)
2919 TEswitch ("columns: ", "", None, textentry, ondone, true)
2921 | 'Z' ->
2922 let ondone s =
2924 let zoom = float (int_of_string s) /. 100.0 in
2925 setzoom zoom
2926 with exc ->
2927 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2929 TEswitch ("zoom: ", "", None, intentry, ondone, true)
2931 | 't' ->
2932 let ondone s =
2934 conf.thumbw <- bound (int_of_string s) 2 4096;
2935 state.text <-
2936 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2937 begin match mode with
2938 | Birdseye beye ->
2939 leavebirdseye beye false;
2940 enterbirdseye ();
2941 | _ -> ();
2943 with exc ->
2944 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
2946 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
2948 | 'R' ->
2949 let ondone s =
2950 match try
2951 Some (int_of_string s)
2952 with exc ->
2953 state.text <- Printf.sprintf "bad integer `%s': %s"
2954 s (exntos exc);
2955 None
2956 with
2957 | Some angle -> reqlayout angle conf.proportional
2958 | None -> ()
2960 TEswitch ("rotation: ", "", None, intentry, ondone, true)
2962 | 'i' ->
2963 conf.icase <- not conf.icase;
2964 TEdone ("case insensitive search " ^ (btos conf.icase))
2966 | 'p' ->
2967 conf.preload <- not conf.preload;
2968 gotoy state.y;
2969 TEdone ("preload " ^ (btos conf.preload))
2971 | 'v' ->
2972 conf.verbose <- not conf.verbose;
2973 TEdone ("verbose " ^ (btos conf.verbose))
2975 | 'd' ->
2976 conf.debug <- not conf.debug;
2977 TEdone ("debug " ^ (btos conf.debug))
2979 | 'h' ->
2980 conf.maxhfit <- not conf.maxhfit;
2981 state.maxy <- calcheight ();
2982 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2984 | 'c' ->
2985 conf.crophack <- not conf.crophack;
2986 TEdone ("crophack " ^ btos conf.crophack)
2988 | 'a' ->
2989 let s =
2990 match conf.maxwait with
2991 | None ->
2992 conf.maxwait <- Some infinity;
2993 "always wait for page to complete"
2994 | Some _ ->
2995 conf.maxwait <- None;
2996 "show placeholder if page is not ready"
2998 TEdone s
3000 | 'f' ->
3001 conf.underinfo <- not conf.underinfo;
3002 TEdone ("underinfo " ^ btos conf.underinfo)
3004 | 'P' ->
3005 conf.savebmarks <- not conf.savebmarks;
3006 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
3008 | 'S' ->
3009 let ondone s =
3011 let pageno, py =
3012 match state.layout with
3013 | [] -> 0, 0
3014 | l :: _ ->
3015 l.pageno, l.pagey
3017 conf.interpagespace <- int_of_string s;
3018 docolumns conf.columns;
3019 state.maxy <- calcheight ();
3020 let y = getpagey pageno in
3021 gotoy (y + py)
3022 with exc ->
3023 state.text <- Printf.sprintf "bad integer `%s': %s" s (exntos exc)
3025 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
3027 | 'l' ->
3028 reqlayout conf.angle (not conf.proportional);
3029 TEdone ("proportional display " ^ btos conf.proportional)
3031 | 'T' ->
3032 settrim (not conf.trimmargins) conf.trimfuzz;
3033 TEdone ("trim margins " ^ btos conf.trimmargins)
3035 | 'I' ->
3036 conf.invert <- not conf.invert;
3037 TEdone ("invert colors " ^ btos conf.invert)
3039 | 'x' ->
3040 let ondone s =
3041 cbput state.hists.sel s;
3042 conf.selcmd <- s;
3044 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
3045 textentry, ondone, true)
3047 | _ ->
3048 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3049 TEstop
3050 else
3051 TEcont state.text
3054 class type lvsource = object
3055 method getitemcount : int
3056 method getitem : int -> (string * int)
3057 method hasaction : int -> bool
3058 method exit :
3059 uioh:uioh ->
3060 cancel:bool ->
3061 active:int ->
3062 first:int ->
3063 pan:int ->
3064 qsearch:string ->
3065 uioh option
3066 method getactive : int
3067 method getfirst : int
3068 method getqsearch : string
3069 method setqsearch : string -> unit
3070 method getpan : int
3071 end;;
3073 class virtual lvsourcebase = object
3074 val mutable m_active = 0
3075 val mutable m_first = 0
3076 val mutable m_qsearch = ""
3077 val mutable m_pan = 0
3078 method getactive = m_active
3079 method getfirst = m_first
3080 method getqsearch = m_qsearch
3081 method getpan = m_pan
3082 method setqsearch s = m_qsearch <- s
3083 end;;
3085 let withoutlastutf8 s =
3086 let len = String.length s in
3087 if len = 0
3088 then s
3089 else
3090 let rec find pos =
3091 if pos = 0
3092 then pos
3093 else
3094 let b = Char.code s.[pos] in
3095 if b land 0b11000000 = 0b11000000
3096 then pos
3097 else find (pos-1)
3099 let first =
3100 if Char.code s.[len-1] land 0x80 = 0
3101 then len-1
3102 else find (len-1)
3104 String.sub s 0 first;
3107 let textentrykeyboard
3108 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3109 let key =
3110 if key >= 0xffb0 && key <= 0xffb9
3111 then key - 0xffb0 + 48 else key
3113 let enttext te =
3114 state.mode <- Textentry (te, onleave);
3115 state.text <- "";
3116 enttext ();
3117 G.postRedisplay "textentrykeyboard enttext";
3119 let histaction cmd =
3120 match opthist with
3121 | None -> ()
3122 | Some (action, _) ->
3123 state.mode <- Textentry (
3124 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3126 G.postRedisplay "textentry histaction"
3128 match key with
3129 | 0xff08 -> (* backspace *)
3130 let s = withoutlastutf8 text in
3131 let len = String.length s in
3132 if cancelonempty && len = 0
3133 then (
3134 onleave Cancel;
3135 G.postRedisplay "textentrykeyboard after cancel";
3137 else (
3138 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3141 | 0xff0d | 0xff8d -> (* (kp) enter *)
3142 ondone text;
3143 onleave Confirm;
3144 G.postRedisplay "textentrykeyboard after confirm"
3146 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3147 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3148 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3149 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3151 | 0xff1b -> (* escape*)
3152 if String.length text = 0
3153 then (
3154 begin match opthist with
3155 | None -> ()
3156 | Some (_, onhistcancel) -> onhistcancel ()
3157 end;
3158 onleave Cancel;
3159 state.text <- "";
3160 G.postRedisplay "textentrykeyboard after cancel2"
3162 else (
3163 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3166 | 0xff9f | 0xffff -> () (* delete *)
3168 | _ when key != 0
3169 && key land 0xff00 != 0xff00 (* keyboard *)
3170 && key land 0xfe00 != 0xfe00 (* xkb *)
3171 && key land 0xfd00 != 0xfd00 (* 3270 *)
3173 begin match onkey text key with
3174 | TEdone text ->
3175 ondone text;
3176 onleave Confirm;
3177 G.postRedisplay "textentrykeyboard after confirm2";
3179 | TEcont text ->
3180 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3182 | TEstop ->
3183 onleave Cancel;
3184 G.postRedisplay "textentrykeyboard after cancel3"
3186 | TEswitch te ->
3187 state.mode <- Textentry (te, onleave);
3188 G.postRedisplay "textentrykeyboard switch";
3189 end;
3191 | _ ->
3192 vlog "unhandled key %s" (Wsi.keyname key)
3195 let firstof first active =
3196 if first > active || abs (first - active) > fstate.maxrows - 1
3197 then max 0 (active - (fstate.maxrows/2))
3198 else first
3201 let calcfirst first active =
3202 if active > first
3203 then
3204 let rows = active - first in
3205 if rows > fstate.maxrows then active - fstate.maxrows else first
3206 else active
3209 let scrollph y maxy =
3210 let sh = (float (maxy + state.winh) /. float state.winh) in
3211 let sh = float state.winh /. sh in
3212 let sh = max sh (float conf.scrollh) in
3214 let percent =
3215 if y = state.maxy
3216 then 1.0
3217 else float y /. float maxy
3219 let position = (float state.winh -. sh) *. percent in
3221 let position =
3222 if position +. sh > float state.winh
3223 then float state.winh -. sh
3224 else position
3226 position, sh;
3229 let coe s = (s :> uioh);;
3231 class listview ~(source:lvsource) ~trusted ~modehash =
3232 object (self)
3233 val m_pan = source#getpan
3234 val m_first = source#getfirst
3235 val m_active = source#getactive
3236 val m_qsearch = source#getqsearch
3237 val m_prev_uioh = state.uioh
3239 method private elemunder y =
3240 let n = y / (fstate.fontsize+1) in
3241 if m_first + n < source#getitemcount
3242 then (
3243 if source#hasaction (m_first + n)
3244 then Some (m_first + n)
3245 else None
3247 else None
3249 method display =
3250 Gl.enable `blend;
3251 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3252 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3253 GlDraw.rect (0., 0.) (float state.winw, float state.winh);
3254 GlDraw.color (1., 1., 1.);
3255 Gl.enable `texture_2d;
3256 let fs = fstate.fontsize in
3257 let nfs = fs + 1 in
3258 let ww = fstate.wwidth in
3259 let tabw = 30.0*.ww in
3260 let itemcount = source#getitemcount in
3261 let rec loop row =
3262 if (row - m_first) > fstate.maxrows
3263 then ()
3264 else (
3265 if row >= 0 && row < itemcount
3266 then (
3267 let (s, level) = source#getitem row in
3268 let y = (row - m_first) * nfs in
3269 let x = 5.0 +. float (level + m_pan) *. ww in
3270 if row = m_active
3271 then (
3272 Gl.disable `texture_2d;
3273 GlDraw.polygon_mode `both `line;
3274 GlDraw.color (1., 1., 1.) ~alpha:0.9;
3275 GlDraw.rect (1., float (y + 1))
3276 (float (state.winw - conf.scrollbw - 1), float (y + fs + 3));
3277 GlDraw.polygon_mode `both `fill;
3278 GlDraw.color (1., 1., 1.);
3279 Gl.enable `texture_2d;
3282 let drawtabularstring s =
3283 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3284 if trusted
3285 then
3286 let tabpos = try String.index s '\t' with Not_found -> -1 in
3287 if tabpos > 0
3288 then
3289 let len = String.length s - tabpos - 1 in
3290 let s1 = String.sub s 0 tabpos
3291 and s2 = String.sub s (tabpos + 1) len in
3292 let nx = drawstr x s1 in
3293 let sw = nx -. x in
3294 let x = x +. (max tabw sw) in
3295 drawstr x s2
3296 else
3297 drawstr x s
3298 else
3299 drawstr x s
3301 let _ = drawtabularstring s in
3302 loop (row+1)
3306 loop m_first;
3307 Gl.disable `blend;
3308 Gl.disable `texture_2d;
3310 method updownlevel incr =
3311 let len = source#getitemcount in
3312 let curlevel =
3313 if m_active >= 0 && m_active < len
3314 then snd (source#getitem m_active)
3315 else -1
3317 let rec flow i =
3318 if i = len then i-1 else if i = -1 then 0 else
3319 let _, l = source#getitem i in
3320 if l != curlevel then i else flow (i+incr)
3322 let active = flow m_active in
3323 let first = calcfirst m_first active in
3324 G.postRedisplay "outline updownlevel";
3325 {< m_active = active; m_first = first >}
3327 method private key1 key mask =
3328 let set1 active first qsearch =
3329 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3331 let search active pattern incr =
3332 let dosearch re =
3333 let rec loop n =
3334 if n >= 0 && n < source#getitemcount
3335 then (
3336 let s, _ = source#getitem n in
3338 (try ignore (Str.search_forward re s 0); true
3339 with Not_found -> false)
3340 then Some n
3341 else loop (n + incr)
3343 else None
3345 loop active
3348 let re = Str.regexp_case_fold pattern in
3349 dosearch re
3350 with Failure s ->
3351 state.text <- s;
3352 None
3354 let itemcount = source#getitemcount in
3355 let find start incr =
3356 let rec find i =
3357 if i = -1 || i = itemcount
3358 then -1
3359 else (
3360 if source#hasaction i
3361 then i
3362 else find (i + incr)
3365 find start
3367 let set active first =
3368 let first = bound first 0 (itemcount - fstate.maxrows) in
3369 state.text <- "";
3370 coe {< m_active = active; m_first = first >}
3372 let navigate incr =
3373 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3374 let active, first =
3375 let incr1 = if incr > 0 then 1 else -1 in
3376 if isvisible m_first m_active
3377 then
3378 let next =
3379 let next = m_active + incr in
3380 let next =
3381 if next < 0 || next >= itemcount
3382 then -1
3383 else find next incr1
3385 if next = -1 || abs (m_active - next) > fstate.maxrows
3386 then -1
3387 else next
3389 if next = -1
3390 then
3391 let first = m_first + incr in
3392 let first = bound first 0 (itemcount - 1) in
3393 let next =
3394 let next = m_active + incr in
3395 let next = bound next 0 (itemcount - 1) in
3396 find next ~-incr1
3398 let active = if next = -1 then m_active else next in
3399 active, first
3400 else
3401 let first = min next m_first in
3402 let first =
3403 if abs (next - first) > fstate.maxrows
3404 then first + incr
3405 else first
3407 next, first
3408 else
3409 let first = m_first + incr in
3410 let first = bound first 0 (itemcount - 1) in
3411 let active =
3412 let next = m_active + incr in
3413 let next = bound next 0 (itemcount - 1) in
3414 let next = find next incr1 in
3415 let active =
3416 if next = -1 || abs (m_active - first) > fstate.maxrows
3417 then (
3418 let active = if m_active = -1 then next else m_active in
3419 active
3421 else next
3423 if isvisible first active
3424 then active
3425 else -1
3427 active, first
3429 G.postRedisplay "listview navigate";
3430 set active first;
3432 match key with
3433 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3434 let incr = if key = 0x72 then -1 else 1 in
3435 let active, first =
3436 match search (m_active + incr) m_qsearch incr with
3437 | None ->
3438 state.text <- m_qsearch ^ " [not found]";
3439 m_active, m_first
3440 | Some active ->
3441 state.text <- m_qsearch;
3442 active, firstof m_first active
3444 G.postRedisplay "listview ctrl-r/s";
3445 set1 active first m_qsearch;
3447 | 0xff08 -> (* backspace *)
3448 if String.length m_qsearch = 0
3449 then coe self
3450 else (
3451 let qsearch = withoutlastutf8 m_qsearch in
3452 let len = String.length qsearch in
3453 if len = 0
3454 then (
3455 state.text <- "";
3456 G.postRedisplay "listview empty qsearch";
3457 set1 m_active m_first "";
3459 else
3460 let active, first =
3461 match search m_active qsearch ~-1 with
3462 | None ->
3463 state.text <- qsearch ^ " [not found]";
3464 m_active, m_first
3465 | Some active ->
3466 state.text <- qsearch;
3467 active, firstof m_first active
3469 G.postRedisplay "listview backspace qsearch";
3470 set1 active first qsearch
3473 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3474 let pattern = m_qsearch ^ toutf8 key in
3475 let active, first =
3476 match search m_active pattern 1 with
3477 | None ->
3478 state.text <- pattern ^ " [not found]";
3479 m_active, m_first
3480 | Some active ->
3481 state.text <- pattern;
3482 active, firstof m_first active
3484 G.postRedisplay "listview qsearch add";
3485 set1 active first pattern;
3487 | 0xff1b -> (* escape *)
3488 state.text <- "";
3489 if String.length m_qsearch = 0
3490 then (
3491 G.postRedisplay "list view escape";
3492 begin
3493 match
3494 source#exit (coe self) true m_active m_first m_pan m_qsearch
3495 with
3496 | None -> m_prev_uioh
3497 | Some uioh -> uioh
3500 else (
3501 G.postRedisplay "list view kill qsearch";
3502 source#setqsearch "";
3503 coe {< m_qsearch = "" >}
3506 | 0xff0d | 0xff8d -> (* (kp) enter *)
3507 state.text <- "";
3508 let self = {< m_qsearch = "" >} in
3509 source#setqsearch "";
3510 let opt =
3511 G.postRedisplay "listview enter";
3512 if m_active >= 0 && m_active < source#getitemcount
3513 then (
3514 source#exit (coe self) false m_active m_first m_pan "";
3516 else (
3517 source#exit (coe self) true m_active m_first m_pan "";
3520 begin match opt with
3521 | None -> m_prev_uioh
3522 | Some uioh -> uioh
3525 | 0xff9f | 0xffff -> (* (kp) delete *)
3526 coe self
3528 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3529 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3530 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3531 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3533 | 0xff53 | 0xff98 -> (* (kp) right *)
3534 state.text <- "";
3535 G.postRedisplay "listview right";
3536 coe {< m_pan = m_pan - 1 >}
3538 | 0xff51 | 0xff96 -> (* (kp) left *)
3539 state.text <- "";
3540 G.postRedisplay "listview left";
3541 coe {< m_pan = m_pan + 1 >}
3543 | 0xff50 | 0xff95 -> (* (kp) home *)
3544 let active = find 0 1 in
3545 G.postRedisplay "listview home";
3546 set active 0;
3548 | 0xff57 | 0xff9c -> (* (kp) end *)
3549 let first = max 0 (itemcount - fstate.maxrows) in
3550 let active = find (itemcount - 1) ~-1 in
3551 G.postRedisplay "listview end";
3552 set active first;
3554 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3555 coe self
3557 | _ ->
3558 dolog "listview unknown key %#x" key; coe self
3560 method key key mask =
3561 match state.mode with
3562 | Textentry te -> textentrykeyboard key mask te; coe self
3563 | _ -> self#key1 key mask
3565 method button button down x y _ =
3566 let opt =
3567 match button with
3568 | 1 when x > state.winw - conf.scrollbw ->
3569 G.postRedisplay "listview scroll";
3570 if down
3571 then
3572 let _, position, sh = self#scrollph in
3573 if y > truncate position && y < truncate (position +. sh)
3574 then (
3575 state.mstate <- Mscrolly;
3576 Some (coe self)
3578 else
3579 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3580 let first = truncate (s *. float source#getitemcount) in
3581 let first = min source#getitemcount first in
3582 Some (coe {< m_first = first; m_active = first >})
3583 else (
3584 state.mstate <- Mnone;
3585 Some (coe self);
3587 | 1 when not down ->
3588 begin match self#elemunder y with
3589 | Some n ->
3590 G.postRedisplay "listview click";
3591 source#exit
3592 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3593 | _ ->
3594 Some (coe self)
3596 | n when (n == 4 || n == 5) && not down ->
3597 let len = source#getitemcount in
3598 let first =
3599 if n = 5 && m_first + fstate.maxrows >= len
3600 then
3601 m_first
3602 else
3603 let first = m_first + (if n == 4 then -1 else 1) in
3604 bound first 0 (len - 1)
3606 G.postRedisplay "listview wheel";
3607 Some (coe {< m_first = first >})
3608 | n when (n = 6 || n = 7) && not down ->
3609 let inc = m_first + (if n = 7 then -1 else 1) in
3610 G.postRedisplay "listview hwheel";
3611 Some (coe {< m_pan = m_pan + inc >})
3612 | _ ->
3613 Some (coe self)
3615 match opt with
3616 | None -> m_prev_uioh
3617 | Some uioh -> uioh
3619 method motion _ y =
3620 match state.mstate with
3621 | Mscrolly ->
3622 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
3623 let first = truncate (s *. float source#getitemcount) in
3624 let first = min source#getitemcount first in
3625 G.postRedisplay "listview motion";
3626 coe {< m_first = first; m_active = first >}
3627 | _ -> coe self
3629 method pmotion x y =
3630 if x < state.winw - conf.scrollbw
3631 then
3632 let n =
3633 match self#elemunder y with
3634 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3635 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3637 let o =
3638 if n != m_active
3639 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3640 else self
3642 coe o
3643 else (
3644 Wsi.setcursor Wsi.CURSOR_INHERIT;
3645 coe self
3648 method infochanged _ = ()
3650 method scrollpw = (0, 0.0, 0.0)
3651 method scrollph =
3652 let nfs = fstate.fontsize + 1 in
3653 let y = m_first * nfs in
3654 let itemcount = source#getitemcount in
3655 let maxi = max 0 (itemcount - fstate.maxrows) in
3656 let maxy = maxi * nfs in
3657 let p, h = scrollph y maxy in
3658 conf.scrollbw, p, h
3660 method modehash = modehash
3661 end;;
3663 class outlinelistview ~source =
3664 object (self)
3665 inherit listview
3666 ~source:(source :> lvsource)
3667 ~trusted:false
3668 ~modehash:(findkeyhash conf "outline")
3669 as super
3671 method key key mask =
3672 let calcfirst first active =
3673 if active > first
3674 then
3675 let rows = active - first in
3676 let maxrows =
3677 if String.length state.text = 0
3678 then fstate.maxrows
3679 else fstate.maxrows - 2
3681 if rows > maxrows then active - maxrows else first
3682 else active
3684 let navigate incr =
3685 let active = m_active + incr in
3686 let active = bound active 0 (source#getitemcount - 1) in
3687 let first = calcfirst m_first active in
3688 G.postRedisplay "outline navigate";
3689 coe {< m_active = active; m_first = first >}
3691 let ctrl = Wsi.withctrl mask in
3692 match key with
3693 | 110 when ctrl -> (* ctrl-n *)
3694 source#narrow m_qsearch;
3695 G.postRedisplay "outline ctrl-n";
3696 coe {< m_first = 0; m_active = 0 >}
3698 | 117 when ctrl -> (* ctrl-u *)
3699 source#denarrow;
3700 G.postRedisplay "outline ctrl-u";
3701 state.text <- "";
3702 coe {< m_first = 0; m_active = 0 >}
3704 | 108 when ctrl -> (* ctrl-l *)
3705 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3706 G.postRedisplay "outline ctrl-l";
3707 coe {< m_first = first >}
3709 | 0xff9f | 0xffff -> (* (kp) delete *)
3710 source#remove m_active;
3711 G.postRedisplay "outline delete";
3712 let active = max 0 (m_active-1) in
3713 coe {< m_first = firstof m_first active;
3714 m_active = active >}
3716 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3717 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3718 | 0xff55 | 0xff9a -> (* (kp) prior *)
3719 navigate ~-(fstate.maxrows)
3720 | 0xff56 | 0xff9b -> (* (kp) next *)
3721 navigate fstate.maxrows
3723 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3724 let o =
3725 if ctrl
3726 then (
3727 G.postRedisplay "outline ctrl right";
3728 {< m_pan = m_pan + 1 >}
3730 else self#updownlevel 1
3732 coe o
3734 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3735 let o =
3736 if ctrl
3737 then (
3738 G.postRedisplay "outline ctrl left";
3739 {< m_pan = m_pan - 1 >}
3741 else self#updownlevel ~-1
3743 coe o
3745 | 0xff50 | 0xff95 -> (* (kp) home *)
3746 G.postRedisplay "outline home";
3747 coe {< m_first = 0; m_active = 0 >}
3749 | 0xff57 | 0xff9c -> (* (kp) end *)
3750 let active = source#getitemcount - 1 in
3751 let first = max 0 (active - fstate.maxrows) in
3752 G.postRedisplay "outline end";
3753 coe {< m_active = active; m_first = first >}
3755 | _ -> super#key key mask
3758 let outlinesource usebookmarks =
3759 let empty = [||] in
3760 (object
3761 inherit lvsourcebase
3762 val mutable m_items = empty
3763 val mutable m_orig_items = empty
3764 val mutable m_prev_items = empty
3765 val mutable m_narrow_pattern = ""
3766 val mutable m_hadremovals = false
3768 method getitemcount =
3769 Array.length m_items + (if m_hadremovals then 1 else 0)
3771 method getitem n =
3772 if n == Array.length m_items && m_hadremovals
3773 then
3774 ("[Confirm removal]", 0)
3775 else
3776 let s, n, _ = m_items.(n) in
3777 (s, n)
3779 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3780 ignore (uioh, first, qsearch);
3781 let confrimremoval = m_hadremovals && active = Array.length m_items in
3782 let items =
3783 if String.length m_narrow_pattern = 0
3784 then m_orig_items
3785 else m_items
3787 if not cancel
3788 then (
3789 if not confrimremoval
3790 then(
3791 let _, _, anchor = m_items.(active) in
3792 gotoghyll (getanchory anchor);
3793 m_items <- items;
3795 else (
3796 state.bookmarks <- Array.to_list m_items;
3797 m_orig_items <- m_items;
3800 else m_items <- items;
3801 m_pan <- pan;
3802 None
3804 method hasaction _ = true
3806 method greetmsg =
3807 if Array.length m_items != Array.length m_orig_items
3808 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3809 else ""
3811 method narrow pattern =
3812 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3813 match reopt with
3814 | None -> ()
3815 | Some re ->
3816 let rec loop accu n =
3817 if n = -1
3818 then (
3819 m_narrow_pattern <- pattern;
3820 m_items <- Array.of_list accu
3822 else
3823 let (s, _, _) as o = m_items.(n) in
3824 let accu =
3825 if (try ignore (Str.search_forward re s 0); true
3826 with Not_found -> false)
3827 then o :: accu
3828 else accu
3830 loop accu (n-1)
3832 loop [] (Array.length m_items - 1)
3834 method denarrow =
3835 m_orig_items <- (
3836 if usebookmarks
3837 then Array.of_list state.bookmarks
3838 else state.outlines
3840 m_items <- m_orig_items
3842 method remove m =
3843 if usebookmarks
3844 then
3845 if m >= 0 && m < Array.length m_items
3846 then (
3847 m_hadremovals <- true;
3848 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3849 let n = if n >= m then n+1 else n in
3850 m_items.(n)
3854 method reset anchor items =
3855 m_hadremovals <- false;
3856 if m_orig_items == empty || m_prev_items != items
3857 then (
3858 m_orig_items <- items;
3859 if String.length m_narrow_pattern = 0
3860 then m_items <- items;
3862 m_prev_items <- items;
3863 let rely = getanchory anchor in
3864 let active =
3865 let rec loop n best bestd =
3866 if n = Array.length m_items
3867 then best
3868 else
3869 let (_, _, anchor) = m_items.(n) in
3870 let orely = getanchory anchor in
3871 let d = abs (orely - rely) in
3872 if d < bestd
3873 then loop (n+1) n d
3874 else loop (n+1) best bestd
3876 loop 0 ~-1 max_int
3878 m_active <- active;
3879 m_first <- firstof m_first active
3880 end)
3883 let enterselector usebookmarks =
3884 let source = outlinesource usebookmarks in
3885 fun errmsg ->
3886 let outlines =
3887 if usebookmarks
3888 then Array.of_list state.bookmarks
3889 else state.outlines
3891 if Array.length outlines = 0
3892 then (
3893 showtext ' ' errmsg;
3895 else (
3896 state.text <- source#greetmsg;
3897 Wsi.setcursor Wsi.CURSOR_INHERIT;
3898 let anchor = getanchor () in
3899 source#reset anchor outlines;
3900 state.uioh <- coe (new outlinelistview ~source);
3901 G.postRedisplay "enter selector";
3905 let enteroutlinemode =
3906 let f = enterselector false in
3907 fun ()-> f "Document has no outline";
3910 let enterbookmarkmode =
3911 let f = enterselector true in
3912 fun () -> f "Document has no bookmarks (yet)";
3915 let color_of_string s =
3916 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
3917 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
3921 let color_to_string (r, g, b) =
3922 let r = truncate (r *. 256.0)
3923 and g = truncate (g *. 256.0)
3924 and b = truncate (b *. 256.0) in
3925 Printf.sprintf "%d/%d/%d" r g b
3928 let irect_of_string s =
3929 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
3932 let irect_to_string (x0,y0,x1,y1) =
3933 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
3936 let makecheckers () =
3937 (* Based on lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3938 following to say:
3939 converted by Issac Trotts. July 25, 2002 *)
3940 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3941 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3942 let id = GlTex.gen_texture () in
3943 GlTex.bind_texture `texture_2d id;
3944 GlPix.store (`unpack_alignment 1);
3945 GlTex.image2d image;
3946 List.iter (GlTex.parameter ~target:`texture_2d)
3947 [ `mag_filter `nearest; `min_filter `nearest ];
3951 let setcheckers enabled =
3952 match state.texid with
3953 | None ->
3954 if enabled then state.texid <- Some (makecheckers ())
3956 | Some texid ->
3957 if not enabled
3958 then (
3959 GlTex.delete_texture texid;
3960 state.texid <- None;
3964 let int_of_string_with_suffix s =
3965 let l = String.length s in
3966 let s1, shift =
3967 if l > 1
3968 then
3969 let suffix = Char.lowercase s.[l-1] in
3970 match suffix with
3971 | 'k' -> String.sub s 0 (l-1), 10
3972 | 'm' -> String.sub s 0 (l-1), 20
3973 | 'g' -> String.sub s 0 (l-1), 30
3974 | _ -> s, 0
3975 else s, 0
3977 let n = int_of_string s1 in
3978 let m = n lsl shift in
3979 if m < 0 || m < n
3980 then raise (Failure "value too large")
3981 else m
3984 let string_with_suffix_of_int n =
3985 if n = 0
3986 then "0"
3987 else
3988 let n, s =
3989 if n land ((1 lsl 30) - 1) = 0
3990 then n lsr 30, "G"
3991 else (
3992 if n land ((1 lsl 20) - 1) = 0
3993 then n lsr 20, "M"
3994 else (
3995 if n land ((1 lsl 10) - 1) = 0
3996 then n lsr 10, "K"
3997 else n, ""
4001 let rec loop s n =
4002 let h = n mod 1000 in
4003 let n = n / 1000 in
4004 if n = 0
4005 then string_of_int h ^ s
4006 else (
4007 let s = Printf.sprintf "_%03d%s" h s in
4008 loop s n
4011 loop "" n ^ s;
4014 let defghyllscroll = (40, 8, 32);;
4015 let ghyllscroll_of_string s =
4016 let (n, a, b) as nab =
4017 if s = "default"
4018 then defghyllscroll
4019 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
4021 if n <= a || n <= b || a >= b
4022 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
4023 nab;
4026 let ghyllscroll_to_string ((n, a, b) as nab) =
4027 if nab = defghyllscroll
4028 then "default"
4029 else Printf.sprintf "%d,%d,%d" n a b;
4032 let describe_location () =
4033 let fn = page_of_y state.y in
4034 let ln = page_of_y (state.y + state.winh - state.hscrollh) in
4035 let maxy = state.maxy - (if conf.maxhfit then state.winh else 0) in
4036 let percent =
4037 if maxy <= 0
4038 then 100.
4039 else (100. *. (float state.y /. float maxy))
4041 if fn = ln
4042 then
4043 Printf.sprintf "page %d of %d [%.2f%%]"
4044 (fn+1) state.pagecount percent
4045 else
4046 Printf.sprintf
4047 "pages %d-%d of %d [%.2f%%]"
4048 (fn+1) (ln+1) state.pagecount percent
4051 let setpresentationmode v =
4052 let n = page_of_y state.y in
4053 state.anchor <- (n, 0.0, 1.0);
4054 conf.presentation <- v;
4055 if conf.presentation
4056 then (
4057 if not conf.scrollbarinpm
4058 then state.scrollw <- 0;
4060 else state.scrollw <- conf.scrollbw;
4061 represent ();
4064 let enterinfomode =
4065 let btos b = if b then "\xe2\x88\x9a" else "" in
4066 let showextended = ref false in
4067 let leave mode = function
4068 | Confirm -> state.mode <- mode
4069 | Cancel -> state.mode <- mode in
4070 let src =
4071 (object
4072 val mutable m_first_time = true
4073 val mutable m_l = []
4074 val mutable m_a = [||]
4075 val mutable m_prev_uioh = nouioh
4076 val mutable m_prev_mode = View
4078 inherit lvsourcebase
4080 method reset prev_mode prev_uioh =
4081 m_a <- Array.of_list (List.rev m_l);
4082 m_l <- [];
4083 m_prev_mode <- prev_mode;
4084 m_prev_uioh <- prev_uioh;
4085 if m_first_time
4086 then (
4087 let rec loop n =
4088 if n >= Array.length m_a
4089 then ()
4090 else
4091 match m_a.(n) with
4092 | _, _, _, Action _ -> m_active <- n
4093 | _ -> loop (n+1)
4095 loop 0;
4096 m_first_time <- false;
4099 method int name get set =
4100 m_l <-
4101 (name, `int get, 1, Action (
4102 fun u ->
4103 let ondone s =
4104 try set (int_of_string s)
4105 with exn ->
4106 state.text <- Printf.sprintf "bad integer `%s': %s"
4107 s (exntos exn)
4109 state.text <- "";
4110 let te = name ^ ": ", "", None, intentry, ondone, true in
4111 state.mode <- Textentry (te, leave m_prev_mode);
4113 )) :: m_l
4115 method int_with_suffix name get set =
4116 m_l <-
4117 (name, `intws get, 1, Action (
4118 fun u ->
4119 let ondone s =
4120 try set (int_of_string_with_suffix s)
4121 with exn ->
4122 state.text <- Printf.sprintf "bad integer `%s': %s"
4123 s (exntos exn)
4125 state.text <- "";
4126 let te =
4127 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4129 state.mode <- Textentry (te, leave m_prev_mode);
4131 )) :: m_l
4133 method bool ?(offset=1) ?(btos=btos) name get set =
4134 m_l <-
4135 (name, `bool (btos, get), offset, Action (
4136 fun u ->
4137 let v = get () in
4138 set (not v);
4140 )) :: m_l
4142 method color name get set =
4143 m_l <-
4144 (name, `color get, 1, Action (
4145 fun u ->
4146 let invalid = (nan, nan, nan) in
4147 let ondone s =
4148 let c =
4149 try color_of_string s
4150 with exn ->
4151 state.text <- Printf.sprintf "bad color `%s': %s"
4152 s (exntos exn);
4153 invalid
4155 if c <> invalid
4156 then set c;
4158 let te = name ^ ": ", "", None, textentry, ondone, true in
4159 state.text <- color_to_string (get ());
4160 state.mode <- Textentry (te, leave m_prev_mode);
4162 )) :: m_l
4164 method string name get set =
4165 m_l <-
4166 (name, `string get, 1, Action (
4167 fun u ->
4168 let ondone s = set s in
4169 let te = name ^ ": ", "", None, textentry, ondone, true in
4170 state.mode <- Textentry (te, leave m_prev_mode);
4172 )) :: m_l
4174 method colorspace name get set =
4175 m_l <-
4176 (name, `string get, 1, Action (
4177 fun _ ->
4178 let source =
4179 let vals = [| "rgb"; "bgr"; "gray" |] in
4180 (object
4181 inherit lvsourcebase
4183 initializer
4184 m_active <- int_of_colorspace conf.colorspace;
4185 m_first <- 0;
4187 method getitemcount = Array.length vals
4188 method getitem n = (vals.(n), 0)
4189 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4190 ignore (uioh, first, pan, qsearch);
4191 if not cancel then set active;
4192 None
4193 method hasaction _ = true
4194 end)
4196 state.text <- "";
4197 let modehash = findkeyhash conf "info" in
4198 coe (new listview ~source ~trusted:true ~modehash)
4199 )) :: m_l
4201 method caption s offset =
4202 m_l <- (s, `empty, offset, Noaction) :: m_l
4204 method caption2 s f offset =
4205 m_l <- (s, `string f, offset, Noaction) :: m_l
4207 method getitemcount = Array.length m_a
4209 method getitem n =
4210 let tostr = function
4211 | `int f -> string_of_int (f ())
4212 | `intws f -> string_with_suffix_of_int (f ())
4213 | `string f -> f ()
4214 | `color f -> color_to_string (f ())
4215 | `bool (btos, f) -> btos (f ())
4216 | `empty -> ""
4218 let name, t, offset, _ = m_a.(n) in
4219 ((let s = tostr t in
4220 if String.length s > 0
4221 then Printf.sprintf "%s\t%s" name s
4222 else name),
4223 offset)
4225 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
4226 let uiohopt =
4227 if not cancel
4228 then (
4229 m_qsearch <- qsearch;
4230 let uioh =
4231 match m_a.(active) with
4232 | _, _, _, Action f -> f uioh
4233 | _ -> uioh
4235 Some uioh
4237 else None
4239 m_active <- active;
4240 m_first <- first;
4241 m_pan <- pan;
4242 uiohopt
4244 method hasaction n =
4245 match m_a.(n) with
4246 | _, _, _, Action _ -> true
4247 | _ -> false
4248 end)
4250 let rec fillsrc prevmode prevuioh =
4251 let sep () = src#caption "" 0 in
4252 let colorp name get set =
4253 src#string name
4254 (fun () -> color_to_string (get ()))
4255 (fun v ->
4257 let c = color_of_string v in
4258 set c
4259 with exn ->
4260 state.text <- Printf.sprintf "bad color `%s': %s" v (exntos exn)
4263 let oldmode = state.mode in
4264 let birdseye = isbirdseye state.mode in
4266 src#caption (if birdseye then "Setup (Bird's eye)" else "Setup") 0;
4268 src#bool "presentation mode"
4269 (fun () -> conf.presentation)
4270 (fun v -> setpresentationmode v);
4272 src#bool "ignore case in searches"
4273 (fun () -> conf.icase)
4274 (fun v -> conf.icase <- v);
4276 src#bool "preload"
4277 (fun () -> conf.preload)
4278 (fun v -> conf.preload <- v);
4280 src#bool "highlight links"
4281 (fun () -> conf.hlinks)
4282 (fun v -> conf.hlinks <- v);
4284 src#bool "under info"
4285 (fun () -> conf.underinfo)
4286 (fun v -> conf.underinfo <- v);
4288 src#bool "persistent bookmarks"
4289 (fun () -> conf.savebmarks)
4290 (fun v -> conf.savebmarks <- v);
4292 src#bool "proportional display"
4293 (fun () -> conf.proportional)
4294 (fun v -> reqlayout conf.angle v);
4296 src#bool "trim margins"
4297 (fun () -> conf.trimmargins)
4298 (fun v -> settrim v conf.trimfuzz; fillsrc prevmode prevuioh);
4300 src#bool "persistent location"
4301 (fun () -> conf.jumpback)
4302 (fun v -> conf.jumpback <- v);
4304 sep ();
4305 src#int "inter-page space"
4306 (fun () -> conf.interpagespace)
4307 (fun n ->
4308 conf.interpagespace <- n;
4309 docolumns conf.columns;
4310 let pageno, py =
4311 match state.layout with
4312 | [] -> 0, 0
4313 | l :: _ ->
4314 l.pageno, l.pagey
4316 state.maxy <- calcheight ();
4317 let y = getpagey pageno in
4318 gotoy (y + py)
4321 src#int "page bias"
4322 (fun () -> conf.pagebias)
4323 (fun v -> conf.pagebias <- v);
4325 src#int "scroll step"
4326 (fun () -> conf.scrollstep)
4327 (fun n -> conf.scrollstep <- n);
4329 src#int "horizontal scroll step"
4330 (fun () -> conf.hscrollstep)
4331 (fun v -> conf.hscrollstep <- v);
4333 src#int "auto scroll step"
4334 (fun () ->
4335 match state.autoscroll with
4336 | Some step -> step
4337 | _ -> conf.autoscrollstep)
4338 (fun n ->
4339 if state.autoscroll <> None
4340 then state.autoscroll <- Some n;
4341 conf.autoscrollstep <- n);
4343 src#int "zoom"
4344 (fun () -> truncate (conf.zoom *. 100.))
4345 (fun v -> setzoom ((float v) /. 100.));
4347 src#int "rotation"
4348 (fun () -> conf.angle)
4349 (fun v -> reqlayout v conf.proportional);
4351 src#int "scroll bar width"
4352 (fun () -> state.scrollw)
4353 (fun v ->
4354 state.scrollw <- v;
4355 conf.scrollbw <- v;
4356 reshape state.winw state.winh;
4359 src#int "scroll handle height"
4360 (fun () -> conf.scrollh)
4361 (fun v -> conf.scrollh <- v;);
4363 src#int "thumbnail width"
4364 (fun () -> conf.thumbw)
4365 (fun v ->
4366 conf.thumbw <- min 4096 v;
4367 match oldmode with
4368 | Birdseye beye ->
4369 leavebirdseye beye false;
4370 enterbirdseye ()
4371 | _ -> ()
4374 let mode = state.mode in
4375 src#string "columns"
4376 (fun () ->
4377 match conf.columns with
4378 | Csingle _ -> "1"
4379 | Cmulti (multi, _) -> multicolumns_to_string multi
4380 | Csplit (count, _) -> "-" ^ string_of_int count
4382 (fun v ->
4383 let n, a, b = multicolumns_of_string v in
4384 setcolumns mode n a b);
4386 sep ();
4387 src#caption "Presentation mode" 0;
4388 src#bool "scrollbar visible"
4389 (fun () -> conf.scrollbarinpm)
4390 (fun v ->
4391 if v != conf.scrollbarinpm
4392 then (
4393 conf.scrollbarinpm <- v;
4394 if conf.presentation
4395 then (
4396 state.scrollw <- if v then conf.scrollbw else 0;
4397 reshape state.winw state.winh;
4402 sep ();
4403 src#caption "Pixmap cache" 0;
4404 src#int_with_suffix "size (advisory)"
4405 (fun () -> conf.memlimit)
4406 (fun v -> conf.memlimit <- v);
4408 src#caption2 "used"
4409 (fun () -> Printf.sprintf "%s bytes, %d tiles"
4410 (string_with_suffix_of_int state.memused)
4411 (Hashtbl.length state.tilemap)) 1;
4413 sep ();
4414 src#caption "Layout" 0;
4415 src#caption2 "Dimension"
4416 (fun () ->
4417 Printf.sprintf "%dx%d (virtual %dx%d)"
4418 state.winw state.winh
4419 state.w state.maxy)
4421 if conf.debug
4422 then
4423 src#caption2 "Position" (fun () ->
4424 Printf.sprintf "%dx%d" state.x state.y
4426 else
4427 src#caption2 "Position" (fun () -> describe_location ()) 1
4430 sep ();
4431 src#bool ~offset:0 ~btos:(fun v -> if v then "(on)" else "(off)")
4432 "Save these parameters as global defaults at exit"
4433 (fun () -> conf.bedefault)
4434 (fun v -> conf.bedefault <- v)
4437 sep ();
4438 let btos b = if b then "\xc2\xab" else "\xc2\xbb" in
4439 src#bool ~offset:0 ~btos "Extended parameters"
4440 (fun () -> !showextended)
4441 (fun v -> showextended := v; fillsrc prevmode prevuioh);
4442 if !showextended
4443 then (
4444 src#bool "checkers"
4445 (fun () -> conf.checkers)
4446 (fun v -> conf.checkers <- v; setcheckers v);
4447 src#bool "update cursor"
4448 (fun () -> conf.updatecurs)
4449 (fun v -> conf.updatecurs <- v);
4450 src#bool "verbose"
4451 (fun () -> conf.verbose)
4452 (fun v -> conf.verbose <- v);
4453 src#bool "invert colors"
4454 (fun () -> conf.invert)
4455 (fun v -> conf.invert <- v);
4456 src#bool "max fit"
4457 (fun () -> conf.maxhfit)
4458 (fun v -> conf.maxhfit <- v);
4459 src#bool "redirect stderr"
4460 (fun () -> conf.redirectstderr)
4461 (fun v -> conf.redirectstderr <- v; redirectstderr ());
4462 src#string "uri launcher"
4463 (fun () -> conf.urilauncher)
4464 (fun v -> conf.urilauncher <- v);
4465 src#string "path launcher"
4466 (fun () -> conf.pathlauncher)
4467 (fun v -> conf.pathlauncher <- v);
4468 src#string "tile size"
4469 (fun () -> Printf.sprintf "%dx%d" conf.tilew conf.tileh)
4470 (fun v ->
4472 let w, h = Scanf.sscanf v "%dx%d" (fun w h -> w, h) in
4473 conf.tilew <- max 64 w;
4474 conf.tileh <- max 64 h;
4475 flushtiles ();
4476 with exn ->
4477 state.text <- Printf.sprintf "bad tile size `%s': %s"
4478 v (exntos exn)
4480 src#int "texture count"
4481 (fun () -> conf.texcount)
4482 (fun v ->
4483 if realloctexts v
4484 then conf.texcount <- v
4485 else showtext '!' " Failed to set texture count please retry later"
4487 src#int "slice height"
4488 (fun () -> conf.sliceheight)
4489 (fun v ->
4490 conf.sliceheight <- v;
4491 wcmd "sliceh %d" conf.sliceheight;
4493 src#int "anti-aliasing level"
4494 (fun () -> conf.aalevel)
4495 (fun v ->
4496 conf.aalevel <- bound v 0 8;
4497 state.anchor <- getanchor ();
4498 opendoc state.path state.password;
4500 src#string "page scroll scaling factor"
4501 (fun () -> string_of_float conf.pgscale)
4502 (fun v ->
4504 let s = float_of_string v in
4505 conf.pgscale <- s
4506 with exn ->
4507 state.text <- Printf.sprintf
4508 "bad page scroll scaling factor `%s': %s" v (exntos exn)
4511 src#int "ui font size"
4512 (fun () -> fstate.fontsize)
4513 (fun v -> setfontsize (bound v 5 100));
4514 src#int "hint font size"
4515 (fun () -> conf.hfsize)
4516 (fun v -> conf.hfsize <- bound v 5 100);
4517 colorp "background color"
4518 (fun () -> conf.bgcolor)
4519 (fun v -> conf.bgcolor <- v);
4520 src#bool "crop hack"
4521 (fun () -> conf.crophack)
4522 (fun v -> conf.crophack <- v);
4523 src#string "trim fuzz"
4524 (fun () -> irect_to_string conf.trimfuzz)
4525 (fun v ->
4527 conf.trimfuzz <- irect_of_string v;
4528 if conf.trimmargins
4529 then settrim true conf.trimfuzz;
4530 with exn ->
4531 state.text <- Printf.sprintf "bad irect `%s': %s" v (exntos exn)
4533 src#string "throttle"
4534 (fun () ->
4535 match conf.maxwait with
4536 | None -> "show place holder if page is not ready"
4537 | Some time ->
4538 if time = infinity
4539 then "wait for page to fully render"
4540 else
4541 "wait " ^ string_of_float time
4542 ^ " seconds before showing placeholder"
4544 (fun v ->
4546 let f = float_of_string v in
4547 if f <= 0.0
4548 then conf.maxwait <- None
4549 else conf.maxwait <- Some f
4550 with exn ->
4551 state.text <- Printf.sprintf "bad time `%s': %s" v (exntos exn)
4553 src#string "ghyll scroll"
4554 (fun () ->
4555 match conf.ghyllscroll with
4556 | None -> ""
4557 | Some nab -> ghyllscroll_to_string nab
4559 (fun v ->
4561 let gs =
4562 if String.length v = 0
4563 then None
4564 else Some (ghyllscroll_of_string v)
4566 conf.ghyllscroll <- gs
4567 with exn ->
4568 state.text <- Printf.sprintf "bad ghyll `%s': %s" v (exntos exn)
4570 src#string "selection command"
4571 (fun () -> conf.selcmd)
4572 (fun v -> conf.selcmd <- v);