(*
 * 3D display widget
 *
 * Copyright (C) 2004 CENA/ENAC, Yann Le Fablec
 *
 * This file is part of paparazzi.
 *
 * paparazzi is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 *
 * paparazzi is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with paparazzi; see the file COPYING.  If not, write to
 * the Free Software Foundation, 59 Temple Place - Suite 330,
 * Boston, MA 02111-1307, USA.
 *
 *)

(* Scale + lighting = pb si pas de GlNormalize *)
(* Ne pas oublier de faire un area#make_current () avant d'appeler des  *)
(* commandes OpenGL car s'il y a plusieurs fenetres ouvertes, il arrive *)
(* que les commandes ne soient pas envoyees dans la bonne... *)

(* Modules gtk/Gdk *)
open GMain
open GdkKeysyms
open GlGtk
open Gtk_tools_GL
open Platform
open Gtkgl_Hack

(* Modules locaux *)
open Geometry_2d
open Geometry_3d

(* Nombre de widgets 3D crees *)
let nb_objects = ref 0

(* Temps en millisecondes pour l'animation *)
let tps_anim = 40

(* Exception levee lors de la recherche d'un objet d'identifiant inconnu *)
exception NO_SUCH_3D_OBJECT of int
(* Exception levee lorsqu'un autre objet est passe alors qu'un contour
   pays est attendu *)
exception NOT_A_3D_OUTLINE of int
(* Idem avec une ligne *)
exception NOT_A_3D_LINE of int
(* Idem avec un point *)
exception NOT_A_3D_POINT of int

(* Debugging *)
let debug_3d = false
(* Les fontes ne sont disponibles que sous Linux... *)
let fonts_available = not platform_is_win32

(* Une couleur OpenGL *)
type glcolor = float*float*float

let glcolor_white = (1., 1., 1.)
let glcolor_black = (0., 0., 0.)
let color_rosace  = (1., 0., 0.)

(* Point 2D *)
type glpoint2d = float*float

(* Point 3D *)
type glpoint3d = float*float*float

(* Point ou vecteur 3D nul *)
let pt_null      = (0., 0., 0.)

(* Point ou vecteur 3D indefini *)
let pt_undefined = (9999.99, 9999.99, 9999.99)

(* Objet non compile *)
let not_compiled_obj = Obj.magic ~-1

(* Type pour designer les axes *)
type t_coord = X_AXIS | Y_AXIS | Z_AXIS

(* Type des action possibles a la souris dans un widget 3D *)
type t_action = ACTION_NONE | ACTION_ZOOM of (int*int) | ACTION_ROTATE of (int*int)

(* Definition des curseurs utilises *)
let cursor_standard  = Gdk.Cursor.create `LEFT_PTR
let cursor_zoom_up   = Gdk.Cursor.create `BASED_ARROW_UP
let cursor_zoom_down = Gdk.Cursor.create `BASED_ARROW_DOWN
let cursor_rotate    = Gdk.Cursor.create `EXCHANGE

(* Valeurs OpenGL pour utiliser une source de lumiere *)
let lights = [`lighting; `light0; `color_material]

(* Types de fleche *)
type t_arrow = ARROW1 | ARROW2

(* Type de polygone *)
type t_triangulation =
    NO_TRI of glpoint3d list               (* polygone convexe non triangule       *)
  | TRI_WITH_FANS of (glpoint3d list) list (* triangule avec des triangles fans    *)
  | TRI_STD of glpoint3d list              (* triangule avec des triangles simples *)

(* Volume 3D *)
type vol3d = {
  vol3d_contour            : glpoint3d list ;  (* Faces verticales (quad_strip) *)
  vol3d_up                 : t_triangulation ; (* Face horizontale superieure   *)
  vol3d_down               : t_triangulation ; (* Face horizontale inferieure   *)
  mutable vol3d_color      : glcolor ;         (* Couleur du volume             *)
  mutable vol3d_filled     : bool              (* Volume plein ou fil de fer    *)
}


(* Volume d'une enveloppe 3D *)
type env3d ={
  env3d_contour        : glpoint3d list ;  (* Faces laterales (quad_strip)  *)
  mutable env3d_color  : glcolor ;         (* Couleur du volume             *)
  mutable env3d_filled : bool              (* Volume plein ou fil de fer    *)
}

(* Volume d'une enveloppe 3D *)
type env3d_double ={
  env3d_double_contour_out       : glpoint3d list ; (* Faces laterales externes (quad_strip) *)
  env3d_double_contour_in        : glpoint3d list ; (* Faces laterales internes (quad_strip) *)
  mutable env3d_double_color_out : glcolor ;        (* Couleur des faces externes *)
  mutable env3d_double_color_in  : glcolor ;        (* Couleur des faces internes *)
  mutable env3d_double_filled    : bool             (* Volume plein ou fil de fer *)
}


(* Contour 3D *)
type out3d = {
  out3d_contour            : glpoint3d list ;  (* Liste des points du contour *)
  mutable out3d_color_in   : glcolor ;         (* Couleur interieure          *)
  mutable out3d_color_out  : glcolor ;         (* Couleur du contour          *)
  mutable out3d_filled     : bool              (* Contour plein ou fil de fer *)
}

(* Ligne 3D *)
type line3d = {
  line3d_points            : glpoint3d list ;  (* Points de la ligne          *)
  mutable line3d_width     : int ;             (* Epaisseur                   *)
  mutable line3d_color     : glcolor ;         (* Couleur                     *)
  mutable line3d_with_bars : bool ;            (* Barres verticales           *)
  mutable line3d_filled    : bool              (* Surface jusqu'au sol        *)
}

(* Fleche 3D *)
type arr3d = {
  arr3d_contour        : (glpoint3d list) list ; (* Faces verticales (quad_strip) *)
  arr3d_pt             : glpoint3d ; (* Deplacement et rotation de la fleche car  *)
  arr3d_vect           : glpoint3d ; (* elle est creee le long de l'axe X. Il faut*)
  arr3d_angle_xy       : float ;     (* donc la remettre dans la bonne direction  *)
  arr3d_angle_z        : float ;
  mutable arr3d_color  : glcolor ;   (* Couleur de la fleche                      *)
  mutable arr3d_filled : bool        (* Fleche pleine ?                           *)
}

(* Point 3D *)
type point3d ={
  p3d_pos               : glpoint3d ; (* Position 3D du point     *)
  p3d_pos2              : glpoint3d ; (* Position du nom du point *)
  p3d_name              : string ;    (* Nom du point             *)
  mutable p3d_with_name : bool ;      (* Affichage du nom         *)
  mutable p3d_color     : glcolor     (* Couleur du point         *)
}

(* Surface triangulee en 3D *)
type surf3d = {
  s3d_pts            : (glpoint3d*glcolor) array array ;
  mutable s3d_filled : bool
}

(* Surface triangulee en 3D avec une texture *)
type surf3d_tex = {
  s3d_tex_pts        : glpoint3d array array ; (* Tableau des points de la surface *)
  s3d_tex_texture_id : GlTex.texture_id        (* Id de la texture a appliquer     *)
}

(* Type contenant tous les objets 3D possibles *)
type tobj3d =
    VOLUME1_3D of vol3d   | OUTLINE_3D of out3d
  | LINE_3D of line3d     | ARROW_3D of arr3d
  | POINT_3D of point3d   | ENVELOPPE_3D_DOUBLE of env3d_double
  | ENVELOPPE_3D of env3d | SURFACE_3D of surf3d
  | SURFACE_3D_TEX of surf3d_tex

(* Stockage d'un objet 3D *)
type obj3d = {o_obj              : tobj3d ;   (* L'objet                *)
              o_id               : int ;      (* Son identifiant unique *)
              mutable o_compiled : GlList.t ; (* L'objet compile        *)
              mutable o_show     : bool       (* Objet affiche ou pas   *)
             }

(* module OImages = OImage *)
(* module Images = Image *)

(* ============================================================================= *)
(* = Creation d'une texture a partir d'une image                               = *)
(* ============================================================================= *)
let make_image filename =
  let img = GdkPixbuf.from_file filename in
  let w = GdkPixbuf.get_width img
  and h = GdkPixbuf.get_height img
  and region = GdkPixbuf.get_pixels img in
  let n_channels = GdkPixbuf.get_n_channels img in
  let row = GdkPixbuf.get_rowstride img in

  assert(GdkPixbuf.get_bits_per_sample img = 8);
  assert(row = n_channels * w);

  let image = GlPix.create `ubyte ~format:`rgb ~width:w ~height:h in
  for i = 0 to h - 1 do
    for j = 0 to w - 1 do
      let pos = i*row + j*n_channels in
      let red = Gpointer.get_byte region ~pos in
      let green = Gpointer.get_byte region ~pos:(pos+1) in
      let blue = Gpointer.get_byte region ~pos:(pos+2) in
      Raw.sets (GlPix.to_raw image) ~pos:(3*(i*w+j))
        [| red; green; blue |]
    done
  done;
  image

let create_texture_from_image texture_filename =
  let texture = make_image texture_filename in
  let id = GlTex.gen_texture () in
  GlTex.bind_texture `texture_2d id;
  GluMisc.build_2d_mipmaps texture;
  id

(* ============================================================================= *)
(* = Infos OpenGL                                                              = *)
(* ============================================================================= *)
(* renvoie les informations relatives a la version d'OpenGL utilisee *)
let get_gl_infos () =
  let l = [("Vendor", `vendor);   ("Renderer", `renderer);
           ("Version", `version); ("Extensions", `extensions)] in
  let s = ref "" in
  List.iter (fun (str, t) -> s:=!s^str^" : "^(GlMisc.get_string t)^"\n") l ;
  !s

(* ============================================================================= *)
(* = Affichages si mode debug                                                  = *)
(* ============================================================================= *)
(* [do_msg msg] affiche le message [msg] si {!Gtk_3d.debug_3d} est vrai *)
let do_msg msg = if debug_3d then begin Printf.printf "%s\n" msg;flush stdout end

(* ============================================================================= *)
(* = Angle modulo 360                                                          = *)
(* ============================================================================= *)
(* [mod_360 angle] angle modulo 360 degres *)
let mod_360 angle = mod_float angle 360.

(* ============================================================================= *)
(* = Manipulations de coordonnees                                              = *)
(* ============================================================================= *)
(* [get_coord (x, y, z) axis] renvoie la composante [x], [y] ou [z] suivant
   l'axe indique *)
let get_coord (x, y, z) axis = match axis with X_AXIS->x | Y_AXIS->y | Z_AXIS->z

(* [add_coord (x, y, z) axis delta] ajoute [delta] a la coordonnee definie
   par [axis] *)
let add_coord (x, y, z) axis d =
  match axis with
      X_AXIS -> (x+.d, y, z) | Y_AXIS -> (x, y+.d, z) | Z_AXIS -> (x, y, z+.d)

(* [add_coord_360 (x, y, z) axis delta] meme chose modulo 360 *)
let add_coord_360 (x, y, z) axis d =
  match axis with
      X_AXIS -> (mod_360 (x+.d), y, z)
    | Y_AXIS -> (x, mod_360 (y+.d), z)
    | Z_AXIS -> (x, y, mod_360 (z+.d))

(* ============================================================================= *)
(* = Encapsulation de fonctions 3D                                             = *)
(* ============================================================================= *)
let glpoint3d_of_pt_3d u = (u.x3D, u.y3D, u.z3D)
let glpoint3d_to_pt_3d (x, y, z) = {x3D=x; y3D=y; z3D=z}
let glpoint3d_of_pt_2d z u = (u.x2D, u.y2D, z)
let glpoint3d_of_pt_3d_lst l = List.map glpoint3d_of_pt_3d l

(* ============================================================================= *)
(* = Normale unitaire a un triplet de points                                   = *)
(* ============================================================================= *)
(* [geom_normal A B C] renvoie la normale unitaire a un triplet de point *)
let geom_normal p1 p2 p3 =
  let p1 = glpoint3d_to_pt_3d p1 and p2 = glpoint3d_to_pt_3d p2
  and p3 = glpoint3d_to_pt_3d p3 in
  let n = Geometry_3d.normal (Geometry_3d.vect_make p1 p2)
    (Geometry_3d.vect_make p1 p3) in
  glpoint3d_of_pt_3d n

let geom_scal_mult n (x, y, z) = (x*.n, y*.n, z*.n)

(* Fermeture d'un polygone *)
let geom_close_poly l = if l=[] then [] else l@[List.hd l]


(* ============================================================================= *)
(* = Encapsulation de fonctions OpenGL                                         = *)
(* ============================================================================= *)
(* polygones remplis *)
let set_gl_fillpoly   () = GlDraw.polygon_mode ~face:`both `fill
(* polygones vides (contour uniquement) *)
let unset_gl_fillpoly () = GlDraw.polygon_mode ~face:`both `line

(* [set_color color] met a jour de la couleur de dessin/remplissage *)
let set_color color = GlDraw.color color
(* [set_faded_color color pct] applique la couleur plus sombre de [pct]% *)
let set_faded_color (r, g, b) pct =
  let p = (float_of_int pct)/.100. in GlDraw.color (r*.p, g*.p, b*.p)

(* [set_3d_points type_objet_opengl lst_pts] creation d'une liste de points 3D *)
let set_3d_points typ l =
  GlDraw.begins typ ; List.iter GlDraw.vertex3 l ; GlDraw.ends ()

let set_3d_points_with_color typ l =
  GlDraw.begins typ ;
  List.iter (fun ((p, c), n) ->
    set_color c; GlDraw.normal3 n; GlDraw.vertex3 p) l ;
  GlDraw.ends ()

let set_3d_points_with_texture typ l (dx, dy) (x1, y1) =
  GlDraw.begins typ ;
  List.iter (fun ((x,y,z), n) ->
    GlDraw.normal3 n; GlTex.coord2 ((x-.x1)/.dx, (y-.y1)/.dy) ;
    GlDraw.vertex3 (x,y,z)) l ;
  GlDraw.ends ()

(* [set_3d_points_quad_strip_with_normal lst_pts] creation d'une liste de
   points 3D [quad_strip] avec les normales *)
let set_3d_points_quad_strip_with_normal l =
  let t = Array.of_list l in
  GlDraw.begins `quad_strip ;
  Array.iteri (fun i pt ->
    (* Tous les 2 points -> normale au quad_strip courant *)
    if i mod 2=0 then
      if i=0 or i=List.length l-2 then GlDraw.normal3 (geom_normal pt t.(1) t.(2))
      else GlDraw.normal3 (geom_normal pt t.(i+1) t.(i+2)) ;
    GlDraw.vertex3 pt) t ;
  GlDraw.ends ()

(* normale vers le haut *)
let normal_up   () = GlDraw.normal3 (0., 0., 1.)
(* normale vers le bas *)
let normal_down () = GlDraw.normal3 (0., 0., -.1.)

(* [rotate axis angle] effectue une rotation suivant un axe donne *)
let rotate axis angle =
  match axis with
      X_AXIS -> GlMat.rotate ~angle ~x:1.0 ()
    | Y_AXIS -> GlMat.rotate ~angle ~y:1.0 ()
    | Z_AXIS -> GlMat.rotate ~angle ~z:1.0 ()

(* [rotate_some angles axis_list] rotation suivant les axes
   indiques par [axis_list].
   La liste [angles] donne la valeur pour chaque axe concerne *)
let rotate_some angles axis_list =
  List.iter (fun axis -> rotate axis (get_coord angles axis)) axis_list
(* [rotate_all angles] rotation suivant tous les axes *)
let rotate_all angles = rotate_some angles [X_AXIS; Y_AXIS; Z_AXIS]


(* ============================================================================= *)
(* = Calcul des normales pour les surfaces 3D avec ou sans texture             = *)
(* ============================================================================= *)
let get_surface_normals tt =
  let geom_normal_in p1 p2 p3 =
    let p1 = glpoint3d_to_pt_3d p1 and p2 = glpoint3d_to_pt_3d p2
    and p3 = glpoint3d_to_pt_3d p3 in
    Geometry_3d.normal (Geometry_3d.vect_make p1 p2) (Geometry_3d.vect_make p1 p3)
  in

  Array.mapi (fun i t0 ->
    Array.mapi (fun j p ->
      if i>0 && i < Array.length tt-1 then begin
        if j>0 && j < Array.length t0-1 then begin
          let n1 = geom_normal_in p tt.(i-1).(j) tt.(i).(j-1)
          and n2 = geom_normal_in p tt.(i-1).(j+1) tt.(i-1).(j)
          and n3 = geom_normal_in p tt.(i).(j+1) tt.(i-1).(j+1)
          and n4 = geom_normal_in p tt.(i+1).(j) tt.(i).(j+1)
          and n5 = geom_normal_in p tt.(i+1).(j-1) tt.(i+1).(j)
          and n6 = geom_normal_in p tt.(i).(j-1) tt.(i+1).(j-1) in
          let n = Geometry_3d.vect_add n1 n2 in
          let n = Geometry_3d.vect_add n n3 in
          let n = Geometry_3d.vect_add n n4 in
          let n = Geometry_3d.vect_add n n5 in
          let n = Geometry_3d.vect_add n n6 in
          let n = Geometry_3d.vect_normalize n in
          glpoint3d_of_pt_3d n
        end else (0., 0., 1.)
      end else (0., 0., 1.)) t0) tt

(* ============================================================================= *)
(* = Manipulation des objets                                                   = *)
(* ============================================================================= *)
(* [get_object_color objet] renvoie la couleur de l'objet *)
let get_object_color obj =
  match obj with
      OUTLINE_3D o          -> o.out3d_color_out
    | LINE_3D l             -> l.line3d_color
    | VOLUME1_3D v          -> v.vol3d_color
    | ENVELOPPE_3D e        -> e.env3d_color
    | ENVELOPPE_3D_DOUBLE e -> e.env3d_double_color_out
    | ARROW_3D a            -> a.arr3d_color
    | POINT_3D p            -> p.p3d_color
    | SURFACE_3D _s          -> glcolor_white
    | SURFACE_3D_TEX _s      -> glcolor_white

(* [set_object_color objet color] met a jour la couleur de l'objet *)
let set_object_color obj color =
  match obj with
      OUTLINE_3D o          -> o.out3d_color_out <- color
    | LINE_3D l             -> l.line3d_color    <- color
    | VOLUME1_3D v          -> v.vol3d_color     <- color
    | ENVELOPPE_3D e        -> e.env3d_color     <- color
    | ENVELOPPE_3D_DOUBLE e -> e.env3d_double_color_out<- color
    | ARROW_3D a            -> a.arr3d_color     <- color
    | POINT_3D p            -> p.p3d_color       <- color
    | _                     -> ()

(* [get_outline_in_color objet id] renvoie la couleur de remplissage d'un objet
   de type [OUTLINE_3D]. Si l'objet n'est pas de ce type, l'exception
   {!Gtk_3d.NOT_A_3D_OUTLINE} est levee *)
let get_outline_in_color obj id =
  match obj with OUTLINE_3D o -> o.out3d_color_in
    | _ -> raise (NOT_A_3D_OUTLINE id)
(* [set_outline_in_color objet color id] met a jour la couleur de remplissage pour
   un objet de type [OUTLINE_3D]. Si l'objet n'est pas de ce type, l'exception
   {!Gtk_3d.NOT_A_3D_OUTLINE} est levee *)
let set_outline_in_color obj color id =
  match obj with OUTLINE_3D o -> o.out3d_color_in <- color
    | _ -> raise (NOT_A_3D_OUTLINE id)

(* [get_object_fill objet] indique si l'objet est rempli ou en fil de fer *)
let get_object_fill obj =
  match obj with
      OUTLINE_3D o          -> o.out3d_filled
    | LINE_3D l             -> l.line3d_filled
    | VOLUME1_3D v          -> v.vol3d_filled
    | ENVELOPPE_3D e        -> e.env3d_filled
    | ENVELOPPE_3D_DOUBLE e -> e.env3d_double_filled
    | ARROW_3D a            -> a.arr3d_filled
    | POINT_3D _p            -> false
    | SURFACE_3D s          -> s.s3d_filled
    | SURFACE_3D_TEX _s      -> true

(* [set_object_filled objet filled] force l'objet en mode plein ou fil de fer *)
let set_object_fill obj filled =
  match obj with
      OUTLINE_3D o          -> o.out3d_filled  <- filled
    | LINE_3D l             -> l.line3d_filled <- filled
    | VOLUME1_3D v          -> v.vol3d_filled  <- filled
    | ENVELOPPE_3D e        -> e.env3d_filled <- filled
    | ENVELOPPE_3D_DOUBLE e -> e.env3d_double_filled <- filled
    | ARROW_3D a            -> a.arr3d_filled <- filled
    | POINT_3D _p            -> ()
    | SURFACE_3D s          -> s.s3d_filled <- filled
    | SURFACE_3D_TEX _s      -> ()

(* [get_line_width objet id] renvoie l'epaisseur d'un objet ligne. Si l'objet
   passe n'est pas du type [LINE_3D] alors l'exception {!Gtk_3d.NOT_A_3D_LINE}
   est levee *)
let get_line_width obj id =
  match obj with LINE_3D l -> l.line3d_width | _ -> raise (NOT_A_3D_LINE id)
(* [set_line_width objet width id] met a jour l'epaisseur d'un objet ligne. Si l'objet
   passe n'est pas du type [LINE_3D] alors l'exception {!Gtk_3d.NOT_A_3D_LINE}
   est levee *)
let set_line_width obj width id =
  match obj with LINE_3D l -> l.line3d_width<-width|_ -> raise (NOT_A_3D_LINE id)
(* [get_line_bars objet id] indique si l'objet est affiche avec des barres
   verticales si cet objet est du type [LINE_3D]. Si ca n'est pas le cas,
   l'exception {!Gtk_3d.NOT_A_3D_LINE} est levee *)
let get_line_bars obj id =
  match obj with LINE_3D l -> l.line3d_with_bars | _ -> raise (NOT_A_3D_LINE id)
(* [set_line_bars objet bars id] met a jour l'affichage des barres
   verticales d'un objet de type [LINE_3D]. S'il n'est pas de ce type alors
   l'exception {!Gtk_3d.NOT_A_3D_LINE} est levee *)
let set_line_bars obj bars id =
  match obj with LINE_3D l ->l.line3d_with_bars<-bars|_ ->raise (NOT_A_3D_LINE id)
(* [get_point_name objet id] indique si le nom de l'objet [POINT_3D] est
   affiche. Si l'objet passe n'est pas du type [POINT_3D],
   l'exception {!Gtk_3d.NOT_A_3D_POINT} est levee*)
let get_point_name obj id =
  match obj with POINT_3D p -> p.p3d_with_name  | _ -> raise (NOT_A_3D_POINT id)
(* [set_point_name objet name id] met a jour l'affichage ou pas du nom.
   Si l'objet passe n'est pas du type [POINT_3D],
   l'exception {!Gtk_3d.NOT_A_3D_POINT} est levee*)
let set_point_name obj name id =
  match obj with POINT_3D p ->p.p3d_with_name <-name|_ ->raise (NOT_A_3D_POINT id)



(* ============================================================================= *)
(* = Objet d'affichage 3D                                                      = *)
(* = pack            = ou mettre le widget                                     = *)
(* = with_status_bar = creation d'une barre d'infos optionnelle                = *)
(* = n               = nom de la fenetre                                       = *)
(* ============================================================================= *)
(* [widget_3d pack with_status_bar name] cree un widget d'affichage 3D

   - [pack] indique oł mettre le widget
   - [with_status_bar] permet la creation d'une barre d'infos optionnelle
   - [name] designe le nom a donner a la zone d'affichage (eventuellement affichee
   en haut a gauche de la zone)
*)
class widget_3d pack with_status_bar n =
  (* Creation de la GtkGlArea avec ou sans barre d'infos *)
  let (area, setstatus) =
    if with_status_bar then begin
      let v = Gtk_tools.create_vbox pack in
      let a = GlGtk.area [`RGBA; `DOUBLEBUFFER; `DEPTH_SIZE 1] ~packing:v#add () in
      let s = GMisc.statusbar ~packing:v#pack () in
      let ss = s#new_context ~name:"status" in
      (a, fun msg -> ignore(ss#push msg))
    end else
      (GlGtk.area [`RGBA; `DOUBLEBUFFER; `DEPTH_SIZE 1] ~packing:pack (),
       fun _msg -> ())
  in

object (self)

  (* Numero du widget 3D *)
  val nb = !nb_objects

  (* Nom de la fenetre eventuellement affiche en haut a gauche *)
  val mutable name      = n
  (* Indique si le nom de la fenetre doit etre affiche *)
  val mutable show_name = true

  (* Contient la largeur de la fenetre apres redimensionnement *)
  val mutable width    = -1
  (* Contient la hauteur de la fenetre apres redimensionnement *)
  val mutable height   = -1
  (* Position utilisateur *)
  val mutable depl     = (0., 0., -.1.5)
  (* Rotation utilisateur *)
  val mutable rot      = (290., 0., 0.)
  (* Position de la source de lumiere *)
  val mutable lightpos = (-.0.3, -.0.3, 0.6)
  (* Rotation de la source de lumiere *)
  val mutable lightrot = pt_null

  (* Couleur du fond *)
  val mutable back_color = glcolor_black

  (* Point central de la scene *)
  val mutable extents = pt_null
  (* Rayon de la scene *)
  val mutable rs = 1.
  (* Extremes minis *)
  val mutable extreme_min = pt_undefined
  (* Extremes maxis *)
  val mutable extreme_max = pt_undefined

  (* indique si l'initialisation a ete faite *)
  val mutable done_init = false
  (* Action souris en cours s'il y en a une *)
  val mutable current_action = ACTION_NONE
  (* indique si les lumieres sont utilisees *)
  val mutable use_lights  = true
  (* indique si la source de lumiere est affichee *)
  val mutable show_light  = false
  (* smoothing ? *)
  val mutable use_smooth  = true

  (* repertoire pour les captures ecran *)
  val mutable screenshot_path   = "Captures/"
  (* nom par defaut de la capture *)
  val mutable screenshot_name   = "capture3d.png"

  (* [triangle_fan] ou [triangle] pour afficher les surfaces triangulees *)
  val mutable use_fans_for_tesselation = true

  (* increment d'eloignement lie aux touches *)
  val dist_incr = -.0.1
  (* increment de rotation lie aux touches *)
  val rot_incr  = 2.

  (* Rotation pendant l'animation *)
  val rot_anim = 0.1

  (* Compteur des objets pour les identifiants uniques *)
  val mutable cpt_obj  = 0
  (* Liste des objets 3D definis dans le widget 3D *)
  val mutable objects  = ([]:obj3d list)

  (* indique si la rosace doit etre affichee *)
  val mutable show_rosace = true
  (* Objet rosace *)
  val mutable rosace = None

  (* Fonte OpenGL si disponible (i.e sous Unix) *)
  val mutable fontbase = Obj.magic ~-1

  (* Timer utilise pour l'animation *)
  val mutable animation_timer = None

  (* cree un nouvel identifiant *)
  method private get_new_id = let n = cpt_obj in cpt_obj<-cpt_obj+1; n

  (* Indique a OpenGL que la fenetre est la fenetre courante
     dans laquelle doivent etre effectuees les commandes OpenGL
     A faire absolument avant d'ajouter des objets pour que la
     bonne fenetre recoive les commandes OpenGL qui suivent...  *)
  method private make_current = area#make_current ()

  (* Mise a jour de la barre d'infos *)
  method private set_status =
    let msg = ref "" in
    let add txt = msg:=if !msg="" then txt else !msg^" "^txt in
    let (x, y, z) = rot in
    add (Printf.sprintf "X=%.0f Y=%.0f Z=%.0f" x y z) ;
    let (_, _, z) = depl in
    add (Printf.sprintf "Dist=%.1f" (-.z)) ;
    add (if use_lights then "Lights on " else "Lights off") ;
    add (if use_smooth then "Smooth on " else "Smooth off") ;
    setstatus !msg

  (* force l'utilisation de la lumiere *)
  method lights_on     = use_lights <- true;  self#update_lights
  (* annule l'utilisation de la lumiere *)
  method lights_off    = use_lights <- false; self#update_lights
  (* change l'etat d'utilisation de la lumiere *)
  method lights_switch = use_lights <- not use_lights; self#update_lights
  (* met a jour le widget pour utiliser ou pas les lumieres suivant
     la valeur de [use_lights] *)
  method private update_lights =
    do_msg (if use_lights then "Lights on" else "Lights off") ;
    List.iter (if use_lights then Gl.enable else Gl.disable) lights ;
    self#setup; self#display_func

  (* force l'utilisation du lissage *)
  method smooth_on     = use_smooth <- true;  self#update_smooth
  (* annule l'utilisation du lissage *)
  method smooth_off    = use_smooth <- false; self#update_smooth
  (* change l'etat d'utilisation du lissage *)
  method smooth_switch = use_smooth <- not use_smooth; self#update_smooth
  (* met a jour le widget 3D pour appliquer ou pas le lissage suivant la
     valeur de [use_smooth] *)
  method private update_smooth =
    do_msg (if use_smooth then "Smooth on" else "Smooth off") ;
    GlDraw.shade_model (if use_smooth then `smooth else `flat) ;
    self#set_status ; self#display_func

  (* affiche la rosace *)
  method rosace_on     = show_rosace <- true; self#display_func
  (* masque la rosace *)
  method rosace_off    = show_rosace <- false; self#display_func
  (* change l'etat d'affichage de la rosace suivant la valeur de [show_rosace] *)
  method rosace_switch = show_rosace <- not show_rosace; self#display_func

  (* Modification de la vue et redessin *)
  method change_and_redraw = self#setup; self#display_func

  (* Rotation/deplacement de la position utilisateur *)
  method rotate_view r = rot<-r;  self#change_and_redraw
  method move_view d   = depl<-d; self#change_and_redraw

  (* Modification du curseur *)
  method private set_cursor c =
    Gtk_tools.set_cursor area#misc#window c
  method private reset_cursor =
    Gtk_tools.set_cursor area#misc#window cursor_standard

  (* [scale_point point] met a l'echelle un point *)
  method private scale_point pt = geom_scal_mult (1./.rs) pt
  (* [scale_points lst_points] met a l'echelle une liste de points *)
  method private scale_points l = List.map self#scale_point l

  (* [draw_triangulation t] dessine une face polygonale triangulee ou
     pas en effectuant en plus la mise a l'echelle *)
  method private draw_triangulation t =
    match t with
        NO_TRI l        -> set_3d_points `polygon (self#scale_points l)
      | TRI_STD l       -> set_3d_points `triangles (self#scale_points l)
      | TRI_WITH_FANS l -> List.iter (fun l ->
        set_3d_points (if List.length l>3 then `triangle_fan else `triangles)
          (self#scale_points l)) l

  (* [create_pyramid (x, y, z) size] cree une pyramide de hauteur
     [size] centree en [(x, y, z)] *)
  method private create_pyramid (x, y, z) size =
    let d = size*.sqrt(3.)/.2. in
    let a=d/.3. and b = (2.*.d)/.3. in
    let p0 = (x, y, z+.b) and p1 = (x, y+.b, z-.a)
    and p2 = (x-.size/.2., y-.a, z-.a) and p3 = (x+.size/.2., y-.a, z-.a) in
    set_3d_points `triangle_fan [p0; p1; p2; p3; p1] ;
    set_3d_points `triangles    [p2; p1; p3]

  (* [compile_one objet] met a l'echelle et compile l'objet *)
  method private compile_one o =
    GlList.delete o.o_compiled ;
    let compiled = GlList.create `compile in
    (match o.o_obj with
        OUTLINE_3D o ->
          let pts = self#scale_points o.out3d_contour in
          if o.out3d_filled then begin
            set_gl_fillpoly () ; set_color o.out3d_color_in ;
            (* Ici il faudrait trianguler le polygone si necessaire... *)
            set_3d_points `polygon pts
          end ;
          GlDraw.line_width 2. ;
          unset_gl_fillpoly () ; set_color o.out3d_color_out ;
          set_3d_points `polygon pts
      | LINE_3D l    ->
        Gl.disable `cull_face ;
        let pts = self#scale_points l.line3d_points in
        if l.line3d_filled or l.line3d_with_bars then begin
          let lfill = List.flatten (List.map (fun (a, b, c) ->
            [(a, b, 0.); (a, b, c)]) pts) in
          if l.line3d_filled then begin
            set_gl_fillpoly () ; set_faded_color l.line3d_color 70 ;
            set_3d_points `quad_strip lfill
          end ;
          if l.line3d_with_bars then begin
            GlDraw.line_width 2. ;
            unset_gl_fillpoly () ; set_faded_color l.line3d_color 85 ;
            set_3d_points `quad_strip lfill
          end
        end ;
        GlDraw.line_width (float_of_int l.line3d_width) ;
        set_color l.line3d_color ;
        set_3d_points `line_strip pts ;
        Gl.enable `cull_face
      | VOLUME1_3D v  ->
        if v.vol3d_filled then set_gl_fillpoly () else begin
          GlDraw.line_width 2. ;  unset_gl_fillpoly ()
        end ;
        (* Faces verticales *)
        GlLight.color_material ~face:`front `ambient_and_diffuse ;
        set_color v.vol3d_color ;
        set_3d_points_quad_strip_with_normal (self#scale_points v.vol3d_contour) ;

        (* Dessin des faces inferieure et superieure avec une couleur plus sombre *)
        if v.vol3d_filled then begin
          GlLight.color_material ~face:`front `ambient_and_diffuse ;
          set_faded_color v.vol3d_color 75 ;
          normal_up () ;   self#draw_triangulation v.vol3d_up ;
          normal_down () ; self#draw_triangulation v.vol3d_down
        end
      | ENVELOPPE_3D e  ->
        (* Faces tjs visibles: Gl.disable `cull_face ; *)
        if e.env3d_filled then set_gl_fillpoly () else begin
          GlDraw.line_width 2. ;  unset_gl_fillpoly ()
        end ;

        (* Faces verticales  *)
        GlLight.color_material ~face:`front `ambient_and_diffuse ;
        set_color e.env3d_color ;
        set_3d_points_quad_strip_with_normal (self#scale_points e.env3d_contour);
      (*si faces env tjs visibles:  Gl.enable `cull_face *)
      | ENVELOPPE_3D_DOUBLE e  ->
        (* Faces tjs visibles: Gl.disable `cull_face ; *)
        if e.env3d_double_filled then set_gl_fillpoly () else begin
          GlDraw.line_width 2. ;  unset_gl_fillpoly ()
        end ;

        (* Faces verticales externes *)
        GlLight.color_material ~face:`front `ambient_and_diffuse ;
        set_color e.env3d_double_color_out ;
        set_3d_points_quad_strip_with_normal
          (self#scale_points e.env3d_double_contour_out);

        (* Faces verticales internes *)
        GlLight.color_material ~face:`front `ambient_and_diffuse ;
        set_color e.env3d_double_color_in ;
        set_3d_points_quad_strip_with_normal
          (self#scale_points e.env3d_double_contour_in)

      (*si faces env tjs visibles: Gl.enable `cull_face *)
      | ARROW_3D a ->
        if a.arr3d_filled then set_gl_fillpoly () else begin
          GlDraw.line_width 2. ;  unset_gl_fillpoly ()
        end ;
        GlLight.color_material ~face:`front `ambient_and_diffuse ;
        set_color a.arr3d_color ;

        GlMat.push () ;
        (* Deplace la fleche sur la pointe de la fleche *)
        GlMat.translate3 (self#scale_point a.arr3d_pt) ;
        (* Tourne la fleche pour qu'elle soit orientee comme voulu *)
        GlMat.rotate3 a.arr3d_vect ~angle:a.arr3d_angle_xy ;
        (* Tourne selon Z pour remettre la fleche comme il faut *)
        rotate Z_AXIS a.arr3d_angle_z ;

        (* Mise a l'echelle des points de la fleche *)
        let l = List.map self#scale_points a.arr3d_contour in
        (* Faces 'verticales' *)
        set_3d_points_quad_strip_with_normal (List.flatten l) ;
        if a.arr3d_filled then begin
          GlLight.color_material ~face:`front `ambient_and_diffuse ;
          set_faded_color a.arr3d_color 75 ;
          let (up, down) =
            (List.rev_map (fun l -> List.hd (List.tl l)) l,
             List.map (fun l -> List.hd l) l) in
          (* Faces 'horizontales' *)
          normal_up () ;   set_3d_points `polygon up ;
          normal_down () ; set_3d_points `polygon down
      end ;
      GlMat.pop ()
      | POINT_3D p ->
      let (x0, y0, z0) = self#scale_point p.p3d_pos
      and (x, y, z)    = self#scale_point p.p3d_pos2 in
      set_gl_fillpoly () ; set_color p.p3d_color ;
      let size = 0.02 in
      self#create_pyramid (x0, y0, z0) size ;

      if p.p3d_with_name then begin
        GlDraw.line_width 2.0 ;
        set_3d_points `line_strip [(x, y, z); (x0, y0, z0+.size)] ;
        if fonts_available then begin
          GlPix.raster_pos ~x ~y ~z:(z+.0.01) () ;
          Gtkgl_Hack.gl_print_string fontbase p.p3d_name
        end
      end ;

      | SURFACE_3D_TEX s ->
      normal_up () ;
      let tt = Array.map (Array.map self#scale_point) s.s3d_tex_pts in
      (* On recentre les coordonnees dans la texture pour la voir en entier *)
      (* sur toute la surface *)
      let (x1,y1,_) = tt.(0).(0) and ttt = tt.(Array.length tt-1) in
      let (x2,y2,_) = ttt.(Array.length ttt-1) in
      let delta = (x2-.x1, y2-.y1) and first = (x1, y1) in

      let t_normals = get_surface_normals tt in
      Gl.enable `texture_2d; GlDraw.shade_model `flat ;
      (* On utilise la texture indiquee *)
      GlTex.bind_texture `texture_2d s.s3d_tex_texture_id;
      Array.iteri (fun i t0 ->
        if i<Array.length tt-1 then begin
          let l = ref [] in
          Array.iteri (fun j p ->
        l:=(tt.(i+1).(j), t_normals.(i+1).(j))::(p, t_normals.(i).(j))::!l) t0 ;
          set_3d_points_with_texture `triangle_strip (List.rev !l) delta first
        end) tt ;
      Gl.disable `texture_2d ;
      GlDraw.shade_model (if use_smooth then `smooth else `flat)

      | SURFACE_3D s ->
      if s.s3d_filled then set_gl_fillpoly () else begin
        GlDraw.line_width 2. ;  unset_gl_fillpoly ()
      end ;
      GlLight.color_material ~face:`front `ambient_and_diffuse ;
      normal_up () ;
      let t = Array.map (Array.map (fun (p, c) -> (self#scale_point p, c))) s.s3d_pts in

      let t_normals = get_surface_normals (Array.map (Array.map fst) t) in
      Array.iteri (fun i t0 ->
        if i<Array.length t-1 then begin
          let l = ref [] in
          Array.iteri (fun j p ->
        l:=(t.(i+1).(j), t_normals.(i+1).(j))::(p, t_normals.(i).(j))::!l) t0 ;
          set_3d_points_with_color `triangle_strip (List.rev !l)
        end) t
      ) ;
      GlList.ends () ;
      o.o_compiled <- compiled

      (* recompilation de tous les objets contenus dans le widget *)
    method private recompile_all_objects = List.iter self#compile_one objects
    (* [make_and_compile objet] compile uniquement l'objet indique *)
    method private make_and_compile o = self#make_current ; self#compile_one o

    (* [add_object objet] ajoute l'objet : compilation de cet objet et eventuelle
       recompilation des autres s'il sort des extremes precedents *)
    method private add_object o =
      self#make_current ;
      let new_o = {o_obj=o; o_id=self#get_new_id;
           o_compiled=not_compiled_obj; o_show=true} in
      objects <- new_o::objects ;
      (* Recherche des valeurs extremes de cet objet si necessaire *)
      let old_rs = rs in
      let (do_it, l) =
    match o with
      OUTLINE_3D _o          -> (false, [])
    | LINE_3D l             -> (true, l.line3d_points)
    | VOLUME1_3D v          -> (true, v.vol3d_contour)
    | ENVELOPPE_3D e        -> (true, e.env3d_contour)
    | ENVELOPPE_3D_DOUBLE e -> (true, e.env3d_double_contour_out)
    | ARROW_3D _a            -> (false, [])
    | POINT_3D p            -> (true, [p.p3d_pos; p.p3d_pos2])
    | SURFACE_3D s          ->
        let l = Array.to_list (Array.map (fun t -> Array.to_list t) s.s3d_pts) in
        (true, List.map fst (List.flatten l))
    | SURFACE_3D_TEX s      ->
        let l = Array.to_list (Array.map (fun t -> Array.to_list t) s.s3d_tex_pts) in
        (true, List.flatten l)
      in
      if do_it then self#get_extremes l ;
      if old_rs<>rs then
    (* Il faut recompiler les autres objets car les extremes ont change... *)
    self#recompile_all_objects
      else
    (* Compilation uniquement de cet objet *)
    self#compile_one new_o ;

      (* Renvoie l'identifiant du nouvel objet cree *)
      new_o.o_id

    (* [get_extremes pts_list] recherche les points extremes d'un objet, met
       a jour les valeurs pour la scene et reaffiche si necessaire *)
    method private get_extremes pts_list =
      if pts_list <> [] then begin
    let (p1, p2) =
      if extreme_min=pt_undefined && extreme_max=pt_undefined then
        (List.hd pts_list, List.hd pts_list)
      else (extreme_min, extreme_max)
    in

    let minmax coord l =
      let dep = (get_coord p1 coord, get_coord p2 coord) in
      List.fold_left (fun (i, a) e0 ->
        let e = get_coord e0 coord in (min e i, max e a)) dep l
    in

    let (minx, maxx) = minmax X_AXIS pts_list
    and (miny, maxy) = minmax Y_AXIS pts_list
    and (minz, maxz) = minmax Z_AXIS pts_list in
    let cc i a = (a +. i) /. 2. in
    let r = max (maxx -. minx) (maxy -. miny) in
    rs <- max r (maxz -. minz) ;
    extreme_min <- (minx, miny, minz) ;
    extreme_max <- (maxx, maxy, maxz) ;
    let new_extents = self#scale_point (-.(cc minx maxx), -.(cc miny maxy),
                        -.(cc minz maxz)) in
    if new_extents<>extents then begin
      extents<-new_extents ; self#setup
    end
      end

      (* Volume simple du type secteur ou seul le contour et les niveaux *)
      (* inf et sup suffisent *)
    method add_object_volume_simple contour zmin zmax color filled =
      (* Le contour doit etre oriente dans le sens contre-horaire (cull_face) *)
      let contour =
    if poly_test_ccw contour = CW then contour else List.rev contour in
      let l0 = geom_close_poly ((List.map (fun p -> [glpoint3d_of_pt_2d zmin p;
                             glpoint3d_of_pt_2d zmax p])
                ) contour) in

      (* Triangulation ou pas des faces superieures et inferieures *)
      let (down, up) =
    if poly_test_convex contour = CONVEX then
      (NO_TRI (List.map (fun l -> List.hd l) l0),
       NO_TRI (List.rev_map (fun l -> List.hd (List.tl l)) l0))
    else begin
      if use_fans_for_tesselation then begin
        let fans = Geometry_2d.tesselation_fans contour in
        let l1 = List.map (List.map (glpoint3d_of_pt_2d zmin)) fans
        and l2 = List.map (fun lst ->
          let l = List.map (glpoint3d_of_pt_2d zmax) lst in
          (* Le premier point ne doit pas se trouver en dernier *)
          (* car c'est le pivot du triangle_fan *)
          (List.hd l)::(List.rev (List.tl l))) fans in
        (TRI_WITH_FANS l1, TRI_WITH_FANS l2)
      end else begin
        let triangles = List.flatten (Geometry_2d.tesselation contour) in
        let l1 = List.map (glpoint3d_of_pt_2d zmin) triangles
        and l2 = List.rev_map (glpoint3d_of_pt_2d zmax) triangles in
        (TRI_STD l1, TRI_STD l2)
      end
    end
      in
      self#add_object (VOLUME1_3D {vol3d_contour = List.flatten l0;
                   vol3d_up      = up;
                   vol3d_down    = down;
                   vol3d_color   = color;
                   vol3d_filled  = filled})
    (* Enveloppe 3D : faces laterales liant un contour_haut et un contour_bas *)
    (* 2 contours = meme nombre de points, oriente dans le sens contre-horaire *)
    method add_object_enveloppe contour_haut contour_bas color filled =
      let add_p p_bas p_haut res =
    (glpoint3d_of_pt_3d p_bas)::(glpoint3d_of_pt_3d p_haut)::res
      in
      let cw_poly c =
    let contour_2d = List.map (pt_3d_to_pt_2d T_Z3D) c in
    if (poly_test_ccw contour_2d = CW) then c else List.rev c
      in
      let l_bas =  geom_close_poly (cw_poly contour_bas) in
      let l_haut = geom_close_poly (cw_poly  contour_haut) in
      let l0 =
    try List.fold_right2 add_p l_bas l_haut []
    with x-> Printf.printf "\nadd_object_enveloppe.fold... : "; raise x
      in
      try
    self#add_object (ENVELOPPE_3D {env3d_contour = l0;
                       env3d_color   = color;
                       env3d_filled  = filled})
      with x ->
    Printf.printf "\nadd_object_enveloppe. self#add_object "; raise x

      (* Enveloppe 3D : faces laterales liant un contour_haut et un contour_bas *)
      (* 2 contours = meme nombre de points, oriente dans le sens contre-horaire *)
    method add_object_enveloppe_double contour_haut contour_bas
    color_out color_in filled =
      let add_p p_bas p_haut res =
    (glpoint3d_of_pt_3d p_bas)::(glpoint3d_of_pt_3d p_haut)::res
      in
      let cw_poly c =
    let contour_2d = List.map (pt_3d_to_pt_2d T_Z3D) c in
    if (poly_test_ccw contour_2d = CW) then c else List.rev c
      in
      let l_bas =  geom_close_poly (cw_poly contour_bas) in
      let l_haut = geom_close_poly (cw_poly  contour_haut) in
      let l0 =
    try List.fold_right2 add_p l_bas l_haut []
    with x-> Printf.printf "\nadd_object_enveloppe.fold... : "; raise x
      in
      let l_inside =
    try List.fold_right2 add_p (List.rev l_bas) (List.rev l_haut) []
    with x-> Printf.printf "\nadd_object_enveloppe.foldinside... : "; raise x
      in
      try
    self#add_object (ENVELOPPE_3D_DOUBLE {env3d_double_contour_out = l0;
                          env3d_double_contour_in  = l_inside;
                          env3d_double_color_out   = color_out;
                          env3d_double_color_in    = color_in;
                          env3d_double_filled      = filled})
      with x ->
    Printf.printf "\nadd_object_enveloppe. self#add_object "; raise x

      (* Fleche (flux) dont la pointe est placee en pt0 si sens est vrai *)
      (* Ici, inutile de tesseler les faces inf et sup *)
    method add_object_arrow pt0 vdir sens ep lg color filled
    arrow_type =
      let pts =
    if arrow_type=ARROW1 then
      [(0., 0.); (2.*.ep, ep); (2.*.ep, ep/.2.); (lg, ep/.2.);
       (lg, (-.ep)/.2.); (2.*.ep, (-.ep)/.2.); (2.*.ep, -.ep)]
    else
      [(0., 0.); (2.5*.ep, ep); (2.*.ep, ep/.2.); (lg, ep/.2.);
       (lg, (-.ep)/.2.); (2.*.ep, (-.ep)/.2.); (2.5*.ep, -.ep)]
      in

      let pts = if sens then pts else List.map (fun (x, y) -> (x-.lg, y)) pts in

      let pts = List.map (fun (x, y) -> {x2D=x; y2D=y}) pts in

      let pts = if poly_test_ccw pts = CW then pts else List.rev pts in
      let l = List.map (fun p ->
    [glpoint3d_of_pt_2d ((-.ep)/.2.) p; glpoint3d_of_pt_2d (ep/.2.) p]) pts in
      let dd =
    if sens then Geometry_3d.vect_make pt0 vdir
    else Geometry_3d.vect_make vdir pt0
      in
      let h = Geometry_3d.vect_norm dd
      and d = sqrt(dd.x3D*.dd.x3D+.dd.y3D*.dd.y3D) in
      let alpha =
    if dd.y3D>0. then acos (dd.x3D/.d) else -. (acos (dd.x3D/.d))
      in
      let beta =
    if dd.z3D>0. then acos (d/.h) else  -.(acos (d/.h))
      in

      self#add_object (ARROW_3D {arr3d_contour  = geom_close_poly l;
                 arr3d_pt       = glpoint3d_of_pt_3d pt0 ;
                 arr3d_vect     = (dd.y3D, -.dd.x3D, 0.) ;
                 arr3d_angle_xy = rad2deg beta ;
                 arr3d_angle_z  = rad2deg alpha ;
                 arr3d_color    = color;
                 arr3d_filled   = filled})

    method add_object_outline contour cin cout filled =
      let l = geom_close_poly (glpoint3d_of_pt_3d_lst contour) in
      self#add_object (OUTLINE_3D {out3d_contour   = l ;
                   out3d_color_in  = cin ;
                   out3d_color_out = cout ;
                   out3d_filled    = filled})

    method add_object_line l color line_width with_bars fill =
      self#add_object (LINE_3D {line3d_points    = glpoint3d_of_pt_3d_lst l;
                line3d_width     = line_width;
                line3d_color     = color;
                line3d_with_bars = with_bars;
                line3d_filled    = fill})

    method add_object_point pos pos2 name color with_name =
      self#add_object (POINT_3D {p3d_pos       = glpoint3d_of_pt_3d pos;
                 p3d_pos2      = glpoint3d_of_pt_3d pos2;
                 p3d_name      = name;
                 p3d_with_name = with_name;
                 p3d_color     = color})

    method add_object_surface_with_texture tab texture_id =
      let t = Array.map (Array.map glpoint3d_of_pt_3d) tab in
      self#add_object (SURFACE_3D_TEX {s3d_tex_pts = t;
                       s3d_tex_texture_id = texture_id})

    method add_object_surface tab fill =
      let t = Array.map (Array.map (fun (p, c) -> (glpoint3d_of_pt_3d p, c))) tab in
      self#add_object (SURFACE_3D {s3d_pts = t; s3d_filled = fill})

    (* cree l'objet rosace *)
    method private create_rosace =
      self#make_current ;
      let compiled = GlList.create `compile in
      GlDraw.line_width 2.0 ;
      GlDraw.color color_rosace ;
      GlDraw.begins `line_strip ;
      List.iter GlDraw.vertex2 [(0.0, -0.05); (0.0, 0.05)] ;
      GlDraw.ends () ;
      GlDraw.begins `line_strip ;
      List.iter GlDraw.vertex2 [(-0.05, 0.0); (0.05, 0.0)] ;
      GlDraw.ends () ;
      GlDraw.begins `line_strip ;
      List.iter GlDraw.vertex2 [(-0.01, 0.04); (0.0, 0.05); (0.01, 0.04)] ;
      GlDraw.ends () ;
      if fonts_available then begin
    (* Affichage du Nord sur la rosace si la fonte est disponible *)
    GlPix.raster_pos ~x:(-.0.01) ~y:0.07 ~z:0.0 () ;
    Gtkgl_Hack.gl_print_string fontbase "N"
      end ;
      GlList.ends () ;
      rosace <- Some compiled ;
      compiled

    (* initialisation lors de la creation du widget *)
    method private init_func () =
      if not done_init then begin
    do_msg "Init 3D" ;
    List.iter Gl.enable [`depth_test; `cull_face] ;
    GlDraw.cull_face `back;
    GlDraw.front_face `ccw;

    List.iter (if use_lights then Gl.enable else Gl.disable) lights ;
    GlDraw.shade_model (if use_smooth then `smooth else `flat) ;

    if fonts_available then fontbase <- load_bitmap_font "8x13" ;

    GlPix.store (`unpack_alignment 1);
    List.iter (GlTex.parameter ~target:`texture_2d)
      [ `wrap_s `repeat; `wrap_t `repeat; `mag_filter `linear; `min_filter `linear ];
    GlTex.env (`mode `decal);

    done_init <- true
      end

    method private reshape_func ~width:w ~height:h =
      if not done_init then self#init_func () ;
      do_msg (Printf.sprintf "Reshape 3D w=%d h=%d" w h) ;
      width <- w; height <- h ;
      GlDraw.viewport ~x:0 ~y:0 ~w ~h;
      self#setup

    (* met a jour de la vue et de la source de lumiere *)
    method private setup =
      do_msg "Setup" ;
      GlMat.mode `projection;
      GlMat.load_identity ();
      let aspect = float width /. float height and view_fovs = 1. in
      GluMat.perspective ~fovy:(45. *. view_fovs) ~aspect
    ~z:(0.1, (rs*.sqrt(2.)+.1.));

      GlMat.mode `modelview;
      GlMat.load_identity ();

      (* Deplace et tourne la position de l'utilisateur *)
      GlMat.translate3 depl ;
      rotate_all rot ;

      (* Place les objets au centre de la scene *)
      GlMat.translate3 extents ;

      (* Positionnement de la lumiere *)
      if use_lights then begin
    GlMat.push ();
    rotate_all lightrot ;
    let (x, y, z)= lightpos in
    List.iter (GlLight.light ~num:0) [`position (x, y, z, 1.);
                      `ambient  (1., 1., 1., 1.);
                      `diffuse  (1., 1., 1., 1.)] ;
    GlMat.pop ()
      end ;

      self#set_status

    method set_name n        = name <- n; self#display_func
    method set_show_name set = show_name <- set; self#display_func

    method display = fun o ->
      GlList.call (self#get_object o).o_compiled; Gl.flush (); area#swap_buffers ()
    (* force l'affichage (apres ajout d'un objet par exemple) *)
    method display_func =
      do_msg "Display 3D" ;
      self#make_current ;
      (* Efface l'ecran *)
      GlClear.color back_color ~alpha:0.0; GlClear.clear [`color;`depth];
      (* Passage des objets *)
      List.iter (fun o -> if o.o_show then GlList.call o.o_compiled) objects ;

      let aspect = float width /. float height in

      (* Affichage du nom si c'est demande *)
      if fonts_available && name<>"" && show_name then begin
    GlMat.push ();
    GlMat.load_identity ();
    set_color (1., 1., 1.) ;
    GlPix.raster_pos ~x:(-.4.*.aspect) ~y:(4.) ~z:(-.10.0) () ;
    Gtkgl_Hack.gl_print_string fontbase name ;
    GlMat.pop ()
      end ;

      (* Affichage de la rosace si necessaire *)
      if show_rosace then begin
    (* Creation de la rosace si ca n'est pas deja fait... *)
    let r = match rosace with None -> self#create_rosace|Some r -> r in
    GlMat.push ();
    GlMat.load_identity ();
    GlMat.translate3 (-.0.5*.aspect, 0.5, -.1.5) ;
    rotate_some rot [X_AXIS; Z_AXIS] ;
    GlList.call r ;
    GlMat.pop ()
      end ;

      (* Affichage de la sphere representant la lumiere *)
      if show_light then begin
    GlMat.push ();
    rotate_all lightrot ;
    GlMat.translate3 lightpos;
    set_color glcolor_white ;
    let radius = 0.03 in
    GluQuadric.sphere ~radius ~stacks:5 ~slices:5 ();
    GlMat.pop ()
      end ;

      (* Affichage *)
      Gl.flush (); area#swap_buffers ()


    (* [mouse_press ev] traite un evenement correspondant a l'appui sur un bouton *)
    method private mouse_press ev =
      let mouse_pos = Gtk_tools.get_mouse_pos_click ev in
      match (Gtk_tools.test_mouse_but ev) with
    Gtk_tools.B_GAUCHE ->
      self#set_cursor cursor_rotate ;
      current_action <- (ACTION_ROTATE mouse_pos); true
      | Gtk_tools.B_MILIEU ->
      current_action <- (ACTION_ZOOM mouse_pos); true
      | Gtk_tools.B_DROIT  -> false
      | _ -> false

        (* [mouse_move ev] traite les mouvements souris *)
    method private mouse_move ev =
      area#misc#grab_focus () ;
      let mouse_pos = Gtk_tools.get_mouse_pos_move ev in
      match current_action with
    ACTION_NONE -> false
      | ACTION_ZOOM old_pos ->
      let dy = (snd mouse_pos)-(snd old_pos) in
      self#set_cursor (if dy<0 then cursor_zoom_up else cursor_zoom_down) ;
      self#incr_dist (dist_incr*.(float_of_int dy)) ;
      current_action <- (ACTION_ZOOM mouse_pos) ; true
      | ACTION_ROTATE old_pos ->
      let dz = (fst mouse_pos)-(fst old_pos)
      and dx = (snd mouse_pos)-(snd old_pos) in
      let r = add_coord_360 rot X_AXIS (float_of_int dx) in
      self#rotate_view (add_coord_360 r Z_AXIS (float_of_int dz)) ;
      current_action <- (ACTION_ROTATE mouse_pos) ; true

        (* [mouse_release ev] traite un evenement de relachement de bouton *)
    method private mouse_release _ev =
      (match current_action with ACTION_NONE -> () | _ -> self#reset_cursor) ;
      current_action <- ACTION_NONE ;
      true

    (* Mouvement de la molette de la souris sous Windows *)
    method private mouse_wheel ev =
      match GdkEvent.Scroll.direction ev with
    `UP    -> self#incr_dist (-.dist_incr) ; true
      | `DOWN  -> self#incr_dist dist_incr ; true
      | `LEFT  -> false
      | `RIGHT -> false

    method private start_stop_animation =
      match animation_timer with
    None ->
      let timeout _ = self#incr_rotz rot_anim; true in
      animation_timer <- Some (Timeout.add ~ms:tps_anim ~callback:timeout)
      | Some t -> Timeout.remove t ; animation_timer <- None

        (* [key_pressed key] teste la touche pressee dans la zone de dessin
           et effectue l'action associee le cas echeant *)
    method private key_pressed key =
      let keys_list =
    [([_Page_Up],   fun () -> self#incr_dist (-.dist_incr)) ;
     ([_Page_Down], fun () -> self#incr_dist dist_incr) ;
     ([_KP_Down; _KP_2],  fun () -> self#incr_rotx rot_incr) ;
     ([_KP_Up; _KP_8],    fun () -> self#incr_rotx (-.rot_incr)) ;
     ([_KP_Left; _KP_4],  fun () -> self#incr_rotz (-.rot_incr)) ;
     ([_KP_Right; _KP_6], fun () -> self#incr_rotz rot_incr) ;
     ([_Down],      fun () -> self#move_y (dist_incr/.3.)) ;
     ([_Up],        fun () -> self#move_y ((-.dist_incr)/.3.)) ;
     ([_Left],      fun () -> self#move_x (dist_incr/.3.)) ;
     ([_Right],     fun () -> self#move_x ((-.dist_incr)/.3.)) ;
     ([_l],         fun () -> self#lights_switch) ;
     ([_s],         fun () -> self#smooth_switch) ;
     ([_r],         fun () -> self#rosace_switch) ;
     ([_Home],      fun () -> self#rotate_view pt_null) ;
     ([_a],         fun () -> self#incr_light_rot rot_incr) ;
     ([_z],         fun () -> self#incr_light_rot (-.rot_incr)) ;
     ([_L],         fun () -> show_light <- not show_light; self#change_and_redraw) ;
     ([_space],     fun () -> self#start_stop_animation);
     ([_Escape],    fun () -> self#redo_all);
     ([_i], fun () -> Printf.printf "%s" (get_gl_infos ()); flush stdout);
     ([_n],         fun () -> self#set_show_name (not show_name))] in
      (* Recherche la fonction associee a la touche presse s'il y en a une *)
      let rec check_keys lst =
    match lst with
      (keys, func)::reste ->
        if List.mem key keys then begin func ();true end else check_keys reste
    | [] -> false
      in
      check_keys keys_list

    (* Modification de la position de l'utilisateur et des angles de vue *)
    method incr_dist d = self#move_view   (add_coord depl Z_AXIS d)
    method incr_rotx d = self#rotate_view (add_coord_360 rot X_AXIS d)
    method incr_rotz d = self#rotate_view (add_coord_360 rot Z_AXIS d)

    method move_x d = self#move_view (add_coord depl X_AXIS d)
    method move_y d = self#move_view (add_coord depl Y_AXIS d)

    (* tourne la lumiere *)
    method incr_light_rot d = lightrot<-add_coord_360 lightrot Z_AXIS d;
      self#change_and_redraw

    (* Manipulations generales des objets *)
    method private get_object id =
      try List.find (fun o -> o.o_id=id) objects
      with Not_found -> raise (NO_SUCH_3D_OBJECT id)
    method delete_object id =
      let found = ref None in
      let new_l = List.fold_left (fun l obj ->
        if obj.o_id=id then begin found:=Some obj; l end else obj::l) [] objects in
      match !found with
        None -> raise (NO_SUCH_3D_OBJECT id)
      | Some obj -> objects <- List.rev new_l; GlList.delete obj.o_compiled
    method object_set_color id new_color =
      let o = self#get_object id in
      set_object_color o.o_obj new_color; self#make_and_compile o
    method object_get_color id =
      get_object_color (self#get_object id).o_obj
    method object_set_visibility id visible =
      let o = self#get_object id in o.o_show <- visible; self#make_and_compile o
    method object_get_visibility id = (self#get_object id).o_show
    method object_set_fill id filled =
      let o = self#get_object id in
      set_object_fill o.o_obj filled; self#make_and_compile o
    method object_get_fill id =
      get_object_fill (self#get_object id).o_obj

    (* Fonctions specifiques a certains objets *)
    method line_get_width id =
      get_line_width (self#get_object id).o_obj id
    method line_set_width id width =
      let o = self#get_object id in
      set_line_width o.o_obj width id; self#make_and_compile o
    method line_get_with_bars id =
      get_line_bars (self#get_object id).o_obj id
    method line_set_with_bars id withbars =
      let o = self#get_object id in
      set_line_bars o.o_obj withbars id; self#make_and_compile o
    method outline_set_in_color id new_color =
      let o = self#get_object id in
      set_outline_in_color o.o_obj new_color id; self#make_and_compile o
    method outline_get_in_color id =
      get_outline_in_color (self#get_object id).o_obj id
    method point_get_with_name id =
      get_point_name (self#get_object id).o_obj id
    method point_set_with_name id withname =
      let o = self#get_object id in
      set_point_name o.o_obj withname id; self#make_and_compile o

    method destroy_all_objects =
      List.iter (fun o -> GlList.delete o.o_compiled) objects ;
      objects <- [] ;
      (match rosace with None -> () | Some r -> GlList.delete r) ;
      unload_bitmap_font fontbase

    method private redo_all =
      self#setup; self#recompile_all_objects;
      (match rosace with None -> () | Some r -> GlList.delete r) ;
      if show_rosace then ignore(self#create_rosace) ;
      self#display_func

    method set_back_color c = back_color <- c ; self#display_func

    initializer
      ignore(area#connect#realize ~callback:self#init_func) ;
      ignore(area#connect#display ~callback:(fun () -> self#display_func)) ;
      ignore(area#connect#reshape ~callback:self#reshape_func) ;
      area#misc#realize ();

      incr nb_objects ;

      (* Indispensable pour que lorsque l'on entre dans la fenetre, les *)
      (* prochaines commandes OpenGL soient bien appliquees dans la vue *)
      (* correspondante dans le cas ou plusieurs vues ont ete ouvertes  *)
      ignore(area#event#connect#focus_in (fun _ -> self#make_current; false)) ;

      (* Callbacks des evenements souris *)
      Gtk_tools_GL.glarea_mouse_connect area
    self#mouse_press self#mouse_move self#mouse_release ;

      let scroll_cb = fun ev ->
    match GdkEvent.get_type ev with
    | `SCROLL -> self#mouse_wheel (GdkEvent.Scroll.cast ev)
    | _ -> false in

      (* Reactions aux mouvements de la molette souris *)
      ignore(area#event#connect#any ~callback:scroll_cb) ;

      (* Attachement des callbacks pour les evenements clavier *)
      Gtk_tools_GL.glarea_key_connect area self#key_pressed (fun _k -> (); false)
  end

(* =============================== FIN ========================================= *)
