










(**************************************************************************)
(* $Id: vrml_objects_post.ml,v 1.8 1997/05/01 13:58:20 doub Exp $         *)
(* Creation and manipulation of VRML objects                              *)
(**************************************************************************)

open Compatibility;;
open Types;;
open Default;;
open Exceptions;;
open Basic_types;;
open Font;;
open Fonts;;
open Colors;;
open Vrml_objects_pre;;


(* *** functions to recompute the frame changed by a coming new obj *)

(* rescale_3Dvect : float * float * float -> float * float * float -> 
   float * float * float = <fun> *)
let rescale_3Dvect vecteur scale =
match vecteur with
   (u,v,w) -> match scale with
                (a,b,c) -> (a *. u,b *. v,c *. w);;

(* retranslate_3Dvect : float * float * float -> 
   float * float * float -> float * float * float = <fun> *)
let retranslate_3Dvect vecteur trans = 
match vecteur with
   (u,v,w) -> match trans with
                (a,b,c) -> (a+.u,b+.v,c+.w);;

(* rotat_point : float * float * float -> float * float * float -> 
   float -> float * float * float = <fun> *)
let rotat_point rotation point =
match rotation with (vecteur,angle) ->
match angle with 0. -> point | _ ->
let rotation_image point phi =
match point with
(x,y,z) -> (x *. cos phi +. z *. sin phi,y,-1. *. x *. sin phi +. z *. cos phi)
in
match vecteur with
    (0.,0.,0.) -> point
|   (0.,v,0.) -> rotation_image point angle
|   (u,v,w) -> 
      let norme = sqrt ( power u 2. +. power v 2. +. power w 2.)
      in let r = sqrt ( power u 2. +. power w 2.) 
      in let c_alpha = u /. r and s_alpha = w /. r and c_beta = r /. norme 
         and s_beta = v /. norme 
      in match point with
      (x,y,z) ->
       let xs = x *. c_alpha *. s_beta -. y *. c_beta +. z *. s_alpha *. s_beta
       and ys = x *. c_alpha *. c_beta +. y *. s_beta +. z *. s_alpha *. c_beta
       and zs = z *. c_alpha -. x *. s_alpha
       in match (rotation_image (xs,ys,zs) angle) with
       (x,y,z) ->
       let xf = x *. c_alpha *. s_beta +. y *. c_beta *. c_alpha -. z *. s_alpha
       and yf = y *. s_beta -. x *. c_beta 
       and zf = x *. s_alpha *. s_beta +. y *. c_beta *. s_alpha +. z *. c_alpha
       in (xf,yf,zf)
;;


(* frame_to_cube : frame -> (float * float * float) list = <fun>*)
let frame_to_cube frame =
match frame.height with (ym,yp) ->
 match frame.width with (xm,xp) ->
  match frame.depth with (zm,zp) ->
   [(xm,ym,zp);(xm,yp,zp);(xp,ym,zp);(xp,yp,zp);
    (xm,ym,zm);(xm,yp,zm);(xp,ym,zm);(xp,yp,zm)]
;;

(* translate_frame : frame -> float * float * float -> frame = <fun>  *)
let translate_frame frame translation =
match translation with
   (a,b,c) -> 
              { 
                height = (match frame.height with (xm,xp) -> (xm +. b,xp +. b));
                width = (match frame.width with (ym,yp) -> (ym +. a,yp +. a));
                depth = (match frame.depth with (zm,zp) -> (zm +. c,zp +. c))
              }
;;

