










(**************************************************************************)
(* $Id: positionables.ml,v 1.6 1997/05/01 17:59:09 doub Exp $             *)
(* Creation and manipulation of positionables                             *)
(**************************************************************************)


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;;


(**************************************************************************)
(* Collision Box                                                          *)
(**************************************************************************)

(* new_basic_collision_box : vect3D -> vect3D -> vrml_positionable *)
let new_basic_collision_box center size =
    CollisionBox (new_basic_collisionBox false center (test_size size))
;;

(* new_collision_box : vect3D -> vect3D -> vrml_object *)
let new_collision_box center size =
    add_object default_vrml_object    
       (new_basic_collision_box center size)
;;    

(* setf_collision_box_center :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_collision_box_center box center =
    match box with
      CollisionBox b -> new_basic_collision_box center b.bbox_size
    | _ -> raise (Failure "Not a CollisionBox")
;;

(* setf_collision_box_size :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_collision_box_size box size =
    match box with
      CollisionBox b -> new_basic_collision_box b.bbox_center size
    | _ -> raise (Failure "Not a CollisionBox")
;;


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

(* new_unlit_geometric_object : unlitGeometric -> vrml_object *)
let new_unlit_geometric_object unlit =
    add_object default_vrml_object unlit
;;


(* new_basic_pointSet : pointSet -> vrml_positionable *)
let new_basic_pointSet set =
    UnlitGeometric (PointSet set)
;;

(* new_pointSet : pointSet -> vrml_object *)
let new_pointSet set =
    new_unlit_geometric_object (new_basic_pointSet set)
;;

(* add_basic_point : vrml_positionable -> point -> vrml_positionable *)
let add_basic_point pointSet point =
    match pointSet with
      UnlitGeometric (PointSet p) -> new_basic_pointSet (p@[point])
    | _ -> raise (Failure "Not a PointSet")
;;


(* new_basic_lineSet : lineSet -> vrml_positionable *)
let new_basic_lineSet set =
    UnlitGeometric (LineSet set)
;;

(* new_lineSet : lineSet -> vrml_object *)
let new_lineSet set =
    new_unlit_geometric_object (new_basic_lineSet set)
;;

(* add_basic_line : vrml_positionable -> line -> vrml_positionable *)
let add_basic_line lineSet line =
    match lineSet with
      UnlitGeometric (LineSet l) -> new_basic_lineSet (l@[line])
    | _ -> raise (Failure "Not a LineSet")
;;


(**************************************************************************)
(* View Point                                                             *)
(**************************************************************************)

(* new_basic_viewPoint :
   float -> bool -> string -> float list -> bool -> float -> string list
-> float -> vrml_positionable *)
let new_basic_viewPoint field_of_view jump description avatar_sizes
                        headlight speed navigation_types visibility_limit =
    ViewPoint
       ({ viewPoint_field_of_view     = test_field_of_view field_of_view ;
          viewPoint_jump              = jump ;
          viewPoint_description       = description ;
          navigation_avatar_size      = map test_avatar_size avatar_sizes ;
          navigation_headlight        = headlight ;
          navigation_speed            = test_speed speed ;
          navigation_type             = navigation_types ;
          navigation_visibility_limit = test_visibility_limit 
                                            visibility_limit
        })
;;

(* new_complete_viewPoint :
   float -> bool -> string -> float list -> bool -> float -> string list
-> float -> vrml_object *)
let new_complete_viewPoint field_of_view jump description avatar_sizes
                           headlight speed navigation_types
                           visibility_limit =
    add_object default_vrml_object    
       (new_basic_viewPoint field_of_view jump description avatar_sizes
                            headlight speed navigation_types
                            visibility_limit)
;;

(* new_viewPoint : string -> vrml_object *)
let new_viewPoint description =
    let d = default_viewPoint
    in
       new_complete_viewPoint d.viewPoint_field_of_view
                              d.viewPoint_jump description
                              d.navigation_avatar_size
                              d.navigation_headlight d.navigation_speed
                              d.navigation_type
                              d.navigation_visibility_limit
;;

(* setf_viewPoint_field_of_view :
   vrml_positionable -> float -> vrml_positionable *)
let setf_viewPoint_field_of_view viewPoint field_of_view =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint field_of_view p.viewPoint_jump
                            p.viewPoint_description p.navigation_avatar_size
                            p.navigation_headlight p.navigation_speed
                            p.navigation_type p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_viewPoint_jump :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_viewPoint_jump viewPoint jump =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view jump
                            p.viewPoint_description p.navigation_avatar_size
                            p.navigation_headlight p.navigation_speed
                            p.navigation_type p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_viewPoint_description :
   vrml_positionable -> string -> vrml_positionable *)
let setf_viewPoint_description viewPoint description =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            description p.navigation_avatar_size
                            p.navigation_headlight p.navigation_speed
                            p.navigation_type p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_navigation_avatar_sizes :
   vrml_positionable -> float list -> vrml_positionable *)
