CS计算机代考程序代写 ————————————————————————-

————————————————————————-
— GL.Textures – GL Textures model

— Copyright (c) Rod Kay 2007
— AUSTRALIA
— Permission granted to use this software, without any warranty,
— for any purpose, provided this copyright note remains attached
— and unmodified if sources are distributed further.
————————————————————————-

with GL.IO;
with GL.Errors;

— with Ada.Directories;
with Ada.Characters.Handling;
with Ada.Text_IO; use Ada.Text_IO;

package body GL.Textures is

— names

function New_Texture_Name return texture_Name is

the_Name : aliased texture_Name;

begin
GL.Gen_Textures (1, the_Name’Unchecked_Access);
return the_Name;
end New_Texture_Name;

procedure Free (the_texture_Name : texture_Name) is

the_Name : aliased texture_Name := the_texture_Name;

begin
GL.Delete_Textures (1, the_Name’Unchecked_Access);
end Free;

— coordinates

function To_Texture_Coordinates_xz (the_Points : GL.Geometry.GL_Vertex_array;
Transform_S : texture_Transform; — transforms point X ordinate.
Transform_T : texture_Transform) — transforms point Z ordinate.
return p_Coordinate_2D_array is

the_Coords : constant p_Coordinate_2D_array := new Coordinate_2D_array (1 .. the_Points’Last);

begin
for Each in the_Points’Range loop
declare
the_Vertex : GL.Geometry.GL_Vertex renames the_Points (Each);
begin
the_Coords.all (Each).S := (the_Vertex (0) + Transform_S.Offset) * Transform_S.Scale;
the_Coords.all (Each).T := 1.0 – (the_Vertex (2) + Transform_T.Offset) * Transform_T.Scale;
end;
end loop;

return the_Coords;
end To_Texture_Coordinates_xz;

function To_Texture_Coordinates_xz (the_Points : GL.Geometry.GL_Vertex_array;
Transform_S : texture_Transform; — transforms point X ordinate.
Transform_T : texture_Transform) — transforms point Z ordinate.
return Coordinate_2D_array is

the_Coords : Coordinate_2D_array (1 .. the_Points’Last);

begin
for Each in the_Points’Range loop
declare
the_Vertex : GL.Geometry.GL_Vertex renames the_Points (Each);
begin
the_Coords (Each).S := (the_Vertex (0) + Transform_S.Offset) * Transform_S.Scale;
the_Coords (Each).T := 1.0 – (the_Vertex (2) + Transform_T.Offset) * Transform_T.Scale;
end;
end loop;

return the_Coords;
end To_Texture_Coordinates_xz;

— xz_Generator

overriding function To_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.p_Coordinate_2D_array is
(To_Texture_Coordinates_xz (the_Vertices, Self.Transform_S, Self.Transform_T));

overriding function To_Coordinates (Self : xz_Generator; the_Vertices : GL.Geometry.GL_Vertex_array) return GL.Textures.Coordinate_2D_array is
(To_Texture_Coordinates_xz (the_Vertices, Self.Transform_S, Self.Transform_T));

— texture objects

function New_Texture (image_Filename : String) return Object is

use Ada.Characters.Handling;

Extension : constant String := image_Filename (image_Filename’Last – 2 .. image_Filename’Last);
the_Texture : Object;

begin
the_Texture.Name := New_Texture_Name;

if To_Lower (Extension) = “bmp” then
GL.IO.Load (image_Filename, GL.IO.BMP, Integer (the_Texture.Name), blending_hint => the_Texture.is_Transparent);

elsif To_Lower (Extension) = “tga” then
GL.IO.Load (image_Filename, GL.IO.TGA, Integer (the_Texture.Name), blending_hint => the_Texture.is_Transparent);
else
raise unsupported_format_Error;
end if;

— tbd : if not found, look in ‘global’ and ‘level’ zip files also, ala gautiers ‘globe_3d.textures’.
return the_Texture;
end New_Texture;

procedure Destroy (Self : in out Object) is

begin
case Self.Pool = null is
when True => Free (Self.Name);
when False => Free (Self.Pool.all, Self);
end case;
end Destroy;

procedure Set_Name (Self : in out Object; To : GL.Uint) is

begin
Self.Name := To;
end Set_Name;

function Name (Self : Object) return GL.Uint is (Self.Name);

function Is_Transparent (Self : Object) return Boolean is (Self.is_Transparent);

procedure Enable (Self : in out Object) is

begin
pragma Assert (Self.Name > 0);

GL.Enable (GL.TEXTURE_2D);
GL.BindTexture (GL.TEXTURE_2D, Self.Name);
end Enable;

— Pool

Null_Image : array (1 .. 10_000_000) of aliased GL.Ubyte := (others => 0);

— tbd : add texture properties as ‘in’ parameters to habdle different types of textures.

function New_Texture (From : access Pool;
min_Width : Positive;
min_Height : Positive) return Object is

the_Texture : aliased Object;

Size_Min_Width : constant Size := To_Size (min_Width);
Size_Min_Height : constant Size := To_Size (min_Height);

