










(**************************************************************************)
(* $Id: complex_geometrics.ml,v 1.4 1997/05/01 13:58:19 doub Exp $        *)
(* Creation and manipulation of complex 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;;
open Geometrics;;
open Geometric_properties;;
open Map;;

(**************************************************************************)
(* Complex lit geometric objects                                          *)
(**************************************************************************)

(* Elevation Grid *)

(* new_basic_elevationGrid :
   color list -> textureCoordinate -> float list -> bool -> bool -> bool
-> int -> float -> int -> float -> shape *)
let new_basic_elevationGrid colors texture_coordinate heights ccw
                            color_per_vertex solid x x_spacing
                            z z_spacing =
    ElevationGrid
      ({ grid_color              = map test_color colors ;
         grid_texture_coordinate = texture_coordinate ;
         grid_height             = heights ;
         grid_ccw                = ccw ;
         grid_color_per_vertex   = color_per_vertex ;
         grid_solid              = solid ;
         grid_x_dimension        = test_elevationGrid_dimension x ;
         grid_x_spacing          = test_elevationGrid_spacing x_spacing ;
         grid_z_dimension        = test_elevationGrid_dimension z ;
         grid_z_spacing          = test_elevationGrid_spacing z_spacing
      })
;;

(* new_complete_elevationGrid :
   color list -> textureCoordinate -> float list -> bool -> bool -> bool
-> int -> float -> int -> float -> vrml_object *)
let new_complete_elevationGrid colors texture_coordinate heights ccw
                               color_per_vertex solid x x_spacing
                               z z_spacing =
    new_geometric_object
       (new_basic_elevationGrid colors texture_coordinate heights ccw
                                color_per_vertex solid x x_spacing
                                z z_spacing)
;;

(* new_elevationGrid :
   float list -> int -> int -> float -> float -> vrml_object *)
let new_elevationGrid heights x z x_spacing z_spacing =
    let d = default_elevationGrid
    in
       new_complete_elevationGrid d.grid_color d.grid_texture_coordinate
                                  heights d.grid_ccw
                                  d.grid_color_per_vertex d.grid_solid
                                  x x_spacing z z_spacing
;;

(* setf_basic_grid_color : shape -> color list -> shape *)
let setf_basic_grid_color grid colors =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid colors g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_texture_coordinate :
   shape -> textureCoordinate -> shape *)
let setf_basic_grid_texture_coordinate grid texture_coordinate =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_height : shape -> float list -> shape *)
let setf_basic_grid_height grid height =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_ccw : shape -> bool -> shape *)
let setf_basic_grid_ccw grid ccw =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_color_per_vertex : shape -> bool -> shape *)
let setf_basic_grid_color_per_vertex grid color_per_vertex =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_solid : shape -> bool -> shape *)
let setf_basic_grid_solid grid solid =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_x_dimension : shape -> int -> shape *)
let setf_basic_grid_x_dimension grid x =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                x g.grid_x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_x_spacing : shape -> float -> shape *)
let setf_basic_grid_x_spacing grid x_spacing =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension x_spacing
                                g.grid_z_dimension g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_z_dimension : shape -> int -> shape *)
let setf_basic_grid_z_dimension grid z =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                z g.grid_z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_basic_grid_z_spacing : shape -> float -> shape *)
let setf_basic_grid_z_spacing grid z_spacing =
    match grid with
      ElevationGrid g ->
        new_basic_elevationGrid g.grid_color g.grid_texture_coordinate
                                g.grid_height g.grid_ccw 
                                g.grid_color_per_vertex g.grid_solid
                                g.grid_x_dimension g.grid_x_spacing
                                g.grid_z_dimension z_spacing
    | _ -> raise (Failure "Not an ElevationGrid")
;;

(* setf_elevationGrid_colors :
   vrml_positionable -> color list -> vrml_positionable *)
let setf_elevationGrid_colors geometric colors =
    setf_shape_field geometric setf_basic_grid_color colors
;;

(* setf_elevationGrid_texture_coordinate :
   vrml_positionable -> textureCoordinate -> vrml_positionable *)
