I'm working on modernizing Rosetta Code's infrastructure. Starting with communications. Please accept this time-limited open invite to RC's Slack.. --Michael Mol (talk) 20:59, 30 May 2020 (UTC)

Loading animated 3D data/OCaml

From Rosetta Code
Library: glMLite
Library: xml-light
Library: GLUT
(* loading the libraries *)
 
#directory "+xml-light" (* or maybe "+site-lib/xml-light" *)
#load "xml-light.cma"
 
#directory "+glMLite"
#load "GL.cma"
#load "Glu.cma"
#load "Glut.cma"
 
 
 
(* types, and scene graph *)
 
type time = float (* in seconds *)
 
type 'a anim = At of time * 'a | Change of time * time * 'a * 'a
 
type 'a timed = Static of 'a | Animated of 'a anim list
 
type float1 = float timed
type float3 = (float * float * float) timed
type float4 = (float * float * float * float) timed
 
type scene = scene_elem list
and scene_elem =
| Viewpoint of float3 * float4 (* position, orientation *)
| PointLight of float3 * float3 (* location, color *)
| Transform of transform_attr list
 
and transform_attr = Translation of float3 | Scale of float3
| Rotation of float4
| Contents of shape list
 
and shape = geom * appearance
and appearance = appearance_attr list
and appearance_attr = DiffuseColor of float3
and geom =
| Box of float3
| Sphere of float1 (* radius *)
| Cylinder of float1 * float1 (* radius, height *)
| Cone of float1 * float1 (* bottomRadius, height *)
 
 
 
 
(* parsing functions *)
 
let scan_float3 s =
Scanf.sscanf s "%f %f %f" (fun x y z -> x,y,z) ;;
 
let scan_float4 s =
Scanf.sscanf s "%f %f %f %f" (fun a x y z -> a,x,y,z) ;;
 
let scan_time s =
Scanf.sscanf s "%fs" (fun sec -> sec) ;;
 
 
let mk_float3 v = Static(scan_float3 v)
let mk_float4 v = Static(scan_float4 v)
 
 
let assoc_opt v li =
try Some(List.assoc v li)
with Not_found -> None
 
let find_opt f li =
try Some(List.find f li)
with Not_found -> None
 
 
 
let get_anim scan attr_name childs =
List.fold_left (fun acc -> function
Xml.Element ("animate", attrs, _) ->
let this_attr_name = List.assoc "attributeName" attrs in
if this_attr_name <> attr_name
then (acc)
else
let from = scan(List.assoc "from" attrs)
and to_ = scan(List.assoc "to" attrs)
and begin_ = scan_time(List.assoc "begin" attrs)
and dur = scan_time(List.assoc "dur" attrs)
in
Change(begin_, begin_ +. dur, from, to_) :: acc
 
| _ -> (acc)
) [] childs
 
 
let to_param scan attr_name attrs default childs =
match assoc_opt attr_name attrs,
get_anim scan attr_name childs with
| None, [] -> Static(default)
| Some v, [] -> Static(scan v)
| None, anim -> Animated(anim)
| Some v, anim -> Animated(At(0.0, scan v)::anim)
 
let to_float3 = to_param scan_float3 ;;
let to_float4 = to_param scan_float4 ;;
let to_float1 = to_param float_of_string ;;
 
 
let parse_geom = function
| Xml.Element ("Box", attrs, childs) ->
Box(to_float3 "size" attrs (2., 2., 2.) childs)
 
| Xml.Element ("Sphere", attrs, childs) ->
Sphere(to_float1 "radius" attrs (1.0) childs)
 
| Xml.Element ("Cylinder", attrs, childs) ->
let radius = (to_float1 "radius" attrs (1.0) childs)
and height = (to_float1 "height" attrs (2.0) childs) in
Cylinder(radius, height)
 
| Xml.Element ("Cone", attrs, childs) ->
let botRad = (to_float1 "bottomRadius" attrs (1.0) childs)
and height = (to_float1 "height" attrs (2.0) childs) in
Cone(botRad, height)
 
| _ -> assert false
 
 
let appearance_fold acc = function
| Xml.Element ("Appearance", [], [
Xml.Element ("Material", attrs, childs)]) ->
DiffuseColor(to_float3 "diffuseColor" attrs (0.8, 0.8, 0.8) childs)::acc
| _ -> (acc)
 
 
let filter_geom = function
| Xml.Element ("Box",_,_)
| Xml.Element ("Sphere",_,_)
| Xml.Element ("Cylinder",_,_)
| Xml.Element ("Cone",_,_) -> true
| _ -> false
 
let parse_shape_contents c =
let geom = parse_geom(List.find filter_geom c)
and appearance = List.fold_left appearance_fold [] c in
let shape = (geom, appearance) in
(shape)
 
 
let parse_shape = function
| Xml.Element("Shape", [], contents) ->
(parse_shape_contents contents)
| _ -> assert false
 
let filter_shape = function Xml.Element("Shape",_,_) -> true | _ -> false
 
 
let map_scene_elem = function
| Xml.Element ("Viewpoint", attrs, childs) ->
let position = (to_float3 "position" attrs (0., 0., 10.) childs)
and orientation = (to_float4 "orientation" attrs (0.,0.,1.,0.) childs) in
Viewpoint(position, orientation)
 
| Xml.Element ("PointLight", attrs, childs) ->
let location = (to_float3 "location" attrs (0., 0., 0.) childs)
and color = (to_float3 "color" attrs (1., 1., 1.) childs) in
PointLight(location, color)
 
