










(**************************************************************************)
(* $Id: vrml_objects_post.ml,v 1.8 1997/05/01 13:58:20 doub Exp $         *)
(* Creation and manipulation of VRML objects                              *)
(**************************************************************************)

open Compatibility;;
open Types;;
open Default;;
open Exceptions;;
open Basic_types;;
open Font;;
open Fonts;;
open Colors;;
open Vrml_objects_pre;;
open Calc_3D;;


(**************************************************************************)
(* Adding children and objects                                            *)
(**************************************************************************)

(* add_object : vrml_object -> vrml_positionable -> vrml_object *)
let add_object referential positionable =
    resize_frame_with_object
      (set_objects referential (positionable::referential.objects))
      positionable
;;

(* add_objects : vrml_object -> vrml_positionable list -> vrml_object *)
let add_objects referential positionable_list =
    let rec r l o =
        match l with
          [] -> o
        | pos::tail -> r tail (add_object o pos)
    in
       r positionable_list referential
;;

(* add_child : vrml_object -> vrml_object -> vrml_object *)
let add_child referential obj =
    set_children 
      (resize_frame_with_child referential obj) 
      (obj::referential.children)
;;

(* add_children : vrml_object -> vrml_object list -> vrml_object *)
let add_children referential object_list =
    let rec r l o =
        match l with
          [] -> o
        | child::tail -> r tail (add_child o child)
    in
       r object_list referential
;;


(**************************************************************************)
(* Position and scale transformations on VRML objects                     *)
(**************************************************************************)

(* set_position : vrml_object -> float -> float -> float -> vrml_object *)
let set_position obj x y z =
    setf_position obj (x , y , z)
;;

let set_translation = set_position ;;

(* set_rotation :
   vrml_object -> float -> float -> float -> float -> vrml_object *)
let set_rotation obj x y z t =
    setf_rotation obj ((x , y , z) , t)
;;

(* set_scale : vrml_object -> float -> float -> float -> vrml_object *)
let set_scale obj x y z =
    setf_scale obj (x , y , z)
;;

(* translation : vrml_object -> float -> float -> float -> vrml_object *)
let translation obj x y z =
    let x1 , y1 , z1 = obj.position
    in
       set_position obj (x1 +. x) (y1 +. y) (z1 +. z)
;;

(* rotation : 
   vrml_object -> float -> vrml_object *)
let rotation obj angle =
    let (x1 , y1 , z1) , t1 = obj.rotation
    in
       set_rotation obj x1 y1 z1 (t1 +. angle)
;;

(* add_rotation :
   vrml_object -> float -> float -> float -> float -> vrml_object *)
let add_rotation obj x y z t =
    let r = set_rotation new_referential x y z t
    in
       add_child r obj
;;

(* resize : vrml_object -> float -> float -> float -> vrml_object *)
let resize obj x y z =
    let x1 , y1 , z1 = obj.scale
    in
       set_scale obj (x1 *. x) (y1 *. y) (z1 *. z)
;;


(**************************************************************************)
(* Grouping and ungrouping VRML objects                                   *)
(**************************************************************************)

(* group : vrml_object list -> vrml_object *)
let group object_list =
    add_children new_referential object_list 
;;

(* ungroup : vrml_object -> vrml_object list *)
let ungroup obj = obj.children ;;


(**************************************************************************)
(* Agregate vrml_positionables                                            *)
(*                                                                        *)
(* Beware of those functions :                                            *)
(*  they put objects IN another one, forgetting their position, rotation  *)
(*  and scale, but also their properties (anchor, billboard and           *)
(*  collision).                                                           *)
(*                                                                        *)
(* unagregate (agregate object_list) != object_list                       *)
(**************************************************************************)

(* agregate_one : vrml_object -> vrml_object -> vrml_object *)
let agregate_one obj in_object =
    add_children (add_objects obj in_object.objects) in_object.children
;;

(* objects_from_list : vrml_object list -> vrml_positionable list *)
let rec objects_from_list l =
    match l with
      [] -> []
    | obj::tail -> obj.objects@(objects_from_list tail)
;;