let setf_elevationGrid_texture_coordinate geometric texture_coordinate =
    setf_shape_field geometric
                     setf_basic_grid_texture_coordinate texture_coordinate
;;

(* setf_elevationGrid_heights :
   vrml_positionable -> float list -> vrml_positionable *)
let setf_elevationGrid_height geometric heights =
    setf_shape_field geometric setf_basic_grid_height heights
;;

(* setf_elevationGrid_ccw :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_elevationGrid_ccw geometric ccw =
    setf_shape_field geometric setf_basic_grid_ccw ccw
;;

(* setf_elevationGrid_color_per_vertex :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_elevationGrid_color_per_vertex geometric color_per_vertex =
    setf_shape_field geometric
                     setf_basic_grid_color_per_vertex color_per_vertex
;;

(* setf_elevationGrid_solid :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_elevationGrid_solid geometric solid =
    setf_shape_field geometric setf_basic_grid_solid solid
;;

(* setf_elevationGrid_x_dimension :
   vrml_positionable -> int -> vrml_positionable *)
let setf_elevationGrid_x_dimension geometric x =
    setf_shape_field geometric setf_basic_grid_x_dimension x
;;

(* setf_elevationGrid_x_spacing :
   vrml_positionable -> float -> vrml_positionable *)
let setf_elevationGrid_x_spacing geometric x_spacing =
    setf_shape_field geometric setf_basic_grid_x_spacing x_spacing
;;

(* setf_elevationGrid_z_dimension :
   vrml_positionable -> int -> vrml_positionable *)
let setf_elevationGrid_z_dimension geometric z =
    setf_shape_field geometric setf_basic_grid_z_dimension z
;;

(* setf_elevationGrid_z_spacing :
   vrml_positionable -> float -> vrml_positionable *)
let setf_elevationGrid_z_spacing geometric z_spacing =
    setf_shape_field geometric setf_basic_grid_z_spacing z_spacing
;;


(* Extrusion *)

(* new_basic_extrusion :
   bool -> bool -> bool -> vect2D list -> bool -> rotation -> vect2D list
-> bool -> vect3D list -> shape *)
let new_basic_extrusion begin_cap ccw convex cross_section end_cap
                        orientations scales solid spine =
    Extrusion
      ({ extrusion_begin_cap     = begin_cap ;
         extrusion_ccw           = ccw ;
         extrusion_convex        = convex ;
         extrusion_cross_section = cross_section ;
         extrusion_end_cap       = end_cap ;
         extrusion_orientation   = orientations ;
         extrusion_scale         = test_extrusion_scale scales ;
         extrusion_solid         = solid ;
         extrusion_spine         = spine
      })
;;

(* new_complete_extrusion :
   bool -> bool -> bool -> vect2D list -> bool -> rotation list
-> vect2D list -> bool -> vect3D list -> vrml_object *)
let new_complete_extrusion begin_cap ccw convex cross_section end_cap
                           orientation scales solid spine =

    new_geometric_object
       (new_basic_extrusion begin_cap ccw convex cross_section end_cap
                            orientation scales solid spine)
;;

(* new_extrusion : vect2D list -> vect3D list -> rotation list
-> vrml_object *)
let new_extrusion cross_section spine orientations =
    let d = default_extrusion
    in
       new_complete_extrusion d.extrusion_begin_cap d.extrusion_ccw
                              d.extrusion_convex cross_section
                              d.extrusion_end_cap orientations
                              d.extrusion_scale d.extrusion_solid spine
;;

(* new_extrusion_with_scales :
   vect2D list -> vect3D list -> rotation list -> vect2D list
-> vrml_object *)
let new_extrusion_with_scales cross_section spine orientations scales =
    let d = default_extrusion
    in
       new_complete_extrusion d.extrusion_begin_cap d.extrusion_ccw
                              d.extrusion_convex cross_section
                              d.extrusion_end_cap orientations
                              scales d.extrusion_solid spine
;;

(* setf_basic_extrusion_begin_cap : shape -> bool -> shape *)
let setf_basic_extrusion_begin_cap extrusion begin_cap =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_ccw : shape -> bool -> shape *)
let setf_basic_extrusion_ccw extrusion ccw =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_convex : shape -> bool -> shape *)
let setf_basic_extrusion_convex extrusion convex =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_cross_section : shape -> vect2D list -> shape *)
let setf_basic_extrusion_cross_section extrusion cross_section =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_end_cap : shape -> bool -> shape *)
let setf_basic_extrusion_end_cap extrusion end_cap =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_orientation : shape -> rotation list -> shape *)
let setf_basic_extrusion_orientation extrusion orientations =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap orientations 
                            e.extrusion_scale e.extrusion_solid 
                            e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_scale : shape -> vect2D -> shape *)
