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