










(**************************************************************************)
(* $Id: geometrics.ml,v 1.4 1997/04/22 17:41:40 doub Exp $                *)
(* Creation and manipulation of geometric 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;;
open Vrml_objects_post;;
open Positionables;;


(**************************************************************************)
(* Creating geometric shapes                                              *)
(**************************************************************************)

(* Geometric objects ******************************************************)

(* new_basic_geometric : shape -> material -> texture
-> vrml_positionable *)
let new_basic_geometric shape material texture =
    Geometric
      ({ shape    = shape ;
         material = material ;
         texture  = texture
      })
;;

(* setf_shape : vrml_positionable -> shape -> vrml_positionable *)
let setf_shape geometric shape =
    match geometric with
      Geometric g -> new_basic_geometric shape g.material g.texture
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_material : vrml_positionable -> material -> vrml_positionable *)
let setf_material geometric material =
    match geometric with
      Geometric g -> new_basic_geometric g.shape material g.texture
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_texture : vrml_positionable -> texture -> vrml_positionable *)
let setf_texture geometric texture =
    match geometric with
      Geometric g -> new_basic_geometric g.shape g.material texture
    | _ -> raise (Failure "Not a Geometric")
;;


(* new_geometric_object : shape -> vrml_object *)
let new_geometric_object shape =
    add_object default_vrml_object (default_basic_geometric shape)
;;

