










(* *************************************************** *)
(*                                                     *)
(*          vrGAml : the X project of the Year         *)
(*                                                     *)
(*              Part One : the Prototype               *)
(*                                                     *)
(* *************************************************** *)

(* *************************************************** *)                      (*                                                     *)
(*       fonctions de traductions vrGAml -> VRML       *)
(*                                                     *)
(*  v1.0 : approche "naive" 2/4/97                     *)
(*  v2.0 : complement des noeuds 8/4/97                *)
(*  v3.0 : generation de USE DEF sur les vrml_object   *)
(*  v3.1 : on continue les noeuds 11/4/97              *)
(*  v3.2 : on continue les noeuds 15/4/97 bis          *)
(*  v3.3 : on tente les anim                           *)
(*                                                     *)
(* *************************************************** *)


open Compatibility;;
open Types;;
open Default;;
open Exceptions;;
open Basic_types;;
open Font;;
open Fonts;;
open Colors;;
open Vrml_objects_pre;;
open Calc_3D;;
open Vrml_objects_post;;
open Positionables;;
open Geometrics;;
open Geometric_properties;;
open Map;;
open Complex_geometrics;;
open Map_complex;;
open Lights;;
open Map_light;;
open Sound;;
open Frame_manipulations;;
open Specials;;
open World;;
open Hashtbl;;


(* ************************************ *)
(* **** declaration des references **** *)


type dictionary =
{ name : string ;
  triggers : trigger list 
};;

type table =
{ trigger_table : (trigger * string) list ;
  object_table : (vrml_object * dictionary) list 
};;

let dico = ref { trigger_table = []; object_table = [] } ;;

(* object_equivalent : vrml_object -> vrml_object -> bool = <fun> *)
let object_equivalent o1 o2 =
if o1.unique then o1 == o2 else o1 = o2 ;;

(* object_table_find : vrml_object -> dictionary = <fun> *)
let object_table_find obj =
let rec find list =
match list with
  [] -> raise Not_found
| (o,n)::b -> if (object_equivalent obj o) then n else find b
in find !dico.object_table;;

(* object_table_remove : vrml_object -> unit = <fun> *)
let object_table_remove obj =
let object_table = !dico.object_table in
let rec find list1 list2 =
 match list1 with
        [] -> list2
  | (o,n)::b -> if (object_equivalent obj o) then b@list2
                else find b ((o,n)::list2)
in dico := { trigger_table = !dico.trigger_table ;
             object_table = find object_table [] } ;;

let object_table_add obj object_dico =
object_table_remove obj;
let object_table = !dico.object_table in
dico := { trigger_table = !dico.trigger_table ;
          object_table = (obj,object_dico)::object_table };;

let dico_clear () =
 dico := { trigger_table = [] ; object_table = []  } ;;

let trigger_equivalent t1 t2 =
match (t1,t2) with
  (Click a,Click b) -> a=b 
| (Exit (a,b),x) -> (match x with
                  Exit (c,d) -> (a=c) & (b=d)
                | Enter (c,d) -> (a=c) & (b=d)
                | _ -> false)
| (Enter (a,b),x) -> (match x with
                   Exit (c,d) -> (a=c) & (b=d)
                 | Enter (c,d) -> (a=c) & (b=d)
                 | _ -> false)
| (Instant a,Instant b) -> a = b
| _ -> false
;;

let trigger_name trigger =
let rec trigger_find list =
match list with
  [] -> ""
| (t,n)::s -> if (trigger_equivalent trigger t) then n else trigger_find s
in trigger_find !dico.trigger_table ;;

let new_trigger_name trigger name =
let rec rename list1 list2 =
match list1 with
  [] -> (trigger,name)::list2
| (t,n)::b -> if (trigger_equivalent trigger t) then ((t,name)::b)@list2
              else rename b ((t,n)::list2)
in dico := { trigger_table = rename !dico.trigger_table [] ;
             object_table = !dico.object_table } ;;

(*  *)
let new_trigger obj trigger  =
let object_dico = try (object_table_find obj) with
                   _ -> { name = "" ; triggers = []  }
in let trigger_list = object_dico.triggers 
in let rec find list1 list2 =
 match list1 with
    [] -> trigger::list2
  | t::s -> if (trigger_equivalent trigger t) then list1@(trigger::list2)
                else find s (t::list2)
in object_table_add obj 
   { name = object_dico.name ; triggers = find trigger_list [] } ;;

let new_object_name obj object_name =
let object_dico = try (object_table_find obj) with
       _ -> { name = "" ; triggers = [] }
in let new_object_dico = { name = object_name ;
                           triggers = object_dico.triggers  }
in object_table_add obj new_object_dico ;;

let object_table_construct world =
let construct_trigger trigger =
match trigger with
  Click target -> new_trigger target trigger
| Enter (_,target) -> new_trigger target trigger
| Exit (_,target) -> new_trigger target trigger
| _ -> ()
in
let construct animation =
do_list construct_trigger (animation.start_trigger@animation.stop_trigger)
in
dico_clear();
do_list construct world.animations;;

(* *********************************************** *)
(* **** Declaration des fonctions de services **** *)

(* *** gensym for creating USE and DEF commands *** *)
let (gensym,reset) = let i = ref 0 in 
((fun () -> incr(i);"Object_" ^ string_of_int !i),
 (fun () -> i := 0)) ;;

let spaced_float f = string_of_float f ^ " " ;;

let string_of_scalar v =
(string_of_float v) ^ "\n";;

let quote s = "\"" ^ s ^ "\" " ;;

let string_of_vect2D v =
match v with (x,y) ->
spaced_float x ^ spaced_float y ;;

let vect2D_translate v = (string_of_vect2D v) ^ "\n";;

let string_of_vect3D v =
match v with (x,y,z) ->
spaced_float x ^
spaced_float y ^ 
spaced_float z;;

let vect3D_translate v = (string_of_vect3D v) ^ "\n";;

let bool_translate b = 
match b with true -> "TRUE\n" | _ -> "FALSE\n" ;;

