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