Add initial prototype.
This commit is contained in:
Rod Kay
917
3-mid/opengl/source/lean/io/opengl-io.adb
Normal file
917
3-mid/opengl/source/lean/io/opengl-io.adb
Normal file
@@ -0,0 +1,917 @@
|
||||
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;
|
||||
Reference in New Issue
Block a user