nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

opengl: Add texture animation.

Browse Source
This commit is contained in:
Rod Kay
2024-09-24 13:45:18 +10:00
parent d0e3870346
commit ab36317bd2
11 changed files with 259 additions and 54 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.adb
View File

@@ -91,6 +91,22 @@ is
overriding
procedure animate (Self : in out Item)
is
use type texture_Set.Animation_view;
begin
if Self.Face.Animation = null
then
return;
end if;
texture_Set.animate (Self.Face.Animation.all,
Self.Face.texture_Applies);
end animate;
--------------------- ---------------------
--- openGL Geometries --- openGL Geometries
-- --

21
3-mid/opengl/source/lean/model/opengl-model-circle-lit_textured.ads
View File

@@ -15,9 +15,10 @@ is
type Face is type Face is
record record
Fades : texture_Set.fade_Levels (texture_Set.texture_Id) := [others => 0.0]; Fades : texture_Set.fade_Levels (texture_Set.texture_Id) := [others => 0.0];
texture_Applies : texture_Set.texture_Apply_array := [others => True];
Textures : openGL.asset_Names (1 .. Positive (texture_Set.texture_Id'Last)) := [others => null_Asset]; -- The textures to be applied to the hex. Textures : openGL.asset_Names (1 .. Positive (texture_Set.texture_Id'Last)) := [others => null_Asset]; -- The textures to be applied to the hex.
texture_Count : Natural := 0; texture_Count : Natural := 0;
texture_Applies : texture_Set.texture_Apply_array := [others => True];
Animation : texture_Set.Animation_view;
end record; end record;
@@ -43,17 +44,17 @@ is
-- --
overriding overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
overriding overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level); Now : in texture_Set.fade_Level);
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in asset_Name); Now : in asset_Name);
overriding overriding
function texture_Count (Self : in Item) return Natural; function texture_Count (Self : in Item) return Natural;
overriding overriding
@@ -63,6 +64,10 @@ is
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean); Now : in Boolean);
overriding
procedure animate (Self : in out Item);
private private

19
3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_textured.adb
View File

@@ -90,6 +90,25 @@ is
overriding
procedure animate (Self : in out Item)
is
use type texture_Set.Animation_view;
begin
if Self.Face.Animation = null
then
return;
end if;
texture_Set.animate (Self.Face.Animation.all,
Self.Face.texture_Applies);
end animate;
---------------------
--- openGL Geometries
--
overriding overriding
function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class; function to_GL_Geometries (Self : access Item; Textures : access Texture.name_Map_of_texture'Class;

17
3-mid/opengl/source/lean/model/opengl-model-hexagon-lit_textured.ads
View File

@@ -18,6 +18,7 @@ is
Textures : openGL.asset_Names (1 .. Positive (texture_Set.texture_Id'Last)) := [others => null_Asset]; -- The textures to be applied to the hex. Textures : openGL.asset_Names (1 .. Positive (texture_Set.texture_Id'Last)) := [others => null_Asset]; -- The textures to be applied to the hex.
texture_Count : Natural := 0; texture_Count : Natural := 0;
texture_Applies : texture_Set.texture_Apply_array := [others => True]; texture_Applies : texture_Set.texture_Apply_array := [others => True];
Animation : texture_Set.Animation_view;
end record; end record;
@@ -42,17 +43,17 @@ is
-- --
overriding overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
overriding overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level); Now : in texture_Set.fade_Level);
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in asset_Name); Now : in asset_Name);
overriding overriding
function texture_Count (Self : in Item) return Natural; function texture_Count (Self : in Item) return Natural;
overriding overriding
@@ -62,6 +63,10 @@ is
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean); Now : in Boolean);
overriding
procedure animate (Self : in out Item);
private private

39
3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.adb
View File

