










(**************************************************************************)
(* $Id: lights.ml,v 1.3 1997/04/22 17:41:40 doub Exp $                    *)
(* Creation and manipulation of lights                                    *)
(**************************************************************************)


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

(**************************************************************************)
(* Lights : basic functions                                               *)
(**************************************************************************)

(* Directional Light ******************************************************)

(* new_basic_directionalLight : vect3D -> lightType *)
let new_basic_directionalLight direction =
    DirectionalLight ({ directionalLight_direction = direction })
;;

(* setf_basic_directionalLight_direction :
   lightType -> vect3D -> lightType *)
let setf_basic_directionalLight_direction directionalLight direction =
    match directionalLight with
      DirectionalLight _ ->
        new_basic_directionalLight direction
    | _ -> raise (Failure "Not a DirectionalLight")
;;


(* Point Light ************************************************************)

(* new_basic_pointLight : vect3D -> float -> lightType *)
let new_basic_pointLight attenuation radius =
    PointLight
      ({ pointLight_attenuation = test_attenuation attenuation ;
         pointLight_radius      = test_radius radius
      })
;;

(* setf_basic_pointLight_attenuation :
   lightType -> vect3D -> lightType *)
let setf_basic_pointLight_attenuation pointLight attenuation =
    match pointLight with
      PointLight p ->
        new_basic_pointLight attenuation p.pointLight_radius
    | _ -> raise (Failure "Not a PointLight")
;;

(* setf_basic_pointLight_radius :
   lightType -> float -> lightType *)
let setf_basic_pointLight_radius pointLight radius =
    match pointLight with
      PointLight p ->
        new_basic_pointLight p.pointLight_attenuation radius
    | _ -> raise (Failure "Not a PointLight")
;;


(* Spot Light *************************************************************)

(* new_basic_spotLight :
   vect3D -> float -> float -> vect3D -> float -> lightType *)
let new_basic_spotLight attenuation beam_width cut_off_angle 
                        direction radius =
    SpotLight
      ({ spotLight_attenuation   = test_attenuation attenuation ;
         spotLight_beam_width    = test_beam_width beam_width ;
         spotLight_cut_off_angle = test_cut_off_angle cut_off_angle ;
         spotLight_direction     = direction ;
         spotLight_radius        = test_radius radius
      })
;;

(* setf_basic_spotLight_attenuation :
   lightType -> vect3D -> lightType *)
let setf_basic_spotLight_attenuation spotLight attenuation =
    match spotLight with
      SpotLight s ->
        new_basic_spotLight attenuation s.spotLight_beam_width
                            s.spotLight_cut_off_angle 
                            s.spotLight_direction s.spotLight_radius
    | _ -> raise (Failure "Not a SpotLight")
;;

(* setf_basic_spotLight_beam_width :
   lightType -> float -> lightType *)
let setf_basic_spotLight_beam_width spotLight beam_width =
    match spotLight with
      SpotLight s ->
        new_basic_spotLight s.spotLight_attenuation beam_width
                            s.spotLight_cut_off_angle 
                            s.spotLight_direction s.spotLight_radius
    | _ -> raise (Failure "Not a SpotLight")
;;

(* setf_basic_spotLight_cut_off_angle :
   lightType -> float -> lightType *)
let setf_basic_spotLight_cut_off_angle spotLight cut_off_angle =
    match spotLight with
      SpotLight s ->
        new_basic_spotLight s.spotLight_attenuation 
                            s.spotLight_beam_width cut_off_angle 
                            s.spotLight_direction s.spotLight_radius
    | _ -> raise (Failure "Not a SpotLight")
;;

(* setf_basic_spotLight_direction :
   lightType -> vect3D -> lightType *)
let setf_basic_spotLight_direction spotLight direction =
    match spotLight with
      SpotLight s ->
        new_basic_spotLight s.spotLight_attenuation 
                            s.spotLight_beam_width
                            s.spotLight_cut_off_angle 
                            direction s.spotLight_radius
    | _ -> raise (Failure "Not a SpotLight")
;;

(* setf_basic_spotLight_radius :
   lightType -> float -> lightType *)
let setf_basic_spotLight_radius spotLight radius =
    match spotLight with
      SpotLight s ->
        new_basic_spotLight s.spotLight_attenuation 
                            s.spotLight_beam_width
                            s.spotLight_cut_off_angle 
                            s.spotLight_direction radius
    | _ -> raise (Failure "Not a SpotLight")
;;


(* Light ******************************************************************)

(* new_basic_light :
   lightType -> color -> float -> float -> vrml_positionable *)
let new_basic_light light color intensity ambient_intensity =
    Light
      ({ light_ambient_intensity = test_light_ambient_intensity 
                                      ambient_intensity ;
         light_color             = test_color color ;
         light_intensity         = test_light_intensity intensity ;
         light_type              = light
      })
;;

(* setf_light_color : vrml_positionable -> color -> vrml_positionable *)
let setf_light_color light color =
    match light with
      Light l ->
        new_basic_light l.light_type color
                        l.light_intensity l.light_ambient_intensity
    | _ -> raise (Failure "Not a Light")
;;

