Alert the use if he tries to go to the outline mode but there's no outline
[llpp.git] / main.ml
blob6d037bca27a71a2ac56248cf6f5501b66b11a505
1 open Format;;
3 let log fmt = Printf.kprintf prerr_endline fmt;;
4 let dolog fmt = Printf.kprintf prerr_endline fmt;;
6 external init : Unix.file_descr -> unit = "ml_init";;
7 external draw : int -> int -> int -> int -> string -> unit = "ml_draw";;
8 external preload : string -> unit = "ml_preload";;
9 external gettext : string -> (int * int * int * int) -> int -> bool -> unit =
10 "ml_gettext";;
11 external checklink : string -> int -> int -> bool = "ml_checklink";;
12 external getlink : string -> int -> int -> (int * int) option = "ml_getlink";;
14 type mstate = Msel of ((int * int) * (int * int)) | Mnone;;
17 type te =
18 | TEstop
19 | TEdone of string
20 | TEcont of string
23 type 'a circbuf =
24 { store : 'a array
25 ; mutable rc : int
26 ; mutable wc : int
27 ; mutable len : int
31 let cbnew n v =
32 { store = Array.create n v
33 ; rc = 0
34 ; wc = 0
35 ; len = 0
39 let cblen b = Array.length b.store;;
41 let cbput b v =
42 let len = cblen b in
43 b.store.(b.wc) <- v;
44 b.wc <- (b.wc + 1) mod len;
45 b.len <- (b.len + 1) mod len;
48 let cbpeekw b = b.store.(b.wc);;
50 let cbget b =
51 let v = b.store.(b.rc) in
52 if b.len = 0
53 then
55 else (
56 let rc = if b.rc = 0 then b.len - 1 else b.rc - 1 in
57 b.rc <- rc;
62 let cbrfollowlen b =
63 b.rc <- b.len - 1;
66 type layout =
67 { pageno : int
68 ; pagedimno : int
69 ; pagew : int
70 ; pageh : int
71 ; pagedispy : int
72 ; pagey : int
73 ; pagevh : int
77 type conf =
78 { mutable scrollw : int
79 ; mutable scrollh : int
80 ; mutable rectsel : bool
81 ; mutable icase : bool
82 ; mutable preload : bool
83 ; mutable titletext : bool
84 ; mutable pagebias : int
85 ; mutable redispimm : bool
86 ; mutable verbose : bool
87 ; mutable scrollincr : int
88 ; mutable maxhfit : bool
92 type outline = string * int * int * int;;
93 type outlines = Oarray of outline array | Olist of outline list;;
95 type state =
96 { mutable csock : Unix.file_descr
97 ; mutable ssock : Unix.file_descr
98 ; mutable w : int
99 ; mutable h : int
100 ; mutable y : int
101 ; mutable prevy : int
102 ; mutable maxy : int
103 ; mutable layout : layout list
104 ; pagemap : ((int * int), string) Hashtbl.t
105 ; mutable pages : (int * int * int) list
106 ; mutable pagecount : int
107 ; pagecache : string circbuf
108 ; navhist : float circbuf
109 ; mutable inflight : int
110 ; mutable mstate : mstate
111 ; mutable searchpattern : string
112 ; mutable rects : (int * int * Gl.point2 * Gl.point2) list
113 ; mutable text : string
114 ; mutable fullscreen : (int * int) option
115 ; mutable textentry :
116 (char * string * (string -> int -> te) * (string -> unit)) option
117 ; mutable outlines : outlines
118 ; mutable outline : (int * int * outline array * string) option
122 let conf =
123 { scrollw = 5
124 ; scrollh = 12
125 ; icase = true
126 ; rectsel = true
127 ; preload = false
128 ; titletext = false
129 ; pagebias = 0
130 ; redispimm = false
131 ; verbose = false
132 ; scrollincr = 18
133 ; maxhfit = true
137 let state =
138 { csock = Unix.stdin
139 ; ssock = Unix.stdin
140 ; w = 0
141 ; h = 0
142 ; y = 0
143 ; prevy = 0
144 ; layout = []
145 ; maxy = max_int
146 ; pagemap = Hashtbl.create 10
147 ; pagecache = cbnew 10 ""
148 ; pages = []
149 ; pagecount = 0
150 ; inflight = 0
151 ; mstate = Mnone
152 ; navhist = cbnew 100 0.0
153 ; rects = []
154 ; text = ""
155 ; fullscreen = None
156 ; textentry = None
157 ; searchpattern = ""
158 ; outlines = Olist []
159 ; outline = None
163 let vlog fmt =
164 if conf.verbose
165 then
166 Printf.kprintf prerr_endline fmt
167 else
168 Printf.kprintf ignore fmt
171 let writecmd fd s =
172 let len = String.length s in
173 let n = 4 + len in
174 let b = Buffer.create n in
175 Buffer.add_char b (Char.chr ((len lsr 24) land 0xff));
176 Buffer.add_char b (Char.chr ((len lsr 16) land 0xff));
177 Buffer.add_char b (Char.chr ((len lsr 8) land 0xff));
178 Buffer.add_char b (Char.chr ((len lsr 0) land 0xff));
179 Buffer.add_string b s;
180 let s' = Buffer.contents b in
181 let n' = Unix.write fd s' 0 n in
182 if n' != n then failwith "write failed";
185 let readcmd fd =
186 let s = "xxxx" in
187 let n = Unix.read fd s 0 4 in
188 if n != 4 then failwith "incomplete read(len)";
189 let len = 0
190 lor (Char.code s.[0] lsl 24)
191 lor (Char.code s.[1] lsl 16)
192 lor (Char.code s.[2] lsl 8)
193 lor (Char.code s.[3] lsl 0)
195 let s = String.create len in
196 let n = Unix.read fd s 0 len in
197 if n != len then failwith "incomplete read(data)";
201 let yratio y =
202 if y = state.maxy then 1.0
203 else float y /. float state.maxy
206 let wcmd s l =
207 let b = Buffer.create 10 in
208 Buffer.add_string b s;
209 let rec combine = function
210 | [] -> Buffer.contents b
211 | x :: xs ->
212 Buffer.add_char b ' ';
213 let s =
214 match x with
215 | `b b -> if b then "1" else "0"
216 | `s s -> s
217 | `i i -> string_of_int i
218 | `f f -> string_of_float f
219 | `I f -> string_of_int (truncate f)
221 Buffer.add_string b s;
222 combine xs;
224 let s = combine l in
225 writecmd state.csock s;
228 let calcheight () =
229 let rec f pn ph fh l =
230 match l with
231 | (n, _, h) :: rest ->
232 let fh = fh + (n - pn) * ph in
233 f n h fh rest
235 | [] ->
236 let fh = fh + (ph * (state.pagecount - pn)) in
237 max 0 fh
239 let fh = f 0 0 0 state.pages in
243 let getpagey pageno =
244 let rec f pn ph y l =
245 match l with
246 | (n, _, h) :: rest ->
247 if n >= pageno
248 then
249 y + (pageno - pn) * ph
250 else
251 let y = y + (n - pn) * ph in
252 f n h y rest
254 | [] ->
255 y + (pageno - pn) * ph
257 f 0 0 0 state.pages;
260 let layout y sh =
261 let rec f pageno pdimno prev vy py dy l cacheleft accu =
262 if pageno = state.pagecount || cacheleft = 0
263 then accu
264 else
265 let ((_, w, h) as curr), rest, pdimno =
266 match l with
267 | ((pageno', _, _) as curr) :: rest when pageno' = pageno ->
268 curr, rest, pdimno + 1
269 | _ ->
270 prev, l, pdimno
272 let pageno' = pageno + 1 in
273 if py + h > vy
274 then
275 let py' = vy - py in
276 let vh = h - py' in
277 if dy + vh > sh
278 then
279 let vh = sh - dy in
280 if vh <= 0
281 then
282 accu
283 else
284 let e =
285 { pageno = pageno
286 ; pagedimno = pdimno
287 ; pagew = w
288 ; pageh = h
289 ; pagedispy = dy
290 ; pagey = py'
291 ; pagevh = vh
294 e :: accu
295 else
296 let e =
297 { pageno = pageno
298 ; pagedimno = pdimno
299 ; pagew = w
300 ; pageh = h
301 ; pagedispy = dy
302 ; pagey = py'
303 ; pagevh = vh
306 let accu = e :: accu in
307 f pageno' pdimno curr
308 (vy + vh) (py + h) (dy + vh + 2) rest
309 (pred cacheleft) accu
310 else
311 f pageno' pdimno curr vy (py + h) dy rest cacheleft accu
313 let accu = f 0 ~-1 (0,0,0) y 0 0 state.pages (cblen state.pagecache) [] in
314 state.maxy <- calcheight ();
315 List.rev accu
318 let clamp incr =
319 let y = state.y + incr in
320 let y = max 0 y in
321 let y = min y (state.maxy - (if conf.maxhfit then state.h else 0)) in
325 let gotoy y =
326 let y = max 0 y in
327 let y = min state.maxy y in
328 let pages = layout y state.h in
329 state.y <- y;
330 state.layout <- pages;
331 if conf.redispimm
332 then
333 Glut.postRedisplay ()
337 let addnav () =
338 cbput state.navhist (yratio state.y);
339 cbrfollowlen state.navhist;
342 let getnav () =
343 let y = cbget state.navhist in
344 truncate (y *. float state.maxy)
347 let gotopage n top =
348 let y = getpagey n in
349 addnav ();
350 state.y <- y + top;
351 gotoy state.y;
354 let reshape ~w ~h =
355 state.w <- w;
356 state.h <- h;
357 GlDraw.viewport 0 0 w h;
358 GlMat.mode `modelview;
359 GlMat.load_identity ();
360 GlMat.mode `projection;
361 GlMat.load_identity ();
362 GlMat.rotate ~x:1.0 ~angle:180.0 ();
363 GlMat.translate ~x:~-.1.0 ~y:~-.1.0 ();
364 GlMat.scale3 (2.0 /. float w, 2.0 /. float state.h, 1.0);
365 GlClear.color (1., 1., 1.);
366 GlClear.clear [`color];
367 state.layout <- [];
368 state.pages <- [];
369 state.rects <- [];
370 state.text <- "";
371 wcmd "geometry" [`i (state.w - conf.scrollw); `i h];
374 let showtext c s =
375 if not conf.titletext
376 then (
377 GlDraw.color (0.0, 0.0, 0.0);
378 GlDraw.rect
379 (0.0, float (state.h - 18))
380 (float (state.w - conf.scrollw - 1), float state.h)
382 let font = Glut.BITMAP_8_BY_13 in
383 GlDraw.color (1.0, 1.0, 1.0);
384 GlPix.raster_pos ~x:0.0 ~y:(float (state.h - 5)) ();
385 Glut.bitmapCharacter ~font ~c:(Char.code c);
386 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
388 else
389 let len = String.length s in
390 let dst = String.create (len + 1) in
391 dst.[0] <- c;
392 StringLabels.blit
393 ~src:s
394 ~dst
395 ~src_pos:0
396 ~dst_pos:1
397 ~len
399 Glut.setWindowTitle ~title:dst
402 let enttext () =
403 let len = String.length state.text in
404 match state.textentry with
405 | None ->
406 if len > 0 then showtext ' ' state.text
408 | Some (c, text, _, _) ->
409 let s =
410 if len > 0
411 then
412 text ^ " [" ^ state.text ^ "]"
413 else
414 text
416 showtext c s;
419 let act cmd =
420 match cmd.[0] with
421 | 'c' ->
422 state.pages <- []
424 | 'd' ->
425 Glut.postRedisplay ()
427 | 'C' ->
428 let n = Scanf.sscanf cmd "C %d" (fun n -> n) in
429 state.pagecount <- n;
430 let rely = yratio state.y in
431 let maxy = calcheight () in
432 state.y <- truncate (float maxy *. rely);
433 let pages = layout state.y state.h in
434 state.layout <- pages;
435 Glut.postRedisplay ();
437 | 'T' ->
438 let s = Scanf.sscanf cmd "T %n"
439 (fun n -> String.sub cmd n (String.length cmd - n))
441 state.text <- s;
442 showtext ' ' s;
443 Glut.swapBuffers ();
444 (* Glut.postRedisplay () *)
446 | 'F' ->
447 let pageno, c, x0, y0, x1, y1 =
448 Scanf.sscanf cmd "F %d %d %f %f %f %f"
449 (fun p c x0 y0 x1 y1 -> (p, c, x0, y0, x1, y1))
451 let y = (getpagey pageno) + truncate y0 in
452 addnav ();
453 gotoy y;
454 state.rects <- [pageno, c, (x0, y0), (x1, y1)]
456 | 'R' ->
457 let pageno, c, x0, y0, x1, y1 =
458 Scanf.sscanf cmd "R %d %d %f %f %f %f"
459 (fun pageno c x0 y0 x1 y1 -> (pageno, c, x0, y0, x1, y1))
461 state.rects <- (pageno, c, (x0, y0), (x1, y1)) :: state.rects
463 | 'r' ->
464 let n, w, h, p =
465 Scanf.sscanf cmd "r %d %d %d %s"
466 (fun n w h p -> (n, w, h, p))
468 Hashtbl.replace state.pagemap (n, w) p;
469 let evicted = cbpeekw state.pagecache in
470 if String.length evicted > 0
471 then begin
472 wcmd "free" [`s evicted];
473 let l = Hashtbl.fold (fun k p a ->
474 if evicted = p then k :: a else a) state.pagemap []
476 List.iter (fun k -> Hashtbl.remove state.pagemap k) l;
477 end;
478 cbput state.pagecache p;
479 state.inflight <- pred state.inflight;
480 Glut.postRedisplay ()
482 | 'l' ->
483 let (n, w, h) as pagelayout =
484 Scanf.sscanf cmd "l %d %d %d" (fun n w h -> n, w, h)
486 state.pages <- pagelayout :: state.pages
488 | 'o' ->
489 let (l, n, t, pos) =
490 Scanf.sscanf cmd "o %d %d %d %n" (fun l n t pos -> l, n, t, pos)
492 let s = String.sub cmd pos (String.length cmd - pos) in
493 let outline = (s, l, n, t) in
494 let outlines =
495 match state.outlines with
496 | Olist outlines -> Olist (outline :: outlines)
497 | Oarray _ -> Olist [outline]
499 state.outlines <- outlines
501 | _ ->
502 log "unknown cmd `%S'" cmd
505 let getopaque pageno =
506 try Some (Hashtbl.find state.pagemap (pageno + 1, state.w - conf.scrollw))
507 with Not_found -> None
510 let cache pageno opaque =
511 Hashtbl.replace state.pagemap (pageno + 1, state.w - conf.scrollw) opaque
514 let validopaque opaque = String.length opaque > 0;;
516 let preload l =
517 match getopaque l.pageno with
518 | Some opaque when validopaque opaque ->
519 preload opaque
521 | None when state.inflight < 2+0*(cblen state.pagecache) ->
522 state.inflight <- succ state.inflight;
523 cache l.pageno "";
524 wcmd "render" [`i (l.pageno + 1)
525 ;`i l.pagedimno
526 ;`i l.pagew
527 ;`i l.pageh];
529 | _ -> ()
532 let idle () =
533 if not conf.redispimm && state.y != state.prevy
534 then (
535 state.prevy <- state.y;
536 Glut.postRedisplay ();
538 else
539 let r, _, _ = Unix.select [state.csock] [] [] 0.02 in
541 begin match r with
542 | [] ->
543 if conf.preload then begin
544 let h = state.h in
545 let y = if state.y < state.h then 0 else state.y - state.h in
546 let pages = layout y (h*3) in
547 List.iter preload pages;
548 end;
550 | _ ->
551 let cmd = readcmd state.csock in
552 act cmd;
553 end;
556 let search pattern forward =
557 if String.length pattern > 0
558 then
559 let pn, py =
560 match state.layout with
561 | [] -> 0, 0
562 | l :: _ ->
563 l.pageno, (l.pagey + if forward then 0 else 0*l.pagevh)
565 wcmd "search" [`b conf.icase; `i pn; `i py; `i (if forward then 1 else 0)
566 ; `s (pattern ^ "\000")]
569 let intentry text key =
570 let c = Char.unsafe_chr key in
571 match c with
572 | '0' .. '9' ->
573 let s = "x" in s.[0] <- c;
574 let text = text ^ s in
575 TEcont text
577 | _ ->
578 state.text <- Printf.sprintf "invalid char (%d, `%c')" key c;
579 TEcont text
582 let addchar s c =
583 let b = Buffer.create (String.length s + 1) in
584 Buffer.add_string b s;
585 Buffer.add_char b c;
586 Buffer.contents b;
589 let textentry text key =
590 let c = Char.unsafe_chr key in
591 match c with
592 | _ when key >= 32 && key <= 127 ->
593 let text = addchar text c in
594 TEcont text
596 | _ ->
597 log "unhandled key %d char `%c'" key (Char.unsafe_chr key);
598 TEcont text
601 let optentry text key =
602 let btos b = if b then "on" else "off" in
603 let c = Char.unsafe_chr key in
604 match c with
605 | 'r' ->
606 conf.rectsel <- not conf.rectsel;
607 TEdone ("rectsel " ^ (btos conf.rectsel))
609 | 'i' ->
610 conf.icase <- not conf.icase;
611 TEdone ("case insensitive search " ^ (btos conf.icase))
613 | 'p' ->
614 conf.preload <- not conf.preload;
615 TEdone ("preload " ^ (btos conf.preload))
617 | 't' ->
618 conf.titletext <- not conf.titletext;
619 TEdone ("titletext " ^ (btos conf.titletext))
621 | 'd' ->
622 conf.redispimm <- not conf.redispimm;
623 TEdone ("immediate redisplay " ^ (btos conf.redispimm))
625 | 'v' ->
626 conf.verbose <- not conf.verbose;
627 TEdone ("verbose " ^ (btos conf.verbose))
629 | 'h' ->
630 conf.maxhfit <- not conf.maxhfit;
631 state.maxy <- state.maxy + (if conf.maxhfit then -state.h else state.h);
632 TEdone ("maxhfit " ^ (btos conf.maxhfit))
634 | _ ->
635 state.text <- Printf.sprintf "bad option %d `%c'" key c;
636 TEstop
639 let maxoutlinerows () = (state.h - 31) / 16;;
641 let enteroutlinemode () =
642 let pageno =
643 match state.layout with
644 | [] -> -1
645 | {pageno=pageno} :: rest -> pageno
647 let outlines =
648 match state.outlines with
649 | Oarray a -> a
650 | Olist l ->
651 let a = Array.of_list (List.rev l) in
652 state.outlines <- Oarray a;
655 if Array.length outlines = 0
656 then (
657 showtext ' ' "Document has no outline";
658 Glut.swapBuffers ()
660 else
661 let active =
662 let rec loop n =
663 if n = Array.length outlines
664 then 0
665 else
666 let (_, _, outlinepageno, _) = outlines.(n) in
667 if outlinepageno >= pageno then n else loop (n+1)
669 loop 0
671 state.outline <-
672 Some (active, max 0 (active - maxoutlinerows ()), outlines, "");
673 Glut.postRedisplay ();
676 let viewkeyboard ~key ~x ~y =
677 let enttext te =
678 state.textentry <- te;
679 state.text <- "";
680 enttext ();
681 Glut.swapBuffers ()
683 match state.textentry with
684 | None ->
685 let c = Char.chr key in
686 begin match c with
687 | '\027' | 'q' ->
688 exit 0
690 | '\008' ->
691 let y = getnav () in
692 gotoy y
694 | 'o' ->
695 enteroutlinemode ()
697 | 'u' ->
698 state.rects <- [];
699 state.text <- "";
700 Glut.postRedisplay ()
702 | '/' | '?' ->
703 let ondone isforw s =
704 state.searchpattern <- s;
705 search s isforw
707 enttext (Some (c, "", textentry, ondone (c ='/')))
709 | '+' ->
710 let ondone s =
711 let n =
712 try int_of_string s with exc ->
713 state.text <- Printf.sprintf "bad integer `%s': %s"
714 s (Printexc.to_string exc);
715 max_int
717 if n != max_int
718 then (
719 conf.pagebias <- n;
720 state.text <- "page bias is now " ^ string_of_int n;
723 enttext (Some ('+', "", intentry, ondone))
725 | '-' ->
726 let ondone msg =
727 state.text <- msg;
729 enttext (Some ('-', "", optentry, ondone))
731 | '0' .. '9' ->
732 let ondone s =
733 let n =
734 try int_of_string s with exc ->
735 state.text <- Printf.sprintf "bad integer `%s': %s"
736 s (Printexc.to_string exc);
739 if n >= 0
740 then (
741 addnav ();
742 state.y <- y;
743 gotoy (getpagey (n + conf.pagebias - 1))
746 let pageentry text key =
747 match Char.unsafe_chr key with
748 | 'g' -> TEdone text
749 | _ -> intentry text key
751 let text = "x" in text.[0] <- c;
752 enttext (Some (':', text, pageentry, ondone))
754 | 'b' ->
755 conf.scrollw <- if conf.scrollw > 0 then 0 else 5;
756 reshape state.w state.h;
758 | 'f' ->
759 begin match state.fullscreen with
760 | None ->
761 state.fullscreen <- Some (state.w, state.h);
762 Glut.fullScreen ()
763 | Some (w, h) ->
764 state.fullscreen <- None;
765 Glut.reshapeWindow ~w ~h
768 | 'n' ->
769 search state.searchpattern true
771 | 'p' ->
772 search state.searchpattern false
774 | 't' ->
775 begin match state.layout with
776 | [] -> ()
777 | l :: _ ->
778 gotoy (state.y - l.pagey);
781 | ' ' | 'N' ->
782 begin match List.rev state.layout with
783 | [] -> ()
784 | l :: _ ->
785 gotoy (clamp (l.pageh - l.pagey))
788 | '\127' | 'P' ->
789 begin match state.layout with
790 | [] -> ()
791 | l :: _ ->
792 gotoy (clamp (-l.pageh));
795 | '=' ->
796 let f (fn, ln) l =
797 if fn = -1 then l.pageno, l.pageno else fn, l.pageno
799 let fn, ln = List.fold_left f (-1, -1) state.layout in
800 let s =
801 let percent = (100. *. yratio state.y) in
802 if fn = ln
803 then
804 Printf.sprintf "Page %d of %d %.2f%%"
805 (fn+1) state.pagecount percent
806 else
807 Printf.sprintf
808 "Pages %d-%d of %d %.2f%%"
809 (fn+1) (ln+1) state.pagecount percent
811 showtext ' ' s;
812 Glut.swapBuffers ()
814 | 'w' ->
815 begin match state.layout with
816 | [] -> ()
817 | l :: _ ->
818 Glut.reshapeWindow (l.pagew + conf.scrollw) l.pageh;
819 Glut.postRedisplay ();
822 | _ ->
823 vlog "huh? %d %c" key (Char.chr key);
826 | Some (c, text, onkey, ondone) when key = 8 ->
827 let len = String.length text in
828 if len = 0 || len = 1
829 then (
830 state.textentry <- None;
831 Glut.postRedisplay ();
833 else (
834 let s = String.sub text 0 (len - 1) in
835 enttext (Some (c, s, onkey, ondone))
838 | Some (c, text, onkey, ondone) ->
839 begin match Char.unsafe_chr key with
840 | '\r' | '\n' ->
841 ondone text;
842 state.textentry <- None;
843 Glut.postRedisplay ()
845 | '\027' ->
846 state.textentry <- None;
847 Glut.postRedisplay ()
849 | _ ->
850 begin match onkey text key with
851 | TEdone text ->
852 state.textentry <- None;
853 ondone text;
854 Glut.postRedisplay ()
856 | TEcont text ->
857 enttext (Some (c, text, onkey, ondone));
859 | TEstop ->
860 state.textentry <- None;
861 Glut.postRedisplay ()
862 end;
863 end;
866 let outlinekeyboard ~key ~x ~y (active, first, outlines, qsearch) =
867 let search active pattern incr =
868 let re = Str.regexp_case_fold pattern in
869 let rec loop n =
870 if n = Array.length outlines || n = -1 then None else
871 let (s, _, _, _) = outlines.(n) in
873 (try ignore (Str.search_forward re s 0); true
874 with Not_found -> false)
875 then (
876 let maxrows = maxoutlinerows () in
877 if first > n
878 then Some (n, max 0 (n - maxrows))
879 else Some (n, max first (n - maxrows))
881 else loop (n + incr)
883 loop active
885 match key with
886 | 27 ->
887 if String.length qsearch = 0
888 then (
889 state.text <- "";
890 state.outline <- None;
891 Glut.postRedisplay ();
893 else (
894 state.text <- "";
895 state.outline <- Some (active, first, outlines, "");
896 Glut.postRedisplay ();
899 | 18 | 19 ->
900 let incr = if key = 18 then -1 else 1 in
901 let active, first =
902 match search (active + incr) qsearch incr with
903 | None -> active, first
904 | Some af -> af
906 state.outline <- Some (active, first, outlines, qsearch);
907 Glut.postRedisplay ();
909 | 8 ->
910 let len = String.length qsearch in
911 if len = 0
912 then ()
913 else (
914 if len = 1
915 then (
916 state.text <- "";
917 state.outline <- Some (active, first, outlines, "");
919 else
920 let qsearch = String.sub qsearch 0 (len - 1) in
921 state.text <- qsearch;
922 state.outline <- Some (active, first, outlines, qsearch);
924 Glut.postRedisplay ()
926 | 13 ->
927 let (_, _, n, t) = outlines.(active) in
928 gotopage n t;
929 state.text <- "";
930 state.outline <- None;
931 Glut.postRedisplay ();
933 | _ when key >= 32 && key <= 127 ->
934 let pattern = addchar qsearch (Char.chr key) in
935 let pattern, active, first =
936 match search active pattern 1 with
937 | None -> qsearch, active, first
938 | Some (active, first) -> (pattern, active, first)
940 state.text <- pattern;
941 state.outline <- Some (active, first, outlines, pattern);
942 Glut.postRedisplay ()
944 | _ -> log "unknown key %d" key
947 let keyboard ~key ~x ~y =
948 match state.outline with
949 | None -> viewkeyboard ~key ~x ~y
950 | Some outline -> outlinekeyboard ~key ~x ~y outline
953 let special ~key ~x ~y =
954 match state.outline with
955 | None ->
956 let y =
957 match key with
958 | Glut.KEY_F3 -> search state.searchpattern true; state.y
959 | Glut.KEY_UP -> clamp (-conf.scrollincr)
960 | Glut.KEY_DOWN -> clamp conf.scrollincr
961 | Glut.KEY_PAGE_UP -> clamp (-state.h)
962 | Glut.KEY_PAGE_DOWN -> clamp state.h
963 | Glut.KEY_HOME -> addnav (); 0
964 | Glut.KEY_END ->
965 addnav ();
966 state.maxy - (if conf.maxhfit then state.h else 0)
967 | _ -> state.y
969 state.text <- "";
970 gotoy y
972 | Some (active, first, outlines, qsearch) ->
973 let maxrows = maxoutlinerows () in
974 let navigate incr =
975 let active = active + incr in
976 let active = max 0 (min active (Array.length outlines - 1)) in
977 let first =
978 if active > first
979 then
980 let rows = active - first in
981 if rows > maxrows then first + incr else first
982 else active
984 state.outline <- Some (active, first, outlines, qsearch);
985 Glut.postRedisplay ()
987 match key with
988 | Glut.KEY_UP -> navigate ~-1
989 | Glut.KEY_DOWN -> navigate 1
990 | Glut.KEY_PAGE_UP -> navigate ~-maxrows
991 | Glut.KEY_PAGE_DOWN -> navigate maxrows
993 | Glut.KEY_HOME ->
994 state.outline <- Some (0, 0, outlines, qsearch);
995 Glut.postRedisplay ()
997 | Glut.KEY_END ->
998 let active = Array.length outlines - 1 in
999 let first = max 0 (active - maxrows) in
1000 state.outline <- Some (active, first, outlines, qsearch);
1001 Glut.postRedisplay ()
1003 | _ -> ()
1006 let drawplaceholder l =
1007 if true
1008 then (
1009 GlDraw.color (0.2, 0.2, 0.2);
1010 GlDraw.color (1.0, 1.0, 1.0);
1011 GlDraw.rect
1012 (0.0, float l.pagedispy)
1013 (float l.pagew, float (l.pagedispy + l.pagevh))
1015 let x = 0.0
1016 and y = float (l.pagedispy + l.pagevh - 5) in
1017 let font = Glut.BITMAP_8_BY_13 in
1018 GlDraw.color (0.0, 0.0, 0.0);
1019 GlPix.raster_pos ~x ~y ();
1020 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c))
1021 ("Loading " ^ string_of_int l.pageno);
1023 else (
1024 GlDraw.begins `quads;
1025 GlDraw.vertex2 (0.0, float l.pagedispy);
1026 GlDraw.vertex2 (float l.pagew, float l.pagedispy);
1027 GlDraw.vertex2 (float l.pagew, float (l.pagedispy + l.pagevh));
1028 GlDraw.vertex2 (0.0, float (l.pagedispy + l.pagevh));
1029 GlDraw.ends ();
1033 let now () = Unix.gettimeofday ();;
1035 let drawpage i l =
1036 begin match getopaque l.pageno with
1037 | Some opaque when validopaque opaque ->
1038 GlDraw.color (1.0, 1.0, 1.0);
1039 let a = now () in
1040 draw l.pagedispy l.pagew l.pagevh l.pagey opaque;
1041 let b = now () in
1042 let d = b-.a in
1043 vlog "draw %f sec" d;
1045 | Some _ ->
1046 drawplaceholder l
1048 | None ->
1049 if state.inflight < cblen state.pagecache
1050 then (
1051 List.iter preload state.layout;
1053 else (
1054 drawplaceholder l;
1055 vlog "inflight %d" state.inflight;
1057 end;
1058 GlDraw.color (0.5, 0.5, 0.5);
1059 GlDraw.rect
1060 (0., float i)
1061 (float (state.w - conf.scrollw), float (i + (l.pagedispy - i)))
1063 l.pagedispy + l.pagevh;
1066 let scrollindicator () =
1067 let maxy = state.maxy - (if conf.maxhfit then state.h else 0) in
1068 GlDraw.color (0.64 , 0.64, 0.64);
1069 GlDraw.rect
1070 (float (state.w - conf.scrollw), 0.)
1071 (float state.w, float state.h)
1073 GlDraw.color (0.0, 0.0, 0.0);
1074 let sh = (float (maxy + state.h) /. float state.h) in
1075 let sh = float state.h /. sh in
1076 let sh = max sh (float conf.scrollh) in
1078 let percent =
1079 if state.y = state.maxy
1080 then 1.0
1081 else float state.y /. float maxy
1083 let position = (float state.h -. sh) *. percent in
1085 let position =
1086 if position +. sh > float state.h
1087 then
1088 float state.h -. sh
1089 else
1090 position
1092 GlDraw.rect
1093 (float (state.w - conf.scrollw), position)
1094 (float state.w, position +. sh)
1098 let showsel () =
1099 match state.mstate with
1100 | Mnone ->
1103 | Msel ((x0, y0), (x1, y1)) ->
1104 let y0' = min y0 y1
1105 and y1 = max y0 y1 in
1106 let y0 = y0' in
1107 let f l =
1108 if (y0 >= l.pagedispy && y0 <= (l.pagedispy + l.pagevh))
1109 || ((y1 >= l.pagedispy)) (* && y1 <= (dy + vh))) *)
1110 then
1111 match getopaque l.pageno with
1112 | Some opaque when validopaque opaque ->
1113 let oy = -l.pagey + l.pagedispy in
1114 gettext opaque (min x0 x1, y0, max x1 x0, y1) oy conf.rectsel
1115 | _ -> ()
1117 List.iter f state.layout
1120 let showrects () =
1121 Gl.enable `blend;
1122 GlDraw.color (0.0, 0.0, 1.0) ~alpha:0.5;
1123 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1124 List.iter
1125 (fun (pageno, c, (x0, y0), (x1, y1)) ->
1126 List.iter (fun l ->
1127 if l.pageno = pageno
1128 then (
1129 let d = float (l.pagedispy - l.pagey) in
1130 GlDraw.color (0.0, 0.0, 1.0 /. float c) ~alpha:0.5;
1131 GlDraw.rect (x0, y0 +. d) (x1, y1 +. d)
1133 ) state.layout
1134 ) state.rects
1136 Gl.disable `blend;
1139 let showoutline = function
1140 | None -> ()
1141 | Some (active, first, outlines, qsearch) ->
1142 Gl.enable `blend;
1143 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1144 GlDraw.color (0., 0., 0.) ~alpha:0.85;
1145 GlDraw.rect (0., 0.) (float state.w, float state.h);
1146 Gl.disable `blend;
1148 GlDraw.color (1., 1., 1.);
1149 let font = Glut.BITMAP_9_BY_15 in
1150 let draw_string x y s =
1151 GlPix.raster_pos ~x ~y ();
1152 String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
1154 let rec loop row =
1155 if row = Array.length outlines || (row - first) * 16 > state.h
1156 then ()
1157 else (
1158 let (s, l, _, _) = outlines.(row) in
1159 let y = (row - first) * 16 in
1160 let x = 5 + 5*l in
1161 if row = active
1162 then (
1163 Gl.enable `blend;
1164 GlDraw.polygon_mode `both `line;
1165 GlFunc.blend_func `src_alpha `one_minus_src_alpha;
1166 GlDraw.color (1., 1., 1.) ~alpha:0.9;
1167 GlDraw.rect (0., float (y + 1))
1168 (float (state.w - conf.scrollw - 1), float (y + 18));
1169 GlDraw.polygon_mode `both `fill;
1170 Gl.disable `blend;
1171 GlDraw.color (1., 1., 1.);
1173 draw_string (float x) (float (y + 16)) s;
1174 loop (row+1)
1177 loop first
1180 let display () =
1181 let lasty = List.fold_left drawpage 0 (state.layout) in
1182 GlDraw.color (0.5, 0.5, 0.5);
1183 GlDraw.rect
1184 (0., float lasty)
1185 (float (state.w - conf.scrollw), float state.h)
1187 showrects ();
1188 scrollindicator ();
1189 showsel ();
1190 showoutline state.outline;
1191 enttext ();
1192 Glut.swapBuffers ();
1195 let getlink x y =
1196 let rec f = function
1197 | l :: rest ->
1198 begin match getopaque l.pageno with
1199 | Some opaque when validopaque opaque ->
1200 let y = y - l.pagedispy in
1201 if y > 0
1202 then
1203 let y = l.pagey + y in
1204 match getlink opaque x y with
1205 | None -> f rest
1206 | some -> some
1207 else
1208 f rest
1209 | _ ->
1210 f rest
1212 | [] -> None
1214 f state.layout
1217 let checklink x y =
1218 let rec f = function
1219 | l :: rest ->
1220 begin match getopaque l.pageno with
1221 | Some opaque when validopaque opaque ->
1222 let y = y - l.pagedispy in
1223 if y > 0
1224 then
1225 let y = l.pagey + y in
1226 if checklink opaque x y then true else f rest
1227 else
1228 f rest
1229 | _ ->
1230 f rest
1232 | [] -> false
1234 f state.layout
1237 let mouse ~button ~bstate ~x ~y =
1238 match button with
1239 | Glut.OTHER_BUTTON n when n == 3 || n == 4 && bstate = Glut.UP ->
1240 let incr =
1241 if n = 3
1242 then
1243 -conf.scrollincr
1244 else
1245 conf.scrollincr
1247 let incr = incr * 2 in
1248 let y = clamp incr in
1249 gotoy y
1251 | Glut.LEFT_BUTTON when state.outline = None ->
1252 let dest = if bstate = Glut.DOWN then getlink x y else None in
1253 begin match dest with
1254 | Some (pageno, top) ->
1255 gotopage pageno top
1257 | None ->
1258 if bstate = Glut.DOWN
1259 then (
1260 Glut.setCursor Glut.CURSOR_CROSSHAIR;
1261 state.mstate <- Msel ((x, y), (x, y));
1262 Glut.postRedisplay ()
1264 else (
1265 Glut.setCursor Glut.CURSOR_RIGHT_ARROW;
1266 state.mstate <- Mnone;
1270 | _ ->
1273 let mouse ~button ~state ~x ~y = mouse button state x y;;
1275 let motion ~x ~y =
1276 if state.outline = None
1277 then
1278 match state.mstate with
1279 | Mnone -> ()
1280 | Msel (a, _) ->
1281 state.mstate <- Msel (a, (x, y));
1282 Glut.postRedisplay ()
1285 let pmotion ~x ~y =
1286 if state.outline = None
1287 then
1288 match state.mstate with
1289 | Mnone when (checklink x y) ->
1290 Glut.setCursor Glut.CURSOR_INFO
1292 | Mnone ->
1293 Glut.setCursor Glut.CURSOR_RIGHT_ARROW
1295 | Msel (a, _) ->
1299 let () =
1300 let name = ref "" in
1301 Arg.parse [] (fun s -> name := s) "options:";
1302 let name =
1303 if String.length !name = 0
1304 then (prerr_endline "filename missing"; exit 1)
1305 else !name
1308 let w = 900 in
1309 let h = 900 in
1310 let _ = Glut.init Sys.argv in
1311 let () = Glut.initDisplayMode ~depth:false ~double_buffer:true () in
1312 let () = Glut.initWindowSize w h in
1313 let _ = Glut.createWindow ("llpp " ^ Filename.basename name) in
1315 let csock, ssock = Unix.socketpair Unix.PF_UNIX Unix.SOCK_STREAM 0 in
1317 init ssock;
1318 state.w <- w;
1319 state.h <- h;
1320 state.csock <- csock;
1321 state.ssock <- ssock;
1322 writecmd csock ("open " ^ name ^ "\000");
1324 let () = Glut.displayFunc display in
1325 let () = Glut.reshapeFunc reshape in
1326 let () = Glut.keyboardFunc keyboard in
1327 let () = Glut.specialFunc special in
1328 let () = Glut.idleFunc (Some idle) in
1329 let () = Glut.mouseFunc mouse in
1330 let () = Glut.motionFunc motion in
1331 let () = Glut.passiveMotionFunc pmotion in
1332 let rec handlelablglutbug () =
1334 Glut.mainLoop ();
1335 with Glut.BadEnum "key in special_of_int" ->
1336 showtext '!' " LablGlut bug: special key not recognized";
1337 Glut.swapBuffers ();
1338 handlelablglutbug ()
1340 handlelablglutbug ()