(* extract : ('a -> 'b) -> 'a list -> 'b * 'b = <fun> *)
let extract func list =
let rec aux func buffer list = 
match list with
    [] -> (match buffer with 
            [min;max] -> (min,max)
           |    _ -> raise (Failure "ca va pas 1 ;-D"))
| a::b -> let valx = func a in 
             aux func ( match buffer with
                 [] -> [valx;valx]
              | [min;max] -> if valx<min then [valx;max]
                             else if valx> max then [min;valx]
                             else [min;max]
              |   _ -> raise (Failure "ca va pas 2 ;-D")) b
in aux func [] list
;;


(* give_x : 'a * 'b * 'c -> 'a = <fun>
   give_y : 'a * 'b * 'c -> 'b = <fun>
   give_z : 'a * 'b * 'c -> 'c = <fun> *)

let give_x v = match v with (x,_,_) -> x;;
let give_y v = match v with (_,y,_) -> y;;
let give_z v = match v with (_,_,z) -> z;;

(* identity : 'a -> 'a = <fun> *)
let identity v = v ;;

(* frame_to_frame : frame -> (float * float * float) * float -> 
 float * float * float -> frame = <fun> *)
let frame_to_frame frame rotation scale =
 let delete_transformation p = rotat_point rotation (rescale_3Dvect p scale)
in let point_list = map delete_transformation (frame_to_cube frame)
in { height = extract give_y point_list ;
     width = extract give_x point_list ;
     depth = extract give_z point_list 
   }
;;

(* build_frame : frame -> (float * float * float) * float ->
float * float * float -> float * float * float -> frame -> frame = <fun> *)
let build_frame main_frame rotation translation scale frame =
let construct_axis a1 a2 =
match a1 with (m1,p1) -> (match a2 with (m2,p2) ->
((if m1<m2 then m1 else m2),(if p1>p2 then p1 else p2)) )
in
let construct_frame f1 f2 = 
{
  height = construct_axis f1.height f2.height ;
  width = construct_axis f1.width f2.width ;
  depth = construct_axis f1.depth f2.depth 
}
in
construct_frame main_frame (translate_frame (frame_to_frame frame rotation scale) translation);;


(* resize_frame_with_child : 
vrml_object -> vrml_object -> vrml_object = <fun> *)
let resize_frame_with_child father child =
set_frame father (build_frame father.frame child.rotation child.position
                  child.scale child.frame)
;;

(* nth : 'a list -> int -> 'a = <fun> *)
let rec nth liste n =
match liste with
   [] -> raise Not_found
| a::b -> if n = 1 then a else nth b (n-1);;

(* fill_frame : float list -> frame = <fun> *)
let fill_frame liste =
{
 height = (nth liste 1,nth liste 2) ;
 width = (nth liste 3,nth liste 4) ;
 depth = (nth liste 5,nth liste 6) 
} ;;

(* inv : float -> float = <fun> *)
let inv x = -1. *. x;;

(* member : 'a -> 'a list -> bool = <fun> *)
let rec member element list =
match list with
   [] -> false
| a::b -> if a=element then true else member element b;;

(* plane_list : 'a list list -> 'a list = <fun> *)
let rec plane_list l =
match l with
  [] -> []
| a::b -> a@plane_list b;;

(* vertex_extract : 'a list -> 'a list -> 'a list = <fun> *)
let rec vertex_extract actual_list list =
match list with
  [] -> actual_list
| a::b -> (if (member a actual_list) then vertex_extract actual_list
          else vertex_extract (a::actual_list)) b;;

(* extract_shape : 'a list -> ('a * 'a * 'a) list -> 'a list = <fun> *)
let rec extract_shape actual_value list =
match list with
  [] -> actual_value
| a::b -> extract_shape (match a with (x,y,z) ->
           match actual_value with [ym;yp;xm;xp;zm;zp] ->
           [if y<ym then y else ym;
            if y>yp then y else yp;
            if x<xm then x else xm;
            if x>xp then x else xp;
            if z<zm then z else zm;
            if z>zp then z else zp]
           | _ -> raise ( Failure "impossible thing" )
           ) b ;;


(* resize_frame : frame -> (float * float * float) list -> frame = <fun> *)
let resize_frame frame point_list =
let rec resize frame list =
match list with
  [] -> frame
| (x,y,z)::b -> let new_frame =
                  match frame.height with (ym,yp) ->
                  match frame.width with (xm,xp) ->
                  match frame.depth with (zm,zp) -> 
                  { height = ((if y<ym then y else ym),
                              (if y>yp then y else yp)) ;
                    width = ((if x<xm then x else xm),
                             (if x>xp then x else xp)) ;
                    depth = ((if z<zm then z else zm),
                             (if z>zp then z else zp))  }
                in resize new_frame b
in resize frame point_list ;;

(* translate_point : float * float * float -> float * float * float -> 
   float * float * float = <fun> *)
let translate_point translation point =
match translation with
 (a,b,c) -> match point with 
              (x,y,z) -> (x +. a, y +. b, z +. c);;

(* scale_point : float * float * float -> float * float * float -> 
   float * float * float = <fun> *)
let scale_point scale point = 
match scale with 
 (a,b,c) -> match point with 
              (x,y,z) -> (x *. a, y *. b, z *. c);;

(* compute_point : (float * float * float) * float ->
   float * float * float -> float * float * float -> float * float * float -> 
   float * float * float = <fun> *)
let compute_point rotation translation scale point =
translate_point translation ( scale_point scale (
(rotat_point rotation point)
));;

let tridim_y y (z,x) = (x,y,z) ;;

(* rotat_list_point : ((float * float * float) * float) list ->
   float * float * float -> float * float * float = <fun> *)
let rec rotat_list_point list point =
match list with
  [] -> point
| a::b -> rotat_list_point b (rotat_point a point);;

(* extrusion_frame_make : extrusion -> frame = <fun> *)
let extrusion_frame_make extrusion =
let rec frame_make actual_cross actual_frame actual_rotation_list scale_list 
rotation_list translation_list =
match (scale_list,rotation_list,translation_list) with
  ([],[],[]) -> actual_frame
| (s::a,r::b,t::c) -> 
     let new_cross = map (scale_point s) actual_cross
     in let new_actual_rotation = r :: actual_rotation_list
     in let n_frame = 
       resize_frame actual_frame (map (translate_point t) 
                     (map (rotat_list_point new_actual_rotation) new_cross)) 
     in frame_make new_cross n_frame new_actual_rotation a b c 
| (_,_,_) -> raise ( Failure "Impossible thing happened in extrusion_frame_make") 
in frame_make (map (tridim_y 0.0) extrusion.extrusion_cross_section) 
default_frame [] (map (tridim_y 0.0) extrusion.extrusion_scale) 
extrusion.extrusion_orientation extrusion.extrusion_spine
;;

(* geometric_frame_construct : geometric -> frame = <fun> *)
let geometric_frame_construct obj =
match obj.shape with
  Box b -> (match b.box_size with (xh,yh,zh) ->
            fill_frame [-0.5 *. yh;0.5 *. yh;
                        -0.5 *. xh;0.5 *. xh;
                        -0.5 *. zh;0.5 *. zh])
| Cone c -> let r = c.cone_bottom_radius
            and h = 0.5 *. c.cone_height
            in fill_frame [inv h;h;inv r;r;inv r;r]
| Sphere s -> let r = s.sphere_radius in fill_frame [inv r;r;inv r;r;inv r;r]
| Cylinder c -> let r = c.cylinder_radius 
                and h = 0.5 *. c.cylinder_height 
                in fill_frame [inv h;h;inv r;r;inv r;r]
| ElevationGrid e -> let xm = e.grid_x_spacing in
                     let xp = xm *. (float_of_int e.grid_x_dimension) in
                     let zm = e.grid_z_spacing in
                     let zp = zm *. (float_of_int e.grid_z_dimension) 
                     in (match (extract identity e.grid_height) 
                        with (ym,yp) -> fill_frame [ym;yp;xm;xp;zm;zp])
| FaceSet f -> fill_frame (extract_shape [0.;0.;0.;0.;0.;0.]
               (vertex_extract [] (plane_list f.faceSet_faces)))
| Extrusion e -> extrusion_frame_make e
| _ -> fill_frame [0.;0.;0.;0.;0.;0.] ;;

(* *)
let rec extract_from_list extract list =
match list with
  [] -> []
| a::b -> (extract a)@extract_from_list extract b;;


(* unlitGeometric_vertex_construct : unlitGeometric -> vect3D list = <fun> *)
let unlitGeometric_vertex_construct u =
match u with
  LineSet l -> let coord_from_line x = x.line_point1::[x.line_point2]
               in extract_from_list coord_from_line l
| PointSet p -> let coord_from_point x = [x.point_coordinate] 
               in extract_from_list coord_from_point p;;

(* unlitGeometric_frame_construct : unlitGeometric -> frame = <fun> *)
let unlitGeometric_frame_construct u =
let vertex_list = unlitGeometric_vertex_construct u in
fill_frame (extract_shape [0.;0.;0.;0.;0.;0.] (vertex_extract []
            vertex_list));;

(* vrml_positionable_frame_construct : vrml_positionable -> frame = <fun> *)
let vrml_positionable_frame_construct obj =
match obj with
  Geometric o -> geometric_frame_construct o
| UnlitGeometric u -> unlitGeometric_frame_construct u
|      _  ->  fill_frame [0.;0.;0.;0.;0.;0.] ;;

(* resize_frame_with_object : 
 vrml_object -> vrml_positionable -> vrml_object = <fun> *)
let resize_frame_with_object father obj =
let o0 = default_vrml_object in
set_frame father (build_frame father.frame o0.rotation o0.position o0.scale                  (vrml_positionable_frame_construct obj))
;;

(* get_resize_frame : vrml_object -> frame = <fun> *)
let get_resize_frame obj =
frame_to_frame obj.frame obj.rotation obj.scale ;;  






















