rend.ml

   1 type cmd = | Char of char | Draw;;
   2 type func = cmd -> func_ret
   3 and func_ret = Func of func
   4
   5 let nmo_name = ref None
   6 let anb_name = ref None
   7 let mipmaps = ref false
   8
   9 type view =
  10     { mutable w : int
  11     ; mutable h : int
  12     ; mutable rotx : float
  13     ; mutable roty : float
  14     ; mutable rotz : float
  15     ; mutable zoom : float
  16     ; mutable center : (float * float * float)
  17     ; mutable radial_scale : float
  18     ; mutable func : func list
  19     ; mutable persp : bool
  20     ; mutable last_time : float
  21     ; mutable animated : bool
  22     ; mutable dumpchan : out_channel Lazy.t
  23     ; mutable dodump : bool
  24     ; mutable aincr : float
  25     ; mutable roteye: bool
  26     ; mutable sphere : bool
  27     ; mutable help : bool
  28     ; mutable x : int
  29     ; mutable y : int
  30     ; mutable mtype : [`none|`zoom|`rotate|`move]
  31     ; mutable transl : (float * float * float)
  32     ; mutable alpha : float
  33     }
  34
  35 let view =
  36   { w = 0; h = 0
  37   ; rotx = 0.0; roty = 0.0; rotz = 0.0
  38   ; center = (0.0, 0.0, 0.0)
  39   ; radial_scale = 0.0
  40   ; zoom = 1.0
  41   ; func = []
  42   ; persp = true
  43   ; last_time = 0.0
  44   ; animated = false
  45   ; dumpchan = lazy (open_out_bin "dump.rgb")
  46   ; dodump = false
  47   ; aincr = 3.0
  48   ; roteye = true
  49   ; sphere = false
  50   ; help = false
  51   ; x = 0
  52   ; y = 0
  53   ; mtype = `none
  54   ; transl = (0.0, 0.0, 0.0)
  55   ; alpha = 0.0
  56   }
  57 ;;
  58
  59 let deg2rad deg = deg /. 180.0 *. acos ~-.1.;;
  60
  61 let center_and_radial_scale (minx, maxx, miny, maxy, minz, maxz) =
  62   let xc = (maxx -. minx) /. 2.0 +. minx in
  63   let yc = (maxy -. miny) /. 2.0 +. miny in
  64   let zc = (maxz -. minz) /. 2.0 +. minz in
  65   let rs =
  66     let rs = maxx -. minx in
  67     let rs = max rs (maxy -. miny) in
  68     let rs = max rs (maxz -. minz) in
  69     rs
  70   in
  71   if false
  72   then (
  73     Format.eprintf "x (% f, % f)@." minx maxx;
  74     Format.eprintf "y (% f, % f)@." miny maxy;
  75     Format.eprintf "z (% f, % f)@." minz maxz;
  76     Format.eprintf "c (% f, % f, % f)@." xc yc zc;
  77     Format.eprintf "rs %f@." rs;
  78   );
  79   ((xc, yc, zc), rs)
  80 ;;
  81
  82 let help () =
  83   let font = Glut.BITMAP_HELVETICA_18 in
  84   let draw_string x y s =
  85     GlPix.raster_pos ~x ~y ();
  86     String.iter (fun c -> Glut.bitmapCharacter ~font ~c:(Char.code c)) s
  87   in
  88   GlMat.mode `projection;
  89   GlMat.push ();
  90   GlMat.load_identity ();
  91   GlMat.mode `modelview;
  92   GlMat.push ();
  93   GlMat.load_identity ();
  94   GlMat.ortho
  95     ~x:(0.0, float view.w)
  96     ~y:(0.0, float view.h)
  97     ~z:(-1., 1.)
  98   ;
  99
 100   Gl.enable `blend;
 101   GlFunc.blend_func `src_alpha `one_minus_src_alpha;
 102   GlDraw.color (0., 0., 0.) ~alpha:0.3;
 103   GlDraw.rect (0., 0.) (float view.w, float view.h);
 104   Gl.disable `blend;
 105
 106   Gl.disable `depth_test;
 107   Gl.disable `alpha_test;
 108   GlDraw.color (1., 1., 1.);
 109   let rec loop row = function
 110     | [] -> ()
 111     | (s, s2) :: rest ->
 112         let y = view.h - row * 18 - 2 in
 113         draw_string 5.0 (float y) s;
 114         draw_string 105.0 (float y) s2;
 115         loop (row+1) rest
 116   in
 117   loop 1
 118     [("Keys:", "")
 119     ;" h", "toggle help"
 120     ;" e", "toggle eye/model rotation"
 121     ;" s", "toggle skeleton"
 122     ;" t", "toggle texturing"
 123     ;" l", "toggle lighting"
 124     ;" m", "toggle model"
 125     ;" w", "toggle wireframe"
 126     ;" a", "toggle animation"
 127     ;" o", "toggle bounding sphere"
 128     ;" c", "toggle color material"
 129     ;" f", "forward one frame"
 130     ;" b", "backward one frame"
 131     ;" r", "bring skeleton to rest pose and set frame number to 0"
 132     ;" d", "dump images to dump.rgb"
 133     ;" z,x,arrows", "rotate"
 134     ;" 0,9", "zoom"
 135     ;" 1,2", "go to first/last pose"
 136     ;" <,>", "increase/decrease alpha"
 137     ;"", ""
 138     ;"Move mouse while holding left button pressed to rotate model", ""
 139     ;"Move mouse while holding right button pressed to zoom", ""
 140     ;"Move mouse while holding left button and shift pressed to move model", ""
 141     ];
 142
 143   Gl.enable `depth_test;
 144   Gl.enable `alpha_test;
 145   GlMat.pop ();
 146   GlMat.mode `projection;
 147   GlMat.pop ();
 148 ;;
 149
 150 let display () =
 151   GlClear.color (0.5, 0.5, 0.5) ~alpha:1.0;
 152   GlClear.clear [`color; `depth];
 153   GlDraw.color (0.0, 0.0, 0.0);
 154   GlFunc.alpha_func `greater view.alpha;
 155
 156   if view.sphere then (
 157     let cx, cy, cz = view.center in
 158     let cx = -.cx and cy = -.cy and cz = -.cz in
 159     GlMat.mode `modelview;
 160     GlMat.push ();
 161     GlMat.translate3 (cx, cy, cz);
 162     GlDraw.polygon_mode `back `line;
 163     GlDraw.polygon_mode `front `line;
 164     Gl.disable `texture_2d;
 165     GluQuadric.sphere ~radius:(0.7*.view.radial_scale) ~stacks:25 ~slices:25 ();
 166     GlMat.pop ();
 167   );
 168
 169   List.iter (fun f -> ignore (f Draw)) view.func;
 170   if view.help then help ();
 171   Glut.swapBuffers ();
 172
 173   if view.dodump then (
 174     let pix = GlPix.read 0 0 view.w view.h `rgb `ubyte in
 175     let raw = GlPix.to_raw pix in
 176     let pitch = view.w * 3 in
 177     let size = view.h * pitch in
 178     let s = Raw.gets_string raw 0 size in
 179     let dc = Lazy.force view.dumpchan in
 180     let rec loop pos =
 181       let pos = pos - pitch in
 182       if pos < 0 then ()
 183       else (
 184         output dc s pos pitch;
 185         loop pos
 186       )
 187     in
 188     loop size;
 189   );
 190 ;;
 191
 192 let get_eye_and_up () =
 193   if not view.roteye
 194   then
 195     (0.0, 0.0, 2.0), (0.0, 1.0, 0.0)
 196   else
 197     let q =
 198       let rx = deg2rad view.rotx
 199       and ry = deg2rad view.roty
 200       and rz = deg2rad view.rotz in
 201       Qtr.from_euler rz ~-.ry rx
 202     in
 203     let v = Qtr.apply q (Vec.make 0.0 0.0 2.0) in
 204     let u = Qtr.apply q (Vec.make 0.0 1.0 0.0) in
 205     Vec.elts v, Vec.elts u
 206 ;;
 207
 208 let setup w h =
 209   view.w <- w;
 210   view.h <- h;
 211   GlDraw.viewport 0 0 w h;
 212
 213   let rs = view.zoom /. view.radial_scale in
 214
 215   GlMat.mode `projection;
 216   GlMat.load_identity ();
 217   GlMat.translate3 view.transl;
 218   GluMat.perspective
 219     ~fovy:45.0
 220     ~aspect:(float w /. float h)
 221     ~z:(0.1, 10.)
 222   ;
 223
 224   GlMat.mode `modelview;
 225   GlMat.load_identity ();
 226
 227   let eye, up = get_eye_and_up () in
 228   GluMat.look_at
 229     ~eye
 230     ~center:(0.0, 0.0, 0.0)
 231     ~up
 232   ;
 233
 234   if not view.roteye then (
 235     GlMat.rotate ~angle:view.rotx ~x:1.0 ();
 236     GlMat.rotate ~angle:view.roty ~y:~-.1.0 ();
 237     GlMat.rotate ~angle:view.rotz ~z:1.0 ();
 238   );
 239
 240   GlMat.scale3 (-.rs, rs, rs);
 241   GlMat.translate3 view.center;
 242 ;;
 243
 244 let reshape ~w ~h =
 245   setup w h;
 246 ;;
 247
 248 let allfunc cmd =
 249   view.func <- List.map (fun f -> let Func fr = f cmd in fr)  view.func;
 250 ;;
 251
 252 let idle () =
 253   let deadline = view.last_time +. 0.04 in
 254   let currtime = Unix.gettimeofday () in
 255   if deadline > currtime
 256   then
 257     let _ = Unix.select [] [] [] (deadline -. currtime) in
 258     view.last_time <- Unix.gettimeofday ()
 259   else
 260     view.last_time <- view.last_time +. 0.04
 261   ;
 262   view.func <- List.map (fun f -> let Func fr = f (Char 'f') in fr)  view.func;
 263   Glut.postRedisplay ();
 264 ;;
 265
 266 let keyboard ~key ~x ~y =
 267   begin match Char.chr key with
 268   | '\027' | 'q' -> exit 0
 269   | '9' -> view.zoom <- view.zoom +. 0.05
 270   | '0' -> view.zoom <- view.zoom -. 0.05
 271   | 'z' -> view.roty <- view.roty +. view.aincr
 272   | 'x' -> view.roty <- view.roty -. view.aincr
 273   | 'd' -> view.dodump <- not view.dodump
 274   | 'e' -> view.roteye <- not view.roteye
 275   | 'o' -> view.sphere <- not view.sphere;
 276   | 'h' -> view.help <- not view.help
 277   | 'a' ->
 278       if view.animated
 279       then (
 280         view.animated <- false;
 281         Glut.idleFunc None
 282       )
 283       else (
 284         view.animated <- true; view.
 285         last_time <- Unix.gettimeofday ();
 286         Glut.idleFunc (Some idle)
 287       )
 288   | 'f' | 'b' when not view.animated -> allfunc (Char (Char.chr key))
 289   | '<' -> view.alpha <- min (view.alpha +. 0.01) 1.0;
 290   | '>' -> view.alpha <- max (view.alpha -. 0.01) 0.0;
 291   | c -> allfunc (Char c)
 292   end;
 293   setup view.w view.h;
 294   Glut.postRedisplay ();
 295 ;;
 296
 297 let special ~key ~x ~y =
 298   begin match key with
 299   | Glut.KEY_LEFT  -> view.rotz <- view.rotz +. view.aincr
 300   | Glut.KEY_RIGHT -> view.rotz <- view.rotz -. view.aincr
 301   | Glut.KEY_UP    -> view.rotx <- view.rotx -. view.aincr
 302   | Glut.KEY_DOWN  -> view.rotx <- view.rotx +. view.aincr
 303   | _ -> ()
 304   end;
 305   setup view.w view.h;
 306   Glut.postRedisplay ();
 307 ;;
 308
 309 let motion ~x ~y =
 310   let dx = (x - view.x) in
 311   let dy = (y - view.y) in
 312   view.x <- x;
 313   view.y <- y;
 314   match view.mtype with
 315   | `move ->
 316       let x, y, z = view.transl in
 317       let dx = float dx /. 100.0
 318       and dy = float dy /. 100.0 in
 319       view.transl <- (x +. dx, y -. dy, z);
 320       setup view.w view.h;
 321       Glut.postRedisplay ();
 322   | `rotate ->
 323       view.rotx <- view.rotx +. float dy;
 324       view.roty <- view.roty -. float dx;
 325       setup view.w view.h;
 326       Glut.postRedisplay ();
 327   | `zoom ->
 328       view.zoom <- view.zoom +. (float dy /. 50.);
 329       setup view.w view.h;
 330       Glut.postRedisplay ();
 331   | `none ->
 332       ()
 333 ;;
 334
 335 let mouse ~button ~state ~x ~y =
 336   if button = Glut.LEFT_BUTTON
 337   then (
 338     if state = Glut.DOWN
 339     then (
 340       view.x <- x;
 341       view.y <- y;
 342       view.mtype <-
 343         if Glut.getModifiers () = Glut.active_shift
 344         then `move else `rotate;
 345     )
 346     else view.mtype <- `none;
 347   )
 348   else if button = Glut.RIGHT_BUTTON
 349   then (
 350     if state = Glut.DOWN
 351     then (
 352       view.x <- x;
 353       view.y <- y;
 354       view.mtype <- `zoom;
 355     )
 356     else view.mtype <- `none;
 357   );
 358 ;;
 359
 360 let main () =
 361   let w = 704
 362   and h = 576 in
 363   let _ = Glut.init Sys.argv in
 364   let () = Glut.initDisplayMode ~depth:true ~double_buffer:true () in
 365   let () = Glut.initWindowSize w h in
 366   let _ = Glut.createWindow "rend (press 'h' to get help)" in
 367   Gl.enable `depth_test;
 368   Gl.enable `alpha_test;
 369   let () = Glut.displayFunc display in
 370   let () = Glut.reshapeFunc reshape in
 371   let () = Glut.keyboardFunc keyboard in
 372   let () = Glut.specialFunc special in
 373   let () = Glut.mouseFunc mouse in
 374   let () = Glut.motionFunc motion in
 375   let () = Glut.mainLoop () in
 376   ()
 377 ;;
 378
 379 let add_func func =
 380   view.func <- func :: view.func;
 381 ;;
 382
 383 let init minmax =
 384   let (cx, cy, cz), rs = center_and_radial_scale minmax in
 385   view.center <- (-.cx, -.cy, -.cz);
 386   view.radial_scale <- rs;
 387 ;;
 388
 389 let _ =
 390   let setsome r s = r := Some s in
 391   let spec =
 392     ["-slice", Arg.String Slice.openslice, " <path> of file to slice data to"
 393     ;"-index", Arg.Set_string Xff.index_path, " <path> of index"
 394     ;"-base", Arg.String (setsome Xff.base_path), " <directory> base"
 395     ;"-mipmaps", Arg.Set mipmaps, "use mipmaps"
 396     ]
 397   in
 398   Arg.parse (Arg.align spec)
 399     (fun s ->
 400       if !nmo_name != None then (
 401         if !anb_name != None
 402         then raise (Arg.Bad "invalid usage")
 403         else anb_name := Some s;
 404       ) else nmo_name := Some s;
 405     )
 406     "Usage: dormin [options] model.nmo [animation.anb]"
 407 ;;