skb.ml

   1 open Format;;
   2
   3 let qof f = Qtr.make f.(5) f.(6) f.(7) f.(8);;
   4 let vof f = Vec.make f.(1) f.(2) f.(3);;
   5
   6 type t = int * (string * int32 array * float array * int array * float);;
   7
   8 let rt sbuf strtab =
   9   let d = Array.init 3 (fun n -> Xff.r32 sbuf (n*4)) in
  10   let f9 = Array.init 9 (fun n -> Xff.rfloat sbuf (12 +n*4)) in
  11   let h = Array.init 3 (fun n -> Xff.rint sbuf (48 + n*4)) in
  12   let f = Xff.rfloat sbuf 60 in
  13   (Xff.rcstrtabent strtab 0 (Int32.to_int d.(0)), d, f9, h, f)
  14 ;;
  15
  16 let r1 xff sbufxff =
  17   if Array.length xff.Xff.sections != 2
  18   then
  19     Xff.sbuferr sbufxff 0 "number of xff sections is not 2"
  20   ;
  21   let sectpos = xff.Xff.sections.(1).Xff.off in
  22   let sectbuf = Xff.sbufplus sbufxff sectpos in
  23   let skbbuf = Xff.sbufplus sectbuf xff.Xff.entry in
  24
  25   let count1 = Xff.rint skbbuf 4 in
  26   let _pos1 = Xff.rint skbbuf 8 in
  27   let tabpos1 = Xff.rint skbbuf 12 in
  28   let strtab1 = Xff.sbufplus sectbuf tabpos1 in
  29
  30   let bones = Array.init count1 (fun n ->
  31     let pos = Xff.rint skbbuf (44 + n*8) in
  32     let sbuf = Xff.sbufplus sectbuf pos in
  33     pos + sectpos, rt sbuf strtab1)
  34   in
  35   bones
  36 ;;
  37
  38 let vertices bones quats =
  39   let parentinfo = Array.make (Array.length bones + 1) (Qtr.id, Vec.origin) in
  40   let mapf i (pos, (name, offsets, floats, neighbors, float)) =
  41     let curq = quats.(i) in
  42     let curv = vof floats in
  43
  44     let parent = neighbors.(2) in
  45     let parentq, parentv = parentinfo.(parent + 1) in
  46
  47     let v = Qtr.apply parentq curv in
  48     let v = Vec.add v parentv in
  49
  50     let q = Qtr.compose curq parentq in
  51     parentinfo.(i + 1) <- (q, v);
  52     Vec.elts parentv, Vec.elts v;
  53   in
  54   Array.mapi mapf bones;
  55 ;;
  56
  57 let sphere =
  58   let quad = lazy (GluQuadric.create ()) in
  59   fun origin ->
  60     GlMat.mode `modelview;
  61     GlMat.push ();
  62     GlMat.translate3 (origin);
  63     let radius = Rend.view.Rend.radial_scale*.0.009 in
  64     let quad = Lazy.force quad in
  65     GluQuadric.sphere ~radius ~stacks:5 ~slices:5 ~quad ();
  66     GlMat.pop ();
  67 ;;
  68
  69 let draw bones =
  70   fun ?(dsphere=false) quats ->
  71     let rta = vertices bones quats in
  72     fun () ->
  73       GlDraw.polygon_mode `both `line;
  74       GlDraw.color (0., 0., 1.);
  75       Gl.disable  `depth_test;
  76       for i = 0 to Array.length bones - 1 do
  77         let v0, v1 = rta.(i) in
  78         if dsphere then (
  79           GlDraw.line_width 0.1;
  80           sphere v1;
  81         );
  82         GlDraw.line_width 2.0;
  83         GlDraw.begins `lines;
  84         GlDraw.vertex3 v0;
  85         GlDraw.vertex3 v1;
  86         GlDraw.ends ();
  87       done;
  88       Gl.enable `depth_test;
  89 ;;
  90
  91 let skbquats bones =
  92   Array.map (fun (_, (_, _, f, _, _)) -> qof f) bones
  93 ;;
  94
  95 let animate quats =
  96   Skin.set_anim quats;
  97   Skin.anim ();
  98 ;;
  99
 100 let func bones anim =
 101   let posecount, rotations = anim in
 102   let clip poseno =
 103     let poseno' = poseno mod posecount in
 104     if poseno' < 0 then posecount + poseno' else poseno'
 105   in
 106   let skeldraw n quats =
 107     match n mod 3 with
 108     | 0 -> ()
 109     | 1 -> draw bones quats ()
 110     | _ -> draw ~dsphere:true bones quats ()
 111   in
 112   let skbquats = skbquats bones in
 113   let rec subfunc drawindex quats sposeno dposeno t dir =
 114     let subf
 115         ?(drawindex=drawindex)
 116         ?(sposeno=sposeno)
 117         ?(dposeno=dposeno)
 118         ?(t=t)
 119         ?(quats=quats)
 120         ?(dir=dir) () =
 121       let drawindex = drawindex mod 3 in
 122       let hf () =
 123         ["s", "toggle skeleton", (if drawindex = 0 then "off" else "on")
 124         ;"S", "skeleton type", string_of_int drawindex
 125         ;"B", sprintf "toggle animation direction", string_of_int dir
 126         ;"f", "forward one frame", sprintf "%d, %f" sposeno t
 127         ;"b", "backward one frame", sprintf "%d, %f" sposeno t
 128         ;"", "", "total frames " ^ string_of_int posecount
 129         ;"r", "go to bind pose", ""
 130         ;"1,2", "go to first/last frame", ""
 131         ]
 132       in
 133       Rend.Func (subfunc drawindex quats sposeno dposeno t dir, hf)
 134     in
 135     let advance quats dir =
 136       let t = t +. !Rend.slerp_step in
 137       if t >= 1.0
 138       then
 139         let sposeno = dposeno
 140         and dposeno = clip (dposeno + dir) in
 141         subf ~quats ~sposeno ~dposeno ~t:0.0 ()
 142       else
 143         subf ~quats ~sposeno ~dposeno ~t ()
 144     in
 145     function
 146       | Rend.Char ('n' | 'f' | 'b' as c) ->
 147           let quats = Anb.interpolated rotations sposeno dposeno t in
 148           animate quats;
 149           advance quats
 150             (match c with
 151             | 'n' -> dir
 152             | 'f' -> 1
 153             | _ -> -1)
 154
 155       | Rend.Char 'B' ->
 156           subf ~dir:~-dir ()
 157
 158       | Rend.Char 'r' ->
 159           Skin.set_anim skbquats;
 160           Skin.anim ();
 161           subf ~drawindex:1 ~quats:skbquats ()
 162
 163       | Rend.Char ('1' | '2' as c) ->
 164           let sposeno, dposeno =
 165             if c = '1'
 166             then 0, clip 1
 167             else clip (posecount - 1), 0
 168           in
 169           let quats = Anb.exact rotations sposeno in
 170           animate quats;
 171           let t = if dir > 0 then 1.0 else 0.0 in
 172           subf ~quats ~sposeno ~dposeno ~t ~dir ()
 173
 174       | Rend.Char 's' ->
 175           subf ~drawindex:(drawindex lxor 1) ()
 176
 177       | Rend.Char 'S' ->
 178           subf ~drawindex:(drawindex + 1) ()
 179
 180       | Rend.Draw ->
 181           skeldraw drawindex quats;
 182           subf ()
 183
 184       | _ ->
 185           subf ()
 186   in
 187   subfunc 0 skbquats 0 1 0.0 1
 188 ;;
 189
 190 let dummy draw =
 191   let rec subfunc dodraw =
 192     let hf () =
 193       ["s", "toggle skeleton", if dodraw then "on" else "off"]
 194     in
 195     function
 196       | Rend.Draw -> if dodraw then draw (); Rend.Func (subfunc dodraw, hf)
 197       | Rend.Char 's' -> Rend.Func (subfunc (not dodraw), hf)
 198       | _ -> Rend.Func (subfunc dodraw, hf)
 199   in
 200   subfunc false
 201 ;;
 202
 203 let skin bones =
 204   let skel = Array.map
 205     (fun (_, (_, _, floats, neighbors, _)) -> (neighbors.(2), floats))
 206     bones
 207   in
 208   Skin.set_skel skel;
 209 ;;
 210
 211 let main name =
 212   let func =
 213     try
 214       let name =
 215         match !Rend.skb_name with
 216         | Some s -> s
 217         | None ->
 218             Filename.chop_extension name ^ ".skb"
 219       in
 220       let xff, sbuf = Xff.test2 name in
 221       let bones = r1 xff sbuf in
 222       begin try
 223           let anim_name =
 224             match !Rend.anb_name with
 225             | None -> raise (Failure "no animation set")
 226             | Some name ->name
 227           in
 228           let xff, sbuf = Xff.test2 (Filename.basename anim_name) in
 229           let anim = Anb.r xff sbuf in
 230           skin bones;
 231           func bones anim
 232         with exn ->
 233           prerr_endline (Printexc.to_string exn);
 234           let quats = skbquats bones in
 235           dummy (draw bones quats)
 236       end;
 237     with exn ->
 238       prerr_endline (Printexc.to_string exn);
 239       dummy (fun () -> ())
 240   in
 241   Rend.add_func func
 242 ;;