unused_texture_List : p_pool_texture_List := From.all.unused_Textures_for_size (Size_Min_Width, Size_Min_Height);

begin
if unused_texture_List = null then
unused_texture_List := new pool_texture_List;
From.all.unused_Textures_for_size (Size_Min_Width, Size_Min_Height) := unused_texture_List;
end if;

— search for existing, but unused, object.

if unused_texture_List.all.Last > 0 then — an existing unused texture has been found
the_Texture := unused_texture_List.all.Textures (unused_texture_List.all.Last);
unused_texture_List.all.Last := unused_texture_List.all.Last – 1;

Enable (the_Texture);

GL.TexImage2D (GL.TEXTURE_2D, 0, GL.RGBA,
Power_of_2_Ceiling (min_Width), Power_of_2_Ceiling (min_Height),
0,
— gl.RGBA, GL.GL_UNSIGNED_BYTE, null); — nb : actual image is not initialised.
GL.RGBA, GL.GL_UNSIGNED_BYTE, Null_Image (Null_Image’First)’Access); — nb : actual image is not initialised.
else
— no existing, unused texture found, so create a new one.

the_Texture.Width := Size_Min_Width;
the_Texture.Height := Size_Min_Height;

the_Texture.Pool := From.all’Access;

the_Texture.Name := New_Texture_Name;
Enable (the_Texture);

PixelStore (UNPACK_ALIGNMENT, 1); — tbd : these properties are tailored for impostors
— TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, REPEAT); — make them user settable !
— TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, REPEAT);
— TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, CLAMP); — make them user settable !
— TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, CLAMP);
TexParameter (TEXTURE_2D, TEXTURE_WRAP_S, CLAMP_TO_EDGE); — make them user settable !
TexParameter (TEXTURE_2D, TEXTURE_WRAP_T, CLAMP_TO_EDGE);

— TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, NEAREST);
— TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, NEAREST);
TexParameter (TEXTURE_2D, TEXTURE_MAG_FILTER, LINEAR);
TexParameter (TEXTURE_2D, TEXTURE_MIN_FILTER, LINEAR);

TexEnv (TEXTURE_ENV, TEXTURE_ENV_MODE, MODULATE);
— TexEnv (TEXTURE_ENV, TEXTURE_ENV_MODE, DECAL);

GL.TexImage2D (GL.TEXTURE_2D, 0, GL.RGBA,
Power_of_2_Ceiling (min_Width), Power_of_2_Ceiling (min_Height),
0,
— gl.RGBA, GL.GL_UNSIGNED_BYTE, null); — nb : actual image is not initialised.
GL.RGBA, GL.GL_UNSIGNED_BYTE, Null_Image (Null_Image’First)’Access); — nb : actual image is not initialised.

GL.Errors.log; — tbd : only for debug.
end if;

return the_Texture;
end New_Texture;

procedure Free (Self : in out Pool; the_Texture : Object) is

begin
if the_Texture.Name = 0 then
return;
end if;

declare
unused_texture_List : constant p_pool_texture_List := Self.unused_Textures_for_size (the_Texture.Width, the_Texture.Height);
begin
unused_texture_List.all.Last := unused_texture_List.all.Last + 1;
unused_texture_List.all.Textures (unused_texture_List.all.Last) := the_Texture;
end;
end Free;

procedure Vacuum (Self : in out Pool) is

begin

for each_Width in Self.unused_Textures_for_size’Range (1) loop
for each_Height in Self.unused_Textures_for_size’Range (2) loop
declare
unused_texture_List : constant p_pool_texture_List := Self.unused_Textures_for_size (each_Width, each_Height);
begin
if unused_texture_List /= null then

for Each in 1 .. unused_texture_List.all.Last loop
Free (unused_texture_List.all.Textures (Each).Name);
end loop;

unused_texture_List.all.Last := 0;
end if;
end;
end loop;
end loop;

end Vacuum;

function To_Size (From : Positive) return Size is

begin
if From <= 2 then return s2; elsif From <= 4 then return s4; elsif From <= 8 then return s8; elsif From <= 16 then return s16; elsif From <= 32 then return s32; elsif From <= 64 then return s64; elsif From <= 128 then return s128; elsif From <= 256 then return s256; elsif From <= 512 then return s512; elsif From <= 1024 then return s1024; elsif From <= 2048 then return s2048; end if; Put_Line ("to_Size : From : " & Positive'Image (From)); raise Constraint_Error; end To_Size; function Power_of_2_Ceiling (From : Positive) return GL.Sizei is begin if From <= 2 then return 2; elsif From <= 4 then return 4; elsif From <= 8 then return 8; elsif From <= 16 then return 16; elsif From <= 32 then return 32; elsif From <= 64 then return 64; elsif From <= 128 then return 128; elsif From <= 256 then return 256; elsif From <= 512 then return 512; elsif From <= 1024 then return 1024; elsif From <= 2048 then return 2048; end if; raise Constraint_Error; end Power_of_2_Ceiling; function Size_Width (Self : Object) return Size is (Self.Width); function Size_Height (Self : Object) return Size is (Self.Height); end GL.Textures;