Remove pointless condition
[llpp.git] / main.ml
blob121008ac26db7b36f69614784946a66f1ca9d78c
1 exception Quit;;
3 let tempfailureretry = Wsi.tempfailureretry;;
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 let dolog fmt = Printf.kprintf prerr_endline fmt;;
17 let now = Unix.gettimeofday;;
19 type params = (angle * proportional * trimparams
20 * texcount * sliceheight * memsize
21 * colorspace * fontpath * trimcachepath
22 * haspbo)
23 and pageno = int
24 and width = int
25 and height = int
26 and leftx = int
27 and opaque = string
28 and recttype = int
29 and pixmapsize = int
30 and angle = int
31 and proportional = bool
32 and trimmargins = bool
33 and interpagespace = int
34 and texcount = int
35 and sliceheight = int
36 and gen = int
37 and top = float
38 and dtop = float
39 and fontpath = string
40 and trimcachepath = string
41 and memsize = int
42 and aalevel = int
43 and irect = (int * int * int * int)
44 and trimparams = (trimmargins * irect)
45 and colorspace = | Rgb | Bgr | Gray
46 and haspbo = bool
49 type link =
50 | Lnotfound
51 | Lfound of int
52 and linkdir =
53 | LDfirst
54 | LDlast
55 | LDfirstvisible of (int * int * int)
56 | LDleft of int
57 | LDright of int
58 | LDdown of int
59 | LDup of int
62 type pagewithlinks =
63 | Pwlnotfound
64 | Pwl of int
67 type keymap =
68 | KMinsrt of key
69 | KMinsrl of key list
70 | KMmulti of key list * key list
71 and key = int * int
72 and keyhash = (key, keymap) Hashtbl.t
73 and keystate =
74 | KSnone
75 | KSinto of (key list * key list)
78 type platform = | Punknown | Plinux | Posx | Psun | Pfreebsd
79 | Pdragonflybsd | Popenbsd | Pnetbsd | Pcygwin;;
81 type pipe = (Unix.file_descr * Unix.file_descr);;
83 external init : pipe -> params -> unit = "ml_init";;
84 external seltext : string -> (int * int * int * int) -> unit = "ml_seltext";;
85 external copysel : Unix.file_descr -> opaque -> unit = "ml_copysel";;
86 external getpdimrect : int -> float array = "ml_getpdimrect";;
87 external whatsunder : string -> int -> int -> under = "ml_whatsunder";;
88 external zoomforh : int -> int -> int -> int -> float = "ml_zoom_for_height";;
89 external drawstr : int -> int -> int -> string -> float = "ml_draw_string";;
90 external measurestr : int -> string -> float = "ml_measure_string";;
91 external getmaxw : unit -> float = "ml_getmaxw";;
92 external postprocess :
93 opaque -> int -> int -> int -> (int * string * int) -> int = "ml_postprocess";;
94 external pagebbox : opaque -> (int * int * int * int) = "ml_getpagebox";;
95 external platform : unit -> platform = "ml_platform";;
96 external setaalevel : int -> unit = "ml_setaalevel";;
97 external realloctexts : int -> bool = "ml_realloctexts";;
98 external cloexec : Unix.file_descr -> unit = "ml_cloexec";;
99 external findlink : opaque -> linkdir -> link = "ml_findlink";;
100 external getlink : opaque -> int -> under = "ml_getlink";;
101 external getlinkrect : opaque -> int -> irect = "ml_getlinkrect";;
102 external getlinkcount : opaque -> int = "ml_getlinkcount";;
103 external findpwl: int -> int -> pagewithlinks = "ml_find_page_with_links"
104 external popen : string -> (Unix.file_descr * int) list -> unit = "ml_popen";;
105 external mbtoutf8 : string -> string = "ml_mbtoutf8";;
106 external getpbo : width -> height -> colorspace -> string = "ml_getpbo";;
107 external freepbo : string -> unit = "ml_freepbo";;
108 external unmappbo : string -> unit = "ml_unmappbo";;
109 external pbousable : unit -> bool = "ml_pbo_usable";;
111 let platform_to_string = function
112 | Punknown -> "unknown"
113 | Plinux -> "Linux"
114 | Posx -> "OSX"
115 | Psun -> "Sun"
116 | Pfreebsd -> "FreeBSD"
117 | Pdragonflybsd -> "DragonflyBSD"
118 | Popenbsd -> "OpenBSD"
119 | Pnetbsd -> "NetBSD"
120 | Pcygwin -> "Cygwin"
123 let platform = platform ();;
125 let popen cmd fda =
126 if platform = Pcygwin
127 then (
128 let sh = "/bin/sh" in
129 let args = [|sh; "-c"; cmd|] in
130 let rec std si so se = function
131 | [] -> si, so, se
132 | (fd, 0) :: rest -> std fd so se rest
133 | (fd, -1) :: rest ->
134 Unix.set_close_on_exec fd;
135 std si so se rest
136 | (_, n) :: _ ->
137 failwith ("unexpected fdn in cygwin popen " ^ string_of_int n)
139 let si, so, se = std Unix.stdin Unix.stdout Unix.stderr fda in
140 ignore (Unix.create_process sh args si so se)
142 else popen cmd fda;
145 type x = int
146 and y = int
147 and tilex = int
148 and tiley = int
149 and tileparams = (x * y * width * height * tilex * tiley)
152 external drawtile : tileparams -> opaque -> unit = "ml_drawtile";;
154 type mpos = int * int
155 and mstate =
156 | Msel of (mpos * mpos)
157 | Mpan of mpos
158 | Mscrolly | Mscrollx
159 | Mzoom of (int * int)
160 | Mzoomrect of (mpos * mpos)
161 | Mnone
164 type textentry = string * string * onhist option * onkey * ondone * cancelonempty
165 and onkey = string -> int -> te
166 and ondone = string -> unit
167 and histcancel = unit -> unit
168 and onhist = ((histcmd -> string) * histcancel)
169 and histcmd = HCnext | HCprev | HCfirst | HClast
170 and cancelonempty = bool
171 and te =
172 | TEstop
173 | TEdone of string
174 | TEcont of string
175 | TEswitch of textentry
178 type 'a circbuf =
179 { store : 'a array
180 ; mutable rc : int
181 ; mutable wc : int
182 ; mutable len : int
186 let bound v minv maxv =
187 max minv (min maxv v);
190 let cbnew n v =
191 { store = Array.create n v
192 ; rc = 0
193 ; wc = 0
194 ; len = 0
198 let cbcap b = Array.length b.store;;
200 let cbput b v =
201 let cap = cbcap b in
202 b.store.(b.wc) <- v;
203 b.wc <- (b.wc + 1) mod cap;
204 b.rc <- b.wc;
205 b.len <- min (b.len + 1) cap;
208 let cbempty b = b.len = 0;;
210 let cbgetg b circular dir =
211 if cbempty b
212 then b.store.(0)
213 else
214 let rc = b.rc + dir in
215 let rc =
216 if circular
217 then (
218 if rc = -1
219 then b.len-1
220 else (
221 if rc >= b.len
222 then 0
223 else rc
226 else bound rc 0 (b.len-1)
228 b.rc <- rc;
229 b.store.(rc);
232 let cbget b = cbgetg b false;;
233 let cbgetc b = cbgetg b true;;
235 let drawstring size x y s =
236 Gl.enable `blend;
237 Gl.enable `texture_2d;
238 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
239 ignore (drawstr size x y s);
240 Gl.disable `blend;
241 Gl.disable `texture_2d;
244 let drawstring1 size x y s =
245 drawstr size x y s;
248 let drawstring2 size x y fmt =
249 Printf.kprintf (drawstring size (x+1) (y+size+1)) fmt
252 type page =
253 { pageno : int
254 ; pagedimno : int
255 ; pagew : int
256 ; pageh : int
257 ; pagex : int
258 ; pagey : int
259 ; pagevw : int
260 ; pagevh : int
261 ; pagedispx : int
262 ; pagedispy : int
263 ; pagecol : int
267 let debugl l =
268 dolog "l %d dim=%d {" l.pageno l.pagedimno;
269 dolog " WxH %dx%d" l.pagew l.pageh;
270 dolog " vWxH %dx%d" l.pagevw l.pagevh;
271 dolog " pagex,y %d,%d" l.pagex l.pagey;
272 dolog " dispx,y %d,%d" l.pagedispx l.pagedispy;
273 dolog " column %d" l.pagecol;
274 dolog "}";
277 let debugrect (x0, y0, x1, y1, x2, y2, x3, y3) =
278 dolog "rect {";
279 dolog " x0,y0=(% f, % f)" x0 y0;
280 dolog " x1,y1=(% f, % f)" x1 y1;
281 dolog " x2,y2=(% f, % f)" x2 y2;
282 dolog " x3,y3=(% f, % f)" x3 y3;
283 dolog "}";
286 type multicolumns = multicol * pagegeom
287 and singlecolumn = pagegeom
288 and splitcolumns = columncount * pagegeom
289 and pagegeom = ((pdimno * x * y * (pageno * width * height * leftx)) array)
290 and multicol = columncount * covercount * covercount
291 and pdimno = int
292 and columncount = int
293 and covercount = int;;
295 type conf =
296 { mutable scrollbw : int
297 ; mutable scrollh : int
298 ; mutable icase : bool
299 ; mutable preload : bool
300 ; mutable pagebias : int
301 ; mutable verbose : bool
302 ; mutable debug : bool
303 ; mutable scrollstep : int
304 ; mutable hscrollstep : int
305 ; mutable maxhfit : bool
306 ; mutable crophack : bool
307 ; mutable autoscrollstep : int
308 ; mutable maxwait : float option
309 ; mutable hlinks : bool
310 ; mutable underinfo : bool
311 ; mutable interpagespace : interpagespace
312 ; mutable zoom : float
313 ; mutable presentation : bool
314 ; mutable angle : angle
315 ; mutable winw : int
316 ; mutable winh : int
317 ; mutable savebmarks : bool
318 ; mutable proportional : proportional
319 ; mutable trimmargins : trimmargins
320 ; mutable trimfuzz : irect
321 ; mutable memlimit : memsize
322 ; mutable texcount : texcount
323 ; mutable sliceheight : sliceheight
324 ; mutable thumbw : width
325 ; mutable jumpback : bool
326 ; mutable bgcolor : float * float * float
327 ; mutable bedefault : bool
328 ; mutable scrollbarinpm : bool
329 ; mutable tilew : int
330 ; mutable tileh : int
331 ; mutable mustoresize : memsize
332 ; mutable checkers : bool
333 ; mutable aalevel : int
334 ; mutable urilauncher : string
335 ; mutable pathlauncher : string
336 ; mutable colorspace : colorspace
337 ; mutable invert : bool
338 ; mutable colorscale : float
339 ; mutable redirectstderr : bool
340 ; mutable ghyllscroll : (int * int * int) option
341 ; mutable columns : columns
342 ; mutable beyecolumns : columncount option
343 ; mutable selcmd : string
344 ; mutable updatecurs : bool
345 ; mutable keyhashes : (string * keyhash) list
346 ; mutable hfsize : int
347 ; mutable pgscale : float
348 ; mutable usepbo : bool
349 ; mutable wheelbypage : bool
351 and columns =
352 | Csingle of singlecolumn
353 | Cmulti of multicolumns
354 | Csplit of splitcolumns
357 type anchor = pageno * top * dtop;;
359 type outline = string * int * anchor;;
361 type rect = float * float * float * float * float * float * float * float;;
363 type tile = opaque * pixmapsize * elapsed
364 and elapsed = float;;
365 type pagemapkey = pageno * gen;;
366 type tilemapkey = pageno * gen * colorspace * angle * width * height * col * row
367 and row = int
368 and col = int;;
370 let emptyanchor = (0, 0.0, 0.0);;
372 type infochange = | Memused | Docinfo | Pdim;;
374 class type uioh = object
375 method display : unit
376 method key : int -> int -> uioh
377 method button : int -> bool -> int -> int -> int -> uioh
378 method motion : int -> int -> uioh
379 method pmotion : int -> int -> uioh
380 method infochanged : infochange -> unit
381 method scrollpw : (int * float * float)
382 method scrollph : (int * float * float)
383 method modehash : keyhash
384 end;;
386 type mode =
387 | Birdseye of (conf * leftx * pageno * pageno * anchor)
388 | Textentry of (textentry * onleave)
389 | View
390 | LinkNav of linktarget
391 and onleave = leavetextentrystatus -> unit
392 and leavetextentrystatus = | Cancel | Confirm
393 and helpitem = string * int * action
394 and action =
395 | Noaction
396 | Action of (uioh -> uioh)
397 and linktarget =
398 | Ltexact of (pageno * int)
399 | Ltgendir of int
402 let isbirdseye = function Birdseye _ -> true | _ -> false;;
403 let istextentry = function Textentry _ -> true | _ -> false;;
405 type currently =
406 | Idle
407 | Loading of (page * gen)
408 | Tiling of (
409 page * opaque * colorspace * angle * gen * col * row * width * height
411 | Outlining of outline list
414 let emptykeyhash = Hashtbl.create 0;;
415 let nouioh : uioh = object (self)
416 method display = ()
417 method key _ _ = self
418 method button _ _ _ _ _ = self
419 method motion _ _ = self
420 method pmotion _ _ = self
421 method infochanged _ = ()
422 method scrollpw = (0, nan, nan)
423 method scrollph = (0, nan, nan)
424 method modehash = emptykeyhash
425 end;;
427 type state =
428 { mutable sr : Unix.file_descr
429 ; mutable sw : Unix.file_descr
430 ; mutable wsfd : Unix.file_descr
431 ; mutable errfd : Unix.file_descr option
432 ; mutable stderr : Unix.file_descr
433 ; mutable errmsgs : Buffer.t
434 ; mutable newerrmsgs : bool
435 ; mutable w : int
436 ; mutable x : int
437 ; mutable y : int
438 ; mutable scrollw : int
439 ; mutable hscrollh : int
440 ; mutable anchor : anchor
441 ; mutable ranchors : (string * string * anchor) list
442 ; mutable maxy : int
443 ; mutable layout : page list
444 ; pagemap : (pagemapkey, opaque) Hashtbl.t
445 ; tilemap : (tilemapkey, tile) Hashtbl.t
446 ; tilelru : (tilemapkey * opaque * pixmapsize) Queue.t
447 ; mutable pdims : (pageno * width * height * leftx) list
448 ; mutable pagecount : int
449 ; mutable currently : currently
450 ; mutable mstate : mstate
451 ; mutable searchpattern : string
452 ; mutable rects : (pageno * recttype * rect) list
453 ; mutable rects1 : (pageno * recttype * rect) list
454 ; mutable text : string
455 ; mutable fullscreen : (width * height) option
456 ; mutable mode : mode
457 ; mutable uioh : uioh
458 ; mutable outlines : outline array
459 ; mutable bookmarks : outline list
460 ; mutable path : string
461 ; mutable password : string
462 ; mutable nameddest : string
463 ; mutable geomcmds : (string * ((string * (unit -> unit)) list))
464 ; mutable memused : memsize
465 ; mutable gen : gen
466 ; mutable throttle : (page list * int * float) option
467 ; mutable autoscroll : int option
468 ; mutable ghyll : (int option -> unit)
469 ; mutable help : helpitem array
470 ; mutable docinfo : (int * string) list
471 ; mutable texid : GlTex.texture_id option
472 ; hists : hists
473 ; mutable prevzoom : float
474 ; mutable progress : float
475 ; mutable redisplay : bool
476 ; mutable mpos : mpos
477 ; mutable keystate : keystate
478 ; mutable glinks : bool
479 ; mutable prevcolumns : (columns * float) option
480 ; mutable wthack : bool
482 and hists =
483 { pat : string circbuf
484 ; pag : string circbuf
485 ; nav : anchor circbuf
486 ; sel : string circbuf
490 let defconf =
491 { scrollbw = 7
492 ; scrollh = 12
493 ; icase = true
494 ; preload = true
495 ; pagebias = 0
496 ; verbose = false
497 ; debug = false
498 ; scrollstep = 24
499 ; hscrollstep = 24
500 ; maxhfit = true
501 ; crophack = false
502 ; autoscrollstep = 2
503 ; maxwait = None
504 ; hlinks = false
505 ; underinfo = false
506 ; interpagespace = 2
507 ; zoom = 1.0
508 ; presentation = false
509 ; angle = 0
510 ; winw = 900
511 ; winh = 900
512 ; savebmarks = true
513 ; proportional = true
514 ; trimmargins = false
515 ; trimfuzz = (0,0,0,0)
516 ; memlimit = 32 lsl 20
517 ; texcount = 256
518 ; sliceheight = 24
519 ; thumbw = 76
520 ; jumpback = true
521 ; bgcolor = (0.5, 0.5, 0.5)
522 ; bedefault = false
523 ; scrollbarinpm = true
524 ; tilew = 2048
525 ; tileh = 2048
526 ; mustoresize = 256 lsl 20
527 ; checkers = true
528 ; aalevel = 8
529 ; urilauncher =
530 (match platform with
531 | Plinux | Pfreebsd | Pdragonflybsd
532 | Popenbsd | Pnetbsd | Psun -> "xdg-open \"%s\""
533 | Posx -> "open \"%s\""
534 | Pcygwin -> "cygstart \"%s\""
535 | Punknown -> "echo %s")
536 ; pathlauncher = "lp \"%s\""
537 ; selcmd =
538 (match platform with
539 | Plinux | Pfreebsd | Pdragonflybsd
540 | Popenbsd | Pnetbsd | Psun -> "xsel -i"
541 | Posx -> "pbcopy"
542 | Pcygwin -> "wsel"
543 | Punknown -> "cat")
544 ; colorspace = Rgb
545 ; invert = false
546 ; colorscale = 1.0
547 ; redirectstderr = false
548 ; ghyllscroll = None
549 ; columns = Csingle [||]
550 ; beyecolumns = None
551 ; updatecurs = false
552 ; hfsize = 12
553 ; pgscale = 1.0
554 ; usepbo = false
555 ; wheelbypage = false
556 ; keyhashes =
557 let mk n = (n, Hashtbl.create 1) in
558 [ mk "global"
559 ; mk "info"
560 ; mk "help"
561 ; mk "outline"
562 ; mk "listview"
563 ; mk "birdseye"
564 ; mk "textentry"
565 ; mk "links"
566 ; mk "view"
571 let wtmode = ref false;;
573 let findkeyhash c name =
574 try List.assoc name c.keyhashes
575 with Not_found -> failwith ("invalid mode name `" ^ name ^ "'")
578 let conf = { defconf with angle = defconf.angle };;
580 let pgscale h = truncate (float h *. conf.pgscale);;
582 type fontstate =
583 { mutable fontsize : int
584 ; mutable wwidth : float
585 ; mutable maxrows : int
589 let fstate =
590 { fontsize = 14
591 ; wwidth = nan
592 ; maxrows = -1
596 let setfontsize n =
597 fstate.fontsize <- n;
598 fstate.wwidth <- measurestr fstate.fontsize "w";
599 fstate.maxrows <- (conf.winh - fstate.fontsize - 1) / (fstate.fontsize + 1);
602 let geturl s =
603 let colonpos = try String.index s ':' with Not_found -> -1 in
604 let len = String.length s in
605 if colonpos >= 0 && colonpos + 3 < len
606 then (
607 if s.[colonpos+1] = '/' && s.[colonpos+2] = '/'
608 then
609 let schemestartpos =
610 try String.rindex_from s colonpos ' '
611 with Not_found -> -1
613 let scheme =
614 String.sub s (schemestartpos+1) (colonpos-1-schemestartpos)
616 match scheme with
617 | "http" | "ftp" | "mailto" ->
618 let epos =
619 try String.index_from s colonpos ' '
620 with Not_found -> len
622 String.sub s (schemestartpos+1) (epos-1-schemestartpos)
623 | _ -> ""
624 else ""
626 else ""
629 let gotouri uri =
630 if String.length conf.urilauncher = 0
631 then print_endline uri
632 else (
633 let url = geturl uri in
634 if String.length url = 0
635 then print_endline uri
636 else
637 let re = Str.regexp "%s" in
638 let command = Str.global_replace re url conf.urilauncher in
639 try popen command []
640 with exn ->
641 Printf.eprintf
642 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
643 flush stderr;
647 let version () =
648 Printf.sprintf "llpp version %s (%s/%dbit, ocaml %s)" Help.version
649 (platform_to_string platform) Sys.word_size Sys.ocaml_version
652 let makehelp () =
653 let strings = version () :: "" :: Help.keys in
654 Array.of_list (
655 List.map (fun s ->
656 let url = geturl s in
657 if String.length url > 0
658 then (s, 0, Action (fun u -> gotouri url; u))
659 else (s, 0, Noaction)
660 ) strings);
663 let noghyll _ = ();;
664 let firstgeomcmds = "", [];;
666 let state =
667 { sr = Unix.stdin
668 ; sw = Unix.stdin
669 ; wsfd = Unix.stdin
670 ; errfd = None
671 ; stderr = Unix.stderr
672 ; errmsgs = Buffer.create 0
673 ; newerrmsgs = false
674 ; x = 0
675 ; y = 0
676 ; w = 0
677 ; scrollw = 0
678 ; hscrollh = 0
679 ; anchor = emptyanchor
680 ; ranchors = []
681 ; layout = []
682 ; maxy = max_int
683 ; tilelru = Queue.create ()
684 ; pagemap = Hashtbl.create 10
685 ; tilemap = Hashtbl.create 10
686 ; pdims = []
687 ; pagecount = 0
688 ; currently = Idle
689 ; mstate = Mnone
690 ; rects = []
691 ; rects1 = []
692 ; text = ""
693 ; mode = View
694 ; fullscreen = None
695 ; searchpattern = ""
696 ; outlines = [||]
697 ; bookmarks = []
698 ; path = ""
699 ; password = ""
700 ; nameddest = ""
701 ; geomcmds = firstgeomcmds
702 ; hists =
703 { nav = cbnew 10 emptyanchor
704 ; pat = cbnew 10 ""
705 ; pag = cbnew 10 ""
706 ; sel = cbnew 10 ""
708 ; memused = 0
709 ; gen = 0
710 ; throttle = None
711 ; autoscroll = None
712 ; ghyll = noghyll
713 ; help = makehelp ()
714 ; docinfo = []
715 ; texid = None
716 ; prevzoom = 1.0
717 ; progress = -1.0
718 ; uioh = nouioh
719 ; redisplay = true
720 ; mpos = (-1, -1)
721 ; keystate = KSnone
722 ; glinks = false
723 ; prevcolumns = None
724 ; wthack = false
728 let vlog fmt =
729 if conf.verbose
730 then
731 Printf.kprintf prerr_endline fmt
732 else
733 Printf.kprintf ignore fmt
736 let launchpath () =
737 if String.length conf.pathlauncher = 0
738 then print_endline state.path
739 else (
740 let re = Str.regexp "%s" in
741 let command = Str.global_replace re state.path conf.pathlauncher in
742 try popen command []
743 with exn ->
744 Printf.eprintf
745 "failed to execute `%s': %s\n" command (Printexc.to_string exn);
746 flush stderr;
750 module Ne = struct
751 type 'a t = | Res of 'a | Exn of exn;;
753 let pipe () =
754 try Res (Unix.pipe ())
755 with exn -> Exn exn
758 let clo fd f =
759 try tempfailureretry Unix.close fd
760 with exn -> f (Printexc.to_string exn)
763 let dup fd =
764 try Res (tempfailureretry Unix.dup fd)
765 with exn -> Exn exn
768 let dup2 fd1 fd2 =
769 try Res (tempfailureretry (Unix.dup2 fd1) fd2)
770 with exn -> Exn exn
772 end;;
774 let redirectstderr () =
775 let clofail what errmsg = dolog "failed to close %s: %s" what errmsg in
776 if conf.redirectstderr
777 then
778 match Ne.pipe () with
779 | Ne.Exn exn ->
780 dolog "failed to create stderr redirection pipes: %s"
781 (Printexc.to_string exn)
783 | Ne.Res (r, w) ->
784 begin match Ne.dup Unix.stderr with
785 | Ne.Exn exn ->
786 dolog "failed to dup stderr: %s" (Printexc.to_string exn);
787 Ne.clo r (clofail "pipe/r");
788 Ne.clo w (clofail "pipe/w");
790 | Ne.Res dupstderr ->
791 begin match Ne.dup2 w Unix.stderr with
792 | Ne.Exn exn ->
793 dolog "failed to dup2 to stderr: %s"
794 (Printexc.to_string exn);
795 Ne.clo dupstderr (clofail "stderr duplicate");
796 Ne.clo r (clofail "redir pipe/r");
797 Ne.clo w (clofail "redir pipe/w");
799 | Ne.Res () ->
800 state.stderr <- dupstderr;
801 state.errfd <- Some r;
802 end;
804 else (
805 state.newerrmsgs <- false;
806 begin match state.errfd with
807 | Some fd ->
808 begin match Ne.dup2 state.stderr Unix.stderr with
809 | Ne.Exn exn ->
810 dolog "failed to dup2 original stderr: %s"
811 (Printexc.to_string exn)
812 | Ne.Res () ->
813 Ne.clo fd (clofail "dup of stderr");
814 state.errfd <- None;
815 end;
816 | None -> ()
817 end;
818 prerr_string (Buffer.contents state.errmsgs);
819 flush stderr;
820 Buffer.clear state.errmsgs;
824 module G =
825 struct
826 let postRedisplay who =
827 if conf.verbose
828 then prerr_endline ("redisplay for " ^ who);
829 state.redisplay <- true;
831 end;;
833 let getopaque pageno =
834 try Some (Hashtbl.find state.pagemap (pageno, state.gen))
835 with Not_found -> None
838 let putopaque pageno opaque =
839 Hashtbl.replace state.pagemap (pageno, state.gen) opaque
842 let pagetranslatepoint l x y =
843 let dy = y - l.pagedispy in
844 let y = dy + l.pagey in
845 let dx = x - l.pagedispx in
846 let x = dx + l.pagex in
847 (x, y);
850 let getunder x y =
851 let rec f = function
852 | l :: rest ->
853 begin match getopaque l.pageno with
854 | Some opaque ->
855 let x0 = l.pagedispx in
856 let x1 = x0 + l.pagevw in
857 let y0 = l.pagedispy in
858 let y1 = y0 + l.pagevh in
859 if y >= y0 && y <= y1 && x >= x0 && x <= x1
860 then
861 let px, py = pagetranslatepoint l x y in
862 match whatsunder opaque px py with
863 | Unone -> f rest
864 | under -> under
865 else f rest
866 | _ ->
867 f rest
869 | [] -> Unone
871 f state.layout
874 let showtext c s =
875 state.text <- Printf.sprintf "%c%s" c s;
876 G.postRedisplay "showtext";
879 let undertext = function
880 | Unone -> "none"
881 | Ulinkuri s -> s
882 | Ulinkgoto (pageno, _) -> Printf.sprintf "%s: page %d" state.path (pageno+1)
883 | Utext s -> "font: " ^ s
884 | Uunexpected s -> "unexpected: " ^ s
885 | Ulaunch s -> "launch: " ^ s
886 | Unamed s -> "named: " ^ s
887 | Uremote (filename, pageno) ->
888 Printf.sprintf "%s: page %d" filename (pageno+1)
891 let updateunder x y =
892 match getunder x y with
893 | Unone -> Wsi.setcursor Wsi.CURSOR_INHERIT
894 | Ulinkuri uri ->
895 if conf.underinfo then showtext 'u' ("ri: " ^ uri);
896 Wsi.setcursor Wsi.CURSOR_INFO
897 | Ulinkgoto (pageno, _) ->
898 if conf.underinfo
899 then showtext 'p' ("age: " ^ string_of_int (pageno+1));
900 Wsi.setcursor Wsi.CURSOR_INFO
901 | Utext s ->
902 if conf.underinfo then showtext 'f' ("ont: " ^ s);
903 Wsi.setcursor Wsi.CURSOR_TEXT
904 | Uunexpected s ->
905 if conf.underinfo then showtext 'u' ("nexpected: " ^ s);
906 Wsi.setcursor Wsi.CURSOR_INHERIT
907 | Ulaunch s ->
908 if conf.underinfo then showtext 'l' ("aunch: " ^ s);
909 Wsi.setcursor Wsi.CURSOR_INHERIT
910 | Unamed s ->
911 if conf.underinfo then showtext 'n' ("amed: " ^ s);
912 Wsi.setcursor Wsi.CURSOR_INHERIT
913 | Uremote (filename, pageno) ->
914 if conf.underinfo then showtext 'r'
915 (Printf.sprintf "emote: %s (%d)" filename (pageno+1));
916 Wsi.setcursor Wsi.CURSOR_INFO
919 let showlinktype under =
920 if conf.underinfo
921 then
922 match under with
923 | Unone -> ()
924 | under ->
925 let s = undertext under in
926 showtext ' ' s
929 let addchar s c =
930 let b = Buffer.create (String.length s + 1) in
931 Buffer.add_string b s;
932 Buffer.add_char b c;
933 Buffer.contents b;
936 let colorspace_of_string s =
937 match String.lowercase s with
938 | "rgb" -> Rgb
939 | "bgr" -> Bgr
940 | "gray" -> Gray
941 | _ -> failwith "invalid colorspace"
944 let int_of_colorspace = function
945 | Rgb -> 0
946 | Bgr -> 1
947 | Gray -> 2
950 let colorspace_of_int = function
951 | 0 -> Rgb
952 | 1 -> Bgr
953 | 2 -> Gray
954 | n -> failwith ("invalid colorspace index " ^ string_of_int n)
957 let colorspace_to_string = function
958 | Rgb -> "rgb"
959 | Bgr -> "bgr"
960 | Gray -> "gray"
963 let intentry_with_suffix text key =
964 let c =
965 if key >= 32 && key < 127
966 then Char.chr key
967 else '\000'
969 match Char.lowercase c with
970 | '0' .. '9' ->
971 let text = addchar text c in
972 TEcont text
974 | 'k' | 'm' | 'g' ->
975 let text = addchar text c in
976 TEcont text
978 | _ ->
979 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
980 TEcont text
983 let multicolumns_to_string (n, a, b) =
984 if a = 0 && b = 0
985 then Printf.sprintf "%d" n
986 else Printf.sprintf "%d,%d,%d" n a b;
989 let multicolumns_of_string s =
991 (int_of_string s, 0, 0)
992 with _ ->
993 Scanf.sscanf s "%u,%u,%u" (fun n a b ->
994 if a > 1 || b > 1
995 then failwith "subtly broken"; (n, a, b)
999 let readcmd fd =
1000 let s = "xxxx" in
1001 let n = tempfailureretry (Unix.read fd s 0) 4 in
1002 if n != 4 then failwith "incomplete read(len)";
1003 let len = 0
1004 lor (Char.code s.[0] lsl 24)
1005 lor (Char.code s.[1] lsl 16)
1006 lor (Char.code s.[2] lsl 8)
1007 lor (Char.code s.[3] lsl 0)
1009 let s = String.create len in
1010 let n = tempfailureretry (Unix.read fd s 0) len in
1011 if n != len then failwith "incomplete read(data)";
1015 let btod b = if b then 1 else 0;;
1017 let wcmd fmt =
1018 let b = Buffer.create 16 in
1019 Buffer.add_string b "llll";
1020 Printf.kbprintf
1021 (fun b ->
1022 let s = Buffer.contents b in
1023 let n = String.length s in
1024 let len = n - 4 in
1025 (* dolog "wcmd %S" (String.sub s 4 len); *)
1026 s.[0] <- Char.chr ((len lsr 24) land 0xff);
1027 s.[1] <- Char.chr ((len lsr 16) land 0xff);
1028 s.[2] <- Char.chr ((len lsr 8) land 0xff);
1029 s.[3] <- Char.chr (len land 0xff);
1030 let n' = tempfailureretry (Unix.write state.sw s 0) n in
1031 if n' != n then failwith "write failed";
1032 ) b fmt;
1035 let calcips h =
1036 let d = conf.winh - h in
1037 max conf.interpagespace ((d + 1) / 2)
1040 let rowyh (c, coverA, coverB) b n =
1041 if c = 1 || (n < coverA || n >= state.pagecount - coverB)
1042 then
1043 let _, _, vy, (_, _, h, _) = b.(n) in
1044 (vy, h)
1045 else
1046 let n' = n - coverA in
1047 let d = n' mod c in
1048 let s = n - d in
1049 let e = min state.pagecount (s + c) in
1050 let rec find m miny maxh = if m = e then miny, maxh else
1051 let _, _, y, (_, _, h, _) = b.(m) in
1052 let miny = min miny y in
1053 let maxh = max maxh h in
1054 find (m+1) miny maxh
1055 in find s max_int 0
1058 let calcheight () =
1059 match conf.columns with
1060 | Cmulti ((_, _, _) as cl, b) ->
1061 if Array.length b > 0
1062 then
1063 let y, h = rowyh cl b (Array.length b - 1) in
1064 y + h + (if conf.presentation then calcips h else 0)
1065 else 0
1066 | Csingle b ->
1067 if Array.length b > 0
1068 then
1069 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1070 y + h + (if conf.presentation then calcips h else 0)
1071 else 0
1072 | Csplit (_, b) ->
1073 if Array.length b > 0
1074 then
1075 let (_, _, y, (_, _, h, _)) = b.(Array.length b - 1) in
1076 y + h
1077 else 0
1080 let getpageyh pageno =
1081 let pageno = bound pageno 0 (state.pagecount-1) in
1082 match conf.columns with
1083 | Csingle b ->
1084 if Array.length b = 0
1085 then 0, 0
1086 else
1087 let (_, _, y, (_, _, h, _)) = b.(pageno) in
1088 let y =
1089 if conf.presentation
1090 then y - calcips h
1091 else y
1093 y, h
1094 | Cmulti (cl, b) ->
1095 if Array.length b = 0
1096 then 0, 0
1097 else
1098 let y, h = rowyh cl b pageno in
1099 let y =
1100 if conf.presentation
1101 then y - calcips h
1102 else y
1104 y, h
1105 | Csplit (c, b) ->
1106 if Array.length b = 0
1107 then 0, 0
1108 else
1109 let n = pageno*c in
1110 let (_, _, y, (_, _, h, _)) = b.(n) in
1111 y, h
1114 let getpagedim pageno =
1115 let rec f ppdim l =
1116 match l with
1117 | (n, _, _, _) as pdim :: rest ->
1118 if n >= pageno
1119 then (if n = pageno then pdim else ppdim)
1120 else f pdim rest
1122 | [] -> ppdim
1124 f (-1, -1, -1, -1) state.pdims
1127 let getpagey pageno = fst (getpageyh pageno);;
1129 let nogeomcmds cmds =
1130 match cmds with
1131 | s, [] -> String.length s = 0
1132 | _ -> false
1135 let page_of_y y =
1136 let ((c, coverA, coverB) as cl), b =
1137 match conf.columns with
1138 | Csingle b -> (1, 0, 0), b
1139 | Cmulti (c, b) -> c, b
1140 | Csplit (_, b) -> (1, 0, 0), b
1142 let rec bsearch nmin nmax =
1143 if nmin > nmax
1144 then bound nmin 0 (state.pagecount-1)
1145 else
1146 let n = (nmax + nmin) / 2 in
1147 let vy, h = rowyh cl b n in
1148 let y0, y1 =
1149 if conf.presentation
1150 then
1151 let ips = calcips h in
1152 let y0 = vy - ips in
1153 let y1 = vy + h + ips in
1154 y0, y1
1155 else (
1156 if n = 0
1157 then 0, vy + h + conf.interpagespace
1158 else
1159 let y0 = vy - conf.interpagespace in
1160 y0, y0 + h + conf.interpagespace
1163 if y >= y0 && y < y1
1164 then (
1165 if c = 1
1166 then n
1167 else (
1168 if n > coverA
1169 then
1170 if n < state.pagecount - coverB
1171 then ((n-coverA)/c)*c + coverA
1172 else n
1173 else n
1176 else (
1177 if y > y0
1178 then bsearch (n+1) nmax
1179 else bsearch nmin (n-1)
1182 let r = bsearch 0 (state.pagecount-1) in
1186 let layoutN ((columns, coverA, coverB), b) y sh =
1187 let sh = sh - state.hscrollh in
1188 let rec fold accu n =
1189 if n = Array.length b
1190 then accu
1191 else
1192 let pdimno, dx, vy, (_, w, h, xoff) = b.(n) in
1193 if (vy - y) > sh &&
1194 (n = coverA - 1
1195 || n = state.pagecount - coverB
1196 || (n - coverA) mod columns = columns - 1)
1197 then accu
1198 else
1199 let accu =
1200 if vy + h > y
1201 then
1202 let pagey = max 0 (y - vy) in
1203 let pagedispy = if pagey > 0 then 0 else vy - y in
1204 let pagedispx, pagex =
1205 let pdx =
1206 if n = coverA - 1 || n = state.pagecount - coverB
1207 then state.x + (conf.winw - state.scrollw - w) / 2
1208 else dx + xoff + state.x
1210 if pdx < 0
1211 then 0, -pdx
1212 else pdx, 0
1214 let pagevw =
1215 let vw = conf.winw - state.scrollw - pagedispx in
1216 let pw = w - pagex in
1217 min vw pw
1219 let pagevh = min (h - pagey) (sh - pagedispy) in
1220 if pagevw > 0 && pagevh > 0
1221 then
1222 let e =
1223 { pageno = n
1224 ; pagedimno = pdimno
1225 ; pagew = w
1226 ; pageh = h
1227 ; pagex = pagex
1228 ; pagey = pagey
1229 ; pagevw = pagevw
1230 ; pagevh = pagevh
1231 ; pagedispx = pagedispx
1232 ; pagedispy = pagedispy
1233 ; pagecol = 0
1236 e :: accu
1237 else
1238 accu
1239 else
1240 accu
1242 fold accu (n+1)
1244 List.rev (fold [] (page_of_y y));
1247 let layoutS (columns, b) y sh =
1248 let sh = sh - state.hscrollh in
1249 let rec fold accu n =
1250 if n = Array.length b
1251 then accu
1252 else
1253 let pdimno, px, vy, (_, pagew, pageh, xoff) = b.(n) in
1254 if (vy - y) > sh
1255 then accu
1256 else
1257 let accu =
1258 if vy + pageh > y
1259 then
1260 let x = xoff + state.x in
1261 let pagey = max 0 (y - vy) in
1262 let pagedispy = if pagey > 0 then 0 else vy - y in
1263 let pagedispx, pagex =
1264 if px = 0
1265 then (
1266 if x < 0
1267 then 0, -x
1268 else x, 0
1270 else (
1271 let px = px - x in
1272 if px < 0
1273 then -px, 0
1274 else 0, px
1277 let pagecolw = pagew/columns in
1278 let pagedispx =
1279 if pagecolw < conf.winw
1280 then pagedispx + ((conf.winw - state.scrollw - pagecolw) / 2)
1281 else pagedispx
1283 let pagevw =
1284 let vw = conf.winw - pagedispx - state.scrollw in
1285 let pw = pagew - pagex in
1286 min vw pw
1288 let pagevw = min pagevw pagecolw in
1289 let pagevh = min (pageh - pagey) (sh - pagedispy) in
1290 if pagevw > 0 && pagevh > 0
1291 then
1292 let e =
1293 { pageno = n/columns
1294 ; pagedimno = pdimno
1295 ; pagew = pagew
1296 ; pageh = pageh
1297 ; pagex = pagex
1298 ; pagey = pagey
1299 ; pagevw = pagevw
1300 ; pagevh = pagevh
1301 ; pagedispx = pagedispx
1302 ; pagedispy = pagedispy
1303 ; pagecol = n mod columns
1306 e :: accu
1307 else
1308 accu
1309 else
1310 accu
1312 fold accu (n+1)
1314 List.rev (fold [] 0)
1317 let layout y sh =
1318 if nogeomcmds state.geomcmds
1319 then
1320 match conf.columns with
1321 | Csingle b -> layoutN ((1, 0, 0), b) y sh
1322 | Cmulti c -> layoutN c y sh
1323 | Csplit s -> layoutS s y sh
1324 else []
1327 let clamp incr =
1328 let y = state.y + incr in
1329 let y = max 0 y in
1330 let y = min y (state.maxy - (if conf.maxhfit then conf.winh else 0)) in
1334 let itertiles l f =
1335 let tilex = l.pagex mod conf.tilew in
1336 let tiley = l.pagey mod conf.tileh in
1338 let col = l.pagex / conf.tilew in
1339 let row = l.pagey / conf.tileh in
1341 let rec rowloop row y0 dispy h =
1342 if h = 0
1343 then ()
1344 else (
1345 let dh = conf.tileh - y0 in
1346 let dh = min h dh in
1347 let rec colloop col x0 dispx w =
1348 if w = 0
1349 then ()
1350 else (
1351 let dw = conf.tilew - x0 in
1352 let dw = min w dw in
1354 f col row dispx dispy x0 y0 dw dh;
1355 colloop (col+1) 0 (dispx+dw) (w-dw)
1358 colloop col tilex l.pagedispx l.pagevw;
1359 rowloop (row+1) 0 (dispy+dh) (h-dh)
1362 if l.pagevw > 0 && l.pagevh > 0
1363 then rowloop row tiley l.pagedispy l.pagevh;
1366 let gettileopaque l col row =
1367 let key =
1368 l.pageno, state.gen, conf.colorspace, conf.angle, l.pagew, l.pageh, col, row
1370 try Some (Hashtbl.find state.tilemap key)
1371 with Not_found -> None
1374 let puttileopaque l col row gen colorspace angle opaque size elapsed =
1375 let key = l.pageno, gen, colorspace, angle, l.pagew, l.pageh, col, row in
1376 Hashtbl.add state.tilemap key (opaque, size, elapsed)
1379 let drawtiles l color =
1380 GlDraw.color color;
1381 let f col row x y tilex tiley w h =
1382 match gettileopaque l col row with
1383 | Some (opaque, _, t) ->
1384 let params = x, y, w, h, tilex, tiley in
1385 if conf.invert
1386 then (
1387 Gl.enable `blend;
1388 GlFunc.blend_func `zero `one_minus_src_color;
1390 drawtile params opaque;
1391 if conf.invert
1392 then Gl.disable `blend;
1393 if conf.debug
1394 then (
1395 let s = Printf.sprintf
1396 "%d[%d,%d] %f sec"
1397 l.pageno col row t
1399 let w = measurestr fstate.fontsize s in
1400 GlMisc.push_attrib [`current];
1401 GlDraw.color (0.0, 0.0, 0.0);
1402 GlDraw.rect
1403 (float (x-2), float (y-2))
1404 (float (x+2) +. w, float (y + fstate.fontsize + 2));
1405 GlDraw.color (1.0, 1.0, 1.0);
1406 drawstring fstate.fontsize x (y + fstate.fontsize - 1) s;
1407 GlMisc.pop_attrib ();
1410 | _ ->
1411 let w =
1412 let lw = conf.winw - state.scrollw - x in
1413 min lw w
1414 and h =
1415 let lh = conf.winh - y in
1416 min lh h
1418 begin match state.texid with
1419 | Some id ->
1420 Gl.enable `texture_2d;
1421 GlTex.bind_texture `texture_2d id;
1422 let x0 = float x
1423 and y0 = float y
1424 and x1 = float (x+w)
1425 and y1 = float (y+h) in
1427 let tw = float w /. 16.0
1428 and th = float h /. 16.0 in
1429 let tx0 = float tilex /. 16.0
1430 and ty0 = float tiley /. 16.0 in
1431 let tx1 = tx0 +. tw
1432 and ty1 = ty0 +. th in
1433 GlDraw.begins `quads;
1434 GlTex.coord2 (tx0, ty0); GlDraw.vertex2 (x0, y0);
1435 GlTex.coord2 (tx0, ty1); GlDraw.vertex2 (x0, y1);
1436 GlTex.coord2 (tx1, ty1); GlDraw.vertex2 (x1, y1);
1437 GlTex.coord2 (tx1, ty0); GlDraw.vertex2 (x1, y0);
1438 GlDraw.ends ();
1440 Gl.disable `texture_2d;
1441 | None ->
1442 GlDraw.color (1.0, 1.0, 1.0);
1443 GlDraw.rect
1444 (float x, float y)
1445 (float (x+w), float (y+h));
1446 end;
1447 if w > 128 && h > fstate.fontsize + 10
1448 then (
1449 GlDraw.color (0.0, 0.0, 0.0);
1450 let c, r =
1451 if conf.verbose
1452 then (col*conf.tilew, row*conf.tileh)
1453 else col, row
1455 drawstring2 fstate.fontsize x y "Loading %d [%d,%d]" l.pageno c r;
1457 GlDraw.color color;
1459 itertiles l f
1462 let pagevisible layout n = List.exists (fun l -> l.pageno = n) layout;;
1464 let tilevisible1 l x y =
1465 let ax0 = l.pagex
1466 and ax1 = l.pagex + l.pagevw
1467 and ay0 = l.pagey
1468 and ay1 = l.pagey + l.pagevh in
1470 let bx0 = x
1471 and by0 = y in
1472 let bx1 = min (bx0 + conf.tilew) l.pagew
1473 and by1 = min (by0 + conf.tileh) l.pageh in
1475 let rx0 = max ax0 bx0
1476 and ry0 = max ay0 by0
1477 and rx1 = min ax1 bx1
1478 and ry1 = min ay1 by1 in
1480 let nonemptyintersection = rx1 > rx0 && ry1 > ry0 in
1481 nonemptyintersection
1484 let tilevisible layout n x y =
1485 let rec findpageinlayout m = function
1486 | l :: rest when l.pageno = n ->
1487 tilevisible1 l x y || (
1488 match conf.columns with
1489 | Csplit (c, _) when c > m -> findpageinlayout (m+1) rest
1490 | _ -> false
1492 | _ :: rest -> findpageinlayout 0 rest
1493 | [] -> false
1495 findpageinlayout 0 layout;
1498 let tileready l x y =
1499 tilevisible1 l x y &&
1500 gettileopaque l (x/conf.tilew) (y/conf.tileh) != None
1503 let tilepage n p layout =
1504 let rec loop = function
1505 | l :: rest ->
1506 if l.pageno = n
1507 then
1508 let f col row _ _ _ _ _ _ =
1509 if state.currently = Idle
1510 then
1511 match gettileopaque l col row with
1512 | Some _ -> ()
1513 | None ->
1514 let x = col*conf.tilew
1515 and y = row*conf.tileh in
1516 let w =
1517 let w = l.pagew - x in
1518 min w conf.tilew
1520 let h =
1521 let h = l.pageh - y in
1522 min h conf.tileh
1524 let pbo =
1525 if conf.usepbo
1526 then getpbo w h conf.colorspace
1527 else "0"
1529 wcmd "tile %s %d %d %d %d %s" p x y w h pbo;
1530 state.currently <-
1531 Tiling (
1532 l, p, conf.colorspace, conf.angle, state.gen, col, row,
1533 conf.tilew, conf.tileh
1536 itertiles l f;
1537 else
1538 loop rest
1540 | [] -> ()
1542 if nogeomcmds state.geomcmds
1543 then loop layout;
1546 let preloadlayout y =
1547 let y = if y < conf.winh then 0 else y - conf.winh in
1548 let h = conf.winh*3 in
1549 layout y h;
1552 let load pages =
1553 let rec loop pages =
1554 if state.currently != Idle
1555 then ()
1556 else
1557 match pages with
1558 | l :: rest ->
1559 begin match getopaque l.pageno with
1560 | None ->
1561 wcmd "page %d %d" l.pageno l.pagedimno;
1562 state.currently <- Loading (l, state.gen);
1563 | Some opaque ->
1564 tilepage l.pageno opaque pages;
1565 loop rest
1566 end;
1567 | _ -> ()
1569 if nogeomcmds state.geomcmds
1570 then loop pages
1573 let preload pages =
1574 load pages;
1575 if conf.preload && state.currently = Idle
1576 then load (preloadlayout state.y);
1579 let layoutready layout =
1580 let rec fold all ls =
1581 all && match ls with
1582 | l :: rest ->
1583 let seen = ref false in
1584 let allvisible = ref true in
1585 let foo col row _ _ _ _ _ _ =
1586 seen := true;
1587 allvisible := !allvisible &&
1588 begin match gettileopaque l col row with
1589 | Some _ -> true
1590 | None -> false
1593 itertiles l foo;
1594 fold (!seen && !allvisible) rest
1595 | [] -> true
1597 let alltilesvisible = fold true layout in
1598 alltilesvisible;
1601 let gotoy y =
1602 state.wthack <- false;
1603 let y = bound y 0 state.maxy in
1604 let y, layout, proceed =
1605 match conf.maxwait with
1606 | Some time when state.ghyll == noghyll ->
1607 begin match state.throttle with
1608 | None ->
1609 let layout = layout y conf.winh in
1610 let ready = layoutready layout in
1611 if not ready
1612 then (
1613 load layout;
1614 state.throttle <- Some (layout, y, now ());
1616 else G.postRedisplay "gotoy showall (None)";
1617 y, layout, ready
1618 | Some (_, _, started) ->
1619 let dt = now () -. started in
1620 if dt > time
1621 then (
1622 state.throttle <- None;
1623 let layout = layout y conf.winh in
1624 load layout;
1625 G.postRedisplay "maxwait";
1626 y, layout, true
1628 else -1, [], false
1631 | _ ->
1632 let layout = layout y conf.winh in
1633 G.postRedisplay "gotoy ready";
1634 y, layout, true
1636 if proceed
1637 then (
1638 state.y <- y;
1639 state.layout <- layout;
1640 begin match state.mode with
1641 | LinkNav (Ltexact (pageno, linkno)) ->
1642 let rec loop = function
1643 | [] ->
1644 state.mode <- LinkNav (Ltgendir 0)
1645 | l :: _ when l.pageno = pageno ->
1646 begin match getopaque pageno with
1647 | None ->
1648 state.mode <- LinkNav (Ltgendir 0)
1649 | Some opaque ->
1650 let x0, y0, x1, y1 = getlinkrect opaque linkno in
1651 if not (x0 >= l.pagex && x1 <= l.pagex + l.pagevw
1652 && y0 >= l.pagey && y1 <= l.pagey + l.pagevh)
1653 then state.mode <- LinkNav (Ltgendir 0)
1655 | _ :: rest -> loop rest
1657 loop layout
1658 | _ -> ()
1659 end;
1660 begin match state.mode with
1661 | Birdseye (conf, leftx, pageno, hooverpageno, anchor) ->
1662 if not (pagevisible layout pageno)
1663 then (
1664 match state.layout with
1665 | [] -> ()
1666 | l :: _ ->
1667 state.mode <- Birdseye (
1668 conf, leftx, l.pageno, hooverpageno, anchor
1671 | LinkNav (Ltgendir dir as lt) ->
1672 let linknav =
1673 let rec loop = function
1674 | [] -> lt
1675 | l :: rest ->
1676 match getopaque l.pageno with
1677 | None -> loop rest
1678 | Some opaque ->
1679 let link =
1680 let ld =
1681 if dir = 0
1682 then LDfirstvisible (l.pagex, l.pagey, dir)
1683 else (
1684 if dir > 0 then LDfirst else LDlast
1687 findlink opaque ld
1689 match link with
1690 | Lnotfound -> loop rest
1691 | Lfound n ->
1692 showlinktype (getlink opaque n);
1693 Ltexact (l.pageno, n)
1695 loop state.layout
1697 state.mode <- LinkNav linknav
1698 | _ -> ()
1699 end;
1700 preload layout;
1702 state.ghyll <- noghyll;
1703 if conf.updatecurs
1704 then (
1705 let mx, my = state.mpos in
1706 updateunder mx my;
1710 let conttiling pageno opaque =
1711 tilepage pageno opaque
1712 (if conf.preload then preloadlayout state.y else state.layout)
1715 let gotoy_and_clear_text y =
1716 if not conf.verbose then state.text <- "";
1717 gotoy y;
1720 let getanchor1 l =
1721 let top =
1722 let coloff = l.pagecol * l.pageh in
1723 float (l.pagey + coloff) /. float l.pageh
1725 let dtop =
1726 if l.pagedispy = 0
1727 then
1729 else
1730 if conf.presentation
1731 then float l.pagedispy /. float (calcips l.pageh)
1732 else float l.pagedispy /. float conf.interpagespace
1734 (l.pageno, top, dtop)
1737 let getanchor () =
1738 match state.layout with
1739 | l :: _ -> getanchor1 l
1740 | [] ->
1741 let n = page_of_y state.y in
1742 let y, h = getpageyh n in
1743 let dy = y - state.y in
1744 let dtop =
1745 if conf.presentation
1746 then
1747 let ips = calcips h in
1748 float (dy + ips) /. float ips
1749 else
1750 float dy /. float conf.interpagespace
1752 (n, 0.0, dtop)
1755 let getanchory (n, top, dtop) =
1756 let y, h = getpageyh n in
1757 if conf.presentation
1758 then
1759 let ips = calcips h in
1760 y + truncate (top*.float h -. dtop*.float ips) + ips;
1761 else
1762 y + truncate (top*.float h -. dtop*.float conf.interpagespace)
1765 let gotoanchor anchor =
1766 gotoy (getanchory anchor);
1769 let addnav () =
1770 cbput state.hists.nav (getanchor ());
1773 let getnav dir =
1774 let anchor = cbgetc state.hists.nav dir in
1775 getanchory anchor;
1778 let gotoghyll y =
1779 let scroll f n a b =
1780 (* http://devmaster.net/forums/topic/9796-ease-in-ease-out-algorithm/ *)
1781 let snake f a b =
1782 let s x = 3.0*.x**2.0 -. 2.0*.x**3.0 in
1783 if f < a
1784 then s (float f /. float a)
1785 else (
1786 if f > b
1787 then 1.0 -. s ((float (f-b) /. float (n-b)))
1788 else 1.0
1791 snake f a b
1792 and summa f n a b =
1793 (* courtesy:
1794 http://integrals.wolfram.com/index.jsp?expr=3x%5E2-2x%5E3&random=false *)
1795 let iv x = -.((-.2.0 +. x)*.x**3.0)/.2.0 in
1796 let iv1 = iv f in
1797 let ins = float a *. iv1
1798 and outs = float (n-b) *. iv1 in
1799 let ones = b - a in
1800 ins +. outs +. float ones
1802 let rec set (_N, _A, _B) y sy =
1803 let sum = summa 1.0 _N _A _B in
1804 let dy = float (y - sy) in
1805 state.ghyll <- (
1806 let rec gf n y1 o =
1807 if n >= _N
1808 then state.ghyll <- noghyll
1809 else
1810 let go n =
1811 let s = scroll n _N _A _B in
1812 let y1 = y1 +. ((s *. dy) /. sum) in
1813 gotoy_and_clear_text (truncate y1);
1814 state.ghyll <- gf (n+1) y1;
1816 match o with
1817 | None -> go n
1818 | Some y' -> set (_N/2, 1, 1) y' state.y
1820 gf 0 (float state.y)
1823 match conf.ghyllscroll with
1824 | None ->
1825 gotoy_and_clear_text y
1826 | Some nab ->
1827 if state.ghyll == noghyll
1828 then set nab y state.y
1829 else state.ghyll (Some y)
1832 let gotopage n top =
1833 let y, h = getpageyh n in
1834 let y = y + (truncate (top *. float h)) in
1835 gotoghyll y
1838 let gotopage1 n top =
1839 let y = getpagey n in
1840 let y = y + top in
1841 gotoghyll y
1844 let invalidate s f =
1845 state.layout <- [];
1846 state.pdims <- [];
1847 state.rects <- [];
1848 state.rects1 <- [];
1849 match state.geomcmds with
1850 | ps, [] when String.length ps = 0 ->
1851 f ();
1852 state.geomcmds <- s, [];
1854 | ps, [] ->
1855 state.geomcmds <- ps, [s, f];
1857 | ps, (s', _) :: rest when s' = s ->
1858 state.geomcmds <- ps, ((s, f) :: rest);
1860 | ps, cmds ->
1861 state.geomcmds <- ps, ((s, f) :: cmds);
1864 let flushpages () =
1865 Hashtbl.iter (fun _ opaque ->
1866 wcmd "freepage %s" opaque;
1867 ) state.pagemap;
1868 Hashtbl.clear state.pagemap;
1871 let opendoc path password =
1872 state.path <- path;
1873 state.password <- password;
1874 state.gen <- state.gen + 1;
1875 state.docinfo <- [];
1877 flushpages ();
1878 setaalevel conf.aalevel;
1879 Wsi.settitle ("llpp " ^ (mbtoutf8 (Filename.basename path)));
1880 wcmd "open %d %s\000%s\000" (btod state.wthack) path password;
1881 invalidate "reqlayout"
1882 (fun () ->
1883 wcmd "reqlayout %d %d %s\000"
1884 conf.angle (btod conf.proportional) state.nameddest;
1888 let reload () =
1889 state.anchor <- getanchor ();
1890 state.wthack <- !wtmode;
1891 opendoc state.path state.password;
1894 let scalecolor c =
1895 let c = c *. conf.colorscale in
1896 (c, c, c);
1899 let scalecolor2 (r, g, b) =
1900 (r *. conf.colorscale, g *. conf.colorscale, b *. conf.colorscale);
1903 let docolumns = function
1904 | Csingle _ ->
1905 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1906 let rec loop pageno pdimno pdim y ph pdims =
1907 if pageno = state.pagecount
1908 then ()
1909 else
1910 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1911 match pdims with
1912 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1913 pdimno+1, pdim, rest
1914 | _ ->
1915 pdimno, pdim, pdims
1917 let x = max 0 (((conf.winw - state.scrollw - w) / 2) - xoff) in
1918 let y = y +
1919 (if conf.presentation
1920 then (if pageno = 0 then calcips h else calcips ph + calcips h)
1921 else (if pageno = 0 then 0 else conf.interpagespace)
1924 a.(pageno) <- (pdimno, x, y, pdim);
1925 loop (pageno+1) pdimno pdim (y + h) h pdims
1927 loop 0 ~-1 (-1,-1,-1,-1) 0 0 state.pdims;
1928 conf.columns <- Csingle a;
1930 | Cmulti ((columns, coverA, coverB), _) ->
1931 let a = Array.make state.pagecount (-1, -1, -1, (-1, -1, -1, -1)) in
1932 let rec loop pageno pdimno pdim x y rowh pdims =
1933 let rec fixrow m = if m = pageno then () else
1934 let (pdimno, x, y, ((_, _, h, _) as pdim)) = a.(m) in
1935 if h < rowh
1936 then (
1937 let y = y + (rowh - h) / 2 in
1938 a.(m) <- (pdimno, x, y, pdim);
1940 fixrow (m+1)
1942 if pageno = state.pagecount
1943 then fixrow (((pageno - 1) / columns) * columns)
1944 else
1945 let pdimno, ((_, w, h, xoff) as pdim), pdims =
1946 match pdims with
1947 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
1948 pdimno+1, pdim, rest
1949 | _ ->
1950 pdimno, pdim, pdims
1952 let x, y, rowh' =
1953 if pageno = coverA - 1 || pageno = state.pagecount - coverB
1954 then (
1955 let x = (conf.winw - state.scrollw - w) / 2 in
1956 let ips =
1957 if conf.presentation then calcips h else conf.interpagespace in
1958 x, y + ips + rowh, h
1960 else (
1961 if (pageno - coverA) mod columns = 0
1962 then (
1963 let x = max 0 (conf.winw - state.scrollw - state.w) / 2 in
1964 let y =
1965 if conf.presentation
1966 then
1967 let ips = calcips h in
1968 y + (if pageno = 0 then 0 else calcips rowh + ips)
1969 else
1970 y + (if pageno = 0 then 0 else conf.interpagespace)
1972 x, y + rowh, h
1974 else x, y, max rowh h
1977 let y =
1978 if pageno > 1 && (pageno - coverA) mod columns = 0
1979 then (
1980 let y =
1981 if pageno = columns && conf.presentation
1982 then (
1983 let ips = calcips rowh in
1984 for i = 0 to pred columns
1986 let (pdimno, x, y, pdim) = a.(i) in
1987 a.(i) <- (pdimno, x, y+ips, pdim)
1988 done;
1989 y+ips;
1991 else y
1993 fixrow (pageno - columns);
1996 else y
1998 a.(pageno) <- (pdimno, x, y, pdim);
1999 let x = x + w + xoff*2 + conf.interpagespace in
2000 loop (pageno+1) pdimno pdim x y rowh' pdims
2002 loop 0 ~-1 (-1,-1,-1,-1) 0 0 0 state.pdims;
2003 conf.columns <- Cmulti ((columns, coverA, coverB), a);
2005 | Csplit (c, _) ->
2006 let a = Array.make (state.pagecount*c) (-1, -1, -1, (-1, -1, -1, -1)) in
2007 let rec loop pageno pdimno pdim y pdims =
2008 if pageno = state.pagecount
2009 then ()
2010 else
2011 let pdimno, ((_, w, h, _) as pdim), pdims =
2012 match pdims with
2013 | ((pageno', _, _, _) as pdim) :: rest when pageno' = pageno ->
2014 pdimno+1, pdim, rest
2015 | _ ->
2016 pdimno, pdim, pdims
2018 let cw = w / c in
2019 let rec loop1 n x y =
2020 if n = c then y else (
2021 a.(pageno*c + n) <- (pdimno, x, y, pdim);
2022 loop1 (n+1) (x+cw) (y + h + conf.interpagespace)
2025 let y = loop1 0 0 y in
2026 loop (pageno+1) pdimno pdim y pdims
2028 loop 0 ~-1 (-1,-1,-1,-1) 0 state.pdims;
2029 conf.columns <- Csplit (c, a);
2032 let represent () =
2033 docolumns conf.columns;
2034 state.maxy <- calcheight ();
2035 state.hscrollh <-
2036 if state.w <= conf.winw - state.scrollw
2037 then 0
2038 else state.scrollw
2040 let wthack = state.wthack in
2041 begin match state.mode with
2042 | Birdseye (_, _, pageno, _, _) ->
2043 let y, h = getpageyh pageno in
2044 let top = (conf.winh - h) / 2 in
2045 gotoy (max 0 (y - top))
2046 | _ -> gotoanchor state.anchor
2047 end;
2048 state.wthack <- wthack;
2051 let reshape w h =
2052 state.wthack <- false;
2053 GlDraw.viewport 0 0 w h;
2054 let firsttime = state.geomcmds == firstgeomcmds in
2055 if not firsttime && nogeomcmds state.geomcmds
2056 then state.anchor <- getanchor ();
2058 conf.winw <- w;
2059 let w = truncate (float w *. conf.zoom) - state.scrollw in
2060 let w = max w 2 in
2061 conf.winh <- h;
2062 setfontsize fstate.fontsize;
2063 GlMat.mode `modelview;
2064 GlMat.load_identity ();
2066 GlMat.mode `projection;
2067 GlMat.load_identity ();
2068 GlMat.rotate ~x:1.0 ~angle:180.0 ();
2069 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
2070 GlMat.scale3 (2.0 /. float conf.winw, 2.0 /. float conf.winh, 1.0);
2072 let relx =
2073 if conf.zoom <= 1.0
2074 then 0.0
2075 else float state.x /. float state.w
2077 invalidate "geometry"
2078 (fun () ->
2079 state.w <- w;
2080 if not firsttime
2081 then state.x <- truncate (relx *. float w);
2082 let w =
2083 match conf.columns with
2084 | Csingle _ -> w
2085 | Cmulti ((c, _, _), _) -> (w - (c-1)*conf.interpagespace) / c
2086 | Csplit (c, _) -> w * c
2088 wcmd "geometry %d %d" w h);
2091 let enttext () =
2092 let len = String.length state.text in
2093 let drawstring s =
2094 let hscrollh =
2095 match state.mode with
2096 | Textentry _
2097 | View ->
2098 let h, _, _ = state.uioh#scrollpw in
2100 | _ -> 0
2102 let rect x w =
2103 GlDraw.rect
2104 (x, float (conf.winh - (fstate.fontsize + 4) - hscrollh))
2105 (x+.w, float (conf.winh - hscrollh))
2108 let w = float (conf.winw - state.scrollw - 1) in
2109 if state.progress >= 0.0 && state.progress < 1.0
2110 then (
2111 GlDraw.color (0.3, 0.3, 0.3);
2112 let w1 = w *. state.progress in
2113 rect 0.0 w1;
2114 GlDraw.color (0.0, 0.0, 0.0);
2115 rect w1 (w-.w1)
2117 else (
2118 GlDraw.color (0.0, 0.0, 0.0);
2119 rect 0.0 w;
2122 GlDraw.color (1.0, 1.0, 1.0);
2123 drawstring fstate.fontsize
2124 (if len > 0 then 8 else 2) (conf.winh - hscrollh - 5) s;
2126 let s =
2127 match state.mode with
2128 | Textentry ((prefix, text, _, _, _, _), _) ->
2129 let s =
2130 if len > 0
2131 then
2132 Printf.sprintf "%s%s_ [%s]" prefix text state.text
2133 else
2134 Printf.sprintf "%s%s_" prefix text
2138 | _ -> state.text
2140 let s =
2141 if state.newerrmsgs
2142 then (
2143 if not (istextentry state.mode)
2144 then
2145 let s1 = "(press 'e' to review error messasges)" in
2146 if String.length s > 0 then s ^ " " ^ s1 else s1
2147 else s
2149 else s
2151 if String.length s > 0
2152 then drawstring s
2155 let gctiles () =
2156 let len = Queue.length state.tilelru in
2157 let layout = lazy (
2158 match state.throttle with
2159 | None ->
2160 if conf.preload
2161 then preloadlayout state.y
2162 else state.layout
2163 | Some (layout, _, _) ->
2164 layout
2165 ) in
2166 let rec loop qpos =
2167 if state.memused <= conf.memlimit
2168 then ()
2169 else (
2170 if qpos < len
2171 then
2172 let (k, p, s) as lruitem = Queue.pop state.tilelru in
2173 let n, gen, colorspace, angle, pagew, pageh, col, row = k in
2174 let (_, pw, ph, _) = getpagedim n in
2176 gen = state.gen
2177 && colorspace = conf.colorspace
2178 && angle = conf.angle
2179 && pagew = pw
2180 && pageh = ph
2181 && (
2182 let x = col*conf.tilew
2183 and y = row*conf.tileh in
2184 tilevisible (Lazy.force_val layout) n x y
2186 then Queue.push lruitem state.tilelru
2187 else (
2188 freepbo p;
2189 wcmd "freetile %s" p;
2190 state.memused <- state.memused - s;
2191 state.uioh#infochanged Memused;
2192 Hashtbl.remove state.tilemap k;
2194 loop (qpos+1)
2197 loop 0
2200 let flushtiles () =
2201 Queue.iter (fun (k, p, s) ->
2202 wcmd "freetile %s" p;
2203 state.memused <- state.memused - s;
2204 state.uioh#infochanged Memused;
2205 Hashtbl.remove state.tilemap k;
2206 ) state.tilelru;
2207 Queue.clear state.tilelru;
2208 load state.layout;
2211 let logcurrently = function
2212 | Idle -> dolog "Idle"
2213 | Loading (l, gen) ->
2214 dolog "Loading %d gen=%d curgen=%d" l.pageno gen state.gen
2215 | Tiling (l, pageopaque, colorspace, angle, gen, col, row, tilew, tileh) ->
2216 dolog
2217 "Tiling %d[%d,%d] page=%s cs=%s angle"
2218 l.pageno col row pageopaque
2219 (colorspace_to_string colorspace)
2221 dolog "gen=(%d,%d) (%d,%d) tile=(%d,%d) (%d,%d)"
2222 angle gen conf.angle state.gen
2223 tilew tileh
2224 conf.tilew conf.tileh
2226 | Outlining _ ->
2227 dolog "outlining"
2230 let act cmds =
2231 (* dolog "%S" cmds; *)
2232 let op, args =
2233 let spacepos =
2234 try String.index cmds ' '
2235 with Not_found -> -1
2237 if spacepos = -1
2238 then cmds, ""
2239 else
2240 let l = String.length cmds in
2241 let op = String.sub cmds 0 spacepos in
2242 op, begin
2243 if l - spacepos < 2 then ""
2244 else String.sub cmds (spacepos+1) (l-spacepos-1)
2247 match op with
2248 | "clear" ->
2249 state.uioh#infochanged Pdim;
2250 state.pdims <- [];
2252 | "clearrects" ->
2253 state.rects <- state.rects1;
2254 G.postRedisplay "clearrects";
2256 | "continue" ->
2257 let n =
2258 try Scanf.sscanf args "%u" (fun n -> n)
2259 with exn ->
2260 dolog "error processing 'continue' %S: %s"
2261 cmds (Printexc.to_string exn);
2262 exit 1;
2264 state.pagecount <- n;
2265 begin match state.currently with
2266 | Outlining l ->
2267 state.currently <- Idle;
2268 state.outlines <- Array.of_list (List.rev l)
2269 | _ -> ()
2270 end;
2272 let cur, cmds = state.geomcmds in
2273 if String.length cur = 0
2274 then failwith "umpossible";
2276 begin match List.rev cmds with
2277 | [] ->
2278 state.geomcmds <- "", [];
2279 represent ();
2280 | (s, f) :: rest ->
2281 f ();
2282 state.geomcmds <- s, List.rev rest;
2283 end;
2284 if conf.maxwait = None
2285 then G.postRedisplay "continue";
2287 | "title" ->
2288 Wsi.settitle args
2290 | "msg" ->
2291 showtext ' ' args
2293 | "vmsg" ->
2294 if conf.verbose
2295 then showtext ' ' args
2297 | "emsg" ->
2298 Buffer.add_string state.errmsgs args;
2299 state.newerrmsgs <- true;
2300 G.postRedisplay "error message"
2302 | "progress" ->
2303 let progress, text =
2305 Scanf.sscanf args "%f %n"
2306 (fun f pos ->
2307 f, String.sub args pos (String.length args - pos))
2308 with exn ->
2309 dolog "error processing 'progress' %S: %s"
2310 cmds (Printexc.to_string exn);
2311 exit 1;
2313 state.text <- text;
2314 state.progress <- progress;
2315 G.postRedisplay "progress"
2317 | "firstmatch" ->
2318 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2320 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2321 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2322 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2323 with exn ->
2324 dolog "error processing 'firstmatch' %S: %s"
2325 cmds (Printexc.to_string exn);
2326 exit 1;
2328 let y = (getpagey pageno) + truncate y0 in
2329 addnav ();
2330 gotoy y;
2331 state.rects1 <- [pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)]
2333 | "match" ->
2334 let pageno, c, x0, y0, x1, y1, x2, y2, x3, y3 =
2336 Scanf.sscanf args "%u %d %f %f %f %f %f %f %f %f"
2337 (fun p c x0 y0 x1 y1 x2 y2 x3 y3 ->
2338 (p, c, x0, y0, x1, y1, x2, y2, x3, y3))
2339 with exn ->
2340 dolog "error processing 'match' %S: %s"
2341 cmds (Printexc.to_string exn);
2342 exit 1;
2344 state.rects1 <-
2345 (pageno, c, (x0, y0, x1, y1, x2, y2, x3, y3)) :: state.rects1
2347 | "page" ->
2348 let pageopaque, t =
2350 Scanf.sscanf args "%s %f" (fun p t -> p, t)
2351 with exn ->
2352 dolog "error processing 'page' %S: %s"
2353 cmds (Printexc.to_string exn);
2354 exit 1;
2356 begin match state.currently with
2357 | Loading (l, gen) ->
2358 vlog "page %d took %f sec" l.pageno t;
2359 Hashtbl.replace state.pagemap (l.pageno, gen) pageopaque;
2360 begin match state.throttle with
2361 | None ->
2362 let preloadedpages =
2363 if conf.preload
2364 then preloadlayout state.y
2365 else state.layout
2367 let evict () =
2368 let module IntSet =
2369 Set.Make (struct type t = int let compare = (-) end) in
2370 let set =
2371 List.fold_left (fun s l -> IntSet.add l.pageno s)
2372 IntSet.empty preloadedpages
2374 let evictedpages =
2375 Hashtbl.fold (fun ((pageno, _) as key) opaque accu ->
2376 if not (IntSet.mem pageno set)
2377 then (
2378 wcmd "freepage %s" opaque;
2379 key :: accu
2381 else accu
2382 ) state.pagemap []
2384 List.iter (Hashtbl.remove state.pagemap) evictedpages;
2386 evict ();
2387 state.currently <- Idle;
2388 if gen = state.gen
2389 then (
2390 tilepage l.pageno pageopaque state.layout;
2391 load state.layout;
2392 load preloadedpages;
2393 if pagevisible state.layout l.pageno
2394 && layoutready state.layout
2395 then G.postRedisplay "page";
2398 | Some (layout, _, _) ->
2399 state.currently <- Idle;
2400 tilepage l.pageno pageopaque layout;
2401 load state.layout
2402 end;
2404 | _ ->
2405 dolog "Inconsistent loading state";
2406 logcurrently state.currently;
2407 exit 1
2410 | "tile" ->
2411 let (x, y, opaque, size, t) =
2413 Scanf.sscanf args "%u %u %s %u %f"
2414 (fun x y p size t -> (x, y, p, size, t))
2415 with exn ->
2416 dolog "error processing 'tile' %S: %s"
2417 cmds (Printexc.to_string exn);
2418 exit 1;
2420 begin match state.currently with
2421 | Tiling (l, pageopaque, cs, angle, gen, col, row, tilew, tileh) ->
2422 vlog "tile %d [%d,%d] took %f sec" l.pageno col row t;
2424 unmappbo opaque;
2425 if tilew != conf.tilew || tileh != conf.tileh
2426 then (
2427 wcmd "freetile %s" opaque;
2428 state.currently <- Idle;
2429 load state.layout;
2431 else (
2432 puttileopaque l col row gen cs angle opaque size t;
2433 state.memused <- state.memused + size;
2434 state.uioh#infochanged Memused;
2435 gctiles ();
2436 Queue.push ((l.pageno, gen, cs, angle, l.pagew, l.pageh, col, row),
2437 opaque, size) state.tilelru;
2439 let layout =
2440 match state.throttle with
2441 | None -> state.layout
2442 | Some (layout, _, _) -> layout
2445 state.currently <- Idle;
2446 if gen = state.gen
2447 && conf.colorspace = cs
2448 && conf.angle = angle
2449 && tilevisible layout l.pageno x y
2450 then conttiling l.pageno pageopaque;
2452 begin match state.throttle with
2453 | None ->
2454 if state.wthack
2455 then state.wthack <- not (layoutready state.layout);
2456 preload state.layout;
2457 if gen = state.gen
2458 && conf.colorspace = cs
2459 && conf.angle = angle
2460 && tilevisible state.layout l.pageno x y
2461 then G.postRedisplay "tile nothrottle";
2463 | Some (layout, y, _) ->
2464 let ready = layoutready layout in
2465 if ready
2466 then (
2467 state.wthack <- false;
2468 state.y <- y;
2469 state.layout <- layout;
2470 state.throttle <- None;
2471 G.postRedisplay "throttle";
2473 else load layout;
2474 end;
2477 | _ ->
2478 dolog "Inconsistent tiling state";
2479 logcurrently state.currently;
2480 exit 1
2483 | "pdim" ->
2484 let pdim =
2486 Scanf.sscanf args "%u %u %u %u" (fun n w h x -> n, w, h, x)
2487 with exn ->
2488 dolog "error processing 'pdim' %S: %s"
2489 cmds (Printexc.to_string exn);
2490 exit 1;
2492 state.uioh#infochanged Pdim;
2493 state.pdims <- pdim :: state.pdims
2495 | "o" ->
2496 let (l, n, t, h, pos) =
2498 Scanf.sscanf args "%u %u %d %u %n"
2499 (fun l n t h pos -> l, n, t, h, pos)
2500 with exn ->
2501 dolog "error processing 'o' %S: %s"
2502 cmds (Printexc.to_string exn);
2503 exit 1;
2505 let s = String.sub args pos (String.length args - pos) in
2506 let outline = (s, l, (n, float t /. float h, 0.0)) in
2507 begin match state.currently with
2508 | Outlining outlines ->
2509 state.currently <- Outlining (outline :: outlines)
2510 | Idle ->
2511 state.currently <- Outlining [outline]
2512 | currently ->
2513 dolog "invalid outlining state";
2514 logcurrently currently
2517 | "a" ->
2518 let (n, t, h) =
2520 Scanf.sscanf args "%u %u %d"
2521 (fun n t h -> n, t, h)
2522 with exn ->
2523 dolog "error processing 'a' %S: %s"
2524 cmds (Printexc.to_string exn);
2525 exit 1;
2527 let top, dtop =
2528 if conf.presentation
2529 then (0.0, 1.0)
2530 else float t, 0.0
2532 state.anchor <- (n, top /. float h, dtop)
2534 | "info" ->
2535 state.docinfo <- (1, args) :: state.docinfo
2537 | "infoend" ->
2538 state.uioh#infochanged Docinfo;
2539 state.docinfo <- List.rev state.docinfo
2541 | _ ->
2542 dolog "unknown cmd `%S'" cmds
2545 let onhist cb =
2546 let rc = cb.rc in
2547 let action = function
2548 | HCprev -> cbget cb ~-1
2549 | HCnext -> cbget cb 1
2550 | HCfirst -> cbget cb ~-(cb.rc)
2551 | HClast -> cbget cb (cb.len - 1 - cb.rc)
2552 and cancel () = cb.rc <- rc
2553 in (action, cancel)
2556 let search pattern forward =
2557 if String.length pattern > 0
2558 then
2559 let pn, py =
2560 match state.layout with
2561 | [] -> 0, 0
2562 | l :: _ ->
2563 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
2565 wcmd "search %d %d %d %d,%s\000"
2566 (btod conf.icase) pn py (btod forward) pattern;
2569 let intentry text key =
2570 let c =
2571 if key >= 32 && key < 127
2572 then Char.chr key
2573 else '\000'
2575 match c with
2576 | '0' .. '9' ->
2577 let text = addchar text c in
2578 TEcont text
2580 | _ ->
2581 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2582 TEcont text
2585 let linknentry text key =
2586 let c =
2587 if key >= 32 && key < 127
2588 then Char.chr key
2589 else '\000'
2591 match c with
2592 | 'a' .. 'z' ->
2593 let text = addchar text c in
2594 TEcont text
2596 | _ ->
2597 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
2598 TEcont text
2601 let linkndone f s =
2602 if String.length s > 0
2603 then (
2604 let n =
2605 let l = String.length s in
2606 let rec loop pos n = if pos = l then n else
2607 let m = Char.code s.[pos] - (if pos = 0 && l > 1 then 96 else 97) in
2608 loop (pos+1) (n*26 + m)
2609 in loop 0 0
2611 let rec loop n = function
2612 | [] -> ()
2613 | l :: rest ->
2614 match getopaque l.pageno with
2615 | None -> loop n rest
2616 | Some opaque ->
2617 let m = getlinkcount opaque in
2618 if n < m
2619 then (
2620 let under = getlink opaque n in
2621 f under
2623 else loop (n-m) rest
2625 loop n state.layout;
2629 let textentry text key =
2630 if key land 0xff00 = 0xff00
2631 then TEcont text
2632 else TEcont (text ^ Wsi.toutf8 key)
2635 let reqlayout angle proportional =
2636 match state.throttle with
2637 | None ->
2638 if nogeomcmds state.geomcmds
2639 then state.anchor <- getanchor ();
2640 conf.angle <- angle mod 360;
2641 if conf.angle != 0
2642 then (
2643 match state.mode with
2644 | LinkNav _ -> state.mode <- View
2645 | _ -> ()
2647 conf.proportional <- proportional;
2648 invalidate "reqlayout"
2649 (fun () -> wcmd "reqlayout %d %d" conf.angle (btod proportional));
2650 | _ -> ()
2653 let settrim trimmargins trimfuzz =
2654 if nogeomcmds state.geomcmds
2655 then state.anchor <- getanchor ();
2656 conf.trimmargins <- trimmargins;
2657 conf.trimfuzz <- trimfuzz;
2658 let x0, y0, x1, y1 = trimfuzz in
2659 invalidate "settrim"
2660 (fun () ->
2661 wcmd "settrim %d %d %d %d %d" (btod conf.trimmargins) x0 y0 x1 y1);
2662 flushpages ();
2665 let setzoom zoom =
2666 match state.throttle with
2667 | None ->
2668 let zoom = max 0.01 zoom in
2669 if zoom <> conf.zoom
2670 then (
2671 state.prevzoom <- conf.zoom;
2672 conf.zoom <- zoom;
2673 reshape conf.winw conf.winh;
2674 state.text <- Printf.sprintf "zoom is now %-5.1f" (zoom *. 100.0);
2677 | Some (layout, y, started) ->
2678 let time =
2679 match conf.maxwait with
2680 | None -> 0.0
2681 | Some t -> t
2683 let dt = now () -. started in
2684 if dt > time
2685 then (
2686 state.y <- y;
2687 load layout;
2691 let setcolumns mode columns coverA coverB =
2692 state.prevcolumns <- Some (conf.columns, conf.zoom);
2693 if columns < 0
2694 then (
2695 if isbirdseye mode
2696 then showtext '!' "split mode doesn't work in bird's eye"
2697 else (
2698 conf.columns <- Csplit (-columns, [||]);
2699 state.x <- 0;
2700 conf.zoom <- 1.0;
2703 else (
2704 if columns < 2
2705 then (
2706 conf.columns <- Csingle [||];
2707 state.x <- 0;
2708 setzoom 1.0;
2710 else (
2711 conf.columns <- Cmulti ((columns, coverA, coverB), [||]);
2712 conf.zoom <- 1.0;
2715 reshape conf.winw conf.winh;
2718 let enterbirdseye () =
2719 let zoom = float conf.thumbw /. float conf.winw in
2720 let birdseyepageno =
2721 let cy = conf.winh / 2 in
2722 let fold = function
2723 | [] -> 0
2724 | l :: rest ->
2725 let rec fold best = function
2726 | [] -> best.pageno
2727 | l :: rest ->
2728 let d = cy - (l.pagedispy + l.pagevh/2)
2729 and dbest = cy - (best.pagedispy + best.pagevh/2) in
2730 if abs d < abs dbest
2731 then fold l rest
2732 else best.pageno
2733 in fold l rest
2735 fold state.layout
2737 state.mode <- Birdseye (
2738 { conf with zoom = conf.zoom }, state.x, birdseyepageno, -1, getanchor ()
2740 conf.zoom <- zoom;
2741 conf.presentation <- false;
2742 conf.interpagespace <- 10;
2743 conf.hlinks <- false;
2744 state.x <- 0;
2745 state.mstate <- Mnone;
2746 conf.maxwait <- None;
2747 conf.columns <- (
2748 match conf.beyecolumns with
2749 | Some c ->
2750 conf.zoom <- 1.0;
2751 Cmulti ((c, 0, 0), [||])
2752 | None -> Csingle [||]
2754 Wsi.setcursor Wsi.CURSOR_INHERIT;
2755 if conf.verbose
2756 then
2757 state.text <- Printf.sprintf "birds eye mode on (zoom %3.1f%%)"
2758 (100.0*.zoom)
2759 else
2760 state.text <- ""
2762 reshape conf.winw conf.winh;
2765 let leavebirdseye (c, leftx, pageno, _, anchor) goback =
2766 state.mode <- View;
2767 conf.zoom <- c.zoom;
2768 conf.presentation <- c.presentation;
2769 conf.interpagespace <- c.interpagespace;
2770 conf.maxwait <- c.maxwait;
2771 conf.hlinks <- c.hlinks;
2772 conf.beyecolumns <- (
2773 match conf.columns with
2774 | Cmulti ((c, _, _), _) -> Some c
2775 | Csingle _ -> None
2776 | Csplit _ -> failwith "leaving bird's eye split mode"
2778 conf.columns <- (
2779 match c.columns with
2780 | Cmulti (c, _) -> Cmulti (c, [||])
2781 | Csingle _ -> Csingle [||]
2782 | Csplit (c, _) -> Csplit (c, [||])
2784 state.x <- leftx;
2785 if conf.verbose
2786 then
2787 state.text <- Printf.sprintf "birds eye mode off (zoom %3.1f%%)"
2788 (100.0*.conf.zoom)
2790 reshape conf.winw conf.winh;
2791 state.anchor <- if goback then anchor else (pageno, 0.0, 1.0);
2794 let togglebirdseye () =
2795 match state.mode with
2796 | Birdseye vals -> leavebirdseye vals true
2797 | View -> enterbirdseye ()
2798 | _ -> ()
2801 let upbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2802 let pageno = max 0 (pageno - incr) in
2803 let rec loop = function
2804 | [] -> gotopage1 pageno 0
2805 | l :: _ when l.pageno = pageno ->
2806 if l.pagedispy >= 0 && l.pagey = 0
2807 then G.postRedisplay "upbirdseye"
2808 else gotopage1 pageno 0
2809 | _ :: rest -> loop rest
2811 loop state.layout;
2812 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor)
2815 let downbirdseye incr (conf, leftx, pageno, hooverpageno, anchor) =
2816 let pageno = min (state.pagecount - 1) (pageno + incr) in
2817 state.mode <- Birdseye (conf, leftx, pageno, hooverpageno, anchor);
2818 let rec loop = function
2819 | [] ->
2820 let y, h = getpageyh pageno in
2821 let dy = (y - state.y) - (conf.winh - h - conf.interpagespace) in
2822 gotoy (clamp dy)
2823 | l :: _ when l.pageno = pageno ->
2824 if l.pagevh != l.pageh
2825 then gotoy (clamp (l.pageh - l.pagevh + conf.interpagespace))
2826 else G.postRedisplay "downbirdseye"
2827 | _ :: rest -> loop rest
2829 loop state.layout
2832 let optentry mode _ key =
2833 let btos b = if b then "on" else "off" in
2834 if key >= 32 && key < 127
2835 then
2836 let c = Char.chr key in
2837 match c with
2838 | 's' ->
2839 let ondone s =
2840 try conf.scrollstep <- int_of_string s with exc ->
2841 state.text <- Printf.sprintf "bad integer `%s': %s"
2842 s (Printexc.to_string exc)
2844 TEswitch ("scroll step: ", "", None, intentry, ondone, true)
2846 | 'A' ->
2847 let ondone s =
2849 conf.autoscrollstep <- int_of_string s;
2850 if state.autoscroll <> None
2851 then state.autoscroll <- Some conf.autoscrollstep
2852 with exc ->
2853 state.text <- Printf.sprintf "bad integer `%s': %s"
2854 s (Printexc.to_string exc)
2856 TEswitch ("auto scroll step: ", "", None, intentry, ondone, true)
2858 | 'C' ->
2859 let ondone s =
2861 let n, a, b = multicolumns_of_string s in
2862 setcolumns mode n a b;
2863 with exc ->
2864 state.text <- Printf.sprintf "bad columns `%s': %s"
2865 s (Printexc.to_string exc)
2867 TEswitch ("columns: ", "", None, textentry, ondone, true)
2869 | 'Z' ->
2870 let ondone s =
2872 let zoom = float (int_of_string s) /. 100.0 in
2873 setzoom zoom
2874 with exc ->
2875 state.text <- Printf.sprintf "bad integer `%s': %s"
2876 s (Printexc.to_string exc)
2878 TEswitch ("zoom: ", "", None, intentry, ondone, true)
2880 | 't' ->
2881 let ondone s =
2883 conf.thumbw <- bound (int_of_string s) 2 4096;
2884 state.text <-
2885 Printf.sprintf "thumbnail width is set to %d" conf.thumbw;
2886 begin match mode with
2887 | Birdseye beye ->
2888 leavebirdseye beye false;
2889 enterbirdseye ();
2890 | _ -> ();
2892 with exc ->
2893 state.text <- Printf.sprintf "bad integer `%s': %s"
2894 s (Printexc.to_string exc)
2896 TEswitch ("thumbnail width: ", "", None, intentry, ondone, true)
2898 | 'R' ->
2899 let ondone s =
2900 match try
2901 Some (int_of_string s)
2902 with exc ->
2903 state.text <- Printf.sprintf "bad integer `%s': %s"
2904 s (Printexc.to_string exc);
2905 None
2906 with
2907 | Some angle -> reqlayout angle conf.proportional
2908 | None -> ()
2910 TEswitch ("rotation: ", "", None, intentry, ondone, true)
2912 | 'i' ->
2913 conf.icase <- not conf.icase;
2914 TEdone ("case insensitive search " ^ (btos conf.icase))
2916 | 'p' ->
2917 conf.preload <- not conf.preload;
2918 gotoy state.y;
2919 TEdone ("preload " ^ (btos conf.preload))
2921 | 'v' ->
2922 conf.verbose <- not conf.verbose;
2923 TEdone ("verbose " ^ (btos conf.verbose))
2925 | 'd' ->
2926 conf.debug <- not conf.debug;
2927 TEdone ("debug " ^ (btos conf.debug))
2929 | 'h' ->
2930 conf.maxhfit <- not conf.maxhfit;
2931 state.maxy <- calcheight ();
2932 TEdone ("maxhfit " ^ (btos conf.maxhfit))
2934 | 'c' ->
2935 conf.crophack <- not conf.crophack;
2936 TEdone ("crophack " ^ btos conf.crophack)
2938 | 'a' ->
2939 let s =
2940 match conf.maxwait with
2941 | None ->
2942 conf.maxwait <- Some infinity;
2943 "always wait for page to complete"
2944 | Some _ ->
2945 conf.maxwait <- None;
2946 "show placeholder if page is not ready"
2948 TEdone s
2950 | 'f' ->
2951 conf.underinfo <- not conf.underinfo;
2952 TEdone ("underinfo " ^ btos conf.underinfo)
2954 | 'P' ->
2955 conf.savebmarks <- not conf.savebmarks;
2956 TEdone ("persistent bookmarks " ^ btos conf.savebmarks)
2958 | 'S' ->
2959 let ondone s =
2961 let pageno, py =
2962 match state.layout with
2963 | [] -> 0, 0
2964 | l :: _ ->
2965 l.pageno, l.pagey
2967 conf.interpagespace <- int_of_string s;
2968 docolumns conf.columns;
2969 state.maxy <- calcheight ();
2970 let y = getpagey pageno in
2971 gotoy (y + py)
2972 with exc ->
2973 state.text <- Printf.sprintf "bad integer `%s': %s"
2974 s (Printexc.to_string exc)
2976 TEswitch ("vertical margin: ", "", None, intentry, ondone, true)
2978 | 'l' ->
2979 reqlayout conf.angle (not conf.proportional);
2980 TEdone ("proportional display " ^ btos conf.proportional)
2982 | 'T' ->
2983 settrim (not conf.trimmargins) conf.trimfuzz;
2984 TEdone ("trim margins " ^ btos conf.trimmargins)
2986 | 'I' ->
2987 conf.invert <- not conf.invert;
2988 TEdone ("invert colors " ^ btos conf.invert)
2990 | 'x' ->
2991 let ondone s =
2992 cbput state.hists.sel s;
2993 conf.selcmd <- s;
2995 TEswitch ("selection command: ", "", Some (onhist state.hists.sel),
2996 textentry, ondone, true)
2998 | _ ->
2999 state.text <- Printf.sprintf "bad option %d `%c'" key c;
3000 TEstop
3001 else
3002 TEcont state.text
3005 class type lvsource = object
3006 method getitemcount : int
3007 method getitem : int -> (string * int)
3008 method hasaction : int -> bool
3009 method exit :
3010 uioh:uioh ->
3011 cancel:bool ->
3012 active:int ->
3013 first:int ->
3014 pan:int ->
3015 qsearch:string ->
3016 uioh option
3017 method getactive : int
3018 method getfirst : int
3019 method getqsearch : string
3020 method setqsearch : string -> unit
3021 method getpan : int
3022 end;;
3024 class virtual lvsourcebase = object
3025 val mutable m_active = 0
3026 val mutable m_first = 0
3027 val mutable m_qsearch = ""
3028 val mutable m_pan = 0
3029 method getactive = m_active
3030 method getfirst = m_first
3031 method getqsearch = m_qsearch
3032 method getpan = m_pan
3033 method setqsearch s = m_qsearch <- s
3034 end;;
3036 let withoutlastutf8 s =
3037 let len = String.length s in
3038 if len = 0
3039 then s
3040 else
3041 let rec find pos =
3042 if pos = 0
3043 then pos
3044 else
3045 let b = Char.code s.[pos] in
3046 if b land 0b11000000 = 0b11000000
3047 then pos
3048 else find (pos-1)
3050 let first =
3051 if Char.code s.[len-1] land 0x80 = 0
3052 then len-1
3053 else find (len-1)
3055 String.sub s 0 first;
3058 let textentrykeyboard
3059 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
3060 let key =
3061 if key >= 0xffb0 && key <= 0xffb9
3062 then key - 0xffb0 + 48 else key
3064 let enttext te =
3065 state.mode <- Textentry (te, onleave);
3066 state.text <- "";
3067 enttext ();
3068 G.postRedisplay "textentrykeyboard enttext";
3070 let histaction cmd =
3071 match opthist with
3072 | None -> ()
3073 | Some (action, _) ->
3074 state.mode <- Textentry (
3075 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
3077 G.postRedisplay "textentry histaction"
3079 match key with
3080 | 0xff08 -> (* backspace *)
3081 let s = withoutlastutf8 text in
3082 let len = String.length s in
3083 if cancelonempty && len = 0
3084 then (
3085 onleave Cancel;
3086 G.postRedisplay "textentrykeyboard after cancel";
3088 else (
3089 enttext (c, s, opthist, onkey, ondone, cancelonempty)
3092 | 0xff0d | 0xff8d -> (* (kp) enter *)
3093 ondone text;
3094 onleave Confirm;
3095 G.postRedisplay "textentrykeyboard after confirm"
3097 | 0xff52 | 0xff97 -> histaction HCprev (* (kp) up *)
3098 | 0xff54 | 0xff99 -> histaction HCnext (* (kp) down *)
3099 | 0xff50 | 0xff95 -> histaction HCfirst (* (kp) home) *)
3100 | 0xff57 | 0xff9c -> histaction HClast (* (kp) end *)
3102 | 0xff1b -> (* escape*)
3103 if String.length text = 0
3104 then (
3105 begin match opthist with
3106 | None -> ()
3107 | Some (_, onhistcancel) -> onhistcancel ()
3108 end;
3109 onleave Cancel;
3110 state.text <- "";
3111 G.postRedisplay "textentrykeyboard after cancel2"
3113 else (
3114 enttext (c, "", opthist, onkey, ondone, cancelonempty)
3117 | 0xff9f | 0xffff -> () (* delete *)
3119 | _ when key != 0
3120 && key land 0xff00 != 0xff00 (* keyboard *)
3121 && key land 0xfe00 != 0xfe00 (* xkb *)
3122 && key land 0xfd00 != 0xfd00 (* 3270 *)
3124 begin match onkey text key with
3125 | TEdone text ->
3126 ondone text;
3127 onleave Confirm;
3128 G.postRedisplay "textentrykeyboard after confirm2";
3130 | TEcont text ->
3131 enttext (c, text, opthist, onkey, ondone, cancelonempty);
3133 | TEstop ->
3134 onleave Cancel;
3135 G.postRedisplay "textentrykeyboard after cancel3"
3137 | TEswitch te ->
3138 state.mode <- Textentry (te, onleave);
3139 G.postRedisplay "textentrykeyboard switch";
3140 end;
3142 | _ ->
3143 vlog "unhandled key %s" (Wsi.keyname key)
3146 let firstof first active =
3147 if first > active || abs (first - active) > fstate.maxrows - 1
3148 then max 0 (active - (fstate.maxrows/2))
3149 else first
3152 let calcfirst first active =
3153 if active > first
3154 then
3155 let rows = active - first in
3156 if rows > fstate.maxrows then active - fstate.maxrows else first
3157 else active
3160 let scrollph y maxy =
3161 let sh = (float (maxy + conf.winh) /. float conf.winh) in
3162 let sh = float conf.winh /. sh in
3163 let sh = max sh (float conf.scrollh) in
3165 let percent =
3166 if y = state.maxy
3167 then 1.0
3168 else float y /. float maxy
3170 let position = (float conf.winh -. sh) *. percent in
3172 let position =
3173 if position +. sh > float conf.winh
3174 then float conf.winh -. sh
3175 else position
3177 position, sh;
3180 let coe s = (s :> uioh);;
3182 class listview ~(source:lvsource) ~trusted ~modehash =
3183 object (self)
3184 val m_pan = source#getpan
3185 val m_first = source#getfirst
3186 val m_active = source#getactive
3187 val m_qsearch = source#getqsearch
3188 val m_prev_uioh = state.uioh
3190 method private elemunder y =
3191 let n = y / (fstate.fontsize+1) in
3192 if m_first + n < source#getitemcount
3193 then (
3194 if source#hasaction (m_first + n)
3195 then Some (m_first + n)
3196 else None
3198 else None
3200 method display =
3201 Gl.enable `blend;
3202 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
3203 GlDraw.color (0., 0., 0.) ~alpha:0.85;
3204 GlDraw.rect (0., 0.) (float conf.winw, float conf.winh);
3205 GlDraw.color (1., 1., 1.);
3206 Gl.enable `texture_2d;
3207 let fs = fstate.fontsize in
3208 let nfs = fs + 1 in
3209 let ww = fstate.wwidth in
3210 let tabw = 30.0*.ww in
3211 let itemcount = source#getitemcount in
3212 let rec loop row =
3213 if (row - m_first) > fstate.maxrows
3214 then ()
3215 else (
3216 if row >= 0 && row < itemcount
3217 then (
3218 let (s, level) = source#getitem row in
3219 let y = (row - m_first) * nfs in
3220 let x = 5.0 +. float (level + m_pan) *. ww in
3221 if row = m_active
3222 then (
3223 Gl.disable `texture_2d;
3224 GlDraw.polygon_mode `both `line;
3225 GlDraw.color (1., 1., 1.) ~alpha:0.9;
3226 GlDraw.rect (1., float (y + 1))
3227 (float (conf.winw - conf.scrollbw - 1), float (y + fs + 3));
3228 GlDraw.polygon_mode `both `fill;
3229 GlDraw.color (1., 1., 1.);
3230 Gl.enable `texture_2d;
3233 let drawtabularstring s =
3234 let drawstr x s = drawstring1 fs (truncate x) (y+nfs) s in
3235 if trusted
3236 then
3237 let tabpos = try String.index s '\t' with Not_found -> -1 in
3238 if tabpos > 0
3239 then
3240 let len = String.length s - tabpos - 1 in
3241 let s1 = String.sub s 0 tabpos
3242 and s2 = String.sub s (tabpos + 1) len in
3243 let nx = drawstr x s1 in
3244 let sw = nx -. x in
3245 let x = x +. (max tabw sw) in
3246 drawstr x s2
3247 else
3248 drawstr x s
3249 else
3250 drawstr x s
3252 let _ = drawtabularstring s in
3253 loop (row+1)
3257 loop m_first;
3258 Gl.disable `blend;
3259 Gl.disable `texture_2d;
3261 method updownlevel incr =
3262 let len = source#getitemcount in
3263 let curlevel =
3264 if m_active >= 0 && m_active < len
3265 then snd (source#getitem m_active)
3266 else -1
3268 let rec flow i =
3269 if i = len then i-1 else if i = -1 then 0 else
3270 let _, l = source#getitem i in
3271 if l != curlevel then i else flow (i+incr)
3273 let active = flow m_active in
3274 let first = calcfirst m_first active in
3275 G.postRedisplay "outline updownlevel";
3276 {< m_active = active; m_first = first >}
3278 method private key1 key mask =
3279 let set1 active first qsearch =
3280 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
3282 let search active pattern incr =
3283 let dosearch re =
3284 let rec loop n =
3285 if n >= 0 && n < source#getitemcount
3286 then (
3287 let s, _ = source#getitem n in
3289 (try ignore (Str.search_forward re s 0); true
3290 with Not_found -> false)
3291 then Some n
3292 else loop (n + incr)
3294 else None
3296 loop active
3299 let re = Str.regexp_case_fold pattern in
3300 dosearch re
3301 with Failure s ->
3302 state.text <- s;
3303 None
3305 let itemcount = source#getitemcount in
3306 let find start incr =
3307 let rec find i =
3308 if i = -1 || i = itemcount
3309 then -1
3310 else (
3311 if source#hasaction i
3312 then i
3313 else find (i + incr)
3316 find start
3318 let set active first =
3319 let first = bound first 0 (itemcount - fstate.maxrows) in
3320 state.text <- "";
3321 coe {< m_active = active; m_first = first >}
3323 let navigate incr =
3324 let isvisible first n = n >= first && n - first <= fstate.maxrows in
3325 let active, first =
3326 let incr1 = if incr > 0 then 1 else -1 in
3327 if isvisible m_first m_active
3328 then
3329 let next =
3330 let next = m_active + incr in
3331 let next =
3332 if next < 0 || next >= itemcount
3333 then -1
3334 else find next incr1
3336 if next = -1 || abs (m_active - next) > fstate.maxrows
3337 then -1
3338 else next
3340 if next = -1
3341 then
3342 let first = m_first + incr in
3343 let first = bound first 0 (itemcount - 1) in
3344 let next =
3345 let next = m_active + incr in
3346 let next = bound next 0 (itemcount - 1) in
3347 find next ~-incr1
3349 let active = if next = -1 then m_active else next in
3350 active, first
3351 else
3352 let first = min next m_first in
3353 let first =
3354 if abs (next - first) > fstate.maxrows
3355 then first + incr
3356 else first
3358 next, first
3359 else
3360 let first = m_first + incr in
3361 let first = bound first 0 (itemcount - 1) in
3362 let active =
3363 let next = m_active + incr in
3364 let next = bound next 0 (itemcount - 1) in
3365 let next = find next incr1 in
3366 let active =
3367 if next = -1 || abs (m_active - first) > fstate.maxrows
3368 then (
3369 let active = if m_active = -1 then next else m_active in
3370 active
3372 else next
3374 if isvisible first active
3375 then active
3376 else -1
3378 active, first
3380 G.postRedisplay "listview navigate";
3381 set active first;
3383 match key with
3384 | (0x72|0x73) when Wsi.withctrl mask -> (* ctrl-r/ctlr-s *)
3385 let incr = if key = 0x72 then -1 else 1 in
3386 let active, first =
3387 match search (m_active + incr) m_qsearch incr with
3388 | None ->
3389 state.text <- m_qsearch ^ " [not found]";
3390 m_active, m_first
3391 | Some active ->
3392 state.text <- m_qsearch;
3393 active, firstof m_first active
3395 G.postRedisplay "listview ctrl-r/s";
3396 set1 active first m_qsearch;
3398 | 0xff08 -> (* backspace *)
3399 if String.length m_qsearch = 0
3400 then coe self
3401 else (
3402 let qsearch = withoutlastutf8 m_qsearch in
3403 let len = String.length qsearch in
3404 if len = 0
3405 then (
3406 state.text <- "";
3407 G.postRedisplay "listview empty qsearch";
3408 set1 m_active m_first "";
3410 else
3411 let active, first =
3412 match search m_active qsearch ~-1 with
3413 | None ->
3414 state.text <- qsearch ^ " [not found]";
3415 m_active, m_first
3416 | Some active ->
3417 state.text <- qsearch;
3418 active, firstof m_first active
3420 G.postRedisplay "listview backspace qsearch";
3421 set1 active first qsearch
3424 | key when (key != 0 && key land 0xff00 != 0xff00) ->
3425 let pattern = m_qsearch ^ Wsi.toutf8 key in
3426 let active, first =
3427 match search m_active pattern 1 with
3428 | None ->
3429 state.text <- pattern ^ " [not found]";
3430 m_active, m_first
3431 | Some active ->
3432 state.text <- pattern;
3433 active, firstof m_first active
3435 G.postRedisplay "listview qsearch add";
3436 set1 active first pattern;
3438 | 0xff1b -> (* escape *)
3439 state.text <- "";
3440 if String.length m_qsearch = 0
3441 then (
3442 G.postRedisplay "list view escape";
3443 begin
3444 match
3445 source#exit (coe self) true m_active m_first m_pan m_qsearch
3446 with
3447 | None -> m_prev_uioh
3448 | Some uioh -> uioh
3451 else (
3452 G.postRedisplay "list view kill qsearch";
3453 source#setqsearch "";
3454 coe {< m_qsearch = "" >}
3457 | 0xff0d | 0xff8d -> (* (kp) enter *)
3458 state.text <- "";
3459 let self = {< m_qsearch = "" >} in
3460 source#setqsearch "";
3461 let opt =
3462 G.postRedisplay "listview enter";
3463 if m_active >= 0 && m_active < source#getitemcount
3464 then (
3465 source#exit (coe self) false m_active m_first m_pan "";
3467 else (
3468 source#exit (coe self) true m_active m_first m_pan "";
3471 begin match opt with
3472 | None -> m_prev_uioh
3473 | Some uioh -> uioh
3476 | 0xff9f | 0xffff -> (* (kp) delete *)
3477 coe self
3479 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3480 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3481 | 0xff55 | 0xff9a -> navigate ~-(fstate.maxrows) (* (kp) prior *)
3482 | 0xff56 | 0xff9b -> navigate fstate.maxrows (* (kp) next *)
3484 | 0xff53 | 0xff98 -> (* (kp) right *)
3485 state.text <- "";
3486 G.postRedisplay "listview right";
3487 coe {< m_pan = m_pan - 1 >}
3489 | 0xff51 | 0xff96 -> (* (kp) left *)
3490 state.text <- "";
3491 G.postRedisplay "listview left";
3492 coe {< m_pan = m_pan + 1 >}
3494 | 0xff50 | 0xff95 -> (* (kp) home *)
3495 let active = find 0 1 in
3496 G.postRedisplay "listview home";
3497 set active 0;
3499 | 0xff57 | 0xff9c -> (* (kp) end *)
3500 let first = max 0 (itemcount - fstate.maxrows) in
3501 let active = find (itemcount - 1) ~-1 in
3502 G.postRedisplay "listview end";
3503 set active first;
3505 | key when (key = 0 || key land 0xff00 = 0xff00) ->
3506 coe self
3508 | _ ->
3509 dolog "listview unknown key %#x" key; coe self
3511 method key key mask =
3512 match state.mode with
3513 | Textentry te -> textentrykeyboard key mask te; coe self
3514 | _ -> self#key1 key mask
3516 method button button down x y _ =
3517 let opt =
3518 match button with
3519 | 1 when x > conf.winw - conf.scrollbw ->
3520 G.postRedisplay "listview scroll";
3521 if down
3522 then
3523 let _, position, sh = self#scrollph in
3524 if y > truncate position && y < truncate (position +. sh)
3525 then (
3526 state.mstate <- Mscrolly;
3527 Some (coe self)
3529 else
3530 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3531 let first = truncate (s *. float source#getitemcount) in
3532 let first = min source#getitemcount first in
3533 Some (coe {< m_first = first; m_active = first >})
3534 else (
3535 state.mstate <- Mnone;
3536 Some (coe self);
3538 | 1 when not down ->
3539 begin match self#elemunder y with
3540 | Some n ->
3541 G.postRedisplay "listview click";
3542 source#exit
3543 (coe {< m_active = n >}) false n m_first m_pan m_qsearch
3544 | _ ->
3545 Some (coe self)
3547 | n when (n == 4 || n == 5) && not down ->
3548 let len = source#getitemcount in
3549 let first =
3550 if n = 5 && m_first + fstate.maxrows >= len
3551 then
3552 m_first
3553 else
3554 let first = m_first + (if n == 4 then -1 else 1) in
3555 bound first 0 (len - 1)
3557 G.postRedisplay "listview wheel";
3558 Some (coe {< m_first = first >})
3559 | n when (n = 6 || n = 7) && not down ->
3560 let inc = m_first + (if n = 7 then -1 else 1) in
3561 G.postRedisplay "listview hwheel";
3562 Some (coe {< m_pan = m_pan + inc >})
3563 | _ ->
3564 Some (coe self)
3566 match opt with
3567 | None -> m_prev_uioh
3568 | Some uioh -> uioh
3570 method motion _ y =
3571 match state.mstate with
3572 | Mscrolly ->
3573 let s = float (max 0 (y - conf.scrollh)) /. float conf.winh in
3574 let first = truncate (s *. float source#getitemcount) in
3575 let first = min source#getitemcount first in
3576 G.postRedisplay "listview motion";
3577 coe {< m_first = first; m_active = first >}
3578 | _ -> coe self
3580 method pmotion x y =
3581 if x < conf.winw - conf.scrollbw
3582 then
3583 let n =
3584 match self#elemunder y with
3585 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
3586 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
3588 let o =
3589 if n != m_active
3590 then (G.postRedisplay "listview pmotion"; {< m_active = n >})
3591 else self
3593 coe o
3594 else (
3595 Wsi.setcursor Wsi.CURSOR_INHERIT;
3596 coe self
3599 method infochanged _ = ()
3601 method scrollpw = (0, 0.0, 0.0)
3602 method scrollph =
3603 let nfs = fstate.fontsize + 1 in
3604 let y = m_first * nfs in
3605 let itemcount = source#getitemcount in
3606 let maxi = max 0 (itemcount - fstate.maxrows) in
3607 let maxy = maxi * nfs in
3608 let p, h = scrollph y maxy in
3609 conf.scrollbw, p, h
3611 method modehash = modehash
3612 end;;
3614 class outlinelistview ~source =
3615 object (self)
3616 inherit listview
3617 ~source:(source :> lvsource)
3618 ~trusted:false
3619 ~modehash:(findkeyhash conf "outline")
3620 as super
3622 method key key mask =
3623 let calcfirst first active =
3624 if active > first
3625 then
3626 let rows = active - first in
3627 let maxrows =
3628 if String.length state.text = 0
3629 then fstate.maxrows
3630 else fstate.maxrows - 2
3632 if rows > maxrows then active - maxrows else first
3633 else active
3635 let navigate incr =
3636 let active = m_active + incr in
3637 let active = bound active 0 (source#getitemcount - 1) in
3638 let first = calcfirst m_first active in
3639 G.postRedisplay "outline navigate";
3640 coe {< m_active = active; m_first = first >}
3642 let ctrl = Wsi.withctrl mask in
3643 match key with
3644 | 110 when ctrl -> (* ctrl-n *)
3645 source#narrow m_qsearch;
3646 G.postRedisplay "outline ctrl-n";
3647 coe {< m_first = 0; m_active = 0 >}
3649 | 117 when ctrl -> (* ctrl-u *)
3650 source#denarrow;
3651 G.postRedisplay "outline ctrl-u";
3652 state.text <- "";
3653 coe {< m_first = 0; m_active = 0 >}
3655 | 108 when ctrl -> (* ctrl-l *)
3656 let first = max 0 (m_active - (fstate.maxrows / 2)) in
3657 G.postRedisplay "outline ctrl-l";
3658 coe {< m_first = first >}
3660 | 0xff9f | 0xffff -> (* (kp) delete *)
3661 source#remove m_active;
3662 G.postRedisplay "outline delete";
3663 let active = max 0 (m_active-1) in
3664 coe {< m_first = firstof m_first active;
3665 m_active = active >}
3667 | 0xff52 | 0xff97 -> navigate ~-1 (* (kp) up *)
3668 | 0xff54 | 0xff99 -> navigate 1 (* (kp) down *)
3669 | 0xff55 | 0xff9a -> (* (kp) prior *)
3670 navigate ~-(fstate.maxrows)
3671 | 0xff56 | 0xff9b -> (* (kp) next *)
3672 navigate fstate.maxrows
3674 | 0xff53 | 0xff98 -> (* [ctrl-] (kp) right *)
3675 let o =
3676 if ctrl
3677 then (
3678 G.postRedisplay "outline ctrl right";
3679 {< m_pan = m_pan + 1 >}
3681 else self#updownlevel 1
3683 coe o
3685 | 0xff51 | 0xff96 -> (* [ctrl-] (kp) left *)
3686 let o =
3687 if ctrl
3688 then (
3689 G.postRedisplay "outline ctrl left";
3690 {< m_pan = m_pan - 1 >}
3692 else self#updownlevel ~-1
3694 coe o
3696 | 0xff50 | 0xff95 -> (* (kp) home *)
3697 G.postRedisplay "outline home";
3698 coe {< m_first = 0; m_active = 0 >}
3700 | 0xff57 | 0xff9c -> (* (kp) end *)
3701 let active = source#getitemcount - 1 in
3702 let first = max 0 (active - fstate.maxrows) in
3703 G.postRedisplay "outline end";
3704 coe {< m_active = active; m_first = first >}
3706 | _ -> super#key key mask
3709 let outlinesource usebookmarks =
3710 let empty = [||] in
3711 (object
3712 inherit lvsourcebase
3713 val mutable m_items = empty
3714 val mutable m_orig_items = empty
3715 val mutable m_prev_items = empty
3716 val mutable m_narrow_pattern = ""
3717 val mutable m_hadremovals = false
3719 method getitemcount =
3720 Array.length m_items + (if m_hadremovals then 1 else 0)
3722 method getitem n =
3723 if n == Array.length m_items && m_hadremovals
3724 then
3725 ("[Confirm removal]", 0)
3726 else
3727 let s, n, _ = m_items.(n) in
3728 (s, n)
3730 method exit ~uioh ~cancel ~active ~first ~pan ~qsearch =
3731 ignore (uioh, first, qsearch);
3732 let confrimremoval = m_hadremovals && active = Array.length m_items in
3733 let items =
3734 if String.length m_narrow_pattern = 0
3735 then m_orig_items
3736 else m_items
3738 if not cancel
3739 then (
3740 if not confrimremoval
3741 then(
3742 let _, _, anchor = m_items.(active) in
3743 gotoghyll (getanchory anchor);
3744 m_items <- items;
3746 else (
3747 state.bookmarks <- Array.to_list m_items;
3748 m_orig_items <- m_items;
3751 else m_items <- items;
3752 m_pan <- pan;
3753 None
3755 method hasaction _ = true
3757 method greetmsg =
3758 if Array.length m_items != Array.length m_orig_items
3759 then "Narrowed to " ^ m_narrow_pattern ^ " (ctrl-u to restore)"
3760 else ""
3762 method narrow pattern =
3763 let reopt = try Some (Str.regexp_case_fold pattern) with _ -> None in
3764 match reopt with
3765 | None -> ()
3766 | Some re ->
3767 let rec loop accu n =
3768 if n = -1
3769 then (
3770 m_narrow_pattern <- pattern;
3771 m_items <- Array.of_list accu
3773 else
3774 let (s, _, _) as o = m_items.(n) in
3775 let accu =
3776 if (try ignore (Str.search_forward re s 0); true
3777 with Not_found -> false)
3778 then o :: accu
3779 else accu
3781 loop accu (n-1)
3783 loop [] (Array.length m_items - 1)
3785 method denarrow =
3786 m_orig_items <- (
3787 if usebookmarks
3788 then Array.of_list state.bookmarks
3789 else state.outlines
3791 m_items <- m_orig_items
3793 method remove m =
3794 if usebookmarks
3795 then
3796 if m >= 0 && m < Array.length m_items
3797 then (
3798 m_hadremovals <- true;
3799 m_items <- Array.init (Array.length m_items - 1) (fun n ->
3800 let n = if n >= m then n+1 else n in
3801 m_items.(n)
3805 method reset anchor items =
3806 m_hadremovals <- false;
3807 if m_orig_items == empty || m_prev_items != items
3808 then (
3809 m_orig_items <- items;
3810 if String.length m_narrow_pattern = 0
3811 then m_items <- items;
3813 m_prev_items <- items;
3814 let rely = getanchory anchor in
3815 let active =
3816 let rec loop n best bestd =
3817 if n = Array.length m_items
3818 then best
3819 else
3820 let (_, _, anchor) = m_items.(n) in
3821 let orely = getanchory anchor in
3822 let d = abs (orely - rely) in
3823 if d < bestd
3824 then loop (n+1) n d
3825 else loop (n+1) best bestd
3827 loop 0 ~-1 max_int
3829 m_active <- active;
3830 m_first <- firstof m_first active
3831 end)
3834 let enterselector usebookmarks =
3835 let source = outlinesource usebookmarks in
3836 fun errmsg ->
3837 let outlines =
3838 if usebookmarks
3839 then Array.of_list state.bookmarks
3840 else state.outlines
3842 if Array.length outlines = 0
3843 then (
3844 showtext ' ' errmsg;
3846 else (
3847 state.text <- source#greetmsg;
3848 Wsi.setcursor Wsi.CURSOR_INHERIT;
3849 let anchor = getanchor () in
3850 source#reset anchor outlines;
3851 state.uioh <- coe (new outlinelistview ~source);
3852 G.postRedisplay "enter selector";
3856 let enteroutlinemode =
3857 let f = enterselector false in
3858 fun ()-> f "Document has no outline";
3861 let enterbookmarkmode =
3862 let f = enterselector true in
3863 fun () -> f "Document has no bookmarks (yet)";
3866 let color_of_string s =
3867 Scanf.sscanf s "%d/%d/%d" (fun r g b ->
3868 (float r /. 256.0, float g /. 256.0, float b /. 256.0)
3872 let color_to_string (r, g, b) =
3873 let r = truncate (r *. 256.0)
3874 and g = truncate (g *. 256.0)
3875 and b = truncate (b *. 256.0) in
3876 Printf.sprintf "%d/%d/%d" r g b
3879 let irect_of_string s =
3880 Scanf.sscanf s "%d/%d/%d/%d" (fun x0 y0 x1 y1 -> (x0,y0,x1,y1))
3883 let irect_to_string (x0,y0,x1,y1) =
3884 Printf.sprintf "%d/%d/%d/%d" x0 y0 x1 y1
3887 let makecheckers () =
3888 (* Appropriated from lablGL-1.04/LablGlut/examples/lablGL/checker.ml which had
3889 following to say:
3890 converted by Issac Trotts. July 25, 2002 *)
3891 let image = GlPix.create `ubyte ~format:`luminance ~width:2 ~height:2 in
3892 Raw.sets_string (GlPix.to_raw image) ~pos:0 "\255\200\200\255";
3893 let id = GlTex.gen_texture () in
3894 GlTex.bind_texture `texture_2d id;
3895 GlPix.store (`unpack_alignment 1);
3896 GlTex.image2d image;
3897 List.iter (GlTex.parameter ~target:`texture_2d)
3898 [ `wrap_s `repeat;
3899 `wrap_t `repeat;
3900 `mag_filter `nearest;
3901 `min_filter `nearest ];
3905 let setcheckers enabled =
3906 match state.texid with
3907 | None ->
3908 if enabled then state.texid <- Some (makecheckers ())
3910 | Some texid ->
3911 if not enabled
3912 then (
3913 GlTex.delete_texture texid;
3914 state.texid <- None;
3918 let int_of_string_with_suffix s =
3919 let l = String.length s in
3920 let s1, shift =
3921 if l > 1
3922 then
3923 let suffix = Char.lowercase s.[l-1] in
3924 match suffix with
3925 | 'k' -> String.sub s 0 (l-1), 10
3926 | 'm' -> String.sub s 0 (l-1), 20
3927 | 'g' -> String.sub s 0 (l-1), 30
3928 | _ -> s, 0
3929 else s, 0
3931 let n = int_of_string s1 in
3932 let m = n lsl shift in
3933 if m < 0 || m < n
3934 then raise (Failure "value too large")
3935 else m
3938 let string_with_suffix_of_int n =
3939 if n = 0
3940 then "0"
3941 else
3942 let n, s =
3943 if n land ((1 lsl 30) - 1) = 0
3944 then n lsr 30, "G"
3945 else (
3946 if n land ((1 lsl 20) - 1) = 0
3947 then n lsr 20, "M"
3948 else (
3949 if n land ((1 lsl 10) - 1) = 0
3950 then n lsr 10, "K"
3951 else n, ""
3955 let rec loop s n =
3956 let h = n mod 1000 in
3957 let n = n / 1000 in
3958 if n = 0
3959 then string_of_int h ^ s
3960 else (
3961 let s = Printf.sprintf "_%03d%s" h s in
3962 loop s n
3965 loop "" n ^ s;
3968 let defghyllscroll = (40, 8, 32);;
3969 let ghyllscroll_of_string s =
3970 let (n, a, b) as nab =
3971 if s = "default"
3972 then defghyllscroll
3973 else Scanf.sscanf s "%u,%u,%u" (fun n a b -> n, a, b)
3975 if n <= a || n <= b || a >= b
3976 then failwith "invalid ghyll N,A,B (N <= A, A < B, N <= B)";
3977 nab;
3980 let ghyllscroll_to_string ((n, a, b) as nab) =
3981 if nab = defghyllscroll
3982 then "default"
3983 else Printf.sprintf "%d,%d,%d" n a b;
3986 let describe_location () =
3987 let f (fn, _) l =
3988 if fn = -1 then l.pageno, l.pageno else fn, l.pageno
3990 let fn, ln = List.fold_left f (-1, -1) state.layout in
3991 let maxy = state.maxy - (if conf.maxhfit then conf.winh else 0) in
3992 let percent =
3993 if maxy <= 0
3994 then 100.
3995 else (100. *. (float state.y /. float maxy))
3997 if fn = ln
3998 then
3999 Printf.sprintf "page %d of %d [%.2f%%]"
4000 (fn+1) state.pagecount percent
4001 else
4002 Printf.sprintf
4003 "pages %d-%d of %d [%.2f%%]"
4004 (fn+1) (ln+1) state.pagecount percent
4007 let setpresentationmode v =
4008 let (n, _, _) = getanchor () in
4009 let _, h = getpageyh n in
4010 let ips = if conf.presentation then calcips h else conf.interpagespace in
4011 state.anchor <- (n, 0.0, float ips);
4012 conf.presentation <- v;
4013 if conf.presentation
4014 then (
4015 if not conf.scrollbarinpm
4016 then state.scrollw <- 0;
4018 else state.scrollw <- conf.scrollbw;
4019 represent ();
4022 let enterinfomode =
4023 let btos b = if b then "\xe2\x88\x9a" else "" in
4024 let showextended = ref false in
4025 let leave mode = function
4026 | Confirm -> state.mode <- mode
4027 | Cancel -> state.mode <- mode in
4028 let src =
4029 (object
4030 val mutable m_first_time = true
4031 val mutable m_l = []
4032 val mutable m_a = [||]
4033 val mutable m_prev_uioh = nouioh
4034 val mutable m_prev_mode = View
4036 inherit lvsourcebase
4038 method reset prev_mode prev_uioh =
4039 m_a <- Array.of_list (List.rev m_l);
4040 m_l <- [];
4041 m_prev_mode <- prev_mode;
4042 m_prev_uioh <- prev_uioh;
4043 if m_first_time
4044 then (
4045 let rec loop n =
4046 if n >= Array.length m_a
4047 then ()
4048 else
4049 match m_a.(n) with
4050 | _, _, _, Action _ -> m_active <- n
4051 | _ -> loop (n+1)
4053 loop 0;
4054 m_first_time <- false;
4057 method int name get set =
4058 m_l <-
4059 (name, `int get, 1, Action (
4060 fun u ->
4061 let ondone s =
4062 try set (int_of_string s)
4063 with exn ->
4064 state.text <- Printf.sprintf "bad integer `%s': %s"
4065 s (Printexc.to_string exn)
4067 state.text <- "";
4068 let te = name ^ ": ", "", None, intentry, ondone, true in
4069 state.mode <- Textentry (te, leave m_prev_mode);
4071 )) :: m_l
4073 method int_with_suffix name get set =
4074 m_l <-
4075 (name, `intws get, 1, Action (
4076 fun u ->
4077 let ondone s =
4078 try set (int_of_string_with_suffix s)
4079 with exn ->
4080 state.text <- Printf.sprintf "bad integer `%s': %s"
4081 s (Printexc.to_string exn)
4083 state.text <- "";
4084 let te =
4085 name ^ ": ", "", None, intentry_with_suffix, ondone, true
4087 state.mode <- Textentry (te, leave m_prev_mode);
4089 )) :: m_l
4091 method bool ?(offset=1) ?(btos=btos) name get set =
4092 m_l <-
4093 (name, `bool (btos, get), offset, Action (
4094 fun u ->
4095 let v = get () in
4096 set (not v);
4098 )) :: m_l
4100 method color name get set =
4101 m_l <-
4102 (name, `color get, 1, Action (
4103 fun u ->
4104 let invalid = (nan, nan, nan) in
4105 let ondone s =
4106 let c =