| Xml.Element ("Transform", attrs, contents) ->
let transform_attrs = [] in
let transform_attrs =
match assoc_opt "translation" attrs with
| Some translation -> Translation(mk_float3 translation)::transform_attrs
| None -> (transform_attrs)
in
let transform_attrs =
match assoc_opt "scale" attrs with
| Some scale -> Scale(mk_float3 scale)::transform_attrs
| None -> (transform_attrs)
in
let transform_attrs =
match assoc_opt "rotation" attrs with
| Some rotation -> Rotation(mk_float4 rotation)::transform_attrs
| None -> (transform_attrs)
in
let shapes = List.filter filter_shape contents in
let shapes = List.map parse_shape shapes in
let transform_attrs = (Contents shapes)::transform_attrs in
 
(* TODO animate (translation, rotation, scale) from childs *)
 
Transform(transform_attrs)
 
| _ -> assert false
 
 
let parse_scene = function
| Xml.Element ("smil", [], [
Xml.Element ("X3D", [], [
Xml.Element ("Scene", [], scene_elems)])])
 
| Xml.Element ("X3D", [], [
Xml.Element ("Scene", [], scene_elems)]) -> List.map map_scene_elem scene_elems
 
| _ -> assert false
 
(* end of parsing the datas *)
 
 
 
(* timeline functions *)
 
let inter1 t t1 t2 v1 v2 =
v1 +. ((t -. t1) /. (t2 -. t1) *. (v2 -. v1))
 
let inter3 t t1 t2 (a1,b1,c1) (a2,b2,c2) =
let m = (t -. t1) /. (t2 -. t1) in
( a1 +. (m *. (a2 -. a1)),
b1 +. (m *. (b2 -. b1)),
c1 +. (m *. (c2 -. c1)) )
 
let inter4 t t1 t2 (a1,b1,c1,d1) (a2,b2,c2,d2) =
let m = (t -. t1) /. (t2 -. t1) in
( a1 +. (m *. (a2 -. a1)),
b1 +. (m *. (b2 -. b1)),
c1 +. (m *. (c2 -. c1)),
d1 +. (m *. (d2 -. d1)) )
 
let rec val_at inter t = function
| At(t1, v) :: At(t2,_) :: _
| At(t1, v) :: Change(t2,_,_,_) :: _
when t1 <= t && t < t2 -> (v)
| At(t, v) :: [] -> (v)
| Change(_,t2,_,v2) :: []
when t >= t2 -> (v2)
| Change(t1,t2,v1,v2) :: _
when t1 <= t && t <= t2 -> inter t t1 t2 v1 v2
| _ :: tl -> val_at inter t tl
| [] -> assert false
 
let get_val inter t = function
| Static v -> v
| Animated anim -> val_at inter t anim
 
let get_val1 = get_val inter1 ;;
let get_val3 = get_val inter3 ;;
let get_val4 = get_val inter4 ;;
 
 
 
(* OpenGL rendering *)
 
open GL
open Glu
open Glut
 
let t = ref 0.0
 
let neg_vec (x, y, z) = (-. x, -. y, -. z)
 
 
let display scene = function () ->
glClear [GL_COLOR_BUFFER_BIT; GL_DEPTH_BUFFER_BIT];
glLoadIdentity ();
 
List.iter (function
| Viewpoint (position, orientation) ->
let position = get_val3 !t position
and orientation = get_val4 !t orientation in
let angle, x, y, z = orientation in
glRotate ~angle ~x ~y ~z;
glTranslatev (neg_vec position)
 
| PointLight (location, color) ->
let location = get_val3 !t location
and color = get_val3 !t color in
ignore(location, color)
 
| Transform cl ->
List.iter (function
| Scale scale ->
let v = get_val3 !t scale in
glScalev v
| Translation vec ->
let v = get_val3 !t vec in
glTranslatev v
| _ -> ()
) cl;
List.iter (function
| Contents cl ->
List.iter (function
| (Box size, appearance) ->
List.iter (function
| DiffuseColor color ->
glColor3v (get_val3 !t color)
) appearance;
glPushMatrix ();
glScalev (get_val3 !t size);
glutSolidCube ~size:1.0;
glPopMatrix ();
 
| _ -> () (* TODO other primitives *)
) cl
| _ -> ()
) cl;
 
) scene;
 
glFlush ();
glutSwapBuffers ();
;;
 
 
let reshape ~width ~height =
glMatrixMode GL_PROJECTION;
glLoadIdentity ();
gluPerspective 30. (float width /. float height) 2. 30.;
glViewport 0 0 width height;
glMatrixMode GL_MODELVIEW;
glutPostRedisplay ();
;;
 
let keyboard ~key ~x ~y =
match key with
| '\027' | 'q' -> exit(0)
| _ -> ()
;;
 
(* main *)
let () =
ignore(glutInit Sys.argv);
glutInitDisplayMode [GLUT_RGBA; GLUT_DOUBLE; GLUT_DEPTH];
glutInitWindowPosition ~x:200 ~y:200;
glutInitWindowSize ~width:400 ~height:300;
ignore(glutCreateWindow ~title:Sys.argv.(0));
 
glEnable GL_DEPTH_TEST;
 
let my_scene = parse_scene (Xml.parse_file Sys.argv.(1)) in
 
let rec timer ~value =
t := !t +. 0.01;
glutTimerFunc ~msecs:value ~timer ~value;
in
let msecs = 10 in
glutTimerFunc ~msecs ~timer ~value:msecs;
glutIdleFunc ~idle:glutPostRedisplay;
glutDisplayFunc ~display:(display my_scene);
glutReshapeFunc ~reshape;
glutKeyboardFunc ~keyboard;
glutMainLoop ();
;;