(* children_from_list : vrml_object list -> vrml_object list *)
let rec children_from_list l =
    match l with
      [] -> []
    | obj::tail -> obj.children@(children_from_list tail)
;;

(* agregate : vrml_object list -> vrml_object -> vrml_object *)
let agregate object_list in_object =
    new_vrml_object
        (in_object.objects@(objects_from_list object_list))
        (in_object.children@(children_from_list object_list))
        in_object.position in_object.rotation in_object.scale
        in_object.frame in_object.unique in_object.anchor
        in_object.billboard in_object.collision
;;


(**************************************************************************)
(* Setting VRML objects properties                                        *)
(**************************************************************************)

(* Anchor *****************************************************************)

(* new_basic_anchor : string -> string list -> string list -> anchor *)
let new_basic_anchor description parameters urls =
    Anchor
      ({ anchor_description = description ;
         anchor_parameters  = parameters ;
         anchor_urls        = urls })
;;

(* set_complete_anchor :
   vrml_object -> string -> string list -> string list -> vrml_object *)
let set_complete_anchor obj description parameters urls =
    setf_anchor obj (new_basic_anchor description parameters urls)
;;

(* Setting NEW anchors (with default values !) *)
(* set_urls : vrml_object -> string list -> vrml_object *)
let set_urls obj urls =
      setf_anchor obj 
                  (new_basic_anchor
                      (default_anchor.anchor_description)
                      (default_anchor.anchor_parameters)
                      urls)
;;

(* Setting a NEW anchor (with default values !) *)
(* set_url : vrml_object -> string -> vrml_object *)
let set_url obj url =
    set_urls obj [ url ]
;;

(* !!! : new URL added at the end of the list *)
(* add_url : vrml_object -> string -> vrml_object *)
let add_url obj url =
    match obj.anchor with
      Anchor ({ anchor_urls = l }) ->
        setf_anchor obj
                    (new_basic_anchor default_anchor.anchor_description
                                      default_anchor.anchor_parameters
                                      (l@[url]))
    | NoAnchor ->
        setf_anchor obj
                    (new_basic_anchor default_anchor.anchor_description
                                      default_anchor.anchor_parameters
                                      [url])
;;


(* Billboard **************************************************************)

(* new_basic_billboard : float -> float -> float -> billboard *)
let new_basic_billboard x y z =
    Billboard ({ axis_of_rotation = x , y , z })
;;

(* set_billboard : vrml_object -> float -> float -> float -> vrml_object *)
let set_billboard obj x y z =
    setf_billboard obj (new_basic_billboard x y z)
;;


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

(* setf_collide : collisionBox -> bool -> collisionBox *)
let setf_collide collisionBox collide =
    new_basic_collisionBox 
       collide collisionBox.bbox_center collisionBox.bbox_size
;;

(* setf_bbox : collisionBox -> vect3D -> vect3D -> collisionBox *)
let setf_bbox collisionBox center size =
    new_basic_collisionBox
       collisionBox.collide center size
;;

(* setf_collision_collide : collision -> bool -> collision *)
let setf_collision_collide collision collide =
    let coll =
        match collision with
          Collision c -> c
        | NoCollision -> default_collisionBox
    in
        Collision ( setf_collide coll collide )
;;

(* setf_collision_bbox : collision -> vect3D -> vect3D -> collision *)
let setf_collision_bbox collision center size =
    let coll =
        match collision with
          Collision c -> c
        | NoCollision -> default_collisionBox
    in
        Collision ( setf_bbox coll center size )
;;

(* new_basic_collision : bool -> vect3D -> vect3D -> collision *)
let new_basic_collision collide center size =
    Collision ( new_basic_collisionBox collide center size )
;;

(* set_collidable : vrml_object -> vrml_object *)
let set_collidable obj =
    setf_collision obj (setf_collision_collide obj.collision true)
;;

(* set_uncollidable : vrml_object -> vrml_object *)
let set_uncollidable obj =
    setf_collision obj (setf_collision_collide obj.collision false)
;;

(* set_collision : vrml_object -> vect3D -> vect3D -> vrml_object *)
let set_collision obj center size =
    setf_collision obj (new_basic_collision true center size)
;;