@@ -1,7 +1,9 @@
with with
openGL.Geometry.lit_textured, openGL.Geometry.lit_textured,
openGL.Primitive.indexed, openGL.Primitive.indexed,
openGL.Texture.Coordinates; openGL.Texture.Coordinates,
ada.Calendar;
package body openGL.Model.polygon.lit_textured package body openGL.Model.polygon.lit_textured
@@ -84,7 +86,7 @@ is
overriding overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean) Now : in Boolean)
is is
begin begin
Self.Face.texture_Applies (Which) := Now; Self.Face.texture_Applies (Which) := Now;
@@ -93,6 +95,21 @@ is
overriding
procedure animate (Self : in out Item)
is
use type texture_Set.Animation_view;
begin
if Self.Face.Animation = null
then
return;
end if;
texture_Set.animate (Self.Face.Animation.all,
Self.Face.texture_Applies);
end animate;
-------------------- --------------------
--- to_GL_Geometries --- to_GL_Geometries
@@ -160,27 +177,17 @@ is
end new_Face; end new_Face;
upper_Face : Geometry.lit_textured.view; the_Face : Geometry.lit_textured.view;
begin begin
-- Upper Face -- Face
-- --
declare declare
use openGL.Texture.Coordinates; use openGL.Texture.Coordinates;
the_Vertices : Geometry.lit_textured.Vertex_array (1 .. the_Sites'Length + 1); the_Vertices : Geometry.lit_textured.Vertex_array (1 .. the_Sites'Length + 1);
Coords_and_Centroid : constant Coords_2D_and_Centroid := to_Coordinates (the_Sites); Coords_and_Centroid : constant Coords_2D_and_Centroid := to_Coordinates (the_Sites);
-- Centroid : Vector_2 := (0.0, 0.0);
begin begin
--- Calculate the centroid and min/max of x and y.
--
-- for i in the_Sites'Range
-- loop
-- Centroid := Centroid + the_Sites (i);
-- end loop;
--
-- Centroid := Centroid / Real (the_Sites'Length);
for i in the_Sites'Range for i in the_Sites'Range
loop loop
the_Vertices (Index_t (i)) := (Site => Vector_3 (the_Sites (i) & 0.0), the_Vertices (Index_t (i)) := (Site => Vector_3 (the_Sites (i) & 0.0),
@@ -196,10 +203,10 @@ is
T => 0.5 * Self.Face.texture_Tiling), T => 0.5 * Self.Face.texture_Tiling),
Shine => default_Shine); Shine => default_Shine);
upper_Face := new_Face (Vertices => the_Vertices); the_Face := new_Face (Vertices => the_Vertices);
end; end;
return [1 => upper_Face.all'Access]; return [1 => the_Face.all'Access];
end to_GL_Geometries; end to_GL_Geometries;

25
3-mid/opengl/source/lean/model/opengl-model-polygon-lit_textured.ads
View File

@@ -12,6 +12,11 @@ is
type View is access all Item'Class; type View is access all Item'Class;
--------
--- Face
--
type Face is type Face is
record record
Fades : texture_Set.fade_Levels (texture_Set.texture_Id) := [others => 0.0]; Fades : texture_Set.fade_Levels (texture_Set.texture_Id) := [others => 0.0];
@@ -19,6 +24,7 @@ is
texture_Count : Natural := 0; texture_Count : Natural := 0;
texture_Tiling : openGL.Real := 1.0; -- The number of times the texture should be wrapped. texture_Tiling : openGL.Real := 1.0; -- The number of times the texture should be wrapped.
texture_Applies : texture_Set.texture_Apply_array := [others => True]; texture_Applies : texture_Set.texture_Apply_array := [others => True];
Animation : texture_Set.Animation_view;
end record; end record;
@@ -43,17 +49,17 @@ is
-- --
overriding overriding
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
overriding overriding
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level); Now : in texture_Set.fade_Level);
procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Texture_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in asset_Name); Now : in asset_Name);
overriding overriding
function texture_Count (Self : in Item) return Natural; function texture_Count (Self : in Item) return Natural;
overriding overriding
@@ -61,7 +67,11 @@ is
overriding overriding
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean); Now : in Boolean);
overriding
procedure animate (Self : in out Item);
private private
@@ -74,4 +84,5 @@ private
Face : lit_textured.Face; Face : lit_textured.Face;
end record; end record;
end openGL.Model.polygon.lit_textured; end openGL.Model.polygon.lit_textured;

