918 lines
28 KiB
Ada
918 lines
28 KiB
Ada
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;
|
|
|
|
|
|
|
|
--------------------
|
|
--- Raw Image Frames
|
|
--
|
|
|
|
procedure write_raw_Frame (to_Stream : in Stream_access;
|
|
Width, Height : in Natural;
|
|
with_Alpha : in Boolean)
|
|
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 := (if with_Alpha then 4 * Integer (Float'Ceiling (Float (Width)))
|
|
else 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),
|
|
(if with_Alpha then to_GL (openGL.Texture.BGRA)
|
|
else to_GL (openGL.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 (to_Stream.all, SE_Buffer (0 .. Stream_Element_Offset (data_Max)));
|
|
end;
|
|
|
|
else
|
|
temp_Bitmap_type'write (to_Stream, PicData (0 .. data_Max));
|
|
end if;
|
|
|
|
end write_raw_Frame;
|
|
|
|
|
|
|
|
--------------
|
|
-- Bitmap File
|
|
--
|
|
|
|
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;
|
|
|
|
|
|
|
|
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 write_BMP_Header (to_Stream : in Stream_Access;
|
|
Width, Height : in GL.GLint;
|
|
with_Alpha : in Boolean)
|
|
is
|
|
use GL,
|
|
GL.Binding,
|
|
Texture;
|
|
|
|
FileHeader : BitMapFileHeader;
|
|
FileInfo : BitMapV4Header;
|
|
|
|
begin
|
|
FileHeader.bfType := 16#4D42#; -- 'BM'
|
|
|
|
FileInfo.Core.biWidth := I32 (Width);
|
|
FileInfo.Core.biHeight := I32 (Height);
|
|
FileInfo.Core.biPlanes := 1;
|
|
|
|
if with_Alpha
|
|
then
|
|
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
|
|
+ BitMapV4Header 'Size / 8;
|
|
FileInfo.Core.biSize := BitMapV4Header'Size / 8;
|
|
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;
|
|
|
|
else
|
|
FileHeader.bfOffBits := BitMapFileHeader'Size / 8
|
|
+ BitMapInfoHeader'Size / 8;
|
|
FileInfo.Core.biSize := BitMapInfoHeader'Size / 8;
|
|
FileInfo.Core.biBitCount := 24;
|
|
FileInfo.Core.biCompression := 0;
|
|
FileInfo.Core.biSizeImage := U32 ( 4 -- 4-byte padding for '.bmp/.avi' formats.
|
|
* Integer (Float'Ceiling (Float (FileInfo.Core.biWidth) * 3.0 / 4.0))
|
|
* Integer (FileInfo.Core.biHeight));
|
|
end if;
|
|
|
|
FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.Core.biSizeImage;
|
|
|
|
declare
|
|
procedure write_Intel is new write_Intel_x86_Number (U16, to_Stream);
|
|
procedure write_Intel is new write_Intel_x86_Number (U32, to_Stream);
|
|
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);
|
|
|
|
if with_Alpha
|
|
then
|
|
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);
|
|
end if;
|
|
end;
|
|
end write_BMP_Header;
|
|
|
|
|
|
|
|
-------------
|
|
-- Save Image
|
|
--
|
|
|
|
procedure save (image_Filename : in String;
|
|
the_Image : in Image)
|
|
is
|
|
use GL,
|
|
GL.Binding,
|
|
ada.Streams.Stream_IO;
|
|
|
|
File : ada.Streams.Stream_IO.File_type;
|
|
S : ada.Streams.Stream_IO.Stream_access;
|
|
|
|
Size : Extent_2D := (Width => the_Image'Length (2),
|
|
Height => the_Image'Length (1));
|
|
|
|
begin
|
|
create (File, out_File, image_Filename);
|
|
|
|
S := Stream (File);
|
|
|
|
write_BMP_Header (to_Stream => S,
|
|
Width => GLint (Size.Width),
|
|
Height => GLint (Size.Height),
|
|
with_Alpha => True);
|
|
|
|
for r in 1 .. Index_t (Size.Height)
|
|
loop
|
|
for c in 1 .. Index_t (Size.Width)
|
|
loop
|
|
color_Value'write (S, the_Image (r, c).Blue);
|
|
color_Value'write (S, the_Image (r, c).Green);
|
|
color_Value'write (S, the_Image (r, c).Red);
|
|
color_Value'write (S, 255);
|
|
end loop;
|
|
end loop;
|
|
|
|
close (File);
|
|
|
|
exception
|
|
when others =>
|
|
if is_Open (File)
|
|
then
|
|
close (File);
|
|
end if;
|
|
|
|
raise;
|
|
end Save;
|
|
|
|
|
|
-------------
|
|
-- Screenshot
|
|
--
|
|
|
|
procedure Screenshot (Filename : in String;
|
|
with_Alpha : in Boolean := False)
|
|
is
|
|
use GL,
|
|
GL.Binding,
|
|
ada.Streams.Stream_IO;
|
|
|
|
File : ada.Streams.Stream_IO.File_type;
|
|
S : ada.Streams.Stream_IO.Stream_access;
|
|
|
|
Viewport : array (0 .. 3) of aliased GLint;
|
|
|
|
begin
|
|
Tasks.check;
|
|
|
|
glGetIntegerv (GL_VIEWPORT,
|
|
Viewport (0)'unchecked_Access);
|
|
Errors.log;
|
|
|
|
create (File, out_File, Filename);
|
|
|
|
S := Stream (File);
|
|
|
|
write_BMP_Header (to_Stream => S,
|
|
Width => Viewport (2),
|
|
Height => Viewport (3),
|
|
with_Alpha => with_Alpha);
|
|
|
|
write_raw_Frame (to_Stream => S,
|
|
Width => Integer (Viewport (2)),
|
|
Height => Integer (Viewport (3)),
|
|
with_Alpha => with_Alpha);
|
|
close (File);
|
|
|
|
exception
|
|
when others =>
|
|
if is_Open (File)
|
|
then
|
|
close (File);
|
|
end if;
|
|
|
|
raise;
|
|
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_Frame (S, Width, Height, with_Alpha => False);
|
|
|
|
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;
|