










(**************************************************************************)
(* $Id: geometric_properties.ml,v 1.5 1997/05/01 17:59:09 doub Exp $      *)
(* Creation and manipulation of geometric properties                      *)
(* (material and texture)                                                 *)
(**************************************************************************)

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

(**************************************************************************)
(* Setting geometric properties : basic functions                         *)
(**************************************************************************)

(* Material ***************************************************************)

(* new_basic_material :
   float -> color -> color -> float -> color -> float -> material *)
let new_basic_material ambient_intensity diffuse_color 
                       emissive_color shininess
                       specular_color transparency =
    Material
      ({ ambient_intensity = test_material_ambient_intensity
                               ambient_intensity ;
         diffuse_color     = test_color diffuse_color ;
         emissive_color    = test_color emissive_color ;
         shininess         = test_material_shininess shininess ;
         specular_color    = test_color specular_color ;
         transparency      = test_material_transparency transparency
      })
;;


(* Material : setting fields **********************************************)

(* setf_basic_ambient_intensity : material -> float -> material *)
let setf_basic_ambient_intensity material intensity =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material intensity m.diffuse_color m.emissive_color
                           m.shininess m.specular_color m.transparency
;;

(* setf_basic_diffuse_color : material -> color -> material *)
let setf_basic_diffuse_color material color =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material m.ambient_intensity color m.emissive_color
                           m.shininess m.specular_color m.transparency
;;

(* setf_basic_emissive_color : material -> color -> material *)
let setf_basic_emissive_color material color =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material m.ambient_intensity m.diffuse_color color
                           m.shininess m.specular_color m.transparency
;;

(* setf_basic_shininess : material -> float -> material *)
let setf_basic_shininess material shininess =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material m.ambient_intensity m.diffuse_color 
                           m.emissive_color shininess 
                           m.specular_color m.transparency
;;

(* setf_basic_specular_color : material -> color -> material *)
let setf_basic_specular_color material color =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material m.ambient_intensity m.diffuse_color 
                           m.emissive_color m.shininess 
                           color m.transparency
;;

(* setf_basic_transparency : material -> float -> material *)
let setf_basic_transparency material transparency =
    let m = match material with
              Material mat -> mat
            | NoMaterial -> default_material
    in
        new_basic_material m.ambient_intensity m.diffuse_color 
                           m.emissive_color m.shininess 
                           m.specular_color transparency
;;


(*************************************************************************)
(* WARNING : the following functions on Material assume the Material     *)
(*           field to be set.                                            *)
(*************************************************************************)

(* setf_material_property :
   vrml_positionable -> (material -> 'a -> material) -> 'a
-> vrml_positionable *)
let setf_material_property geometric f valx =
    match geometric with
      Geometric ({ material = m }) ->
         setf_material geometric (f m valx)
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_ambient_intensity : vrml_positionable -> float
-> vrml_positionable *)
let setf_ambient_intensity geometric intensity =
    setf_material_property
        geometric setf_basic_ambient_intensity intensity
;;

(* setf_diffuse_color : vrml_positionable -> color -> vrml_positionable *)
let setf_diffuse_color geometric color =
    setf_material_property
        geometric setf_basic_diffuse_color color
;;

(* setf_emissive_color : vrml_positionable -> color -> vrml_positionable *)
let setf_emissive_color geometric color =
    setf_material_property
        geometric setf_basic_emissive_color color
;;

(* setf_shininess : vrml_positionable -> float -> vrml_positionable *)
let setf_shininess geometric shininess =
    setf_material_property
        geometric setf_basic_shininess shininess
;;

(* setf_specular_color : vrml_positionable -> color -> vrml_positionable *)
let setf_specular_color geometric color =
    setf_material_property
        geometric setf_basic_specular_color color
;;

(* setf_transparency : vrml_positionable -> float -> vrml_positionable *)
let setf_transparency geometric transparency =
    setf_material_property
        geometric setf_basic_transparency transparency
;;


(* Texture ***************************************************************)

(* new_basic_texture :
   textureType -> bool -> bool -> vect2D -> float -> vect2D -> vect2D
-> texture *)
let new_basic_texture texture repeatS repeatT center 
                      rotation scale translation =
    Texture
      ({ texture_repeatS     = repeatS ;
         texture_repeatT     = repeatT ;
         texture_type        = texture ;
         texture_center      = center ;
         texture_rotation    = rotation ;
         texture_scale       = scale ;
         texture_translation = translation
      })
;;

(* new_basic_imageTexture : string list -> textureType *)
let new_basic_imageTexture urls =
    ImageTexture ( urls )