4
3-mid/opengl/source/lean/model/opengl-model-texturing.ads
View File

@@ -3,10 +3,6 @@ with
openGL.texture_Set, openGL.texture_Set,
openGL.Program; openGL.Program;
-- limited
-- with
-- openGL.Model;
private private
package openGL.Model.texturing package openGL.Model.texturing

10
3-mid/opengl/source/lean/model/opengl-model.ads
View File

@@ -74,16 +74,18 @@ is
-- Texturing -- Texturing
-- --
function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level; function Fade (Self : in Item; Which : in texture_Set.texture_Id) return texture_Set.fade_Level;
procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure Fade_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in texture_Set.fade_Level); Now : in texture_Set.fade_Level);
function texture_Count (Self : in Item) return Natural; function texture_Count (Self : in Item) return Natural;
function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean; function texture_Applied (Self : in Item; Which : in texture_Set.texture_Id) return Boolean;
procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id; procedure texture_Applied_is (Self : in out Item; Which : in texture_Set.texture_Id;
Now : in Boolean); Now : in Boolean);
procedure animate (Self : in out Item) is null;
private private

73
3-mid/opengl/source/lean/opengl-texture_set.adb
View File

@@ -12,6 +12,57 @@ with ada.Text_IO; use ada.Text_IO;
package body openGL.texture_Set package body openGL.texture_Set
is is
-------------
--- Animation
--
function to_Frames (From : in texture_Set.texture_Ids) return Frames
is
Result : Frames (1 .. From'Length);
begin
for i in From'Range
loop
Result (i).texture_Id := From (i);
end loop;
return Result;
end to_Frames;
procedure animate (the_Animation : in out Animation;
texture_Applies : in out texture_Apply_array)
is
use ada.Calendar;
Now : constant ada.Calendar.Time := Clock;
begin
if Now >= the_Animation.next_frame_Time
then
declare
next_frame_Id : constant frame_Id := (if the_Animation.Current < the_Animation.frame_Count then the_Animation.Current + 1
else 1);
old_Frame : Frame renames the_Animation.Frames (the_Animation.Current);
new_Frame : Frame renames the_Animation.Frames (next_frame_Id);
begin
texture_Applies (old_Frame.texture_Id) := False;
texture_Applies (new_Frame.texture_Id) := True;
the_Animation.Current := next_frame_Id;
the_Animation.next_frame_Time := Now + the_Animation.frame_Duration;
end;
end if;
end animate;
--------
--- Item
--
procedure Texture_is (in_Set : in out Item; Which : texture_ID; Now : in openGL.Texture.Object) procedure Texture_is (in_Set : in out Item; Which : texture_ID; Now : in openGL.Texture.Object)
is is
begin begin
@@ -180,4 +231,26 @@ is
end enable; end enable;
-----------
--- Streams
--
procedure write (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Item : in Animation_view)
is
begin
Animation'output (Stream, Item.all);
end write;
procedure read (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
Item : out Animation_view)
is
begin
Item := new Animation' (Animation'Input (Stream));
end read;
end openGL.texture_Set; end openGL.texture_Set;

83
3-mid/opengl/source/lean/opengl-texture_set.ads
View File

