1. -- 
  2.  -- Input: 
  3.  --   TGA  : Orig. author is Nate Miller (tga.c, 7 - Aug - 1999), vandals1@home.com 
  4.  --   BMP  : from Gautier's SVGA.IO package 
  5.  -- 
  6.  -- Output: 
  7.  --   BMP  : from http://wiki.delphigl.com/index.php/Screenshot (Delphi) 
  8.  --   AVI  : from specification, plus re - using the raw bitmap output from BMP 
  9.  
  10. with Ada.Exceptions;                    use Ada.Exceptions; 
  11. with Ada.Unchecked_Conversion; 
  12. with System; 
  13.  
  14. package body GL.IO is 
  15.  
  16.    use Ada.Streams.Stream_IO; 
  17.  
  18.    type U8  is mod 2 ** 8;   for U8'Size  use 8; 
  19.    type U16 is mod 2 ** 16;  for U16'Size use 16; 
  20.    type U32 is mod 2 ** 32;  for U32'Size use 32; 
  21.  
  22.    type I32 is range -2 ** 31 .. 2 ** 31 - 1; for I32'Size use 32; 
  23.  
  24.    not_yet_implemented  : exception; 
  25.  
  26.    function to_greyscale_Pixels (the_Image : Image) return Byte_Grid is 
  27.  
  28.       the_Grid  : Byte_Grid (1 .. the_Image.Height, 1 .. the_Image.Width); 
  29.  
  30.    begin 
  31.       case the_Image.tex_pixel_Format is 
  32.          when GL.LUMINANCE => 
  33.  
  34.             for Row in the_Grid'Range (1) loop 
  35.                for Col in the_Grid'Range (2) loop 
  36.                   the_Grid (Row, Col) := the_Image.Data.all (the_Image.Width * (Row - 1) + Col - 1); 
  37.                end loop; 
  38.             end loop; 
  39.  
  40.          when others => 
  41.             raise not_yet_implemented;       -- tbd : do these 
  42.       end case; 
  43.       return the_Grid; 
  44.    end to_greyscale_Pixels; 
  45.  
  46.    procedure Insert_into_GL (id              : Integer; 
  47.                              Insert_Size     : Integer; 
  48.                              width           : Integer; 
  49.                              height          : Integer; 
  50.                              texFormat       : TexFormatEnm; 
  51.                              texPixelFormat  : TexPixelFormatEnm; 
  52.                              image_p         : Byte_Array_Ptr 
  53.                             ) is 
  54.       pragma Unreferenced (Insert_Size); 
  55.  
  56.       ptr : constant GL.pointer := image_p.all (0)'Access; 
  57.  
  58.    begin 
  59.       BindTexture (TEXTURE_2D, Uint (id)); 
  60.       PixelStore (UNPACK_ALIGNMENT, 1); 
  61.       TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, REPEAT); 
  62.       TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, REPEAT); 
  63.       -- TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, NEAREST); 
  64.       TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, LINEAR); 
  65.       -- TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, NEAREST); 
  66.       TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, LINEAR); 
  67.       TexEnv (TEXTURE_ENV, TEXTURE_ENV_MODE, MODULATE); 
  68.       TexImage2D (TEXTURE_2D, 0, texFormat, Sizei (width), 
  69.                   Sizei (height), 0, texPixelFormat, GL_UNSIGNED_BYTE, 
  70.                   ptr); 
  71.    end Insert_into_GL; 
  72.  
  73.    -- Workaround for the severe xxx'Read xxx'Write performance 
  74.    -- problems in the GNAT and ObjectAda compilers (as in 2009) 
  75.    -- This is possible if and only if Byte = Stream_Element and 
  76.    -- arrays types are both packed the same way. 
  77.    -- 
  78.    subtype Size_test_a is Byte_Array (1 .. 19); 
  79.    subtype Size_test_b is Ada.Streams.Stream_Element_Array (1 .. 19); 
  80.    workaround_possible : constant Boolean := 
  81.      Size_test_a'Size = Size_test_b'Size and then 
  82.      Size_test_a'Alignment = Size_test_b'Alignment; 
  83.    -- 
  84.  
  85.    procedure Fill_Buffer (b : in out Input_buffer); 
  86.    -- ^ Spec here to avoid in Get_Byte below (GNAT 2009): 
  87.    -- warning : call to subprogram with no separate spec prevents inlining 
  88.  
  89.    procedure Fill_Buffer (b : in out Input_buffer) 
  90.    is 
  91.       -- 
  92.       procedure BlockRead ( 
  93.                            buffer        :    out Byte_Array; 
  94.                            actually_read :    out Natural 
  95.                           ) 
  96.       is 
  97.          use Ada.Streams; 
  98.          Last_Read : Stream_Element_Offset; 
  99.       begin 
  100.          if workaround_possible then 
  101.             declare 
  102.                SE_Buffer : Stream_Element_Array (1 .. buffer'Length); 
  103.                -- direct mapping : buffer = SE_Buffer 
  104.                for SE_Buffer'Address use buffer'Address; 
  105.                pragma Import (Ada, SE_Buffer); 
  106.             begin 
  107.                Read (b.stm.all, SE_Buffer, Last_Read); 
  108.             end; 
  109.          else 
  110.             declare 
  111.                SE_Buffer : Stream_Element_Array (1 .. buffer'Length); 
  112.                -- need to copy array 
  113.             begin 
  114.                Read (b.stm.all, SE_Buffer, Last_Read); 
  115.                for i in buffer'Range loop 
  116.                   buffer (i) := Ubyte (SE_Buffer (Stream_Element_Offset (i - buffer'First) + SE_Buffer'First)); 
  117.                end loop; 
  118.             end; 
  119.          end if; 
  120.          actually_read := Natural (Last_Read); 
  121.       end BlockRead; 
  122.  
  123.    begin 
  124.       BlockRead ( 
  125.                  buffer        => b.data, 
  126.                  actually_read => b.MaxInBufIdx 
  127.                 ); 
  128.       b.InputEoF := b.MaxInBufIdx = 0; 
  129.       b.InBufIdx := 1; 
  130.    end Fill_Buffer; 
  131.  
  132.    procedure Attach_Stream (b    : out Input_buffer; 
  133.                             stm  :     Ada.Streams.Stream_IO.Stream_Access) is 
  134.  
  135.    begin 
  136.       b.stm := stm; 
  137.       Fill_Buffer (b); 
  138.    end Attach_Stream; 
  139.  
  140.    procedure Get_Byte (b : in out Input_buffer; Return_Byte : out Ubyte) is 
  141.  
  142.    begin 
  143.       if b.InBufIdx > b.MaxInBufIdx then 
  144.          Fill_Buffer (b); 
  145.          if b.InputEoF then 
  146.             raise End_Error; 
  147.          end if; 
  148.       end if; 
  149.       Return_Byte := b.data (b.InBufIdx); 
  150.       b.InBufIdx := b.InBufIdx + 1; 
  151.    end Get_Byte; 
  152.  
  153.    function To_TGA_Image (S  :  Ada.Streams.Stream_IO.Stream_Access) return Image is 
  154.  
  155.       the_Image  : Image; 
  156.       stream_buf : Input_buffer; 
  157.  
  158.       -- Run Length Encoding -- 
  159.       RLE : Boolean; 
  160.       RLE_pixels_remaining : Natural := 0; 
  161.       pix_mem : Byte_Array (1 .. 4); 
  162.       is_run_packet : Boolean; 
  163.  
  164.       procedure RLE_Pixel (iBits : Integer; pix : out Byte_Array) is 
  165.  
  166.          procedure Get_pixel is 
  167.  
  168.          begin 
  169.             case iBits is 
  170.             when 32 => -- BGRA 
  171.                Get_Byte (stream_buf, pix (pix'First + 2)); 
  172.                Get_Byte (stream_buf, pix (pix'First + 1)); 
  173.                Get_Byte (stream_buf, pix (pix'First)); 
  174.                Get_Byte (stream_buf, pix (pix'First + 3)); 
  175.             when 24 => -- BGR 
  176.                Get_Byte (stream_buf, pix (pix'First + 2)); 
  177.                Get_Byte (stream_buf, pix (pix'First + 1)); 
  178.                Get_Byte (stream_buf, pix (pix'First)); 
  179.             when 8  => -- Grey 
  180.                Get_Byte (stream_buf, pix (pix'First)); 
  181.             when others => 
  182.                null; 
  183.             end case; 
  184.          end Get_pixel; 
  185.  
  186.          tmp : GL.Ubyte; 
  187.  
  188.       begin --  RLE_Pixel 
  189.          if RLE_pixels_remaining = 0 then -- load RLE code 
  190.             Get_Byte (stream_buf, tmp); 
  191.             Get_pixel; 
  192.             RLE_pixels_remaining := GL.Ubyte'Pos (tmp and 16#7F#); 
  193.             is_run_packet := (tmp and 16#80#) /= 0; 
  194.             if is_run_packet then 
  195.                case iBits is 
  196.                when 32 => 
  197.                   pix_mem (1 .. 4) := pix; 
  198.                when 24 => 
  199.                   pix_mem (1 .. 3) := pix; 
  200.                when 8  => 
  201.                   pix_mem (1 .. 1) := pix; 
  202.                when others => 
  203.                   null; 
  204.                end case; 
  205.             end if; 
  206.          else 
  207.             if is_run_packet then 
  208.                case iBits is 
  209.                when 32 => 
  210.                   pix := pix_mem (1 .. 4); 
  211.                when 24 => 
  212.                   pix := pix_mem (1 .. 3); 
  213.                when 8  => 
  214.                   pix := pix_mem (1 .. 1); 
  215.                when others => 
  216.                   null; 
  217.                end case; 
  218.             else 
  219.                Get_pixel; 
  220.             end if; 
  221.             RLE_pixels_remaining := RLE_pixels_remaining - 1; 
  222.          end if; 
  223.       end RLE_Pixel; 
  224.  
  225.       --  ============= 
  226.       --  getRGBA 
  227.  
  228.       --  Reads in RGBA data for a 32bit image. 
  229.       --  ============= 
  230.  
  231.       procedure getRGBA (buffer : out Byte_Array) is 
  232.          i : Integer := buffer'First; 
  233.       begin 
  234.          if RLE then 
  235.             while i <= buffer'Last - 3 loop 
  236.                RLE_Pixel (32, buffer (i .. i + 3)); 
  237.                i := i + 4; 
  238.             end loop; 
  239.          else 
  240.             while i <= buffer'Last - 3 loop 
  241.                -- TGA is stored in BGRA, make it RGBA 
  242.                Get_Byte (stream_buf, buffer (i + 2)); 
  243.                Get_Byte (stream_buf, buffer (i + 1)); 
  244.                Get_Byte (stream_buf, buffer (i)); 
  245.                Get_Byte (stream_buf, buffer (i + 3)); 
  246.                i := i + 4; 
  247.             end loop; 
  248.          end if; 
  249.          the_Image.tex_Format      := GL.RGBA; 
  250.          the_Image.tex_pixel_Format := GL.RGBA; 
  251.       end getRGBA; 
  252.  
  253.       --  ============= 
  254.       --  getRGB 
  255.  
  256.       --  Reads in RGB data for a 24bit image. 
  257.       --  ============= 
  258.  
  259.       procedure getRGB (buffer : out Byte_Array) is 
  260.          i : Integer := buffer'First; 
  261.       begin 
  262.          if RLE then 
  263.             while i <= buffer'Last - 2 loop 
  264.                RLE_Pixel (24, buffer (i .. i + 2)); 
  265.                i := i + 3; 
  266.             end loop; 
  267.          else 
  268.             while i <= buffer'Last - 2 loop 
  269.                -- TGA is stored in BGR, make it RGB 
  270.                Get_Byte (stream_buf, buffer (i + 2)); 
  271.                Get_Byte (stream_buf, buffer (i + 1)); 
  272.                Get_Byte (stream_buf, buffer (i)); 
  273.                i := i + 3; 
  274.             end loop; 
  275.          end if; 
  276.          the_Image.tex_Format      := GL.RGB; 
  277.          the_Image.tex_pixel_Format := GL.RGB; 
  278.       end getRGB; 
  279.  
  280.       --  ============= 
  281.       --  getGray 
  282.  
  283.       --  Gets the grayscale image data.  Used as an alpha channel. 
  284.       --  ============= 
  285.  
  286.       procedure getGray (buffer : out Byte_Array) is 
  287.       begin 
  288.          if RLE then 
  289.             for b in buffer'Range loop 
  290.                RLE_Pixel (8, buffer (b .. b)); 
  291.             end loop; 
  292.          else 
  293.             for b in buffer'Range loop 
  294.                Get_Byte (stream_buf, buffer (b)); 
  295.             end loop; 
  296.          end if; 
  297.          the_Image.tex_Format      := GL.LUMINANCE; -- ALPHA 
  298.          the_Image.tex_pixel_Format := GL.LUMINANCE; 
  299.       end getGray; 
  300.  
  301.       --  ============= 
  302.       --  getData 
  303.  
  304.       --  Gets the image data for the specified bit depth. 
  305.       --  ============= 
  306.  
  307.       procedure getData (iBits : Integer; buffer : out Byte_Array) is 
  308.       begin 
  309.          Attach_Stream (stream_buf, S); 
  310.          case iBits is 
  311.          when 32 => 
  312.             getRGBA (buffer); 
  313.             the_Image.blending_hint := True; 
  314.          when 24 => 
  315.             getRGB (buffer); 
  316.             the_Image.blending_hint := False; 
  317.          when 8  => 
  318.             getGray (buffer); 
  319.             the_Image.blending_hint := True; 
  320.          when others => null; 
  321.          end case; 
  322.       end getData; 
  323.  
  324.       TGA_type : Byte_Array (0 .. 3); 
  325.       info     : Byte_Array (0 .. 5); 
  326.       dummy    : Byte_Array (1 .. 8); 
  327.  
  328.       Image_Bits : Integer; 
  329.       Image_Type : Integer; 
  330.  
  331.    begin -- to_TGA_Image 
  332.       Byte_Array'Read (S, TGA_type); -- read in colormap info and image type 
  333.       Byte_Array'Read (S, dummy);    -- seek past the header and useless info 
  334.       Byte_Array'Read (S, info); 
  335.  
  336.       if TGA_type (1) /= GL.Ubyte'Val (0) then 
  337.          Raise_Exception ( 
  338.                           TGA_Unsupported_Image_Type'Identity, 
  339.                           "TGA : palette not supported, please use BMP" 
  340.                          ); 
  341.       end if; 
  342.  
  343.       -- Image type: 
  344.       --      1=8 - bit palette style 
  345.       --      2=Direct [A]RGB image 
  346.       --      3=grayscale 
  347.       --      9=RLE version of Type 1 
  348.       --     10=RLE version of Type 2 
  349.       --     11=RLE version of Type 3 
  350.  
  351.       Image_Type := GL.Ubyte'Pos (TGA_type (2)); 
  352.       RLE := Image_Type >= 9; 
  353.       if RLE then 
  354.          Image_Type := Image_Type - 8; 
  355.          RLE_pixels_remaining := 0; 
  356.       end if; 
  357.       if Image_Type /= 2 and then Image_Type /= 3 then 
  358.          Raise_Exception ( 
  359.                           TGA_Unsupported_Image_Type'Identity, 
  360.                           "TGA type =" & Integer'Image (Image_Type) 
  361.                          ); 
  362.       end if; 
  363.  
  364.       the_Image.Width  := GL.Ubyte'Pos (info (0)) + GL.Ubyte'Pos (info (1)) * 256; 
  365.       the_Image.Height := GL.Ubyte'Pos (info (2)) + GL.Ubyte'Pos (info (3)) * 256; 
  366.       Image_Bits   := GL.Ubyte'Pos (info (4)); 
  367.  
  368.       the_Image.size := the_Image.Width * the_Image.Height; 
  369.  
  370.       -- 30 - Apr - 2006 : dimensions not power of two allowed, but discouraged in the docs. 
  371.       -- 
  372.       --  -- make sure dimension is a power of 2 
  373.       --  if not (checkSize (imageWidth)  and  checkSize (imageHeight)) then 
  374.       --     raise TGA_BAD_DIMENSION; 
  375.       --  end if; 
  376.  
  377.       -- make sure we are loading a supported TGA_type 
  378.       if Image_Bits /= 32 and then Image_Bits /= 24 and then Image_Bits /= 8 then 
  379.          raise TGA_Unsupported_Bits_per_pixel; 
  380.       end if; 
  381.  
  382.       -- Allocation 
  383.       the_Image.Data := new Byte_Array (0 .. (Image_Bits / 8) * the_Image.size - 1); 
  384.       getData (Image_Bits, the_Image.Data.all); 
  385.  
  386.       return the_Image; 
  387.    end To_TGA_Image; 
  388.  
  389.    function To_TGA_Image (Filename : String) return Image is 
  390.  
  391.       f          : File_Type; 
  392.       the_Image  : Image; 
  393.  
  394.    begin 
  395.       begin 
  396.          Open (f, In_File, Filename); 
  397.       exception 
  398.          when Name_Error => Raise_Exception (File_Not_Found'Identity, " file name:" & Filename); 
  399.       end; 
  400.       the_Image := To_TGA_Image (Stream (f)); 
  401.       Close (f); 
  402.       return the_Image; 
  403.    exception 
  404.       when e : others => 
  405.          Close (f); 
  406.          Raise_Exception (Exception_Identity (e), " file name:" & Filename); 
  407.          return the_Image; 
  408.    end To_TGA_Image; 
  409.  
  410.    --  ============= 
  411.    --  loadTGA 
  412.  
  413.    --  Loads up a targa stream. 
  414.    --  Supported types are 8, 24 and 32 uncompressed images. 
  415.    --  id is the texture ID to bind to. 
  416.    --  ============= 
  417.  
  418.    procedure Load_TGA (S             :     Ada.Streams.Stream_IO.Stream_Access; 
  419.                        Id            :     Integer;     -- Id is the texture identifier to bind to 
  420.                        blending_hint : out Boolean) is  -- has the image blending / transparency /alpha ? 
  421.  
  422.       the_Image  : Image := To_TGA_Image (S); 
  423.  
  424.    begin 
  425.       Insert_into_GL (id             => Id, 
  426.                       Insert_Size    => the_Image.size, 
  427.                       width          => the_Image.Width, 
  428.                       height         => the_Image.Height, 
  429.                       texFormat      => the_Image.tex_Format, 
  430.                       texPixelFormat => the_Image.tex_pixel_Format, 
  431.                       image_p        => the_Image.Data); 
  432.  
  433.       -- release our data, its been uploaded to the GL system 
  434.       Free (the_Image.Data); 
  435.  
  436.       blending_hint := the_Image.blending_hint; 
  437.    end Load_TGA; 
  438.  
  439.    -- Template for all loaders from a file 
  440.    generic 
  441.       with procedure Stream_Loader (S : Stream_Access; id : Integer; blending_hint : out Boolean); 
  442.    procedure Load_XXX (name : String; id : Integer; blending_hint : out Boolean); 
  443.  
  444.    procedure Load_XXX (name : String; id : Integer; blending_hint : out Boolean) is 
  445.       f : File_Type; 
  446.    begin 
  447.       begin 
  448.          Open (f, In_File, name); 
  449.       exception 
  450.          when Name_Error => Raise_Exception (File_Not_Found'Identity, " file name:" & name); 
  451.       end; 
  452.       Stream_Loader (Stream (f), id, blending_hint); 
  453.       Close (f); 
  454.    exception 
  455.       when e : others => 
  456.          Close (f); 
  457.          Raise_Exception (Exception_Identity (e), " file name:" & name); 
  458.    end Load_XXX; 
  459.  
  460.    procedure i_Load_TGA is new Load_XXX (Stream_Loader => Load_TGA); 
  461.  
  462.    procedure Load_TGA (Name : String; Id : Integer; blending_hint : out Boolean) renames i_Load_TGA; 
  463.  
  464.    -- BMP 
  465.  
  466.    procedure Load_BMP (S             :     Ada.Streams.Stream_IO.Stream_Access; -- Input data stream 
  467.                        Id            :     Integer;     -- Id is the texture identifier to bind to 
  468.                        blending_hint : out Boolean) is  -- has the image blending / transparency /alpha ? 
  469.  
  470.       imageData : Byte_Array_Ptr := null; 
  471.       stream_buf : Input_buffer; 
  472.  
  473.       subtype Y_Loc is Natural range 0 .. 4095; 
  474.       subtype X_Loc is Natural range 0 .. 4095; 
  475.  
  476.       -- 256 - col types 
  477.  
  478.       subtype Color_Type is GL.Ubyte; 
  479.  
  480.       type RGB_Color_Bytes is 
  481.          record 
  482.             Red    : Color_Type; 
  483.             Green  : Color_Type; 
  484.             Blue   : Color_Type; 
  485.          end record; 
  486.  
  487.       type Color_Palette is array (Color_Type) of RGB_Color_Bytes; 
  488.  
  489.       Palette  : Color_Palette; 
  490.  
  491.       ---------------------------------------------------- 
  492.       -- BMP format I/O                                 -- 
  493.       --                                                -- 
  494.       -- Rev 1.5  10 - May - 2006 GdM : added 4 - bit support  -- 
  495.       -- Rev 1.4  11/02/99    RBS                       -- 
  496.       --                                                -- 
  497.       ---------------------------------------------------- 
  498.       -- Coded by G. de Montmollin 
  499.  
  500.       -- Code additions, changes, and corrections by Bob Sutton 
  501.       -- 
  502.       -- Remarks expanded and altered 
  503.       -- Provided for scanline padding in data stream 
  504.       -- Corrected stream reading for images exceeding screen size. 
  505.       -- Provided selectable trim modes for oversize images 
  506.       -- Procedures originally Read_BMP_dimensions now Read_BMP_Header 
  507.       -- Some exceptions added 
  508.       -- 
  509.       -- Rev 1.2  RBS.  Added variable XY screen location for BMP 
  510.       -- Rev 1.3  RBS.  Added image inversion & reversal capability 
  511.       -- Rev 1.4  RBS.  Activated LOCATE centering / clipping options 
  512.       -- 
  513.       -- This version presumes that the infile is a new style, 256 color bitmap. 
  514.       -- The Bitmap Information Header structure (40 bytes) is presumed 
  515.       -- instead of the pre - Windows 3.0 Bitmap Core Header Structure (12 Bytes) 
  516.       -- Pos 15 (0EH), if 28H, is valid BIH structure.  If 0CH, is BCH structure. 
  517.  
  518.       procedure Read_BMP_Header (S : Stream_Access; 
  519.                                  width      : out X_Loc; 
  520.                                  height     : out Y_Loc; 
  521.                                  image_bits : out Integer; 
  522.                                  offset     : out U32) is 
  523.  
  524.          fsz : U32; 
  525.          ih : U32; 
  526.          w, dummy16 : U16; 
  527.          n : U32; 
  528.          Str2 :  String (1 .. 2); 
  529.          Str4 :  String (1 .. 4); 
  530.          Str20 : String (1 .. 20); 
  531.  
  532.          -- Get numbers with correct trucmuche endian, to ensure 
  533.          -- correct header loading on some non - Intel machines 
  534.  
  535.          generic 
  536.             type Number is mod <>; -- range <> in Ada83 version (fake Interfaces) 
  537.          procedure Read_Intel_x86_number (n : out Number); 
  538.  
  539.          procedure Read_Intel_x86_number (n : out Number) is 
  540.             b : GL.Ubyte; 
  541.             m : Number := 1; 
  542.          begin 
  543.             n := 0; 
  544.             for i in 1 .. Number'Size / 8 loop 
  545.                GL.Ubyte'Read (S, b); 
  546.                n := n + m * Number (b); 
  547.                m := m * 256; 
  548.             end loop; 
  549.          end Read_Intel_x86_number; 
  550.  
  551.          procedure Read_Intel is new Read_Intel_x86_number (U16); 
  552.          procedure Read_Intel is new Read_Intel_x86_number (U32); 
  553.  
  554.       begin 
  555.          --   First 14 bytes is file header structure. 
  556.          --   Pos= 1,  read 2 bytes, file signature word 
  557.          String'Read (S, Str2); 
  558.          if Str2 /= "BM" then 
  559.             raise Not_BMP_format; 
  560.          end if; 
  561.          --   Pos= 3,  read the file size 
  562.          Read_Intel (fsz); 
  563.          --   Pos= 7, read four bytes, unknown 
  564.          String'Read (S, Str4); 
  565.          --   Pos= 11, read four bytes offset, file top to bitmap data. 
  566.          --            For 256 colors, this is usually 36 04 00 00 
  567.          Read_Intel (offset); 
  568.          --   Pos= 15. The beginning of Bitmap information header. 
  569.          --   Data expected :  28H, denoting 40 byte header 
  570.          Read_Intel (ih); 
  571.          --   Pos= 19. Bitmap width, in pixels.  Four bytes 
  572.          Read_Intel (n); 
  573.          width :=  X_Loc (n); 
  574.          --   Pos= 23. Bitmap height, in pixels.  Four bytes 
  575.          Read_Intel (n); 
  576.          height := Y_Loc (n); 
  577.          --   Pos= 27, skip two bytes.  Data is number of Bitmap planes. 
  578.          Read_Intel (dummy16); -- perform the skip 
  579.          --   Pos= 29, Number of bits per pixel 
  580.          --   Value 8, denoting 256 color, is expected 
  581.          Read_Intel (w); 
  582.          if w /= 8 and then w /= 4 and then w /= 1 then 
  583.             raise BMP_Unsupported_Bits_per_Pixel; 
  584.          end if; 
  585.          image_bits := Integer (w); 
  586.          --   Pos= 31, read four bytees 
  587.          Read_Intel (n);                -- Type of compression used 
  588.          if n /= 0 then 
  589.             raise Unsupported_compression; 
  590.          end if; 
  591.  
  592.          --   Pos= 35 (23H), skip twenty bytes 
  593.          String'Read (S, Str20);     -- perform the skip 
  594.  
  595.          --   Pos= 55 (36H), - start of palette 
  596.       end Read_BMP_Header; 
  597.  
  598.       procedure Load_BMP_Palette (S           :     Stream_Access; 
  599.                                   Image_Bits  :     Integer; 
  600.                                   BMP_Palette : out Color_Palette) is 
  601.  
  602.          dummy : GL.Ubyte; 
  603.          mc : constant Color_Type := (2**Image_Bits) - 1; 
  604.  
  605.       begin 
  606.          for DAC in 0 .. mc loop 
  607.             GL.Ubyte'Read (S, BMP_Palette (DAC).Blue); 
  608.             GL.Ubyte'Read (S, BMP_Palette (DAC).Green); 
  609.             GL.Ubyte'Read (S, BMP_Palette (DAC).Red); 
  610.             GL.Ubyte'Read (S, dummy); 
  611.          end loop; 
  612.       end Load_BMP_Palette; 
  613.  
  614.       -- Load image only from stream (after having read header and palette!) 
  615.  
  616.       procedure Load_BMP_Image (S           : Stream_Access; 
  617.                                 width       :        X_Loc; 
  618.                                 height      :        Y_Loc; 
  619.                                 Buffer      : in out Byte_Array; 
  620.                                 BMP_bits    :        Integer; 
  621.                                 BMP_Palette : Color_Palette) is 
  622.  
  623.          idx : Natural; 
  624.          b01, b : GL.Ubyte := 0; 
  625.          pair : Boolean := True; 
  626.          bit : Natural range 0 .. 7 := 0; 
  627.          -- 
  628.          x3 : Natural; -- idx + x*3 (each pixel takes 3 bytes) 
  629.          x3_max : Natural; 
  630.          -- 
  631.          procedure Fill_palettized is 
  632.             pragma Inline (Fill_palettized); 
  633.          begin 
  634.             Buffer (x3) := Ubyte (BMP_Palette (b).Red); 
  635.             Buffer (x3 + 1) := Ubyte (BMP_Palette (b).Green); 
  636.             Buffer (x3 + 2) := Ubyte (BMP_Palette (b).Blue); 
  637.          end Fill_palettized; 
  638.          -- 
  639.       begin 
  640.          Attach_Stream (stream_buf, S); 
  641.          for y in 0 .. height - 1 loop 
  642.             idx := y * width * 3; -- GL destination picture is 24 bit 
  643.             x3 := idx; 
  644.             x3_max := idx + (width - 1) * 3; 
  645.             case BMP_bits is 
  646.             when 1 => -- B/W 
  647.                while x3 <= x3_max loop 
  648.                   if bit = 0 then 
  649.                      Get_Byte (stream_buf, b01); 
  650.                   end if; 
  651.                   b := (b01 and 16#80#) / 16#80#; 
  652.                   Fill_palettized; 
  653.                   b01 := b01 * 2; -- cannot overflow. 
  654.                   if bit = 7 then 
  655.                      bit := 0; 
  656.                   else 
  657.                      bit := bit + 1; 
  658.                   end if; 
  659.                   x3 := x3 + 3; 
  660.                end loop; 
  661.             when 4 => -- 16 colour image 
  662.                while x3 <= x3_max loop 
  663.                   if pair then 
  664.                      Get_Byte (stream_buf, b01); 
  665.                      b := (b01 and 16#F0#) / 16#10#; 
  666.                   else 
  667.                      b := (b01 and 16#0F#); 
  668.                   end if; 
  669.                   pair := not pair; 
  670.                   Fill_palettized; 
  671.                   x3 := x3 + 3; 
  672.                end loop; 
  673.             when 8 => -- 256 colour image 
  674.                while x3 <= x3_max loop 
  675.                   Get_Byte (stream_buf, b); 
  676.                   Fill_palettized; 
  677.                   x3 := x3 + 3; 
  678.                end loop; 
  679.             when others => 
  680.                null; 
  681.             end case; 
  682.          end loop; 
  683.       end Load_BMP_Image; 
  684.  
  685.       Width                : X_Loc; 
  686.       Height               : Y_Loc; 
  687.       offset               : U32; 
  688.       BMP_bits, imagebits  : Integer; 
  689.       BMP_Size             : Integer; 
  690.       BMP_tex_format       : GL.TexFormatEnm; 
  691.       BMP_tex_pixel_format : GL.TexPixelFormatEnm; 
  692.  
  693.    begin 
  694.       Read_BMP_Header (S, Width, Height, BMP_bits, offset); 
  695.       imagebits := 24; 
  696.       blending_hint := False; -- no blending with BMP's 
  697.       BMP_tex_format      := GL.RGB; 
  698.       BMP_tex_pixel_format := GL.RGB; 
  699.       Load_BMP_Palette (S, BMP_bits, Palette); 
  700.  
  701.       BMP_Size := Width * Height; 
  702.  
  703.       -- Allocation 
  704.       imageData := new Byte_Array (0 .. (imagebits / 8) * BMP_Size - 1); 
  705.  
  706.       Load_BMP_Image 
  707.         (S, Width, Height, imageData.all, 
  708.          BMP_bits, Palette); 
  709.  
  710.       Insert_into_GL (id             => Id, 
  711.                       Insert_Size    => BMP_Size, 
  712.                       width          => Width, 
  713.                       height         => Height, 
  714.                       texFormat      => BMP_tex_format, 
  715.                       texPixelFormat => BMP_tex_pixel_format, 
  716.                       image_p        => imageData 
  717.                      ); 
  718.  
  719.       -- release our data, its been uploaded to the GL system 
  720.       Free (imageData); 
  721.  
  722.    end Load_BMP; 
  723.  
  724.    procedure i_Load_BMP is new Load_XXX (Stream_Loader => Load_BMP); 
  725.  
  726.    procedure Load_BMP (Name : String; Id : Integer; blending_hint : out Boolean) renames i_Load_BMP; 
  727.  
  728.    procedure Load (name          :     String;            -- file name 
  729.                    format        :     Supported_format;  -- expected file format 
  730.                    ID            :     Integer;           -- ID is the texture identifier to bind to 
  731.                    blending_hint : out Boolean) is        -- has blending / transparency /alpha ? 
  732.  
  733.    begin 
  734.       case format is 
  735.       when BMP => Load_BMP (name, ID, blending_hint); 
  736.       when TGA => Load_TGA (name, ID, blending_hint); 
  737.       end case; 
  738.    end Load; 
  739.  
  740.    procedure Load (s             :     Ada.Streams.Stream_IO.Stream_Access; -- input data stream (e.g. Unzip.Streams) 
  741.                    format        :     Supported_format;  -- expected file format 
  742.                    ID            :     Integer;           -- ID is the texture identifier to bind to 
  743.                    blending_hint : out Boolean) is        -- has blending / transparency /alpha ? 
  744.  
  745.    begin 
  746.       case format is 
  747.       when BMP => Load_BMP (s, ID, blending_hint); 
  748.       when TGA => Load_TGA (s, ID, blending_hint); 
  749.       end case; 
  750.    end Load; 
  751.  
  752.    ------------- 
  753.    -- Outputs -- 
  754.    ------------- 
  755.  
  756.    generic 
  757.       type Number is mod <>; 
  758.       s : Stream_Access; 
  759.    procedure Write_Intel_x86_number (n : Number); 
  760.  
  761.    procedure Write_Intel_x86_number (n : Number) is 
  762.       m : Number := n; 
  763.       bytes : constant Integer := Number'Size / 8; 
  764.    begin 
  765.       for i in 1 .. bytes loop 
  766.          U8'Write (s, U8 (m mod 256)); 
  767.          m := m / 256; 
  768.       end loop; 
  769.    end Write_Intel_x86_number; 
  770.  
  771.    procedure Write_raw_BGR_frame (s : Stream_Access; width, height : Natural) is 
  772.       -- 4 - byte padding for .bmp/.avi formats is the same as GL's default 
  773.       -- padding : see glPixelStore, GL_[UN]PACK_ALIGNMENT = 4 as initial value. 
  774.       -- http://www.opengl.org/sdk/docs/man/xhtml/glPixelStore.xml 
  775.       -- 
  776.       padded_row_size : constant Positive := 
  777.         4 * Integer (C_Float'Ceiling (C_Float (width) * 3.0 / 4.0)); 
  778.       -- (in bytes) 
  779.       -- 
  780.       type Temp_bitmap_type is array (Natural range <>) of aliased GL.Ubyte; 
  781.       PicData : Temp_bitmap_type (0 .. (padded_row_size + 4) * (height + 4) - 1); 
  782.       -- No dynamic allocation needed! 
  783.       -- The "+ 4" are there to avoid parity address problems when GL writes 
  784.       -- to the buffer. 
  785.       type loc_pointer is new GL.pointer; 
  786.       function Cvt is new Ada.Unchecked_Conversion (System.Address, loc_pointer); 
  787.       -- This method is functionally identical as GNAT's Unrestricted_Access 
  788.       -- but has no type safety (cf GNAT Docs) 
  789.       pragma No_Strict_Aliasing (loc_pointer); -- recommended by GNAT 2005 + 
  790.       pPicData : loc_pointer; 
  791.       data_max : constant Integer := padded_row_size * height - 1; 
  792.    begin 
  793.       pPicData := Cvt (PicData (0)'Address); 
  794.       GL.ReadPixels ( 
  795.                      0, 0, 
  796.                      GL.Sizei (width), GL.Sizei (height), 
  797.                      GL.BGR, 
  798.                      GL.GL_UNSIGNED_BYTE, 
  799.                      GL.pointer (pPicData) 
  800.                     ); 
  801.       if workaround_possible then 
  802.          declare 
  803.             use Ada.Streams; 
  804.             SE_Buffer    : Stream_Element_Array (0 .. Stream_Element_Offset (PicData'Last)); 
  805.             for SE_Buffer'Address use PicData'Address; 
  806.             pragma Import (Ada, SE_Buffer); 
  807.          begin 
  808.             Ada.Streams.Write (s.all, SE_Buffer (0 .. Stream_Element_Offset (data_max))); 
  809.          end; 
  810.       else 
  811.          Temp_bitmap_type'Write (s, PicData (0 .. data_max)); 
  812.       end if; 
  813.    end Write_raw_BGR_frame; 
  814.  
  815.    ------------------------------------------------------- 
  816.    -- BMP RGB (A) output of the current, active viewport -- 
  817.    ------------------------------------------------------- 
  818.  
  819.    procedure Screenshot (Name : String) is 
  820.       -- Translated by (New) P2Ada v. 15 - Nov - 2006 
  821.       -- http://wiki.delphigl.com/index.php/Screenshot 
  822.       f : Ada.Streams.Stream_IO.File_Type; 
  823.  
  824.       type Bitmap_File_Header is record 
  825.          bfType      : U16; 
  826.          bfSize      : U32; 
  827.          bfReserved1 : U16 := 0; 
  828.          bfReserved2 : U16 := 0; 
  829.          bfOffBits   : U32; 
  830.       end record; 
  831.       pragma Pack (Bitmap_File_Header); 
  832.       for Bitmap_File_Header'Size use 8 * 14; 
  833.  
  834.       type Bitmap_Info_Header is record 
  835.          biSize          : U32; 
  836.          biWidth         : I32; 
  837.          biHeight        : I32; 
  838.          biPlanes        : U16; 
  839.          biBitCount      : U16; 
  840.          biCompression   : U32; 
  841.          biSizeImage     : U32; 
  842.          biXPelsPerMeter : I32 := 0; 
  843.          biYPelsPerMeter : I32 := 0; 
  844.          biClrUsed       : U32 := 0; 
  845.          biClrImportant  : U32 := 0; 
  846.       end record; 
  847.       pragma Pack (Bitmap_Info_Header); 
  848.       for Bitmap_Info_Header'Size use 8 * 40; 
  849.  
  850.       FileInfo            : Bitmap_Info_Header; 
  851.       FileHeader          : Bitmap_File_Header; 
  852.       Screenshot_Viewport : array (0 .. 3) of aliased GL.Int; 
  853.  
  854.       type GL_IntPointer is new GL.intPointer; 
  855.       function Cvt is new Ada.Unchecked_Conversion (System.Address, GL_IntPointer); 
  856.       -- This method is functionally identical as GNAT's Unrestricted_Access 
  857.       -- but has no type safety (cf GNAT Docs) 
  858.       pragma No_Strict_Aliasing (GL_IntPointer); -- recommended by GNAT 2005+ 
  859.  
  860.    begin 
  861.       --  Größe des Viewports abfragen --> Spätere Bildgrößenangaben 
  862.       GL.GetIntegerv (GL.VIEWPORT, GL.intPointer (Cvt (Screenshot_Viewport (0)'Address))); 
  863.  
  864.       --  Initialisieren der Daten des Headers 
  865.       FileHeader.bfType := 16#4D42#; -- 'BM' 
  866.       FileHeader.bfOffBits := Bitmap_Info_Header'Size / 8 + Bitmap_File_Header'Size / 8; 
  867.  
  868.       --  Schreiben der Bitmap - Informationen 
  869.       FileInfo.biSize       := Bitmap_Info_Header'Size / 8; 
  870.       FileInfo.biWidth      := I32 (Screenshot_Viewport (2)); 
  871.       FileInfo.biHeight     := I32 (Screenshot_Viewport (3)); 
  872.       FileInfo.biPlanes     := 1; 
  873.       FileInfo.biBitCount   := 24; 
  874.       FileInfo.biCompression := 0; 
  875.       FileInfo.biSizeImage  := 
  876.         U32 ( 
  877.              -- 4 - byte padding for .bmp/.avi formats 
  878.              4 * Integer (C_Float'Ceiling (C_Float (FileInfo.biWidth) * 3.0 / 4.0)) * 
  879.                Integer (FileInfo.biHeight) 
  880.             ); 
  881.  
  882.       --  Größenangabe auch in den Header übernehmen 
  883.       FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.biSizeImage; 
  884.  
  885.       --  Und den ganzen Müll in die Datei schieben ; - ) 
  886.       --  Moderne Leute nehmen dafür auch Streams . .. 
  887.       Create (f, Out_File, Name); 
  888.       declare 
  889.          procedure Write_Intel is new Write_Intel_x86_number (U16, Stream (f)); 
  890.          procedure Write_Intel is new Write_Intel_x86_number (U32, Stream (f)); 
  891.          function Cvt is new Ada.Unchecked_Conversion (I32, U32); 
  892.  
  893.       begin 
  894.          -- ** Only for Intel endianess : ** -- 
  895.          --  BITMAPFILEHEADER'Write (Stream (F), FileHeader); 
  896.          --  BITMAPINFOHEADER'Write (Stream (F), FileInfo); 
  897.          -- 
  898.          -- ** Endian - safe : ** -- 
  899.          Write_Intel (FileHeader.bfType); 
  900.          Write_Intel (FileHeader.bfSize); 
  901.          Write_Intel (FileHeader.bfReserved1); 
  902.          Write_Intel (FileHeader.bfReserved2); 
  903.          Write_Intel (FileHeader.bfOffBits); 
  904.          -- 
  905.          Write_Intel (FileInfo.biSize); 
  906.          Write_Intel (Cvt (FileInfo.biWidth)); 
  907.          Write_Intel (Cvt (FileInfo.biHeight)); 
  908.          Write_Intel (FileInfo.biPlanes); 
  909.          Write_Intel (FileInfo.biBitCount); 
  910.          Write_Intel (FileInfo.biCompression); 
  911.          Write_Intel (FileInfo.biSizeImage); 
  912.          Write_Intel (Cvt (FileInfo.biXPelsPerMeter)); 
  913.          Write_Intel (Cvt (FileInfo.biYPelsPerMeter)); 
  914.          Write_Intel (FileInfo.biClrUsed); 
  915.          Write_Intel (FileInfo.biClrImportant); 
  916.          -- 
  917.          Write_raw_BGR_frame (Stream (f), Integer (Screenshot_Viewport (2)), Integer (Screenshot_Viewport (3))); 
  918.          Close (f); 
  919.       exception 
  920.          when others => 
  921.             Close (f); 
  922.             raise; 
  923.       end; 
  924.    end Screenshot; 
  925.  
  926.    ------------------- 
  927.    -- Video capture -- 
  928.    ------------------- 
  929.  
  930.    -- Exceptionally we define global variables since it is not expected 
  931.    -- that more that one capture is taken at the same time. 
  932.    avi : Ada.Streams.Stream_IO.File_Type; 
  933.    frames : Natural; 
  934.    rate : Positive; 
  935.    width, height : Positive; 
  936.    bmp_size : U32; 
  937.  
  938.    procedure Write_RIFF_headers is 
  939.       -- Written 1st time to take place (but # of frames unknown) 
  940.       -- Written 2nd time for setting # of frames, sizes, etc. 
  941.       -- 
  942.       padded_row_size : constant Positive := 
  943.         4 * Integer (C_Float'Ceiling (C_Float (width) * 3.0 / 4.0)); 
  944.       calc_bmp_size : constant U32 := U32 (padded_row_size * height); 
  945.       index_size : constant U32 := U32 (frames) * 16; 
  946.       movie_size : constant U32 := 4 + U32 (frames) * (calc_bmp_size + 8); 
  947.       second_list_size : constant U32 := 4 + 64 + 48; 
  948.       first_list_size  : constant U32 := (4 + 64) + (8 + second_list_size); 
  949.       file_size : constant U32 := 8 + (8 + first_list_size) + (4 + movie_size) + (8 + index_size); 
  950.       s : constant Stream_Access := Stream (avi); 
  951.       procedure Write_Intel is new Write_Intel_x86_number (U16, s); 
  952.       procedure Write_Intel is new Write_Intel_x86_number (U32, s); 
  953.       microseconds_per_frame : constant U32 := U32 (1_000_000.0 / Long_Float (rate)); 
  954.  
  955.    begin 
  956.       bmp_size := calc_bmp_size; 
  957.       String'Write (s, "RIFF"); 
  958.       U32'Write (s, file_size); 
  959.       String'Write (s, "AVI "); 
  960.       String'Write (s, "LIST"); 
  961.       Write_Intel (first_list_size); 
  962.       String'Write (s, "hdrl"); 
  963.       String'Write (s, "avih"); 
  964.       Write_Intel (U32'(56)); 
  965.       -- Begin of AVI Header 
  966.       Write_Intel (microseconds_per_frame); 
  967.       Write_Intel (U32'(0));  -- MaxBytesPerSec 
  968.       Write_Intel (U32'(0));  -- Reserved1 
  969.       Write_Intel (U32'(16)); -- Flags (16 = has an index) 
  970.       Write_Intel (U32 (frames)); 
  971.       Write_Intel (U32'(0));  -- InitialFrames 
  972.       Write_Intel (U32'(1));  -- Streams 
  973.       Write_Intel (bmp_size); 
  974.       Write_Intel (U32 (width)); 
  975.       Write_Intel (U32 (height)); 
  976.       Write_Intel (U32'(0));  -- Scale 
  977.       Write_Intel (U32'(0));  -- Rate 
  978.       Write_Intel (U32'(0));  -- Start 
  979.       Write_Intel (U32'(0));  -- Length 
  980.       -- End of AVI Header 
  981.       String'Write (s, "LIST"); 
  982.       Write_Intel (second_list_size); 
  983.       String'Write (s, "strl"); 
  984.       -- Begin of Str 
  985.       String'Write (s, "strh"); 
  986.       Write_Intel (U32'(56)); 
  987.       String'Write (s, "vids"); 
  988.       String'Write (s, "DIB "); 
  989.       Write_Intel (U32'(0));     -- flags 
  990.       Write_Intel (U32'(0));     -- priority 
  991.       Write_Intel (U32'(0));     -- initial frames 
  992.       Write_Intel (microseconds_per_frame); -- Scale 
  993.       Write_Intel (U32'(1_000_000));        -- Rate 
  994.       Write_Intel (U32'(0));                -- Start 
  995.       Write_Intel (U32 (frames));            -- Length 
  996.       Write_Intel (bmp_size);               -- SuggestedBufferSize 
  997.       Write_Intel (U32'(0));                -- Quality 
  998.       Write_Intel (U32'(0));                -- SampleSize 
  999.       Write_Intel (U32'(0)); 
  1000.       Write_Intel (U16 (width)); 
  1001.       Write_Intel (U16 (height)); 
  1002.       -- End of Str 
  1003.       String'Write (s, "strf"); 
  1004.       Write_Intel (U32'(40)); 
  1005.       -- Begin of BMI 
  1006.       Write_Intel (U32'(40));    -- BM header size (like BMP) 
  1007.       Write_Intel (U32 (width)); 
  1008.       Write_Intel (U32 (height)); 
  1009.       Write_Intel (U16'(1));     -- Planes 
  1010.       Write_Intel (U16'(24));    -- BitCount 
  1011.       Write_Intel (U32'(0));     -- Compression 
  1012.       Write_Intel (bmp_size);    -- SizeImage 
  1013.       Write_Intel (U32'(3780));  -- XPelsPerMeter 
  1014.       Write_Intel (U32'(3780));  -- YPelsPerMeter 
  1015.       Write_Intel (U32'(0));     -- ClrUsed 
  1016.       Write_Intel (U32'(0));     -- ClrImportant 
  1017.       -- End of BMI 
  1018.       String'Write (s, "LIST"); 
  1019.       Write_Intel (movie_size); 
  1020.       String'Write (s, "movi"); 
  1021.    end Write_RIFF_headers; 
  1022.  
  1023.    procedure Start_Capture (AVI_Name : String; frame_rate : Positive) is 
  1024.  
  1025.       Capture_Viewport  : array (0 .. 3) of aliased GL.Int; 
  1026.  
  1027.       type GL_Int_Pointer is new GL.intPointer; 
  1028.       function Cvt is new Ada.Unchecked_Conversion (System.Address, GL_Int_Pointer); 
  1029.       -- This method is functionally identical as GNAT's Unrestricted_Access 
  1030.       -- but has no type safety (cf GNAT Docs) 
  1031.       pragma No_Strict_Aliasing (GL_Int_Pointer); -- recommended by GNAT 2005 + 
  1032.  
  1033.    begin 
  1034.       Create (avi, Out_File, AVI_Name); 
  1035.       frames := 0; 
  1036.       rate := frame_rate; 
  1037.       GL.GetIntegerv (GL.VIEWPORT, GL.intPointer (Cvt (Capture_Viewport (0)'Address))); 
  1038.       width := Positive (Capture_Viewport (2)); 
  1039.       height := Positive (Capture_Viewport (3)); 
  1040.       -- NB : GL viewport resizing should be blocked during the video capture! 
  1041.       Write_RIFF_headers; 
  1042.    end Start_Capture; 
  1043.  
  1044.    procedure Capture_Frame is 
  1045.  
  1046.       s : constant Stream_Access := Stream (avi); 
  1047.       procedure Write_Intel is new Write_Intel_x86_number (U32, s); 
  1048.  
  1049.    begin 
  1050.       String'Write (s, "00db"); 
  1051.       Write_Intel (bmp_size); 
  1052.       Write_raw_BGR_frame (s, width, height); 
  1053.       frames := frames + 1; 
  1054.    end Capture_Frame; 
  1055.  
  1056.    procedure Stop_Capture is 
  1057.  
  1058.       index_size : constant U32 := U32 (frames) * 16; 
  1059.       s : constant Stream_Access := Stream (avi); 
  1060.       procedure Write_Intel is new Write_Intel_x86_number (U32, s); 
  1061.       ChunkOffset : U32 := 4; 
  1062.  
  1063.    begin 
  1064.       -- write the index section 
  1065.       String'Write (s, "idx1"); 
  1066.       -- 
  1067.       Write_Intel (index_size); 
  1068.       for f in 1 .. frames loop 
  1069.          String'Write (s, "00db"); 
  1070.          Write_Intel (U32'(16)); -- keyframe 
  1071.          Write_Intel (ChunkOffset); 
  1072.          ChunkOffset := ChunkOffset + bmp_size + 8; 
  1073.          Write_Intel (bmp_size); 
  1074.       end loop; 
  1075.       -- Go back to file beginning .. . 
  1076.       Set_Index (avi, 1); 
  1077.       Write_RIFF_headers; -- rewrite headers with correct data 
  1078.       Close (avi); 
  1079.    end Stop_Capture; 
  1080.  
  1081. end GL.IO;