(* setf_light_ambient_intensity :
   vrml_positionable -> float -> vrml_positionable *)
let setf_light_ambient_intensity light intensity =
    match light with
      Light l ->
        new_basic_light l.light_type l.light_color
                        l.light_intensity intensity
    | _ -> raise (Failure "Not a Light")
;;

(* setf_light_intensity :
   vrml_positionable -> float -> vrml_positionable *)
let setf_light_intensity light intensity =
    match light with
      Light l ->
        new_basic_light l.light_type l.light_color
                        intensity l.light_ambient_intensity
    | _ -> raise (Failure "Not a Light")
;;

(* setf_light_type :
   vrml_positionable -> lightType -> vrml_positionable *)
let setf_light_type light light_type =
    match light with
      Light l ->
        new_basic_light light_type l.light_color
                        l.light_intensity l.light_ambient_intensity
    | _ -> raise (Failure "Not a Light")
;;

(* setf_light_type_property :
   vrml_positionable -> (lightType -> 'a -> lightType) -> 'a 
-> vrml_positionable *)
let setf_light_type_property light f valx =
    match light with
      Light ({ light_type = l_type }) -> 
         setf_light_type light (f l_type valx)
    | _ -> raise (Failure "Not a Light")
;;

(* setf_directionalLight_direction :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_directionalLight_direction light direction =
    setf_light_type_property
       light setf_basic_directionalLight_direction direction
;;
    
(* setf_pointLight_attenuation :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_pointLight_attenuation light attenuation =
    setf_light_type_property
       light setf_basic_pointLight_attenuation attenuation
;;       

(* setf_pointLight_radius :
   vrml_positionable -> float -> vrml_positionable *)
let setf_pointLight_radius light radius =
    setf_light_type_property
       light setf_basic_pointLight_radius radius
;;

(* setf_spotLight_attenuation :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_spotLight_attenuation light attenuation =
    setf_light_type_property
       light setf_basic_spotLight_attenuation attenuation
;;

(* setf_spotLight_beam_width :
   vrml_positionable -> float -> vrml_positionable *)
let setf_spotLight_beam_width light beam_width =
    setf_light_type_property
       light setf_basic_spotLight_beam_width beam_width
;;

(* setf_spotLight_cut_off_angle :
   vrml_positionable -> float -> vrml_positionable *)
let setf_spotLight_cut_off_angle light cut_off_angle =
    setf_light_type_property
       light setf_basic_spotLight_cut_off_angle cut_off_angle
;;

(* setf_spotLight_direction :
   vrml_positionable -> vect3D -> vrml_positionable *)
let setf_spotLight_direction light direction =
    setf_light_type_property
       light setf_basic_spotLight_direction direction
;;

(* setf_spotLight_radius :
   vrml_positionable -> float -> vrml_positionable *)
let setf_spotLight_radius light radius =
    setf_light_type_property
       light setf_basic_spotLight_radius radius
;;


(**************************************************************************)
(* Lights : high-level functions                                          *)
(**************************************************************************)

(* Directional Light ******************************************************)

(* new_complete_directionalLight :
 color -> float -> float -> vect3D -> vrml_object *)
let new_complete_directionalLight color intensity
                                  ambient_intensity direction =
    add_object default_vrml_object
               (new_basic_light (new_basic_directionalLight direction)
                                color intensity ambient_intensity)
;;

(* new_directionalLight : color -> float -> vect3D -> vrml_object *)
let new_directionalLight color intensity direction =
    new_complete_directionalLight color intensity
                                  (default_light.light_ambient_intensity)
                                  direction
;;


(* Point Light ************************************************************)

(* new_complete_pointLight : 
   color -> float -> float -> vect3D -> float -> vrml_object *)
let new_complete_pointLight color intensity ambient_intensity
                            attenuation radius =
    add_object default_vrml_object 
               (new_basic_light (new_basic_pointLight attenuation radius)
                                color intensity ambient_intensity)
;;

(* new_pointLight : color -> float -> float -> vrml_object *)
let new_pointLight color intensity radius =
    new_complete_pointLight color intensity
                            (default_light.light_ambient_intensity)
                            (default_pointLight.pointLight_attenuation)
                            radius
;;


(* Spot Light *************************************************************)

(* new_complete_spotLight :
   color -> float -> float -> vect3D -> float -> float -> vect3D -> float
-> vrml_object *)
let new_complete_spotLight color intensity ambient_intensity
                           attenuation beam_width cut_off_angle
                           direction radius =
    add_object default_vrml_object
               (new_basic_light
                  (new_basic_spotLight attenuation beam_width
                                       cut_off_angle direction radius)
                  color intensity ambient_intensity)
;;

(* new_spotLight : color -> float -> vect3D -> float -> vrml_object *)
let new_spotLight color intensity direction radius =
    let d = default_spotLight
    in
       new_complete_spotLight 
          color intensity default_light.light_ambient_intensity
          d.spotLight_attenuation d.spotLight_beam_width
          d.spotLight_cut_off_angle direction radius
;;



(**************************************************************************)
(* Setting light properties : high-level functions                        *)
(**************************************************************************)

(*
include "map_light.ml" ;;

*)
