










(**************************************************************************)
(* $Id: specials.ml,v 1.3 1997/04/22 17:41:40 doub Exp $                  *)
(* Creation and manipulation of non-positionable 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;;
open Complex_geometrics;;
open Map_complex;;
open Lights;;
open Map_light;;
open Sound;;
open Frame_manipulations;;


(**************************************************************************)
(* Non-positionable objects                                               *)
(**************************************************************************)

(* Background *************************************************************)

(* new_basic_background :
   float list -> color list -> string list -> string list -> string list
-> string list -> string list -> string list -> float list -> color list
-> vrml_special *)
let new_basic_background ground_angles ground_colors back_urls bottom_urls
                         front_urls left_urls right_urls top_urls
                         sky_angles sky_colors =
    Background
       ({ ground_angle = map test_background_angle ground_angles ;
          ground_color = map test_color ground_colors ;
          back_url     = back_urls ;
          bottom_url   = bottom_urls ;
          front_url    = front_urls ;
          left_url     = left_urls ;
          right_url    = right_urls ;
          top_url      = top_urls ;
          sky_angle    = map test_background_angle sky_angles ;
          sky_color    = map test_color sky_colors
       })
;;

let new_complete_background = new_basic_background ;;

(* new_background : string -> color -> vrml_special *)
let new_background url color =
    let d = default_background
    in
       new_complete_background d.ground_angle [ color ] [ url ] [ url ]
                               [ url ] [ url ] [ url ] [ url ] d.sky_angle
                               [ color ]
;;


(* setf_background_ground_angles :
   vrml_special -> float list -> vrml_special *)
let setf_background_ground_angles background angles =
    match background with
      Background b ->
        new_basic_background angles b.ground_color b.back_url
                             b.bottom_url b.front_url b.left_url
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_ground_colors :
   vrml_special -> color list -> vrml_special *)
let setf_background_ground_colors background colors =
    match background with
      Background b ->
        new_basic_background b.ground_angle colors b.back_url
                             b.bottom_url b.front_url b.left_url
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_back_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_back_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color urls
                             b.bottom_url b.front_url b.left_url
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;


(* setf_background_bottom_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_bottom_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             urls b.front_url b.left_url
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_front_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_front_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url urls b.left_url
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_left_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_left_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url b.front_url urls
                             b.right_url b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_right_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_right_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url b.front_url b.left_url
                             urls b.top_url b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_top_urls :
   vrml_special -> string list -> vrml_special *)
let setf_background_top_urls background urls =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url b.front_url b.left_url
                             b.right_url urls b.sky_angle b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_sky_angles :
   vrml_special -> float list -> vrml_special *)
let setf_background_sky_angles background angles =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url b.front_url b.left_url
                             b.right_url b.top_url angles b.sky_color
    | _ -> raise (Failure "Not a Background")
;;

(* setf_background_sky_colors :
   vrml_special -> color list -> vrml_special *)
let setf_background_sky_colors background colors =
    match background with
      Background b ->
        new_basic_background b.ground_angle b.ground_color b.back_url
                             b.bottom_url b.front_url b.left_url
                             b.right_url b.top_url b.sky_angle colors
    | _ -> raise (Failure "Not a Background")
;;


(* Fog ********************************************************************)

(* new_basic_fog : color -> string -> float -> vrml_special *)
let new_basic_fog color fog_type visibility_range =
    Fog
      ({ fog_color            = test_color color ;
         fog_type             = fog_type ;
         fog_visibility_range = visibility_range
      })
;;

let linear_fog = "LINEAR" ;;
let exponential_fog = "EXPONENTIAL" ;;

let new_complete_fog = new_basic_fog ;;

(* new_linear_fog : color -> vrml_special *)
let new_linear_fog color =
    new_complete_fog color linear_fog default_fog.fog_visibility_range
;;

(* new_exponential_fog : color -> vrml_special *)
let new_exponential_fog color =
    new_complete_fog color exponential_fog default_fog.fog_visibility_range
;;


(* setf_fog_color : vrml_special -> color -> vrml_special *)
let setf_fog_color fog color =
    match fog with
      Fog f ->
        new_basic_fog color f.fog_type f.fog_visibility_range
    | _ -> raise (Failure "Not a Fog")
;;

(* setf_fog_type : vrml_special -> string -> vrml_special *)
let setf_fog_type fog fog_type =
    match fog with
      Fog f ->
        new_basic_fog f.fog_color fog_type f.fog_visibility_range
    | _ -> raise (Failure "Not a Fog")
;;

(* setf_fog_visibility_range : vrml_special -> float -> vrml_special *)
let setf_fog_visibility_range fog range =
    match fog with
      Fog f ->
        new_basic_fog f.fog_color f.fog_type range
    | _ -> raise (Failure "Not a Fog")
;;

