Alpha animation assessment algorithm added

1 files changed, 179 insertions, 0 deletions

diff --git a/test/animated.adb b/test/animated.adb
new file mode 100644
index 0000000..b512284
--- /dev/null
+++ b/test/animated.adb
@@ -0,0 +1,179 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+--  Alpha rendering benchmark test program functionality duplicated in Ada
+
+
+with
+
+    FLTK.Draw,
+    FLTK.Images.RGB,
+    FLTK.Static,
+    FLTK.Widgets.Groups.Windows.Double;
+
+
+function Animated
+    return Integer
+is
+
+
+    package FDR renames FLTK.Draw;
+    package RGB renames FLTK.Images.RGB;
+    package Stc renames FLTK.Static;
+    package WD  renames FLTK.Widgets.Groups.Windows.Double;
+
+
+    Frames    : constant Integer := 48;
+    Channels  : constant Integer := 4;
+    Dimension : constant Integer := 256;
+
+
+    subtype Image_Data is FLTK.Color_Component_Array (1 .. Dimension ** 2 * Channels);
+    type Image_Data_Array is array (Positive range <>) of Image_Data;
+
+    type RGB_Image_Access is access RGB.RGB_Image;
+    type RGB_Image_Access_Array is array (Positive range <>) of RGB_Image_Access;
+
+
+    procedure Black_Box_Corner
+           (Store : in out Image_Data) is
+    begin
+        for X in Integer range 0 .. 9 loop
+            for Y in Integer range 0 .. 9 loop
+                Store (Y * Dimension * Channels + X * Channels + 4) := 255;
+            end loop;
+        end loop;
+    end Black_Box_Corner;
+
+
+    procedure Fading_Sphere
+           (Store : in out Image_Data;
+            Place : in     Integer)
+    is
+        Sphere_W : constant Integer := 60;
+        Sphere_X : constant Integer := (Dimension - Sphere_W) / 2;
+        Max_Dist : constant Integer := (Sphere_W / 2) ** 2;
+        Dist_X, Dist_Y, Dist, Fill : Float;
+        Alpha, My_Alpha, Grey : FLTK.Color_Component;
+    begin
+        if Place - 1 < Frames / 2 then
+            Alpha := FLTK.Color_Component
+                (255.0 * (Float (Place - 1) / (Float (Frames) / 2.0)));
+        else
+            Alpha := FLTK.Color_Component
+                (Integer (255.0 * (Float (Frames - Place + 1) / (Float (Frames) / 2.0))) mod 256);
+        end if;
+
+        for X in Integer range Sphere_X .. Sphere_X + Sphere_W - 1 loop
+            for Y in Integer range 20 .. 20 + Sphere_W - 1 loop
+                Dist_X := Float (X) - (Float (Sphere_X) + Float (Sphere_W) / 2.0);
+                Dist_Y := Float (Y) - (20.0 + Float (Sphere_W) / 2.0);
+                Dist := Dist_X ** 2 + Dist_Y ** 2;
+
+                if Dist <= Float (Max_Dist) then
+                    Fill := Dist / Float (Max_Dist);
+                    Grey := FLTK.Color_Component (Fill * 255.0);
+                    My_Alpha := Alpha;
+
+                    if Fill > 0.9 then
+                        My_Alpha := FLTK.Color_Component (Float (My_Alpha) * (1.0 - Fill) * 10.0);
+                    end if;
+
+                    Store (Y * Dimension * Channels + X * Channels + 1) := Grey;
+                    Store (Y * Dimension * Channels + X * Channels + 2) := Grey;
+                    Store (Y * Dimension * Channels + X * Channels + 3) := Grey;
+                    Store (Y * Dimension * Channels + X * Channels + 4) := My_Alpha;
+                end if;
+            end loop;
+        end loop;
+    end Fading_Sphere;
+
+
+    procedure Moving_Blob
+           (Store : in out Image_Data;
+            Place : in     Integer)
+    is
+        Position : constant Float := 2.0 * Float (Place - 1) / Float (Frames) - 0.5;
+        X_Offset : constant Integer := Integer (Position * Float (Dimension));
+        Y_Offset : constant Integer := 2 * Dimension / 3;
+        W : constant Integer := Dimension / 4;
+        Grey : FLTK.Color_Component;
+    begin
+        for X in Integer range (-W) .. W - 1 loop
+            if (X + X_Offset >= 0) and (X + X_Offset < Dimension) then
+                for Y in Integer range Y_Offset - W .. Y_Offset + W - 1 loop
+                    Grey := FLTK.Color_Component (abs (Y - Y_Offset));
+                    Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 3) := Grey;
+                    Store (Y * Dimension * Channels + (X + X_Offset) * Channels + 4) := 127;
+                end loop;
+            end if;
+        end loop;
+    end Moving_Blob;
+
+
+    function Make_Images
+        return Image_Data_Array is
+    begin
+        return Pict_Data : Image_Data_Array (1 .. Frames) := (others => (others => 0)) do
+            for Index in Pict_Data'Range loop
+                Black_Box_Corner (Pict_Data (Index));
+                Fading_Sphere    (Pict_Data (Index), Index);
+                Moving_Blob      (Pict_Data (Index), Index);
+            end loop;
+        end return;
+    end Make_Images;
+
+
+    Frame_Image_Data : Image_Data_Array := Make_Images;
+    Frame_Images : RGB_Image_Access_Array (1 .. Frames);
+
+
+    Current_Frame : Integer range 1 .. Frames := 1;
+
+
+    type My_Window is new WD.Double_Window with null record;
+
+    procedure Draw
+           (This : in out My_Window) is
+    begin
+        WD.Double_Window (This).Draw;
+        FDR.Push_Clip (5, 5, This.Get_W - 5, This.Get_H - 5);
+        Frame_Images (Current_Frame).Draw (0, 0, Dimension, Dimension, 5, 5);
+        FDR.Pop_Clip;
+    end Draw;
+
+    The_Window : My_Window :=
+       (WD.Forge.Create (Dimension, Dimension, "Alpha rendering benchmark")
+        with null record);
+
+
+    procedure Frame_Update is
+    begin
+        The_Window.Redraw;
+        Stc.Repeat_Timeout (1.0 / 24.0, Frame_Update'Unrestricted_Access);
+        Current_Frame := (Current_Frame + 1) mod Frames + 1;
+    end Frame_Update;
+
+
+begin
+
+
+    for Index in Frame_Images'Range loop
+        Frame_Images (Index) := new RGB.RGB_Image'(RGB.Forge.Create
+            (Frame_Image_Data (Index), Dimension, Dimension, Channels));
+    end loop;
+
+    The_Window.Set_Background_Color (FLTK.RGB_Color (142, 0, 0));
+    The_Window.Show_With_Args;
+
+    Stc.Add_Timeout (1.0 / 24.0, Frame_Update'Unrestricted_Access);
+
+    return FLTK.Run;
+
+
+end Animated;
+
+