let setf_basic_extrusion_scale extrusion scale =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            scale e.extrusion_solid e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_solid : shape -> bool -> shape *)
let setf_basic_extrusion_solid extrusion solid =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale solid e.extrusion_spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_basic_extrusion_spine : shape -> vect3D list -> shape *)
let setf_basic_extrusion_spine extrusion spine =
    match extrusion with
      Extrusion e ->
        new_basic_extrusion e.extrusion_begin_cap e.extrusion_ccw
                            e.extrusion_convex e.extrusion_cross_section
                            e.extrusion_end_cap e.extrusion_orientation 
                            e.extrusion_scale e.extrusion_solid 
                            spine
    | _ -> raise (Failure "Not an Extrusion")
;;

(* setf_extrusion_begin_cap :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_extrusion_begin_cap geometric begin_cap =
    setf_shape_field geometric setf_basic_extrusion_begin_cap begin_cap
;;

(* setf_extrusion_ccw : vrml_positionable -> bool -> vrml_positionable *)
let setf_extrusion_ccw geometric ccw =
    setf_shape_field geometric setf_basic_extrusion_ccw ccw
;;

(* setf_extrusion_convex :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_extrusion_convex geometric convex =
    setf_shape_field geometric setf_basic_extrusion_convex convex
;;

(* setf_extrusion_cross_section :
   vrml_positionable -> vect2D list -> vrml_positionable *)
let setf_extrusion_cross_section geometric cross_section =
    setf_shape_field geometric
                     setf_basic_extrusion_cross_section cross_section
;;

(* setf_extrusion_end_cap :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_extrusion_end_cap geometric end_cap =
    setf_shape_field geometric setf_basic_extrusion_end_cap end_cap
;;

(* setf_extrusion_orientation :
   vrml_positionable -> rotation list -> vrml_positionable *)
let setf_extrusion_orientation geometric orientation =
    setf_shape_field geometric
                     setf_basic_extrusion_orientation orientation
;;

(* setf_extrusion_scale :
   vrml_positionable -> vect2D -> vrml_positionable *)
let setf_extrusion_scale geometric scale =
    setf_shape_field geometric setf_basic_extrusion_scale scale
;;

(* setf_extrusion_solid :
   vrml_positionable -> bool -> vrml_positionable *)
let setf_extrusion_solid geometric solid =
    setf_shape_field geometric setf_basic_extrusion_solid solid
;;

(* setf_extrusion_spine :
   vrml_positionable -> vect3D list -> vrml_positionable *)
let setf_extrusion_spine geometric spine =
    setf_shape_field geometric setf_basic_extrusion_spine spine
;;


(* Face Set *)

(* new_basic_faceSet :
   face list -> textureCoordinate -> bool -> bool -> bool -> int list
-> shape *)
let new_basic_faceSet faces texture_coordinate ccw convex solid index =
    FaceSet
      ({ faceSet_faces                    = faces ;
         faceSet_texture_coordinate       = texture_coordinate ;
         faceSet_ccw                      = ccw ;
         faceSet_convex                   = convex ;
         faceSet_solid                    = solid ;
         faceSet_texture_coordinate_index = index
      })
;;

(* new_complete_faceSet :
   face list -> textureCoordinate -> bool -> bool -> bool -> int list
-> vrml_object *)
let new_complete_faceSet faces texture_coordinate ccw convex solid index =
    new_geometric_object
       (new_basic_faceSet faces texture_coordinate ccw convex solid index)
;;

(* new_faceSet : face list -> vrml_object *)
let new_faceSet faces =
    let d = default_faceSet
    in
       new_complete_faceSet faces d.faceSet_texture_coordinate
                            d.faceSet_ccw d.faceSet_convex 
                            d.faceSet_solid
                            d.faceSet_texture_coordinate_index
;;

(* setf_basic_faceSet_faces : shape -> face list -> shape *)
let setf_basic_faceSet_faces faceSet faces =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet faces f.faceSet_texture_coordinate
                          f.faceSet_ccw f.faceSet_convex
                          f.faceSet_solid
                          f.faceSet_texture_coordinate_index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_basic_faceSet_texture_coordinate :
   shape -> textureCoordinate -> shape *)
let setf_basic_faceSet_texture_coordinate faceSet texture_coordinate =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet f.faceSet_faces texture_coordinate
                          f.faceSet_ccw f.faceSet_convex
                          f.faceSet_solid
                          f.faceSet_texture_coordinate_index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_basic_faceSet_ccw : shape -> bool -> shape *)
let setf_basic_faceSet_ccw faceSet ccw =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet f.faceSet_faces f.faceSet_texture_coordinate
                          ccw f.faceSet_convex f.faceSet_solid
                          f.faceSet_texture_coordinate_index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_basic_faceSet_convex : shape -> bool -> shape *)