let rec concapply f liste =
match liste with
  [] -> ""
| t::s -> let result = (f t) in result ^ concapply f s ;;  

let rotation_translate r = 
match r with (v,a) ->
(string_of_vect3D v)^ "  " ^
string_of_float a ^ "\n";;

(* *** generic func to create a string of a list with , *** *)
let translate_list show_func l =
let rec show_liste  l =
match l with
  [] -> "]\n"
| [a] -> show_func a ^ "]\n"
| a::b -> show_func a ^ "," ^ show_liste b
in "[" ^ show_liste l ;;

(* rotation_list_translate : 
  ((float * float * float) * float) list -> string = <fun> *)
let rotation_list_translate = translate_list rotation_translate;;

(* vect3D_list_translate : (float * float * float) list -> string = <fun> *)
let vect3D_list_translate = translate_list string_of_vect3D ;; 

(* point_color_list_translate : point list -> string = <fun> *)
let point_color_list_translate = 
 let point_color_translate x = string_of_vect3D x.point_color
  in translate_list point_color_translate ;;

(* index_translate : int list -> string = <fun> *)
let index_translate = translate_list string_of_int ;;

(* scalar_list_translate : float list -> string = <fun> *)
let scalar_list_translate = translate_list string_of_float ;;

(* point_coordinate_list_translate : point list -> string = <fun> *)
let point_coordinate_list_translate =
 let point_coordinate_translate x = string_of_vect3D x.point_coordinate 
  in translate_list point_coordinate_translate ;;

(* vect2D_list_translate : (float * float) list -> string = <fun> *)
let vect2D_list_translate = translate_list string_of_vect2D ;; 

(* string_list_translate : string list -> string = <fun> *)
let string_list_translate u =
match u with
  [] -> ""
| _  ->  "[" ^ (concapply quote u) ^ "]\n";;

(* url_translate : string list -> string = <fun> *)
let url_translate u = "url " ^ string_list_translate u ;;

