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 =
  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 = qof floats 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 vertices1 bones quats =
  58   let parentinfo = Array.make (Array.length bones + 1) (Qtr.id, Vec.origin) in
  59   let mapf i (pos, (name, offsets, floats, neighbors, float)) =
  60     let curq = quats.(i) in
  61     let curv = vof floats in
  62
  63     let parent = neighbors.(2) in
  64     let parentq, parentv = parentinfo.(parent + 1) in
  65
  66     let v = Qtr.apply parentq curv in
  67     let v = Vec.add v parentv in
  68
  69     let q = Qtr.compose curq parentq in
  70     parentinfo.(i + 1) <- (q, v);
  71     Vec.elts parentv, Vec.elts v;
  72   in
  73   Array.mapi mapf bones;
  74 ;;
  75
  76 let sphere =
  77   let quad = lazy (GluQuadric.create ()) in
  78   fun origin ->
  79     GlMat.mode `modelview;
  80     GlMat.push ();
  81     GlMat.translate3 (origin);
  82     let radius = Rend.view.Rend.radial_scale*.0.009 in
  83     let quad = Lazy.force quad in
  84     GluQuadric.sphere ~radius ~stacks:5 ~slices:5 ~quad ();
  85     GlMat.pop ();
  86 ;;
  87
  88 let draw data =
  89   let rta = vertices data in
  90   fun () ->
  91     GlDraw.polygon_mode `both `line;
  92     Gl.disable  `depth_test;
  93     Array.iteri
  94       (fun i (pos, (n, d, m, h, f)) ->
  95         GlDraw.line_width 0.1;
  96         GlDraw.color (0., 0., 1.);
  97         let v0, v1 = rta.(i) in
  98         sphere v1;
  99         GlDraw.line_width 2.0;
 100         GlDraw.begins `lines;
 101         GlDraw.vertex3 v0;
 102         GlDraw.vertex3 v1;
 103         GlDraw.ends ();
 104       ) data;
 105     Gl.enable `depth_test;
 106 ;;
 107
 108 let draw1 bones =
 109   fun ?(dsphere=false) quats ->
 110     let rta = vertices1 bones quats in
 111     fun () ->
 112       GlDraw.polygon_mode `both `line;
 113       GlDraw.color (0., 0., 1.);
 114       Gl.disable  `depth_test;
 115       for i = 0 to Array.length bones - 1 do
 116         (* GlDraw.line_width 0.1; *)
 117         let v0, v1 = rta.(i) in
 118         if dsphere then sphere v1;
 119         GlDraw.line_width 2.0;
 120         GlDraw.begins `lines;
 121         GlDraw.vertex3 v0;
 122         GlDraw.vertex3 v1;
 123         GlDraw.ends ();
 124       done;
 125       Gl.enable `depth_test;
 126 ;;
 127
 128 let animate quats =
 129   Skin.set_anim quats;
 130   Skin.anim ();
 131 ;;
 132
 133 let func bones anim =
 134   let posecount, rotations = anim in
 135   let clip poseno =
 136     let poseno' = poseno mod posecount in
 137     if poseno' < 0 then posecount + poseno' else poseno'
 138   in
 139   let skeldraw n quats =
 140     match n mod 3 with
 141     | 0 -> ()
 142     | 1 -> draw1 bones quats ()
 143     | _ -> draw1 ~dsphere:true bones quats ()
 144   in
 145   let skbquats = Array.map (fun (_, (_, _, f, _, _)) -> qof f) bones in
 146   let rec subfunc drawindex quats sposeno dposeno t dir =
 147     let subf
 148         ?(drawindex=drawindex)
 149         ?(sposeno=sposeno)
 150         ?(dposeno=dposeno)
 151         ?(t=t)
 152         ?(quats=quats)
 153         ?(dir=dir) () =
 154       Rend.Func (subfunc drawindex quats sposeno dposeno t dir)
 155     in
 156     let advance quats dir =
 157       let t = t +. !Rend.slerp_step in
 158       if t >= 1.0
 159       then
 160         let sposeno = dposeno
 161         and dposeno = clip (dposeno + dir) in
 162         subf ~quats ~sposeno ~dposeno ~t:(if dir > 0 then 0.0 else 1.0) ()
 163       else
 164         subf ~quats ~sposeno ~dposeno ~t ()
 165     in
 166     function
 167       | Rend.Char ('n' | 'f' | 'b' as c) ->
 168           let quats =
 169             Anb.interpolated rotations sposeno dposeno
 170               (if c = 'b' then 1.0 -. t else t)
 171           in
 172           animate quats;
 173           advance quats
 174             (match c with
 175             | 'n' -> dir
 176             | 'f' -> 1
 177             | _ -> -1)
 178
 179       | Rend.Char 'B' ->
 180           subf ~dir:~-dir ()
 181
 182       | Rend.Char 'r' ->
 183           Skin.set_anim skbquats;
 184           Skin.anim ();
 185           subf ~drawindex:1 ~quats:skbquats ()
 186
 187       | Rend.Char ('1' | '2' as c) ->
 188           let sposeno, dposeno =
 189             if c = '1'
 190             then 0, clip 1
 191             else clip (posecount - 1), 0
 192           in
 193           let quats = Anb.exact rotations sposeno in
 194           animate quats;
 195           let t = if dir > 0 then 1.0 else 0.0 in
 196           subf ~quats ~sposeno ~dposeno ~t ~dir ()
 197
 198       | Rend.Char 's' ->
 199           subf ~drawindex:(drawindex lxor 1) ()
 200
 201       | Rend.Char 'S' ->
 202           subf ~drawindex:(drawindex + 1) ()
 203
 204       | Rend.Draw ->
 205           skeldraw drawindex quats;
 206           subf ()
 207
 208       | _ ->
 209           subf ()
 210   in
 211   subfunc 0 skbquats 0 1 0.0 1
 212 ;;
 213
 214 let dummy draw =
 215   let rec subfunc dodraw = function
 216     | Rend.Draw -> if dodraw then draw (); Rend.Func (subfunc dodraw)
 217     | Rend.Char 's' -> Rend.Func (subfunc (not dodraw))
 218     | _ -> Rend.Func (subfunc dodraw)
 219   in
 220   subfunc false
 221 ;;
 222
 223 let skin bones =
 224   let skel = Array.map
 225     (fun (_, (_, _, floats, neighbors, _)) -> (neighbors.(2), floats))
 226     bones
 227   in
 228   Skin.set_skel skel;
 229 ;;
 230
 231 let main name =
 232   let func =
 233     try
 234       let name = Filename.chop_extension name ^ ".skb" in
 235       let xff, sbuf = Xff.test2 name in
 236       let bones = r1 xff sbuf in
 237       begin try
 238           let anim_name =
 239             match !Rend.anb_name with
 240             | None -> raise (Failure "no animation set")
 241             | Some name ->name
 242           in
 243           let xff, sbuf = Xff.test2 (Filename.basename anim_name) in
 244           let anim = Anb.r xff sbuf in
 245           skin bones;
 246           func bones anim
 247         with exn ->
 248           prerr_endline (Printexc.to_string exn);
 249           dummy (draw bones)
 250       end;
 251     with exn ->
 252       prerr_endline (Printexc.to_string exn);
 253       dummy (fun () -> ())
 254   in
 255   Rend.add_func func
 256 ;;