imgv.ml

   1 type view =
   2     { mutable w : int
   3     ; mutable h : int
   4     ; mutable tw : float
   5     ; mutable th : float
   6     }
   7 ;;
   8
   9 let view = { w = -1; h = -1; tw = 0.0; th = 0.0; };;
  10
  11 let setup () =
  12   GlDraw.viewport 0 0 view.w view.h;
  13   GlMat.mode `projection;
  14   GlMat.load_identity ();
  15   GlMat.mode `modelview;
  16   GlMat.load_identity ();
  17   GluMat.ortho2d ~x:(0.0, view.tw) ~y:(0.0, view.th);
  18 ;;
  19
  20 let reshape ~w ~h =
  21   view.w <- w;
  22   view.h <- h;
  23   setup ();
  24 ;;
  25
  26 let keyboard ~key ~x ~y =
  27   begin match Char.chr key with
  28   | '\027' | 'q' -> exit 0
  29   | _ -> ()
  30   end;
  31   setup ();
  32   Glut.postRedisplay ();
  33 ;;
  34
  35 let draw what func =
  36   GlDraw.begins what;
  37   func ();
  38   GlDraw.ends ();
  39 ;;
  40
  41 let display () =
  42   GlClear.clear [`color];
  43
  44   draw `quads (fun () ->
  45     GlTex.coord2 (0.0, 0.0);
  46     GlDraw.vertex2 (0.0, view.th);
  47
  48     GlTex.coord2 (1.0, 0.0);
  49     GlDraw.vertex2 (view.tw, view.th);
  50
  51     GlTex.coord2 (1.0, 1.0);
  52     GlDraw.vertex2 (view.tw, 0.0);
  53
  54     GlTex.coord2 (0.0, 1.0);
  55     GlDraw.vertex2 (0.0, 0.0);
  56   );
  57   Glut.swapBuffers ();
  58 ;;
  59
  60 let main =
  61   let level = ref 0 in
  62   let nto_name = ref None in
  63   let swap = ref false in
  64   let setsome r s = r := Some s in
  65   let spec =
  66     ["-index", Arg.Set_string Xff.index_path, " <path> to index"
  67     ;"-base", Arg.String (setsome Xff.base_path), " <directory> base"
  68     ;"-level", Arg.Set_int level, " <level> mipmap level"
  69     ;"-swap", Arg.Set swap, " swap width and height"
  70     ]
  71   in
  72   Arg.parse (Arg.align spec) (setsome nto_name) "Usage: imgv image.nto";
  73   let nto_name =
  74     match !nto_name with
  75     | None -> failwith "NTO name not specified"
  76     | Some s -> Filename.basename s
  77   in
  78   let xff, sbuf = Xff.test2 nto_name in
  79   let nto = Nto.r xff sbuf () in
  80   let image2d level (w, h, data) =
  81     let w, h = if !swap then (h, w) else (w, h) in
  82     let id = GlTex.gen_texture () in
  83     Gl.enable `texture_2d;
  84     GlTex.bind_texture `texture_2d id;
  85     GlTex.env (`mode `replace);
  86     GlTex.parameter `texture_2d (`mag_filter `linear);
  87     GlTex.parameter `texture_2d (`min_filter `linear);
  88     GlTex.parameter `texture_2d (`wrap_s `repeat);
  89     GlTex.parameter `texture_2d (`wrap_t `repeat);
  90     let raw = Raw.of_string data `ubyte in
  91     let pix = GlPix.of_raw raw `rgba w h in
  92     GlTex.image2d ~level pix
  93   in
  94   let level =
  95     if !level < 0 || !level >= Array.length nto
  96     then (
  97       failwith (
  98         Printf.sprintf "invalid mipmap level %d, must be in [0..%d]"
  99           !level
 100           (pred (Array.length nto))
 101       );
 102     )
 103     else
 104       !level
 105   in
 106   let (w, h, img) as nto = nto.(level) in
 107   let w, h = if !swap then (h, w) else (w, h) in
 108   view.w <- w;
 109   view.h <- h;
 110   view.tw <- float w;
 111   view.th <- float h;
 112   let _ = Glut.init Sys.argv in
 113   let () = Glut.initDisplayMode ~depth:true ~double_buffer:true () in
 114   let () = Glut.initWindowSize w h in
 115   let title = Printf.sprintf "%s (%dx%d)" nto_name w h in
 116   let _ = Glut.createWindow title in
 117   let () = Glut.displayFunc display in
 118   let () = Glut.reshapeFunc reshape in
 119   let () = Glut.keyboardFunc keyboard in
 120   image2d 0 nto;
 121   let () = Glut.mainLoop () in
 122   ()
 123 ;;