;;

(* new_basic_movieTexture : float -> clip -> textureType *)
let new_basic_movieTexture speed clip =
    MovieTexture
      ({ movieTexture_speed = test_speed speed ;
         movieTexture_clip  = clip
      })
;;

(* new_basic_pixelTexture : image -> textureType *)
let new_basic_pixelTexture image =
    PixelTexture ( image )
;;


(* new_imageTexture : string list -> texture *)
let new_imageTexture urls =
    let d = default_texture default_basic_imageTexture
    in
       new_basic_texture (new_basic_imageTexture urls )
                         d.texture_repeatS d.texture_repeatT
                         d.texture_center d.texture_rotation
                         d.texture_scale d.texture_translation
;;

(* new_pixelTexture : image -> texture *)
let new_pixelTexture image =
    let d = default_texture default_basic_pixelTexture
    in
       new_basic_texture (new_basic_pixelTexture image)
                         d.texture_repeatS d.texture_repeatT
                         d.texture_center d.texture_rotation
                         d.texture_scale d.texture_translation
;;

(* new_complete_movieTexture : float -> clip -> texture *)
let new_complete_movieTexture speed clip =
    let d = default_texture default_basic_pixelTexture
    in
       new_basic_texture (new_basic_movieTexture speed clip)
                         d.texture_repeatS d.texture_repeatT
                         d.texture_center d.texture_rotation
                         d.texture_scale d.texture_translation
;;

(* new_movieTexture : clip -> texture *)
let new_movieTexture clip =
    let d = default_texture default_basic_pixelTexture
    in
       new_basic_texture (new_basic_movieTexture 
                             default_movieTexture.movieTexture_speed clip)
                         d.texture_repeatS d.texture_repeatT
                         d.texture_center d.texture_rotation
                         d.texture_scale d.texture_translation
;;


(* Texture : setting fields ***********************************************)

(* setf_basic_texture_repeatS : texture -> bool -> texture *)
let setf_basic_texture_repeatS texture repeat =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type repeat t.texture_repeatT
                          t.texture_center t.texture_rotation 
                          t.texture_scale t.texture_translation
;;

(* setf_basic_texture_repeatT : texture -> bool -> texture *)
let setf_basic_texture_repeatT texture repeat =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type t.texture_repeatS repeat
                          t.texture_center t.texture_rotation 
                          t.texture_scale t.texture_translation
;;

(* setf_basic_texture_type : texture -> textureType -> texture *)
let setf_basic_texture_type texture texture_type =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture texture_type
                          t.texture_repeatS t.texture_repeatT
                          t.texture_center t.texture_rotation 
                          t.texture_scale t.texture_translation
;;

(* setf_basic_texture_center : texture -> vect2D -> texture *)
let setf_basic_texture_center texture center =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type 
                          t.texture_repeatS t.texture_repeatT
                          center t.texture_rotation 
                          t.texture_scale t.texture_translation
;;

(* setf_basic_texture_rotation : texture -> float -> texture *)
let setf_basic_texture_rotation texture rotation =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type 
                          t.texture_repeatS t.texture_repeatT
                          t.texture_center rotation 
                          t.texture_scale t.texture_translation
;;

(* setf_basic_texture_scale : texture -> vect2D -> texture *)
let setf_basic_texture_scale texture scale =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type 
                          t.texture_repeatS t.texture_repeatT
                          t.texture_center t.texture_rotation 
                          scale t.texture_translation
;;

(* setf_basic_texture_translation : texture -> vect2D -> texture *)
let setf_basic_texture_translation texture translation =
    let t = match texture with
              Texture tex -> tex
            | NoTexture -> default_textureItem
    in
        new_basic_texture t.texture_type 
                          t.texture_repeatS t.texture_repeatT
                          t.texture_center t.texture_rotation 
                          t.texture_scale translation
;;

(* setf_basic_imageTexture_urls : textureType -> string list
-> textureType *)
let setf_basic_imageTexture_urls imageTexture urls =
    match imageTexture with
      ImageTexture i -> new_basic_imageTexture urls
    | _ -> raise (Failure "Not an ImageTexture")
;;

(* setf_basic_pixelTexture_image : textureType -> image -> textureType *)
let setf_basic_pixelTexture_image pixelTexture image =
    match pixelTexture with
      PixelTexture p -> new_basic_pixelTexture image
    | _ -> raise (Failure "Not a PixelTexture")
;;