let setf_navigation_avatar_sizes viewPoint avatar_sizes =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            p.viewPoint_description avatar_sizes
                            p.navigation_headlight p.navigation_speed
                            p.navigation_type p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_navigation_headlight :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_navigation_headlight viewPoint headlight =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            p.viewPoint_description p.navigation_avatar_size
                            headlight p.navigation_speed p.navigation_type
                            p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_navigation_speed :
   vrml_positionable -> float -> vrml_positionable *)
let setf_navigation_speed viewPoint speed =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            p.viewPoint_description p.navigation_avatar_size
                            p.navigation_headlight speed p.navigation_type
                            p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_navigation_types :
   vrml_positionable -> string list -> vrml_positionable *)
let setf_navigation_types viewPoint navigation_types =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            p.viewPoint_description p.navigation_avatar_size
                            p.navigation_headlight p.navigation_speed
                            navigation_types p.navigation_visibility_limit
   | _ -> raise (Failure "Not a ViewPoint")
;;

(* setf_visibility_limit :
   vrml_positionable -> float -> vrml_positionable *)
let setf_navigation_visibility_limit viewPoint limit =
    match viewPoint with
      ViewPoint p -> 
        new_basic_viewPoint p.viewPoint_field_of_view p.viewPoint_jump
                            p.viewPoint_description p.navigation_avatar_size
                            p.navigation_headlight p.navigation_speed
                            p.navigation_type limit
   | _ -> raise (Failure "Not a ViewPoint")
;;


(**************************************************************************)
(* Level Of Detail                                                        *)
(**************************************************************************)

(* new_basic_lod : vrml_object list -> float list -> vrml_positionable *)
let new_basic_lod levels (* center *) ranges =
    LOD
      ({ lod_levels = levels ;
         (* lod_center = center ; *) 
         lod_ranges = ranges
      })
;;

(* new_lod : vrml_object list -> float list -> vrml_object *)
let new_lod levels (* center *) ranges =
    add_object default_vrml_object 
               (new_basic_lod levels (* center *) ranges)
;;

(* setf_lod_levels :
   vrml_positionable -> vrml_object list -> vrml_positionable *)
let setf_lod_levels lod levels =
    match lod with
      LOD l ->
        new_lod levels (* l.lod_center *) l.lod_ranges
    | _ -> raise (Failure "Not a LOD")
;;

(* let setf_lod_center lod center =
    match lod with
      LOD l ->
        new_lod l.lod_levels center l.lod_ranges
    | _ -> raise (Failure "Not a LOD")
;; *)

(* setf_lod_ranges :
   vrml_positionable -> float list -> vrml_positionable *)
let setf_lod_ranges lod ranges =
    match lod with
      LOD l ->
        new_lod l.lod_levels (* l.lod_center *) ranges
    | _ -> raise (Failure "Not a LOD")
;;


(* !!! : DEVRAIT PEUT-ETRE CLASSER DANS LE BON ORDRE !!! *)
(* add_lod_level_at_range :
   vrml_positionable -> vrml_object -> float -> vrml_positionable *)
let add_lod_level_at_range lod level range =
    match lod with
      LOD l ->
        new_lod (l.lod_levels@[level]) 
                (* l.lod_center *) 
                (l.lod_ranges@[range])
    | _ -> raise (Failure "Not a LOD")
;;