let setf_basic_faceSet_convex faceSet convex =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet f.faceSet_faces f.faceSet_texture_coordinate
                          f.faceSet_ccw convex f.faceSet_solid
                          f.faceSet_texture_coordinate_index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_basic_faceSet_solid : shape -> bool -> shape *)
let setf_basic_faceSet_solid faceSet solid =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet f.faceSet_faces f.faceSet_texture_coordinate
                          f.faceSet_ccw f.faceSet_convex solid
                          f.faceSet_texture_coordinate_index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_basic_faceSet_texture_coordinate_index :
   shape -> int list -> shape *)
let setf_basic_faceSet_texture_coordinate_index faceSet index =
    match faceSet with
      FaceSet f ->
        new_basic_faceSet f.faceSet_faces f.faceSet_texture_coordinate
                          f.faceSet_ccw f.faceSet_convex
                          f.faceSet_solid index
    | _ -> raise (Failure "Not a FaceSet")
;;

(* setf_faceSet_faces :
   vrml_positionable -> face list -> vrml_positionable *)
let setf_faceSet_faces geometric faces =
    setf_shape_field geometric setf_basic_faceSet_faces faces
;;

(* setf_faceSet_texture_coordinate :
   vrml_positionable -> textureCoordinate -> vrml_positionable *)
let setf_faceSet_texture_coordinate geometric texture_coordinate =
    setf_shape_field
       geometric setf_basic_faceSet_texture_coordinate texture_coordinate
;;

(* setf_faceSet_ccw : vrml_positionable -> bool -> vrml_positionable *)
let setf_faceSet_ccw geometric ccw =
    setf_shape_field geometric setf_basic_faceSet_ccw ccw
;;

(* setf_faceSet_convex : vrml_positionable -> bool -> vrml_positionable *)
let setf_faceSet_convex geometric convex =
    setf_shape_field geometric setf_basic_faceSet_convex convex
;;

(* setf_faceSet_solid : vrml_positionable -> bool -> vrml_positionable *)
let setf_faceSet_solid geometric solid =
    setf_shape_field geometric setf_basic_faceSet_solid solid
;;

(* setf_faceSet_texture_coordinate_index :
   vrml_positionable -> int list -> vrml_positionable *)
let setf_faceSet_texture_coordinate_index geometric index =
    setf_shape_field geometric
                     setf_basic_faceSet_texture_coordinate_index index
;;

(**************************************************************************)

(* include "map_complex.ml" ;;

*)
