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