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