(* setf_shape_field :
   vrml_positionable -> (shape -> 'a -> shape) -> 'a
-> vrml_positionable *)
let setf_shape_field geometric f valx = 
    match geometric with
      Geometric g ->
        setf_shape geometric (f g.shape valx)
    | _ -> raise (Failure "Not a Geometric")
;;


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

(* new_basic_box : float -> float -> float -> shape *)
let new_basic_box x y z =
    let s = x , y , z
    in
       Box ({ box_size = test_size s })
;;

(* Cone *******************************************************************)

(* new_basic_cone : float -> float -> bool -> bool -> shape *)
let new_basic_cone radius height side bottom =
    Cone
      ({ cone_bottom_radius = test_radius radius ;
         cone_height        = test_height height ;
         cone_side          = side ;
         cone_bottom        = bottom
      })
;;

(* setf_basic_cone_radius : shape -> float -> shape *)
let setf_basic_cone_radius cone radius =
    match cone with
      Cone c ->
        new_basic_cone radius c.cone_height c.cone_side c.cone_bottom
    | _ -> raise (Failure "Not a Cone")
;;

(* setf_basic_cone_height : shape -> float -> shape *)
let setf_basic_cone_height cone height =
    match cone with
      Cone c ->
        new_basic_cone c.cone_bottom_radius height
                       c.cone_side c.cone_bottom
    | _ -> raise (Failure "Not a Cone")
;;

(* setf_basic_cone_side : shape -> bool -> shape *)
let setf_basic_cone_side cone side =
    match cone with
      Cone c ->
        new_basic_cone c.cone_bottom_radius c.cone_height
                       side c.cone_bottom
    | _ -> raise (Failure "Not a Cone")
;;

(* setf_basic_cone_bottom : shape -> bool -> shape *)
let setf_basic_cone_bottom cone bottom =
    match cone with
      Cone c ->
        new_basic_cone c.cone_bottom_radius c.cone_height
                       c.cone_side bottom
    | _ -> raise (Failure "Not a Cone")
;;


(* setf_cone_radius : vrml_positionable -> float -> vrml_positionable *)
let setf_cone_radius geometric radius =
    setf_shape_field geometric setf_basic_cone_radius radius
;;

(* setf_cone_height : vrml_positionable -> float -> vrml_positionable *)
let setf_cone_height geometric height =
    setf_shape_field geometric setf_basic_cone_height height
;;

(* setf_cone_side : vrml_positionable -> bool -> vrml_positionable *)
let setf_cone_side geometric side =
    setf_shape_field geometric setf_basic_cone_side side
;;

(* setf_cone_bottom : vrml_positionable -> bool -> vrml_positionable *)
let setf_cone_bottom geometric bottom =
    setf_shape_field geometric setf_basic_cone_bottom bottom
;;


(* Cylinder ***************************************************************)

(* new_basic_cylinder : 
   bool -> float -> float -> bool -> bool -> shape *)
let new_basic_cylinder bottom height radius side top =
    Cylinder
      ({ cylinder_bottom = bottom ;
         cylinder_height = test_height height ;
         cylinder_radius = test_radius radius ;
         cylinder_side   = side ;
         cylinder_top    = top
      })
;;

(* setf_basic_cylinder_bottom : shape -> bool -> shape *)
let setf_basic_cylinder_bottom cylinder bottom =
    match cylinder with
      Cylinder c -> new_basic_cylinder bottom c.cylinder_height 
                                       c.cylinder_radius c.cylinder_side
                                       c.cylinder_top
    | _ -> raise (Failure "Not a Cylinder")
;;

(* setf_basic_cylinder_height : shape -> float -> shape *)
let setf_basic_cylinder_height cylinder height =
    match cylinder with
      Cylinder c -> new_basic_cylinder c.cylinder_bottom height 
                                       c.cylinder_radius c.cylinder_side
                                       c.cylinder_top
    | _ -> raise (Failure "Not a Cylinder")
;;

(* setf_basic_cylinder_radius : shape -> float -> shape *)
let setf_basic_cylinder_radius cylinder radius =
    match cylinder with
      Cylinder c -> new_basic_cylinder c.cylinder_bottom c.cylinder_height 
                                       radius c.cylinder_side
                                       c.cylinder_top
    | _ -> raise (Failure "Not a Cylinder")
;;

(* setf_basic_cylinder_side : shape -> bool -> shape *)
let setf_basic_cylinder_side cylinder side =
    match cylinder with
      Cylinder c -> new_basic_cylinder c.cylinder_bottom c.cylinder_height 
                                       c.cylinder_radius side
                                       c.cylinder_top
    | _ -> raise (Failure "Not a Cylinder")
;;

(* setf_basic_cylinder_top : shape -> bool -> shape *)
let setf_basic_cylinder_top cylinder top =
    match cylinder with
      Cylinder c -> new_basic_cylinder c.cylinder_bottom c.cylinder_height 
                                       c.cylinder_radius c.cylinder_side
                                       top
    | _ -> raise (Failure "Not a Cylinder")
;;

(* setf_cylinder_bottom :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_cylinder_bottom geometric bottom =
    setf_shape_field geometric setf_basic_cylinder_bottom bottom
;;

(* setf_cylinder_height :
   vrml_positionable -> float -> vrml_positionable *)
let setf_cylinder_height geometric height =
    setf_shape_field geometric setf_basic_cylinder_height height
;;

(* setf_cylinder_radius :
   vrml_positionable -> float -> vrml_positionable *)
let setf_cylinder_radius geometric radius =
    setf_shape_field geometric setf_basic_cylinder_radius radius
;;

(* setf_cylinder_side :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_cylinder_side geometric side =
    setf_shape_field geometric setf_basic_cylinder_side side
;;

(* setf_cylinder_top :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_cylinder_top geometric top =
    setf_shape_field geometric setf_basic_cylinder_top top
;;


(* Sphere *****************************************************************)

(* new_basic_sphere : float -> shape *)
let new_basic_sphere radius =
    Sphere ({ sphere_radius = test_radius radius }) 
;;


(* Text *******************************************************************)

(* new_basic_text :
   string list -> fontStyle -> float list -> float -> shape *)
let new_basic_text content font lengths max_extent =
    Text
      ({ content    = content ;
         font_style = font ;
         length     = map test_length lengths ;
         max_extent = test_max_extent max_extent })
;;

(* setf_basic_content : shape -> string list -> shape *)
let setf_basic_content text content =
    match text with
      Text t -> new_basic_text content t.font_style t.length t.max_extent
    | _ -> raise (Failure "Not a Text")
;;

(* setf_basic_font_style : shape -> fontStyle -> shape *)
let setf_basic_font_style text font =
    match text with
      Text t -> new_basic_text t.content font t.length t.max_extent
    | _ -> raise (Failure "Not a Text")
;;

(* setf_basic_length : shape -> float list -> shape *)
let setf_basic_length text length =
    match text with
      Text t -> new_basic_text t.content t.font_style length t.max_extent
    | _ -> raise (Failure "Not a Text")
;;

(* setf_basic_max_extent : shape -> float -> shape *)
let setf_basic_max_extent text max =
    match text with
      Text t -> new_basic_text t.content t.font_style t.length max
    | _ -> raise (Failure "Not a Text")
;;

(* setf_text_content :
   vrml_positionable -> string list -> vrml_positionable *)
let setf_text_content geometric content =
    setf_shape_field geometric setf_basic_content content
;;

(* setf_text_font :
   vrml_positionable -> fontStyle -> vrml_positionable *)
let setf_text_font geometric font =
    setf_shape_field geometric setf_basic_font_style font
;;

(* setf_text_length :
   vrml_positionable -> float list -> vrml_positionable *)
let setf_text_length geometric length =
    setf_shape_field geometric setf_basic_length length
;;

(* setf_text_max_extent :
   vrml_positionable -> float -> vrml_positionable *)
let setf_text_max_extent geometric max_extent =
    setf_shape_field geometric setf_basic_max_extent max_extent
;;


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


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

(* new_box : float -> float -> float -> vrml_object *)
let new_box x y z =
   new_geometric_object (new_basic_box x y z)
;;


(* Cone *******************************************************************)

(* new_complete_cone : float -> float -> bool -> bool -> vrml_object *)
let new_complete_cone radius height side bottom =
    new_geometric_object (new_basic_cone radius height side bottom)
;;

(* new_cone : float -> float -> vrml_object *)
let new_cone radius height =
    let d = default_cone
    in
       new_geometric_object
          (new_basic_cone radius height d.cone_side d.cone_bottom)
;;


(* Cylinder ***************************************************************)

(* new_complete_cylinder :
   float -> float -> bool -> bool -> bool -> vrml_object *)
let new_complete_cylinder radius height bottom top side =
    new_geometric_object (new_basic_cylinder bottom height radius side top)
;;

(* new_cylinder : float -> float -> vrml_object *)
let new_cylinder radius height =
    let d = default_cylinder 
    in
       new_geometric_object
          (new_basic_cylinder d.cylinder_bottom height radius 
                              d.cylinder_side d.cylinder_top)
;;


(* Cube *******************************************************************)

(* new_cube : float -> vrml_object *)
let new_cube x = 
    new_box x x x
;;


(* Sphere *****************************************************************)

(* new_sphere : float -> vrml_object *)
let new_sphere radius =
    new_geometric_object (new_basic_sphere radius)
;;


(* Text *******************************************************************)

(* new_complete_text;;
   string list -> fontStyle -> float list -> float -> vrml_object *)
let new_complete_text content font length max_extent =
    new_geometric_object
       (new_basic_text content font length max_extent)
;;

(* new_text : string list -> vrml_object *)
let new_text content =
    let d = default_text
    in
       new_complete_text content d.font_style d.length d.max_extent
;;

(* new_text_with_font : string list -> fontStyle -> vrml_object *)
let new_text_with_font content font =
    let d = default_text
    in
       new_complete_text content font d.length d.max_extent
;;