(* setf_basic_movieTexture_speed : textureType -> float -> textureType *)
let setf_basic_movieTexture_speed movieTexture speed =
    match movieTexture with
      MovieTexture p -> new_basic_movieTexture speed p.movieTexture_clip
    | _ -> raise (Failure "Not a MovieTexture")
;;

(* setf_basic_movieTexture_clip : textureType -> clip -> textureType *)
let setf_basic_movieTexture_clip movieTexture clip =
    match movieTexture with
      MovieTexture p -> new_basic_movieTexture p.movieTexture_speed clip
    | _ -> raise (Failure "Not a MovieTexture")
;;


(**************************************************************************)
(* WARNING : the setf_texture_... assume a Texture to be set before       *)
(**************************************************************************)

(* setf_texture_property :
   vrml_positionable -> (texture -> 'a -> texture) -> 'a
-> vrml_positionable *)
let setf_texture_property geometric f valx =
    match geometric with
      Geometric ({ texture = t }) ->
         setf_texture geometric (f t valx)
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_texture_repeatS : vrml_positionable -> bool -> vrml_positionable *)
let setf_texture_repeatS geometric repeat =
    setf_texture_property
        geometric setf_basic_texture_repeatS repeat
;;

(* setf_texture_repeatT : vrml_positionable -> bool -> vrml_positionable *)
let setf_texture_repeatT geometric repeat =
    setf_texture_property
        geometric setf_basic_texture_repeatT repeat
;;

(* setf_texture_type : vrml_positionable -> textureType
-> vrml_positionable *)
let setf_texture_type geometric texture_type =
    setf_texture_property
        geometric setf_basic_texture_type texture_type
;;

(* setf_texture_center : vrml_positionable -> vect2D -> vrml_positionable *)
let setf_texture_center geometric center =
    setf_texture_property
        geometric setf_basic_texture_center center
;;

(* setf_texture_rotation : vrml_positionable -> float
-> vrml_positionable *)
let setf_texture_rotation geometric rotation =
    setf_texture_property
        geometric setf_basic_texture_rotation rotation
;;

(* setf_texture_scale : vrml_positionable -> vect2D -> vrml_positionable *)
let setf_texture_scale geometric scale =
    setf_texture_property
        geometric setf_basic_texture_scale scale
;;

(* setf_texture_translation : vrml_positionable -> vect2D
-> vrml_positionable *)
let setf_texture_translation geometric translation =
    setf_texture_property
        geometric setf_basic_texture_translation translation
;;


(* setf_imageTexture_urls :
   vrml_positionable -> string list -> vrml_positionable *)
let setf_imageTexture_urls geometric urls =
    match geometric with
      Geometric ({ texture = t }) ->
         (match t with
            Texture ({ texture_type = t_type }) ->
              setf_texture geometric
                 (setf_basic_texture_type t
                    (setf_basic_imageTexture_urls t_type urls))
          | NoTexture ->
              setf_texture geometric (new_imageTexture urls))
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_pixelTexture_image :
   vrml_positionable -> image -> vrml_positionable *)
let setf_pixelTexture_image geometric image =
    match geometric with
      Geometric ({ texture = t }) ->
         (match t with
            Texture ({ texture_type = t_type }) ->
              setf_texture geometric
                 (setf_basic_texture_type t
                   (setf_basic_pixelTexture_image t_type image))
          | NoTexture ->
              setf_texture geometric (new_pixelTexture image))
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_movieTexture_speed :
   vrml_positionable -> float -> vrml_positionable *) 
let setf_movieTexture_speed geometric speed =
    match geometric with
      Geometric ({ texture = t }) ->
         (match t with
            Texture ({ texture_type = t_type }) ->
              setf_texture geometric
                 (setf_basic_texture_type t
                    (setf_basic_movieTexture_speed t_type speed))
          | NoTexture ->
              setf_texture geometric
                          (new_complete_movieTexture
                             speed default_movieTexture.movieTexture_clip))
    | _ -> raise (Failure "Not a Geometric")
;;

(* setf_movieTexture_clip :
   vrml_positionable -> clip -> vrml_positionable *)
let setf_movieTexture_clip geometric clip =
    match geometric with
      Geometric ({ texture = t }) ->
         (match t with
            Texture ({ texture_type = t_type }) ->
              setf_texture geometric
                 (setf_basic_texture_type t
                    (setf_basic_movieTexture_clip t_type clip))
          | NoTexture ->
              setf_texture geometric
                          (new_complete_movieTexture
                             default_movieTexture.movieTexture_speed clip))
    | _ -> raise (Failure "Not a Geometric")
;;


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

(*include "map.ml" ;;
*)

