rend.ml

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