@@ -1,23 +1,36 @@
with with
openGL.Program, openGL.Program,
openGL.Texture, openGL.Texture,
openGL.Variable.uniform; ada.Calendar;
private
with
ada.Streams;
package openGL.texture_Set package openGL.texture_Set
-- --
-- Facilitates texturing of geometries. -- Facilitates multi-texturing of geometries.
--
-- Note that Mesa currently only supports 16 texture units.
-- --
is is
--- Note that Mesa currently only supports 16 texture units.
---------------
--- Texture Ids
-- --
-- max_Textures : constant := 32;
max_Textures : constant := 16;
type texture_Id is range 1 .. max_Textures; max_Textures : constant := 16; -- 32;
type texture_Id is range 1 .. max_Textures;
type texture_Ids is array (Positive range <>) of texture_Id;
--------
--- Fade
--
type fade_Level is delta 0.001 range 0.0 .. 1.0 -- '0.0' is no fading, '1.0' is fully faded (ie invisible). type fade_Level is delta 0.001 range 0.0 .. 1.0 -- '0.0' is no fading, '1.0' is fully faded (ie invisible).
with Atomic; with Atomic;
@@ -31,7 +44,7 @@ is
record record
Fade : fade_Level := 0.0; Fade : fade_Level := 0.0;
Object : openGL.Texture.Object := openGL.Texture.null_Object; Object : openGL.Texture.Object := openGL.Texture.null_Object;
Applied : Boolean := True; -- Whether this texture is painted on. Applied : Boolean := True; -- Whether this texture is painted on or not.
-- texture_Uniform : openGL.Variable.uniform.sampler2D; -- texture_Uniform : openGL.Variable.uniform.sampler2D;
-- fade_Uniform : openGL.Variable.uniform.float; -- fade_Uniform : openGL.Variable.uniform.float;
end record; end record;
@@ -39,6 +52,45 @@ is
type fadeable_Textures is array (texture_Id range 1 .. max_Textures) of fadeable_Texture; type fadeable_Textures is array (texture_Id range 1 .. max_Textures) of fadeable_Texture;
-------------
--- Animation
--
subtype frame_Id is Positive;
type Frame is
record
texture_Id : texture_Set.texture_Id;
end record;
type Frames is array (frame_Id range <>) of Frame;
function to_Frames (From : in texture_Ids) return Frames;
type Animation (frame_Count : Positive) is
record
frame_Duration : Duration := 0.1;
next_frame_Time : ada.Calendar.Time := ada.Calendar.Clock;
Current : frame_Id := 1;
Frames : texture_Set.Frames (1 .. frame_Count);
end record;
type Animation_view is access all Animation;
procedure animate (the_Animation : in out Animation;
texture_Applies : in out texture_Apply_array);
--------
--- Item
--
type Item is type Item is
record record
Textures : fadeable_Textures; Textures : fadeable_Textures;
@@ -59,4 +111,21 @@ is
function Texture (in_Set : in Item) return openGL.Texture.Object; function Texture (in_Set : in Item) return openGL.Texture.Object;
private
-----------
--- Streams
--
procedure write (Stream : not null access ada.Streams.Root_Stream_type'Class;
Item : in texture_Set.Animation_view);
procedure read (Stream : not null access ada.Streams.Root_Stream_type'Class;
Item : out texture_Set.Animation_view);
for Animation_view'write use write;
for Animation_view'read use read;
end openGL.texture_Set; end openGL.texture_Set;

6
4-high/gel/source/forge/gel-forge.adb
View File

@@ -166,7 +166,8 @@ is
Face => (Fades => [1 => 0.0, others => <>], Face => (Fades => [1 => 0.0, others => <>],
texture_Applies => [1 => True, others => <>], texture_Applies => [1 => True, others => <>],
Textures => [1 => Texture, others => <>], Textures => [1 => Texture, others => <>],
texture_Count => 1)).all'Access; texture_Count => 1,
Animation => null)).all'Access;
end if; end if;
return gel.Sprite.Forge.new_Sprite (Name, return gel.Sprite.Forge.new_Sprite (Name,
@@ -225,7 +226,8 @@ is
Textures => [1 => Texture, others => <>], Textures => [1 => Texture, others => <>],
texture_Count => 1, texture_Count => 1,
texture_Tiling => texture_Tiling, texture_Tiling => texture_Tiling,
texture_Applies => [others => <>])).all'Access; texture_Applies => [others => <>],
Animation => null)).all'Access;
end if; end if;
return gel.Sprite.Forge.new_Sprite (Name, return gel.Sprite.Forge.new_Sprite (Name,