(* compare : 'a -> 'a -> ('a -> string) -> string = <fun> *)
let compare real_value default_value show_func =
if real_value=default_value then "" else show_func real_value;;

let box_translate center size =
"center " ^ vect3D_translate center ^
"size " ^ vect3D_translate size ;;

(* ************************************************** *)
(* ***********  start of translating func  ********** *)

(* material_translate : material -> string = <fun> *)
let material_translate p =
match p with 
  Material m -> let m0 = default_material in 
                "material Material { " ^
                let v = m.ambient_intensity in
                (if ( v = m0.ambient_intensity) then ""
                else "ambientIntensity " ^ string_of_scalar v) ^ 
                let v = m.diffuse_color in 
                (if ( v = m0.diffuse_color ) then ""  
                else "diffuseColor " ^ vect3D_translate v) ^
                let v = m.emissive_color in 
                (if ( v = m0.emissive_color ) then ""
                else "emissiveColor " ^ vect3D_translate v) ^
                let v = m.shininess in
                (if ( v = m0.shininess ) then ""
		else "shininess " ^ string_of_scalar v) ^
                let v = m.specular_color in
                (if ( v = m0.specular_color ) then ""
                else "specularColor " ^ vect3D_translate v) ^
                let v = m.transparency in
                (if ( v = m0.transparency ) then ""
                else "transparency " ^ string_of_scalar v) ^
                "}\n"
|  _  -> ""
;;

(* common_texture_translate : textureItem -> string = <fun> *)
let common_texture_translate t =
let t0 = default_textureItem in
(let v = t.texture_repeatS in
if v = t0.texture_repeatS then ""
else "repeatS " ^ bool_translate v) ^
(let v = t.texture_repeatT in 
if v = t0.texture_repeatT then ""
else "repeatT " ^ bool_translate v)
;;

(* hexa : int -> string = <fun> *)
let hexa i =
" " ^ string_of_int i 
;;

(* clip_translate : clip -> string = <fun> *)
let clip_translate c =
let c0 = default_clip in
(let v = c.clip_loop in
if v = c0.clip_loop then ""
else "loop " ^ bool_translate v) ^
(let v = c.clip_start_time in
if v = c0.clip_start_time then ""
else "startTime " ^ string_of_scalar v) ^
(let v = c.clip_stop_time in
if v = c0.clip_stop_time then ""
else "startTime " ^ string_of_scalar v) ^
url_translate c.clip_urls ^
"\n";;

(* image_translate : image -> string = <fun> *)
let image_translate image = 
if image = default_image then "" 
else
"image " ^ 
string_of_int image.image_width ^ " " ^
string_of_int image.image_height ^ " " ^
string_of_int image.image_components ^ " " ^
concapply hexa image.image_pixels ^ "\n"
;;



(* ******************************************************* *)
(* ***      unlit geometric obj translate           *** *)

(* color_translate : point list -> string = <fun> *)
let color_translate obj =
"Color {\n" ^
"color " ^ point_color_list_translate obj ^
"}\n"
;;

(* coordinate_translate : point list -> string = <fun> *)
let coordinate_translate obj =
"Coordinate {\n" ^
"point " ^ point_coordinate_list_translate obj ^
"}\n"
;;

(* texCoord_translate : (float * float) list -> string = <fun> *)
let texCoord_translate list =
"TextureCoordinate {\n" ^
"point " ^ vect2D_list_translate list ^
"}\n"
;;

(* pointSet_translate : point list -> string = <fun> *)
let pointSet_translate obj = 
"PointSet {\n" ^
"color " ^ color_translate obj ^
"coord " ^ coordinate_translate obj ^ 
"}\n";;

(* close_index : int list -> int list = <fun> *)
let close_index l = l@[-1] ;;

(* create_index : 'a -> 'a list -> int list -> 'a list * int list = <fun> *)
let create_index element list index_list =
match
 try (index element list)
 with _ -> -1 
with
 -1 -> (list@[element],index_list@[list_length list])
| v -> (list,index_list@[v])
;;

(* multi_create_index : 'a list -> 'a list -> int list -> 
   'a list * int list = <fun> *) 
let rec multi_create_index elements list index_list =
match elements with
   []  -> (list,close_index index_list)
| a::b -> match create_index a list index_list with
        (list,index_list) -> multi_create_index b list index_list ;;

(* lineSet_translate : line list -> string = <fun> *)
let lineSet_translate obj =
let rec translate p_liste p_index c_liste c_index l =
match l with
  [] -> "IndexedLineSet {\n" ^
        "color Color { color " ^ vect3D_list_translate c_liste ^ "}\n" ^
        "coord Coordinate { point " ^ vect3D_list_translate p_liste ^
        "}\n" ^
        "colorPerVertex FALSE\n" ^
        "colorIndex " ^ index_translate c_index ^
        "coordIndex " ^ index_translate p_index ^ "}\n"
| a::b -> match multi_create_index [a.line_point1;a.line_point2] 
                                   p_liste p_index 
           with (p_liste,p_index) ->
            match create_index a.line_color c_liste c_index          
             with (c_liste,c_index) ->
              translate p_liste p_index c_liste c_index b
in 
translate [] [] [] [] obj;;

(* unlitGeometric_translate : unlitGeometric -> string = <fun> *)
let unlitGeometric_translate obj =
"Shape {\n" ^
"geometry " ^
(match obj with
  PointSet p -> pointSet_translate p
| LineSet l -> lineSet_translate l) ^
"}\n";;

(* ***************************************************** *)
(* ****            and now ... the faceSet          **** *)

(* textureCoordinate_translate : (float * float) list -> string = <fun> *)
let textureCoordinate_translate list =
"TextureCoordinate {\n" ^
"point " ^ vect2D_list_translate list ^
"}\n";;

(* create_face_list_index : 'a list list -> 'a list * int list = <fun> *)
let create_face_list_index list =
let rec translate faces list index =
match faces with
  [] -> (list,index)
| a::b -> match multi_create_index a list index with
            (list2,index2) -> translate b list2 index2
in translate list [] [] ;;
 
(* faceSet_translate : faceSet -> string = <fun> *)
let faceSet_translate f = 
match (create_face_list_index f.faceSet_faces) with
(p_list,p_index) ->
"IndexedFaceSet {\n" ^
"coord Coordinate { point " ^ vect3D_list_translate p_list ^ "}\n" ^
"texCoord " ^ textureCoordinate_translate f.faceSet_texture_coordinate ^
"ccw " ^ bool_translate f.faceSet_ccw ^
"convex " ^ bool_translate f.faceSet_convex ^
"coordIndex " ^ index_translate p_index ^
"solid " ^ bool_translate f.faceSet_solid ^
"texCoordIndex " ^ index_translate f.faceSet_texture_coordinate_index ^
"}\n" ;;

(* *************************************************** *)
(* ********         elevationGrid           ********** *)

(* elevationGrid_translate : elevationGrid -> string = <fun> *)
let elevationGrid_translate obj =
let e0 = default_elevationGrid in
(*"Transform {\n" ^*)
(*"Children [\n" ^*)
"ElevationGrid {\n" ^
(let v = obj.grid_texture_coordinate in
if v = e0.grid_texture_coordinate then ""
else "texCoord " ^ texCoord_translate v) ^
"height " ^ scalar_list_translate obj.grid_height ^
(let v = obj.grid_ccw  in
if v = e0.grid_ccw then "" 
else "ccw " ^ bool_translate v) ^
(let v = obj.grid_color_per_vertex  in
if v = e0.grid_color_per_vertex then "" 
else "colorPerVertex " ^ bool_translate v) ^
(let v = obj.grid_solid in
if v = e0.grid_solid then "" 
else "solid " ^ bool_translate v) ^
(let v = obj.grid_x_dimension in
if v = e0.grid_x_dimension then "" 
else "xDimension " ^ string_of_int v ^ "\n") ^
(let v = obj.grid_x_spacing in
if v = e0.grid_x_spacing then "" 
else "xSpacing " ^ string_of_scalar v) ^
(let v = obj.grid_z_dimension in
if v = e0.grid_z_dimension then "" 
else "zDimension " ^ string_of_int v ^ "\n") ^
(let v = obj.grid_z_spacing in
if v = e0.grid_z_spacing then "" 
else "zSpacing " ^ string_of_scalar v) ^
"}\n";;


(* *************************************************** *)
(* ***                extrusion                    *** *)

(* extrusion_translate : extrusion -> string = <fun> *)
let extrusion_translate obj =
let e0 = default_extrusion in
"Extrusion {\n" ^
(let v = obj.extrusion_begin_cap in
if v = e0.extrusion_begin_cap then "" 
else "beginCap " ^ bool_translate v) ^
(let v = obj.extrusion_ccw in
if v = e0.extrusion_ccw then "" 
else "ccw " ^ bool_translate v) ^
(let v = obj.extrusion_convex in
if v = e0.extrusion_convex then "" 
else "convex " ^ bool_translate v) ^
(let v = obj.extrusion_cross_section in
if v = e0.extrusion_cross_section then ""
else "crossSection " ^ vect2D_list_translate v) ^
(let v = obj.extrusion_end_cap in
if v = e0.extrusion_end_cap then "" 
else "beginCap " ^ bool_translate v) ^
(let v = obj.extrusion_orientation in
if v = e0.extrusion_orientation then "" 
else "orientation " ^ rotation_list_translate v) ^
(let v = obj.extrusion_scale in
if v = e0.extrusion_scale then "" 
else "scale " ^ vect2D_list_translate v) ^
(let v = obj.extrusion_solid in
if v = e0.extrusion_solid then "" 
else "solid " ^ bool_translate v) ^
(let v = obj.extrusion_spine in
if v = e0.extrusion_spine then "" 
else "spine " ^ vect3D_list_translate v) ^
"}\n";;

(* *************************************************** *)
(* ***           what it must follow ...           *** *)

(* pixelTexture_translate : textureItem -> string = <fun> *)
let pixelTexture_translate t =
match t.texture_type with
  PixelTexture p -> "PixelTexture {\n" ^
                    common_texture_translate t ^
                    image_translate p ^
                    "}/n"   
| _ -> raise ( Failure "Y'a un probleme" ) ;;

(* movieTexture_translate : textureItem -> string = <fun> *)
let movieTexture_translate t = 
match t.texture_type with
  MovieTexture m -> "MovieTexture {\n" ^
                    common_texture_translate t ^
                    (let v = m.movieTexture_speed in
                    if v = default_movieTexture.movieTexture_speed then ""
                    else "speed " ^ string_of_scalar v) ^
                    clip_translate m.movieTexture_clip ^
                    "}/n"
| _ -> raise ( Failure "Y'a un probleme" );;

(* imageTexture_translate : textureItem -> string = <fun> *)
let imageTexture_translate t =
match t.texture_type with
  ImageTexture s -> "ImageTexture {\n" ^
                    common_texture_translate t ^
                    url_translate s ^
                    "}\n"
| _ -> raise ( Failure "Y'a un probleme" ) ;;

(* texture_translate : texture -> string = <fun> *)
let texture_translate t =
match t with
  Texture t -> let t0 = default_textureItem in
               "texture " ^ 
               (match t.texture_type with
                 ImageTexture i -> imageTexture_translate t
               | PixelTexture p -> pixelTexture_translate t
               | MovieTexture m -> movieTexture_translate t) ^
               "\n" ^
               "textureTransform TextureTransform {\n" ^
               (let v = t.texture_center in
               if v = t0.texture_center then ""
               else "center " ^ vect2D_translate v) ^
               (let v = t.texture_rotation in
               if v = t0.texture_rotation then ""
               else "rotation " ^ string_of_scalar v) ^
               (let v = t.texture_scale in
               if v = t0.texture_scale then ""
               else "scale " ^ vect2D_translate v) ^
               (let v = t.texture_translation in
               if v = t0.texture_translation then ""
               else "translation " ^ vect2D_translate v ) ^
               "}\n"
| _ -> "" ;;


(* ************************************************ *)
(* ***       translate text and font in vrml    *** *)

(* font_style_translate : fontStyle -> string = <fun> *)
 let font_style_translate f =
let f0 = default_fontStyle in
"fontStyle FontStyle {\n" ^
(let v = f.family in
if v = f0.family then ""
else "family " ^ quote v ^ "\n") ^
(let v = f.horizontal in
if v = f0.horizontal then ""
else "horizontal " ^ bool_translate v) ^
(let v = f.justify in
if v = f0.justify then ""
else "justify [" ^ url_translate v ^ "]\n") ^
(let v = f.language in
if v = f0.language then ""
else "language " ^ quote v ^ "\n") ^
(let v = f.left_to_right in
if v = f0.left_to_right then ""
else "leftToRight " ^ bool_translate v) ^
(let v = f.size in
if v = f0.size then ""
else "size " ^ string_of_scalar v) ^
(let v = f.spacing in
if v = f0.spacing then ""
else "spacing " ^ string_of_scalar v) ^
(let v = f.style in
if v = f0.style then ""
else "style " ^ quote v ^ "\n") ^
(let v = f.top_to_bottom in
if v = f0.top_to_bottom then ""
else "topToBottom " ^ bool_translate v) ^
"}\n";;

(* **************************************************** *)
(* ***            geometric objects                 *** *)

(* recenter_translation : shape -> float * float * float = <fun> *)
let recenter_translation obj =
match obj with
  ElevationGrid e -> 
     (-0.5 *. e.grid_x_spacing *. (float_of_int (e.grid_x_dimension - 1)),
      0.,-0.5 *. e.grid_z_spacing *. (float_of_int (e.grid_z_dimension - 1)))
| _ -> (0.,0.,0.) ;;


(* geometric_translate : shape -> string = <fun> *)
let geometric_translate obj =
(match obj with
  Box b      -> let b0 = default_box in
                "Box { " ^
		(let v = b.box_size in
                if v = b0.box_size then "" 
                else "size " ^ string_of_vect3D v) ^
                " }"
| Sphere s   -> let s0 = default_sphere in
                "Sphere { " ^
                (let v = s.sphere_radius in
                if v = s0.sphere_radius then ""
                else "radius " ^ string_of_float v) ^ 
                " }"
| Cone c     -> let c0 = default_cone in
                "Cone { " ^
	        (let v = c.cone_bottom_radius in
	        if v = c0.cone_bottom_radius then ""
                else "bottomRadius " ^ string_of_scalar v) ^
                (let v = c.cone_height in
                if v = c0.cone_height then ""
                else "height " ^ string_of_scalar v) ^
                (let v = c.cone_side in
                if v = c0.cone_side then ""
                else "side " ^ bool_translate v) ^
                (let v = c.cone_bottom in
	        if v = c0.cone_bottom then ""
                else "bottom " ^ bool_translate v) ^ "} \n"
| Cylinder c -> let c0 = default_cylinder in
                "Cylinder { " ^
	        (let v = c.cylinder_radius in
	        if v = c0.cylinder_radius then ""
                else "radius " ^ string_of_scalar v) ^
                (let v = c.cylinder_height in
                if v = c0.cylinder_height then ""
                else "height " ^ string_of_scalar v) ^
                (let v = c.cylinder_side in
                if v = c0.cylinder_side then ""
                else "side " ^ bool_translate v) ^
                (let v = c.cylinder_bottom in
	        if v = c0.cylinder_bottom then ""
                else "bottom " ^ bool_translate v) ^ 
                (let v = c.cylinder_top in
                if v = c0.cylinder_top then ""
                else "top " ^ bool_translate v) ^ 
	        "} \n"
| Text t -> let t0 = default_text in
                "Text {\n" ^
                (let v = t.content in
                if v = t0.content then ""
                else "string " ^ string_list_translate v) ^
                font_style_translate t.font_style ^
                (let v = t.length in
                if v = t0.length then ""
                else "length [" ^ concapply spaced_float v ^ "]\n") ^
                (let v = t.max_extent in
                if v = t0.max_extent then ""
                else "maxExtent " ^ string_of_scalar v) ^ 
                "}\n"
| FaceSet f -> faceSet_translate f
| ElevationGrid e -> elevationGrid_translate e 
| Extrusion e -> extrusion_translate e)
;;

(* shape_translate : geometric -> string = <fun> *)
let shape_translate obj =
let translate =
"Shape {" ^
(match (obj.material,obj.texture) with
  (NoMaterial,NoTexture) -> ""
| (m,t) -> "appearance Appearance {\n" ^
		material_translate m ^
		texture_translate t ^
		"}\n"
) ^
"geometry " ^ geometric_translate obj.shape ^
"}\n"
in match (recenter_translation obj.shape) with
  (0.,0.,0.) -> translate
| (_,_,_) as v -> "Transform {\n" ^
                  "children [\n" ^ translate ^ " ]\n" ^
                  "translation " ^ vect3D_translate v ^ " }\n";;

(* sound_translate : sound -> string = <fun> *)
let sound_translate objx =
let s0 = default_sound in
"Sound {\n" ^
(let v = objx.sound_direction in
if v = s0.sound_direction then ""
else "direction " ^ vect3D_translate v) ^
(let v = objx.sound_intensity in
if v = s0.sound_intensity then ""
else "intensity " ^ string_of_scalar v) ^
(let v = objx.sound_max_back in
if v = s0.sound_max_back then ""
else "maxBack " ^ string_of_scalar v) ^
(let v = objx.sound_max_front in
if v = s0.sound_max_front then ""
else "maxFront " ^ string_of_scalar v) ^
(let v = objx.sound_min_back in
if v = s0.sound_min_back then ""
else "minBack " ^ string_of_scalar v) ^
(let v = objx.sound_min_front in
if v = s0.sound_min_front then ""
else "minFront " ^ string_of_scalar v) ^
(let v = objx.sound_priority in
if v = s0.sound_priority then ""
else "priority " ^ string_of_scalar v) ^
(let v = objx.sound_spatialize in
if v = s0.sound_spatialize then ""
else "spatialize " ^ bool_translate v) ^
"source AudioClip {\n" ^
(let v = objx.sound_description in
if v = s0.sound_description then ""
else "description " ^ quote v ^ "\n" ) ^
(let v = objx.sound_pitch in
if v = s0.sound_pitch then ""
else "pitch " ^ string_of_scalar v) ^
clip_translate objx.sound_clip ^
"} }\n"
;;

(* light_translate : light -> string = <fun> *)
let light_translate obj =
let v0 = default_light 
in
let common_translate l =
(let v = l.light_ambient_intensity in
if ( v = v0.light_ambient_intensity ) then ""
else "ambientIntensity " ^ string_of_scalar v) ^
(let v = l.light_color in
if ( v = v0.light_color ) then ""
else "color " ^ vect3D_translate v) ^
(let v = l.light_intensity in 
if ( v = v0.light_intensity ) then "" 
else "intensity " ^ string_of_scalar v)
in
(match obj.light_type with
 PointLight l -> let pl0 = default_pointLight in
                 "PointLight {\n" ^
                 (let v = l.pointLight_attenuation in
                 if v = pl0.pointLight_attenuation then ""
                 else "attenuation " ^ vect3D_translate v) ^
                 (let v = l.pointLight_radius in 
                 if v = pl0.pointLight_radius then ""
                 else "radius " ^ string_of_scalar v)  
| SpotLight l -> let sp0 = default_spotLight in
                 "SpotLight {\n" ^
                 (let v = l.spotLight_attenuation in
                 if v = sp0.spotLight_attenuation then ""
                 else "attenuation " ^ vect3D_translate v) ^
                 (let v = l.spotLight_beam_width in
                 if v = sp0.spotLight_beam_width then ""
                 else "beamWidth " ^ string_of_scalar v) ^
                 (let v = l.spotLight_cut_off_angle in
                 if v = sp0.spotLight_cut_off_angle then ""
                 else "cutOffAngle " ^ string_of_scalar v) ^
                 (let v = l.spotLight_direction in
                 if v = sp0.spotLight_direction then ""
                 else "direction " ^ vect3D_translate v) ^
                 (let v = l.spotLight_radius in
                 if v = sp0.spotLight_radius then ""
                 else "radius " ^ string_of_scalar v)
| DirectionalLight l -> let dl0 = default_directionalLight in
                         "DirectionalLight {\n" ^
                         (let v = l.directionalLight_direction in
                         if v = dl0.directionalLight_direction then ""
                         else "direction " ^ vect3D_translate v)) ^
common_translate obj ^
"}\n"
;;


(* viewPoint_translate : viewPoint -> string = <fun> *)
let viewPoint_translate objx =
let v0 = default_viewPoint in
"Viewpoint {" ^
(let v = objx.viewPoint_field_of_view in
if v = v0.viewPoint_field_of_view then ""
else "fieldOfView " ^ string_of_scalar v) ^
(let v = objx.viewPoint_jump in
if v = v0.viewPoint_jump then ""
else "jump " ^ bool_translate v) ^
(let v = objx.viewPoint_description in
if v = v0.viewPoint_description then ""
else "description " ^ quote v) ^
"}\n";;

(* proximityBox_translate : string -> proximityBox -> string = <fun> *)
let proximityBox_translate my_prox =
" ProximitySensor {\n" ^
box_translate my_prox.proximity_center my_prox.proximity_size ^
"}\n" 
;;

(*  *)
let is_a_real_transform obj =
match (obj.anchor,obj.billboard,obj.collision) with
  (NoAnchor,NoBillboard,NoCollision) -> true
| (_,_,_) -> false ;;

(*  *)
let compute_proximity_name name trigger object_dico =
let rec compute number list =
match list with
  [] -> raise Not_found
| a::b -> if (trigger_equivalent a trigger) then number
          else compute ((match a with
                         Exit _ -> 1
                       | Enter _ -> 1
                       | _ -> 0) + number ) b
in name ^ "_Proximity_" ^ string_of_int (compute 0 object_dico);;

(* *)
let sensor_translate name world obj =
let trigger_list = try (object_table_find obj).triggers
                   with _ -> []
in let translate trigger =
match trigger with
  Click _ -> let sensorname = name ^ "_Touch"
             in new_trigger_name trigger sensorname;
             "DEF " ^ sensorname ^ " TouchSensor {}\n"
| Exit (p,_) -> let sensorname = compute_proximity_name name trigger
                                 trigger_list
                in new_trigger_name trigger sensorname ;
                "DEF " ^ sensorname ^ proximityBox_translate p
| Enter (p,_) -> let sensorname = compute_proximity_name name trigger
                                  trigger_list
                 in new_trigger_name trigger sensorname ;
                 "DEF " ^ sensorname ^ proximityBox_translate p
| _ -> ""
in concapply translate trigger_list ;;

(* collisionBox_translate : collisionBox -> string = <fun> *)
let collisionBox_translate c =
let c0 = default_collisionBox in
"Collision {\n" ^
(let v = c.collide in
 if v = c0.collide then "" else "collide " ^ bool_translate v) ^
(let v = c.bbox_center in
 if v = c0.bbox_center then "" else "bboxCenter " ^ vect3D_translate v) ^
(let v = c.bbox_size in
 if v = c0.bbox_size then "" else "bboxSize " ^ vect3D_translate v) ^
"}\n";;

(* *** the heart of the static translation part of VRcaML *** *)

(* lod_translate : vrml_world -> lod -> string = <fun> *)
let rec lod_translate world objx =
let l0 = default_lod in
"LOD {\n" ^
(let v = objx.lod_levels in
if v = l0.lod_levels then ""
else "level [" ^ concapply (vrml_object_translate world) v ^ "]\n") ^
(let v = objx.lod_ranges in
if v = l0.lod_ranges then ""
else "range [" ^ concapply spaced_float v ^ "]\n") ^
"}\n"

and

(* vrml_positionnable_translate : string -> vrml_object -> vrml_world -> vrml_positionable -> string = <fun> *)
vrml_positionnable_translate father_name father world my_pos =
match my_pos with
  Geometric objx -> shape_translate objx
| UnlitGeometric objx -> unlitGeometric_translate objx
| Light objx -> light_translate objx
| LOD objx -> lod_translate world objx
| ViewPoint objx -> viewPoint_translate objx
| Sound objx -> sound_translate objx
| CollisionBox c -> collisionBox_translate c
(* | _ -> raise ( Failure "non-implemente les gars" )  (*INUTILE *)  *)

and

(* anchor_translate : string -> vrml_world -> vrml_object -> 
   string = <fun>  *)
anchor_translate name world obj =
match obj.anchor with
  NoAnchor -> billboard_translate name world obj
| Anchor a -> 
   let a0 = default_anchor in
    "Anchor {\n" ^
    (let v = a.anchor_description in
     if v = a0.anchor_description then "" 
     else "description \"" ^ v ^ "\"\n") ^
    (let v = a.anchor_parameters in
     if v = a0.anchor_parameters then "" 
     else "parameter [" ^ (concapply quote v) ^ "]\n") ^
    (let v = a.anchor_urls in
     if v = a0.anchor_urls then "" 
     else "url [" ^ (concapply quote v) ^ "]\n") ^
     "children [\n" ^ billboard_translate name world obj ^ "]\n" ^ "}\n"

and 

(* vrml_object_translate : vrml_world -> vrml_object -> string = <fun> *)
vrml_object_translate world obj =
match
(try (object_table_find obj).name
 with _  -> "" )
with
 "" -> let name = gensym() in
       (match (obj.anchor,obj.billboard,obj.collision)
        with 
          (NoAnchor,NoBillboard,NoCollision) -> 
          let new_name = name ^ "_Referential" in
          let result = transform_translate name world obj in
          (new_object_name obj new_name;result) 
        | (_,_,_) -> 
          let result = anchor_translate name world obj in
          (new_object_name obj name;
          "DEF " ^ name ^ " " ^ result)
        ) 
| n -> "USE " ^ n ^ "\n"

and 

(* transform_translate : string -> vrml_world -> vrml_object -> 
  string = <fun> *)
transform_translate name world obj =
let v0 = default_vrml_object in
"DEF " ^ name ^ "_Referential Transform {\n" ^
let name = (if (is_a_real_transform obj) then name ^ "_Referential"
            else name)
in "children [\n" ^
concapply (vrml_positionnable_translate name obj world) obj.objects ^
concapply (vrml_object_translate world) obj.children ^ 
sensor_translate name world obj ^
"]\n" ^
(let v = obj.position in
if v = v0.position then ""
else "translation " ^ vect3D_translate v) ^
(let v = obj.rotation in
if v = v0.rotation then "" 
else "rotation " ^ rotation_translate v) ^
(let v = obj.scale in
if v = v0.scale then ""
else "scale " ^ vect3D_translate v) ^
"}\n"

and

(* collision_translate : string -> vrml_world -> vrml_object -> 
  string = <fun> *)
collision_translate name world obj =
match obj.collision with
  NoCollision -> transform_translate name world obj
| Collision c -> 
   let c0 = default_collisionBox in
   "Collision {\n" ^
   (let v = c.collide in
    if v = c0.collide then "" else "collide " ^ bool_translate v) ^
   (let v = c.bbox_center in
    if v = c0.bbox_center then "" else "bboxCenter " ^ vect3D_translate v) ^
   (let v = c.bbox_size in
    if v = c0.bbox_size then "" else "bboxSize " ^ vect3D_translate v) ^
   "children [\n" ^ (transform_translate name world obj) ^ "]\n" ^ "}\n"

and

(* billboard_translate : string -> vrml_world -> vrml_object -> 
   string = <fun> *) 
billboard_translate name world obj =
match obj.billboard with
  NoBillboard -> collision_translate name world obj
| Billboard b ->
   let b0 = default_billboard in
   "Billboard {\n" ^
   (let v = b.axis_of_rotation in
    if v = b0.axis_of_rotation then ""
    else "axisOfRotation " ^ vect3D_translate v) ^
   "children [\n" ^ (collision_translate name world obj) ^ "]\n" ^ "}\n"

;;

(* real_vrml_object_translate : vrml_object -> string = <fun> *)
let real_vrml_object_translate world obj =
vrml_object_translate world obj;;

(* ***************************************************** *)
(* *** start of animation translating functions     **** *)

let timeSensor_translate name cycle enabled loop st stp =
"DEF " ^ name ^ " TimeSensor {\n" ^
"cycleInterval " ^ string_of_scalar cycle ^
"enabled " ^ bool_translate enabled ^
"loop " ^ bool_translate loop ^
"startTime " ^ string_of_scalar st ^
"stopTime " ^ string_of_scalar stp ^
"}\n";;

let instant_script =
"field SFFloat counter 0.0
eventIn SFTime new_cycle
eventOut SFTime instant_time 
url " ^ 
quote ("vrmlscript:\n" ^
"function new_cycle (value,timeStamp) {
if (counter < 2.0) { 
counter = counter + 1.0 ;
if (counter > 1.0) { instant_time = val ; } 
} 
}\n")
;;

let memory_script =
"eventIn SFFloat tictac
eventOut SFFloat fraction_changed
eventIn SFTime memorize
field SFFloat last_value 0.0
field SFFloat buffer 0.0
url " ^
quote "vrmlscript:

function tic_tac (val,t) { 
if ((last_value + val)>1.0) { buffer = last_value + val - 1.0 ; }
else { buffer = last_value + val ; }
fraction_changed = buffer ;
}

function memorize () {
last_value = buffer ;
}";;

let script_translate name str =
"DEF " ^ name ^ " Script {\n" ^
str ^ "}\n" ;;

let new_route route_list x =
route_list := x :: !route_list ;;

let rec new_routes route_list l = 
route_list := l @ !route_list ;;

let instant_route_translate eOut eIn l a =
let animation_name = find l a 
in (eOut,animation_name ^ "." ^ eIn);;

let start_instant_route n l = 
instant_route_translate (n ^ ".instant_time") "startTime" l ;; 

let stop_instant_route n l = 
instant_route_translate (n ^ ".instant_time") "stopTime" l ;; 

let trigger_create trigger_table route_list t =
match
 trigger_name t
with
"" -> let trigger_name = gensym() in
      (new_trigger_name t trigger_name;
       match t with
       Instant v -> let script_name = "Script_of_" ^ trigger_name in
                    new_route route_list (trigger_name ^ ".cycleTime",
                    script_name ^".new_cycle");
                    timeSensor_translate trigger_name v true true 0.0 0.0 ^
                    script_translate script_name instant_script 
       | _ -> "")
| v -> ""
;;

let start_trigger_route_translate trigger_table route_list anim_name anim t =
let trigger_name = trigger_name t in
match t with
  Instant t ->
  [("Script_of_" ^ trigger_name ^ ".instant_time",anim_name^".startTime")]
| Click o -> [(trigger_name ^ ".touchTime",anim_name ^ ".startTime")]
| Enter (trigger,owner) -> 
               [(trigger_name ^ ".enterTime",anim_name ^ ".startTime")]
| Exit (trigger,owner) -> 
               [(trigger_name ^ ".exitTime",anim_name ^ ".startTime")] 
;;


let stop_trigger_route_translate trigger_table route_list anim_name anim t =
let trigger_name = trigger_name t in
match t with 
  Instant t ->
    (trigger_name ^ ".instant_time",anim_name^".stopTime")::
    (if anim.memory then     
      [(trigger_name ^ ".instant_time","Memory_Script_of_" ^ anim_name ^
       ".memorize")] else [])
| Click o -> let father_name = object_table_find o in
             (trigger_name ^ ".touchTime",anim_name ^ ".stopTime")::
             (if anim.memory then     
             [(trigger_name ^ ".touchTime","Memory_Script_of_" ^ anim_name ^
             ".memorize")] else [])
| Enter (trigger,owner) -> 
             (trigger_name ^ ".enterTime",anim_name ^ ".stopTime")::
             (if anim.memory then     
             [(trigger_name ^ ".enterTime","Memory_Script_of_" ^ anim_name ^
             ".memorize")] else [])
| Exit (trigger,owner) -> 
             (trigger_name ^ ".exitTime",anim_name ^ ".stopTime")::
             (if anim.memory then     
             [(trigger_name ^ ".exitTime","Memory_Script_of_" ^ anim_name ^
             ".memorize")] else [])
;;

let start_trigger_translate trigger_table route_list anim_name anim t =
let str = trigger_create trigger_table route_list t
in new_routes route_list
(start_trigger_route_translate trigger_table route_list anim_name anim t);
str;;

let stop_trigger_translate trigger_table route_list anim_name anim t =
let str = trigger_create trigger_table route_list t
in new_routes route_list
(stop_trigger_route_translate trigger_table route_list anim_name anim t);
str;;

let interpolator_translate 
   name father_name key_list number value_translate =
match key_list with (key_list,key_value_list) ->
"DEF " ^ father_name ^ "_Anim_" ^ (string_of_int number) ^
" " ^ name ^ "Interpolator {\n" ^
"key " ^ (scalar_list_translate key_list) ^
"keyValue " ^ value_translate key_value_list ^
"}\n";;

let rec interpolator_route_translate 
 e2_In clock_name father_name target_name n =
  let inter_name = father_name ^ "_Anim_" ^ string_of_int n in
   let e1_Out = ".fraction_changed"
    and e1_In = ".set_fraction"
     and e2_Out = ".value_changed"
     in (clock_name ^ e1_Out ,inter_name ^ e1_In)::
        [(inter_name ^ e2_Out,target_name ^ e2_In)]
;;

(*  *** new functions for animation2 module *** *)

let changing_route_translate 
    changing clock_name father_name target_name number =
match changing with
  Translation t -> 
    interpolator_route_translate ".set_translation" clock_name father_name
    target_name number    
| Rotation r -> interpolator_route_translate ".set_rotation" clock_name
                father_name target_name number
| Scale r -> interpolator_route_translate ".set_scale" clock_name father_name
             target_name number
| _ -> raise ( Failure "not implemented part of the code" )
;;

let rec changing_list_route_translate changing_list clock_name father_name 
target_name number =
match changing_list with
  [] -> []
| a::b -> 
  changing_route_translate a clock_name father_name target_name number @ 
  changing_list_route_translate b clock_name father_name target_name (number+1)
;;

let interpolator_translate 
	name father_name key_list number value_translate =
match key_list with (key_list,key_value_list)  ->
"DEF " ^ father_name ^ "_Anim_" ^ (string_of_int number) ^
" " ^ name ^ "Interpolator {\n" ^
"key " ^ (scalar_list_translate key_list) ^
"keyValue " ^ value_translate key_value_list ^
"}\n";;

let changing_translate changing father_name number =
(* changing -> string -> integer -> string *)
match changing with
  Translation t_key -> interpolator_translate "Position" father_name t_key number vect3D_list_translate 
| Rotation r_key -> interpolator_translate "Rotation" father_name r_key number rotation_list_translate
| Scale s_key -> interpolator_translate "Position" father_name s_key number vect3D_list_translate
| _ -> raise ( Failure "non implemented part of the code")
;;

let rec changing_list_translate movie_list father_name number =
(* changing list -> string -> integer -> string *)
match movie_list with
  [] -> ""
| a::b -> changing_translate a father_name number ^
 	changing_list_translate b father_name (number+1);;

let animation_translate trigger_table route_list a =
let target_name = (object_table_find a.target).name in
let animation_name = gensym() 
 in let start_trigger_translate t =
    start_trigger_translate trigger_table route_list animation_name a t 
  in let stop_trigger_translate t =
     stop_trigger_translate trigger_table route_list animation_name a t 
   in let father_name = 
         (if a.memory then ("Memory_Script_of_" ^ animation_name)
          else animation_name) 
    in new_routes route_list (changing_list_route_translate a.movie 
     animation_name father_name target_name 0);
       concapply start_trigger_translate a.start_trigger ^
       concapply stop_trigger_translate a.stop_trigger ^
       timeSensor_translate animation_name a.duration true a.loop 1.0 2.0 ^
       (if a.memory then
         let script_name = "Memory_Script_of_" ^ animation_name in 
         ( new_route route_list (animation_name ^ ".fraction_changed",
          script_name ^ ".tictac" );
          script_translate script_name memory_script
         )
       else "") ^
       changing_list_translate a.movie animation_name 0;;

let routes_translate l =
let route_translate r =
match r with
 (s,r) -> "ROUTE " ^ s ^ " TO " ^ r ^ "\n" 
in concapply route_translate !l ;;

let moving_object_translate v =

let trigger_table = create 10 in

let route_list = ref [] in
let aux a = animation_translate trigger_table route_list a in
let result = (concapply aux v) in
result ^
routes_translate route_list ;;

(* *** func to translate vrml_specials *** *)

(* background_translate : background -> string = <fun> *)
let background_translate b =
let b0=default_background in
"Background {\n" ^
(let v = b.ground_angle in
 if v = b0.ground_angle then "" 
 else "groundAngle " ^ scalar_list_translate v) ^
(let v = b.ground_color in
 if v = b0.ground_color then "" 
else "groundColor " ^ vect3D_list_translate v) ^
(let v = b.back_url in
 if v = b0.back_url then "" 
else "backUrl " ^ string_list_translate v) ^
(let v = b.bottom_url in
 if v = b0.bottom_url then "" 
else "bottomUrl " ^ string_list_translate v) ^
(let v = b.front_url in
 if v = b0.front_url then "" 
else "frontUrl " ^ string_list_translate v) ^
(let v = b.left_url in
 if v = b0.left_url then "" 
else "leftUrl " ^ string_list_translate v) ^
(let v = b.right_url in
 if v = b0.right_url then "" 
else "rightUrl " ^ string_list_translate v) ^
(let v = b.top_url in
 if v = b0.top_url then "" 
else "topUrl " ^ string_list_translate v) ^
(let v = b.sky_angle in
 if v = b0.sky_angle then "" else 
"skyAngle " ^ scalar_list_translate v) ^
(let v = b.sky_color in
 if v = b0.sky_color then "" else 
"skyColor " ^ vect3D_list_translate v) ^
"}\n";;

(* fog_translate : fog -> string = <fun> *)
let fog_translate f =
let f0 = default_fog in
"Fog {\n" ^
(let v = f.fog_color in
if v = f0.fog_color then "" 
else "color " ^ vect3D_translate v) ^
(let v = f.fog_type in
if v = f0.fog_type then "" 
else "fogType " ^ quote v) ^
(let v = f.fog_visibility_range in
if v = f0.fog_visibility_range then "" 
else "visibilityRange " ^ string_of_scalar v) ^
"}\n";;

(* vrml_special_translate : vrml_special -> string = <fun>  *)
let vrml_special_translate special =
match special with 
  Background b -> background_translate b
| Fog f -> fog_translate f ;;

(* vrml_special_list_translate : vrml_special list -> string = <fun> *)
let rec vrml_special_list_translate specials =
match specials with 
   [] -> ""
| a::b -> (vrml_special_translate a) ^ vrml_special_list_translate b;;

(* vrml_world_translate : vrml_world -> string = <fun> *)
let vrml_world_translate world =
reset();
object_table_construct world ;
let static = vrml_object_translate world world.tree 
in let special = vrml_special_list_translate world.specials
in let dynamic = moving_object_translate world.animations 
in static ^ special ^ dynamic ;;

let test x = print_string (vrml_world_translate x);;

(* *** pour ecrire dans un fichier *** *)

(* vrml_translate_to : vrml_object -> string -> unit = <fun> *)
let vrml_translate_to world filename =
 let c_out = open_out filename in
   begin
    output_string c_out "#VRML V2.0 utf8\n";
    output_string c_out (vrml_world_translate world);
    close_out c_out;
   end;;





























































