lace_opengl_0.1.0_672a6415/source/lean/io/opengl-io.adb

with
     openGL.Images,
     openGL.Viewport,
     openGL.Tasks,
     openGL.Errors,

     GID,

     GL.Binding,
     GL.safe,
     GL.Pointers,

     ada.unchecked_Conversion,
     ada.Calendar,
     ada.Characters.handling,

     System;

package body openGL.IO
is
   use ada.Characters.handling,
       ada.Streams.Stream_IO;

   use type Index_t;


   --------
   --  Face
   --

   function Vertices_of (Self : in Face) return Vertices
   is
   begin
      case Self.Kind
      is
         when Triangle =>   return Self.Tri;
         when Quad     =>   return Self.Quad;
         when Polygon  =>   return Self.Poly.all;
      end case;
   end Vertices_of;



   procedure set_Vertex_in (Self : in out Face;   Which : in long_Index_t;
                                                  To    : in Vertex)
   is
   begin
      case Self.Kind
      is
         when Triangle =>   Self.Tri  (Which) := To;
         when Quad     =>   Self.Quad (Which) := To;
         when Polygon  =>   Self.Poly (Which) := To;
      end case;
   end set_Vertex_in;



   procedure destroy (Self : in out Face)
   is
      procedure free is new ada.unchecked_Deallocation (Vertices, Vertices_view);
   begin
      if Self.Kind = Polygon
      then
         free (Self.Poly);
      end if;
   end destroy;


   -------------
   -- Operations
   --

   function current_Frame return Image
   is
      use GL,
          GL.Binding,
          GL.Pointers,
          Texture;

      Extent  : constant Extent_2d := openGL.Viewport.Extent;
      Frame   :          Image (1 .. Index_t (Extent.Width),
                                1 .. Index_t (Extent.Height));
   begin
      glReadPixels (0, 0,
                    GLsizei (Extent.Width),
                    GLsizei (Extent.Height),
                    to_GL (Format' (Texture.RGB)),
                    GL_UNSIGNED_BYTE,
                    to_GLvoid_access (Frame (1, 1).Red'Access));
      return Frame;
   end current_Frame;


   ---------
   --  Forge
   --

   function to_height_Map (image_Filename : in asset_Name;
                           Scale          : in Real  := 1.0) return height_Map_view
   is
      File    :          Ada.Streams.Stream_IO.File_Type;
      Image   :          GID.Image_Descriptor;
      up_Name : constant String              := To_Upper (to_String (image_Filename));

      next_Frame : ada.Calendar.Day_Duration := 0.0;

   begin
      open (File, in_File, to_String (image_Filename));

      GID.load_Image_Header (Image,
                             Stream (File).all,
                             try_tga =>          image_Filename'Length >= 4
                                        and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
      declare
         image_Width  : constant Positive := GID.Pixel_Width  (Image);
         image_Height : constant Positive := GID.Pixel_Height (Image);

         the_Heights  : constant access height_Map := new height_Map' (1 .. Index_t (image_height) =>
                                                                         (1 .. Index_t (image_width) => <>));
         procedure load_raw_Image
         is
            subtype primary_Color_range is GL.GLubyte;

            Row, Col : Index_t;


            procedure set_X_Y (x, y : Natural)
            is
            begin
               Col := Index_t (X + 1);
               Row := Index_t (Y + 1);
            end Set_X_Y;


            procedure put_Pixel (Red, Green, Blue : primary_Color_range;
                                 Alpha            : primary_Color_range)
            is
               pragma Warnings (Off, alpha); -- Alpha is just ignored.
               use type GL.GLubyte, Real;
            begin
               the_Heights (Row, Col) :=   (Real (Red) + Real (Green) + Real (Blue))
                                         / (3.0 * 255.0)
                                         * Scale;

               if Col = Index_t (image_Width)
               then
                  Row := Row + 1;
                  Col := 1;
               else
                  Col := Col + 1;
               end if;

               --  ^ GID requires us to look to next pixel on the right for next time.
            end put_Pixel;


            procedure Feedback (Percents : Natural) is null;

            procedure load_Image is new GID.load_Image_contents (primary_Color_range,
                                                                 set_X_Y,
                                                                 put_Pixel,
                                                                 Feedback,
                                                                 GID.fast);
         begin
            load_Image (Image, next_Frame);
         end load_Raw_image;

      begin
         load_raw_Image;
         close (File);

         return the_Heights.all'unchecked_Access;
      end;
   end to_height_Map;



   function fetch_Image (Stream  : in ada.Streams.Stream_IO.Stream_access;
                         try_TGA : in Boolean) return Image
   is
   begin
      return Images.fetch_Image (Stream, try_TGA);
   end fetch_Image;



   function to_Image (image_Filename : in asset_Name)  return Image
   is
      File    :          ada.Streams.Stream_IO.File_type;
      up_Name : constant String := to_Upper (to_String (image_Filename));
   begin
      open (File, In_File, to_String (image_Filename));

      declare
         the_Image : constant Image
           := fetch_Image (Stream (File),
                           try_TGA =>          image_Filename'Length >= 4
                                      and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
      begin
         close (File);
         return the_Image;
      end;
   end to_Image;



   function to_lucid_Image (image_Filename : in asset_Name) return lucid_Image
   is
      Unused : aliased Boolean;
   begin
      return to_lucid_Image (image_Filename, Unused'Access);
   end to_lucid_Image;



   function to_lucid_Image (image_Filename : in     asset_Name;
                            is_Lucid       : access Boolean) return lucid_Image
   is
      File      :          ada.Streams.Stream_IO.File_type;
      the_Image :          GID.Image_Descriptor;
      up_Name   : constant String := to_Upper (to_String (image_Filename));

      next_Frame :          ada.Calendar.Day_Duration := 0.0;

   begin
      open (File, in_File, to_String (image_Filename));

      GID.load_Image_Header (the_Image,
                             Stream (File).all,
                             try_TGA =>          image_Filename'Length >= 4
                                        and then up_Name (up_Name'Last - 3 .. up_Name'Last) = ".TGA");
      declare
         image_Width  : constant Positive := GID.Pixel_Width  (the_Image);
         image_Height : constant Positive := GID.Pixel_Height (the_Image);

         Frame : lucid_Image (1 .. Index_t (image_Height),
                              1 .. Index_t (image_Width));

         procedure load_raw_Image
         is
            subtype primary_Color_range is GL.GLubyte;

            Row, Col : Index_t;


            procedure set_X_Y (X, Y : Natural)
            is
            begin
               Col := Index_t (X + 1);
               Row := Index_t (Y + 1);
            end set_X_Y;


            procedure put_Pixel (Red, Green, Blue : primary_Color_range;
                                 Alpha            : primary_Color_range)
            is
               use type GL.GLubyte, Real;
            begin
               Frame (Row, Col) := ((Red, Green, Blue), Alpha);

               if Col = Index_t (image_Width)
               then     -- GID requires us to look to next pixel on the right for next time.
                  Row := Row + 1;
                  Col := 1;
               else
                  Col := Col + 1;
               end if;

               if Alpha /= opaque_Value
               then
                  is_Lucid.all := True;
               end if;
            end put_Pixel;


            procedure Feedback (Percents : Natural) is null;

            procedure load_Image is new GID.load_Image_contents (primary_Color_range,
                                                                 set_X_Y,
                                                                 put_Pixel,
                                                                 Feedback,
                                                                 GID.fast);
         begin
            load_Image (the_Image, next_Frame);
         end Load_raw_image;

      begin
         is_Lucid.all := False;

         load_raw_Image;
         close (File);

         return Frame;
      end;
   end to_lucid_Image;



   function to_Texture (image_Filename : in asset_Name) return Texture.Object
   is
      use Texture;

      is_Lucid        : aliased  Boolean;
      the_lucid_Image : constant lucid_Image    := to_lucid_Image (image_Filename, is_Lucid'Access);
      the_Texture     :          Texture.Object := Forge.to_Texture (Texture.Dimensions' (the_lucid_Image'Length (2),
                                                                                          the_lucid_Image'Length (1)));
   begin
      if is_Lucid
      then
         set_Image (the_Texture, the_lucid_Image);
      else
         declare
            the_opaque_Image : constant Image := to_Image (the_lucid_Image);
         begin
            set_Image (the_Texture, the_opaque_Image);
         end;
      end if;

      return the_Texture;
   end to_Texture;



   procedure destroy (Self : in out Model)
   is
      procedure free is new ada.unchecked_Deallocation (bone_Weights,       bone_Weights_view);
      procedure free is new ada.unchecked_Deallocation (bone_Weights_array, bone_Weights_array_view);
   begin
      free (Self.Sites);
      free (Self.Coords);
      free (Self.Normals);

      if Self.Weights /= null
      then
         for Each in Self.Weights'Range
         loop
            free (Self.Weights (Each));
         end loop;

         free (Self.Weights);
      end if;

      for Each in Self.Faces'Range
      loop
         destroy (Self.Faces (Each));
      end loop;

      free (Self.Faces);
   end destroy;


   --------------------------------
   --- Screenshot and Video Capture
   --

   type U8  is mod 2 **  8;   for U8 'Size use  8;
   type U16 is mod 2 ** 16;   for U16'Size use 16;
   type U32 is mod 2 ** 32;   for U32'Size use 32;

   type I32 is range -2 ** 31 .. 2 ** 31 - 1;
   for  I32'Size use 32;


   generic
      type Number is mod <>;
      S : Stream_Access;
   procedure write_Intel_x86_Number (N : in Number);


   procedure write_Intel_x86_Number (N : in Number)
   is
      M     :          Number  := N;
      Bytes : constant Integer := Number'Size / 8;
   begin
      for i in 1 .. bytes
      loop
         U8'write (S, U8 (M mod 256));
         M := M / 256;
      end loop;
   end write_Intel_x86_Number;



   procedure write_raw_BGR_Frame (Stream        : Stream_Access;
                                  Width, Height : Natural)
   is
      use GL,
          GL.Binding,
          openGL.Texture;

      -- 4-byte padding for .bmp/.avi formats is the same as GL's default
      -- padding: see glPixelStore, GL_[UN]PACK_ALIGNMENT = 4 as initial value.
      -- http://www.openGL.org/sdk/docs/man/xhtml/glPixelStore.xml
      --
      padded_row_Size : constant Positive := 4 * Integer (Float'Ceiling (Float (Width) * 3.0 / 4.0));
      -- (in bytes)


      type temp_Bitmap_type is array (Natural range <>) of aliased gl.GLUbyte;

      PicData: temp_Bitmap_type (0 .. (padded_row_Size + 4) * (Height + 4) - 1);
      -- No dynamic allocation needed!
      -- The "+4" are there to avoid parity address problems when GL writes to the buffer.

      type Loc_pointer is new gl.safe.GLvoid_Pointer;

      function convert is new ada.unchecked_Conversion (System.Address, Loc_pointer);
      -- This method is functionally identical as GNAT's Unrestricted_Access
      -- but has no type safety (cf GNAT Docs).

      pragma no_strict_Aliasing (Loc_pointer);     -- Recommended by GNAT 2005+.

      pPicData :          Loc_pointer;
      data_Max : constant Integer    := padded_row_Size * Height - 1;

      -- Workaround for the severe xxx'Read xxx'Write performance
      -- problems in the GNAT and ObjectAda compilers (as in 2009)
      -- This is possible if and only if Byte = Stream_Element and
      -- arrays types are both packed the same way.
      --
      type Byte_array is array (Integer range <>) of aliased GLUByte;

      subtype Size_Test_a is Byte_array (1 .. 19);
      subtype Size_Test_b is ada.Streams.Stream_Element_array (1 .. 19);

      workaround_possible: constant Boolean :=          Size_Test_a'Size      = Size_Test_b'Size
                                               and then Size_Test_a'Alignment = Size_Test_b'Alignment;
   begin
      Tasks.check;

      pPicData:= Convert (PicData (0)'Address);

      GLReadPixels (0, 0,
                    GLSizei (Width),
                    GLSizei (Height),
                    to_GL (Texture.BGR),
                    GL.GL_UNSIGNED_BYTE,
                    pPicData);
      Errors.log;

      if workaround_possible
      then
         declare
            use ada.Streams;

            SE_Buffer : Stream_Element_array (0 .. Stream_Element_Offset (PicData'Last));

            for SE_Buffer'Address use PicData'Address;
            pragma import (Ada, SE_Buffer);
         begin
            ada.Streams.write (Stream.all, SE_Buffer (0 .. Stream_Element_Offset (data_Max)));
         end;

      else
         temp_Bitmap_type'write (Stream, PicData (0 .. data_Max));
      end if;

   end write_raw_BGR_Frame;



   procedure write_raw_BGRA_Frame (Stream        : Stream_access;
                                   Width, Height : Natural)
   is
      use GL,
          GL.Binding,
          Texture;

      -- 4-byte padding for .bmp/.avi formats is the same as GL's default
      -- padding: see glPixelStore, GL_[UN]PACK_ALIGNMENT = 4 as initial value.
      -- http://www.openGL.org/sdk/docs/man/xhtml/glPixelStore.xml
      --
      padded_row_Size : constant Positive:= 4 * Integer (Float'Ceiling (Float (Width)));
      -- (in bytes)

      type temp_Bitmap_type is array (Natural range <>) of aliased gl.GLUbyte;

      PicData: temp_Bitmap_type (0.. (padded_row_size + 4) * (height + 4) - 1);
      -- No dynamic allocation needed!
      -- The "+4" are there to avoid parity address problems when GL writes
      -- to the buffer.

      type Loc_pointer is new gl.safe.GLvoid_Pointer;

      function convert is new ada.unchecked_Conversion (System.Address, Loc_pointer);
      -- This method is functionally identical as GNAT's Unrestricted_Access
      -- but has no type safety (cf GNAT Docs).

      pragma no_strict_Aliasing (loc_pointer); -- Recommended by GNAT 2005+.

      pPicData :          Loc_pointer;
      data_Max : constant Integer    := padded_row_Size * Height - 1;

      -- Workaround for the severe xxx'Read xxx'Write performance
      -- problems in the GNAT and ObjectAda compilers (as in 2009)
      -- This is possible if and only if Byte = Stream_Element and
      -- arrays types are both packed the same way.
      --
      type Byte_array is array (Integer range <>) of aliased GLUByte;

      subtype Size_Test_a is Byte_Array (1..19);
      subtype Size_Test_b is ada.Streams.Stream_Element_array (1 .. 19);

      workaround_possible: constant Boolean :=          Size_Test_a'Size      = Size_Test_b'Size
                                               and then Size_Test_a'Alignment = Size_Test_b'Alignment;
   begin
      Tasks.check;

      pPicData:= convert (PicData (0)'Address);

      GLReadPixels (0, 0,
                    GLSizei (width),
                    GLSizei (height),
                    to_GL (openGL.Texture.BGRA),
                    GL.GL_UNSIGNED_BYTE,
                    pPicData);
      Errors.log;

      if workaround_possible
      then
         declare
            use ada.Streams;

            SE_Buffer : Stream_Element_array (0 .. Stream_Element_Offset (PicData'Last));

            for SE_Buffer'Address use PicData'Address;
            pragma Import (Ada, SE_Buffer);
         begin
            ada.Streams.write (Stream.all, SE_Buffer (0 .. Stream_Element_Offset (data_Max)));
         end;

      else
         temp_Bitmap_type'write (Stream, PicData (0 .. data_Max));
      end if;

   end write_raw_BGRA_Frame;


   -------------
   -- Screenshot
   --

   subtype FXPT2DOT30 is U32;

   type CIEXYZ is
      record
         ciexyzX : FXPT2DOT30;
         ciexyzY : FXPT2DOT30;
         ciexyzZ : FXPT2DOT30;
      end record;

   type CIEXYZTRIPLE is
      record
         ciexyzRed   : CIEXYZ;
         ciexyzGreen : CIEXYZ;
         ciexyzBlue  : CIEXYZ;
      end record;

   type BITMAPFILEHEADER is
      record
         bfType      : U16;
         bfSize      : U32;
         bfReserved1 : U16 := 0;
         bfReserved2 : U16 := 0;
         bfOffBits   : U32;
      end record;
   pragma pack (BITMAPFILEHEADER);
   for          BITMAPFILEHEADER'Size use 8 * 14;

   type BITMAPINFOHEADER is
      record
         biSize          : U32;
         biWidth         : I32;
         biHeight        : I32;
         biPlanes        : U16;
         biBitCount      : U16;
         biCompression   : U32;
         biSizeImage     : U32;
         biXPelsPerMeter : I32 := 0;
         biYPelsPerMeter : I32 := 0;
         biClrUsed       : U32 := 0;
         biClrImportant  : U32 := 0;
      end record;
   pragma pack (BITMAPINFOHEADER);
   for          BITMAPINFOHEADER'Size use 8 * 40;

   type BITMAPV4HEADER is
      record
         Core          : BITMAPINFOHEADER;
         bV4RedMask    : U32;
         bV4GreenMask  : U32;
         bV4BlueMask   : U32;
         bV4AlphaMask  : U32;
         bV4CSType     : U32;
         bV4Endpoints  : CIEXYZTRIPLE;
         bV4GammaRed   : U32;
         bV4GammaGreen : U32;
         bV4GammaBlue  : U32;
      end record;
   pragma pack (BITMAPV4HEADER);
   for          BITMAPV4HEADER'Size use 8 * 108;


   procedure opaque_Screenshot (Filename : in String)
   is
      use GL,
          GL.Binding;

      File       : ada.Streams.Stream_IO.File_Type;
      FileInfo   : BITMAPINFOHEADER;
      FileHeader : BITMAPFILEHEADER;

      Viewport   : array (0 .. 3) of aliased GLint;
   begin
      Tasks.check;

      glGetIntegerv (GL_VIEWPORT,
                     Viewport (0)'Unchecked_Access);
      Errors.log;

      FileHeader.bfType    := 16#4D42#;     -- 'BM'
      FileHeader.bfOffBits :=   BITMAPINFOHEADER'Size / 8
                              + BITMAPFILEHEADER'Size / 8;

      FileInfo.biSize        := BITMAPINFOHEADER'Size / 8;
      FileInfo.biWidth       := I32 (Viewport (2));
      FileInfo.biHeight      := I32 (Viewport (3));
      FileInfo.biPlanes      := 1;
      FileInfo.biBitCount    := 24;
      FileInfo.biCompression := 0;
      FileInfo.biSizeImage   := U32 (  4
                                     * Integer (Float'Ceiling (Float (FileInfo.biWidth) * 3.0 / 4.0))
                                     * Integer (FileInfo.biHeight));
      FileHeader.bfSize      := FileHeader.bfOffBits + FileInfo.biSizeImage;

      create (File, out_File, Filename);
      declare
         procedure write_Intel is new write_Intel_x86_Number (U16, Stream (File));
         procedure write_Intel is new write_Intel_x86_Number (U32, Stream (File));
         function  convert     is new ada.unchecked_Conversion (I32, U32);
      begin
         -- ** Endian-safe: ** --
         write_Intel (FileHeader.bfType);
         write_Intel (FileHeader.bfSize);
         write_Intel (FileHeader.bfReserved1);
         write_Intel (FileHeader.bfReserved2);
         write_Intel (FileHeader.bfOffBits);
         --
         write_Intel (         FileInfo.biSize);
         write_Intel (convert (FileInfo.biWidth));
         write_Intel (convert (FileInfo.biHeight));
         write_Intel (         FileInfo.biPlanes);
         write_Intel (         FileInfo.biBitCount);
         write_Intel (         FileInfo.biCompression);
         write_Intel (         FileInfo.biSizeImage);
         write_Intel (convert (FileInfo.biXPelsPerMeter));
         write_Intel (convert (FileInfo.biYPelsPerMeter));
         write_Intel (         FileInfo.biClrUsed);
         write_Intel (         FileInfo.biClrImportant);
         --
         write_raw_BGR_Frame (Stream (File),
                              Integer (Viewport (2)),
                              Integer (Viewport (3)));
         Close (File);

      exception
         when others =>
            Close (File);
            raise;
      end;
   end opaque_Screenshot;



   procedure lucid_Screenshot (Filename : in String)
   is
      use GL,
          GL.Binding;

      File        : ada.Streams.Stream_IO.File_type;

      FileHeader  : BITMAPFILEHEADER;
      FileInfo    : BITMAPV4HEADER;

      Viewport    : array (0 .. 3) of aliased GLint;

   begin
      Tasks.check;

      glGetIntegerv (GL_VIEWPORT,
                     Viewport (0)'Unchecked_Access);
      Errors.log;

      FileHeader.bfType    := 16#4D42#;     -- 'BM'
      FileHeader.bfOffBits :=   BITMAPV4HEADER  'Size / 8
                              + BITMAPFILEHEADER'Size / 8;

      FileInfo.Core.biSize        := BITMAPV4HEADER'Size / 8;
      FileInfo.Core.biWidth       := I32 (Viewport (2));
      FileInfo.Core.biHeight      := I32 (Viewport (3));
      FileInfo.Core.biPlanes      :=  1;
      FileInfo.Core.biBitCount    := 32;
      FileInfo.Core.biCompression :=  3;
      FileInfo.Core.biSizeImage   := U32 (  4     -- 4-byte padding for '.bmp/.avi' formats.
                                          * Integer (Float'Ceiling (Float (FileInfo.Core.biWidth)))
                                          * Integer (FileInfo.Core.biHeight));

      FileInfo.bV4RedMask    := 16#00FF0000#;
      FileInfo.bV4GreenMask  := 16#0000FF00#;
      FileInfo.bV4BlueMask   := 16#000000FF#;
      FileInfo.bV4AlphaMask  := 16#FF000000#;
      FileInfo.bV4CSType     := 0;
      FileInfo.bV4Endpoints  := (others => (others => 0));
      FileInfo.bV4GammaRed   := 0;
      FileInfo.bV4GammaGreen := 0;
      FileInfo.bV4GammaBlue  := 0;

      FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.Core.biSizeImage;

      Create (File, out_File, Filename);
      declare
         procedure write_Intel is new write_Intel_x86_Number (U16, Stream (File));
         procedure write_Intel is new write_Intel_x86_Number (U32, Stream (File));
         function  convert     is new ada.unchecked_Conversion (I32, U32);
      begin
         -- ** Endian-safe: ** --
         write_Intel (FileHeader.bfType);
         write_Intel (FileHeader.bfSize);
         write_Intel (FileHeader.bfReserved1);
         write_Intel (FileHeader.bfReserved2);
         write_Intel (FileHeader.bfOffBits);
         --
         write_Intel (         FileInfo.Core.biSize);
         write_Intel (convert (FileInfo.Core.biWidth));
         write_Intel (convert (FileInfo.Core.biHeight));
         write_Intel (         FileInfo.Core.biPlanes);
         write_Intel (         FileInfo.Core.biBitCount);
         write_Intel (         FileInfo.Core.biCompression);
         write_Intel (         FileInfo.Core.biSizeImage);
         write_Intel (convert (FileInfo.Core.biXPelsPerMeter));
         write_Intel (convert (FileInfo.Core.biYPelsPerMeter));
         write_Intel (         FileInfo.Core.biClrUsed);
         write_Intel (         FileInfo.Core.biClrImportant);

         write_Intel (FileInfo.bV4RedMask);
         write_Intel (FileInfo.bV4GreenMask);
         write_Intel (FileInfo.bV4BlueMask);
         write_Intel (FileInfo.bV4AlphaMask);
         write_Intel (FileInfo.bV4CSType);

         write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzX);
         write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzY);
         write_Intel (FileInfo.bV4Endpoints.ciexyzRed.ciexyzZ);

         write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzX);
         write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzY);
         write_Intel (FileInfo.bV4Endpoints.ciexyzGreen.ciexyzZ);

         write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzX);
         write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzY);
         write_Intel (FileInfo.bV4Endpoints.ciexyzBlue.ciexyzZ);

         write_Intel (FileInfo.bV4GammaRed);
         write_Intel (FileInfo.bV4GammaGreen);
         write_Intel (FileInfo.bV4GammaBlue);

         write_raw_BGRA_Frame (Stream (File),
                               Integer (Viewport (2)),
                               Integer (Viewport (3)));
         close (File);

      exception
         when others =>
            Close (File);
            raise;
      end;
   end lucid_Screenshot;



   procedure Screenshot (Filename : in String;   with_Alpha : in Boolean := False)
   is
   begin
      if with_Alpha
      then  lucid_Screenshot (Filename);
      else opaque_Screenshot (Filename);
      end if;
   end Screenshot;


   ----------------
   -- Video Capture
   --

   --  We define global variables since it is not expected
   --  that more that one capture is taken at the same time.
   --
   avi           : ada.Streams.Stream_IO.File_type;
   frames        : Natural;
   rate          : Positive;
   width, height : Positive;
   bmp_size      : U32;

   procedure write_RIFF_Headers
   is
      --  Written 1st time to take place (but # of frames unknown)
      --  Written 2nd time for setting # of frames, sizes, etc.
      --
      calc_bmp_size    : constant U32           := U32 (((width)) * height * 3);
      --  !! stuff to multiple of 4 !!
      index_size       : constant U32           := U32 (frames) * 16;
      movie_size       : constant U32           := 4 + U32 (frames) * (calc_bmp_size + 8);
      second_list_size : constant U32           := 4 + 64 + 48;
      first_list_size  : constant U32           := (4 + 64) + (8 + second_list_size);
      file_size        : constant U32           := 8 + (8 + first_list_size) + (4 + movie_size) + (8 + index_size);
      Stream           : constant Stream_access := ada.Streams.Stream_IO.Stream (avi);

      procedure write_Intel is new write_Intel_x86_Number (U16, Stream);
      procedure write_Intel is new write_Intel_x86_Number (U32, Stream);

      microseconds_per_frame : constant U32 := U32 (1_000_000.0 / long_Float (rate));
   begin
      bmp_size := calc_bmp_size;

      String'write (Stream, "RIFF");
      U32   'write (Stream, file_size);
      String'write (Stream, "AVI ");
      String'write (Stream, "LIST");
      write_Intel  (first_list_size);
      String'write (Stream, "hdrl");
      String'write (Stream, "avih");
      write_Intel  (U32' (56));

      --  Begin of AVI Header
      write_Intel (microseconds_per_frame);
      write_Intel (U32'(0));      -- MaxBytesPerSec
      write_Intel (U32'(0));      -- Reserved1
      write_Intel (U32'(16));     -- Flags (16 = has an index)
      write_Intel (U32 (frames));
      write_Intel (U32'(0));      -- InitialFrames
      write_Intel (U32'(1));      -- Streams
      write_Intel (bmp_size);
      write_Intel (U32 (width));
      write_Intel (U32 (height));
      write_Intel (U32'(0));      -- Scale
      write_Intel (U32'(0));      -- Rate
      write_Intel (U32'(0));      -- Start
      write_Intel (U32'(0));      -- Length
      --  End of AVI Header

      String'write (Stream, "LIST");
      write_Intel  (second_list_size);
      String'write (Stream, "strl");

      --  Begin of Str
      String'write (Stream, "strh");
      write_Intel  (U32'(56));
      String'write (Stream, "vids");
      String'write (Stream, "DIB ");
      write_Intel  (U32'(0));                -- flags
      write_Intel  (U32'(0));                -- priority
      write_Intel  (U32'(0));                -- initial frames
      write_Intel  (microseconds_per_frame); -- Scale
      write_Intel  (U32'(1_000_000));        -- Rate
      write_Intel  (U32'(0));                -- Start
      write_Intel  (U32 (frames));           -- Length
      write_Intel  (bmp_size);               -- SuggestedBufferSize
      write_Intel  (U32'(0));                -- Quality
      write_Intel  (U32'(0));                -- SampleSize
      write_Intel  (U32'(0));
      write_Intel  (U16 (width));
      write_Intel  (U16 (height));
      --  End of Str

      String'write (Stream, "strf");
      write_Intel (U32'(40));

      --  Begin of BMI
      write_Intel (U32'(40));    -- BM header size (like BMP)
      write_Intel (U32 (width));
      write_Intel (U32 (height));
      write_Intel (U16'(1));     -- Planes
      write_Intel (U16'(24));    -- BitCount
      write_Intel (U32'(0));     -- Compression
      write_Intel (bmp_size);    -- SizeImage
      write_Intel (U32'(3780));  -- XPelsPerMeter
      write_Intel (U32'(3780));  -- YPelsPerMeter
      write_Intel (U32'(0));     -- ClrUsed
      write_Intel (U32'(0));     -- ClrImportant
      --  End of BMI

      String'write (Stream, "LIST");
      write_Intel  (movie_size);
      String'write (Stream, "movi");
   end Write_RIFF_headers;



   procedure start_Capture (AVI_Name   : String;
                            frame_Rate : Positive)
   is
      use GL,
          GL.Binding;
      Viewport : array (0 .. 3) of aliased GLint;
   begin
      Tasks.check;

      create (Avi, out_File, AVI_Name);

      Frames := 0;
      Rate   := frame_Rate;

      glGetIntegerv (GL_VIEWPORT,
                     Viewport (0)'unchecked_Access);
      Errors.log;

      Width  := Positive (Viewport (2));
      Height := Positive (Viewport (3));
      --  NB: GL viewport resizing should be blocked during the video capture !
      write_RIFF_Headers;
   end start_Capture;



   procedure capture_Frame
   is
      S : constant Stream_Access := Stream (Avi);
      procedure Write_Intel is new Write_Intel_x86_number (U32, s);
   begin
      String'write        (S, "00db");
      write_Intel         (bmp_Size);
      write_raw_BGR_frame (S, Width, Height);

      Frames := Frames + 1;
   end capture_Frame;



   procedure stop_Capture
   is
      index_Size  : constant U32           := U32 (Frames) * 16;
      S           : constant Stream_Access := Stream (Avi);
      ChunkOffset :          U32           := 4;

      procedure write_Intel is new write_Intel_x86_Number (U32, S);
   begin
      --  Write the index section
      --
      String'write (S, "idx1");
      write_Intel (index_Size);

      for f in 1 .. Frames
      loop
         String'write (S, "00db");
         write_Intel  (U32'(16));     -- Keyframe.
         write_Intel  (ChunkOffset);
         ChunkOffset := ChunkOffset + bmp_Size + 8;
         write_Intel  (bmp_Size);
      end loop;

      Set_Index (avi, 1);     -- Go back to file beginning.
      write_RIFF_Headers;     -- Rewrite headers with correct data.
      close (Avi);
   end stop_Capture;


end openGL.IO;