Alpha animation assessment algorithm added

6 files changed, 225 insertions, 2 deletions

diff --git a/src/c_fl.cpp b/src/c_fl.cpp
index 1e8fd1c..50eed9e 100644
--- a/src/c_fl.cpp
+++ b/src/c_fl.cpp
@@ -4,6 +4,7 @@
 //  Released into the public domain
 
 
+#include <FL/Enumerations.H>
 #include <FL/Fl.H>
 #include "c_fl.h"
 
@@ -22,6 +23,13 @@ size_t c_pointer_size() {
 
 
 
+unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b) {
+    return fl_rgb_color(r, g, b);
+}
+
+
+
+
 int fl_abi_check(int v) {
     return Fl::abi_check(v);
 }
diff --git a/src/c_fl.h b/src/c_fl.h
index 5a8d942..8ef9df5 100644
--- a/src/c_fl.h
+++ b/src/c_fl.h
@@ -14,6 +14,9 @@ extern "C" const short fl_mod_command;
 extern "C" size_t c_pointer_size();
 
 
+extern "C" unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b);
+
+
 extern "C" int fl_abi_check(int v);
 extern "C" int fl_abi_version();
 extern "C" int fl_api_version();
diff --git a/src/fltk.adb b/src/fltk.adb
index 61491d9..f302b47 100644
--- a/src/fltk.adb
+++ b/src/fltk.adb
@@ -17,6 +17,15 @@ use type
 package body FLTK is
 
 
+    function fl_enum_rgb_color
+           (R, G, B : in Interfaces.C.unsigned_char)
+        return Interfaces.C.unsigned;
+    pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color");
+    pragma Inline (fl_enum_rgb_color);
+
+
+
+
     function fl_abi_check
            (V : in Interfaces.C.int)
         return Interfaces.C.int;
@@ -100,6 +109,19 @@ package body FLTK is
 
 
 
+    function RGB_Color
+           (R, G, B : in Color_Component)
+        return Color is
+    begin
+        return Color (fl_enum_rgb_color
+           (Interfaces.C.unsigned_char (R),
+            Interfaces.C.unsigned_char (G),
+            Interfaces.C.unsigned_char (B)));
+    end RGB_Color;
+
+
+
+
     function Press
            (Key : in Pressable_Key)
         return Keypress is
diff --git a/src/fltk.ads b/src/fltk.ads
index f6b7292..785ad23 100644
--- a/src/fltk.ads
+++ b/src/fltk.ads
@@ -44,7 +44,11 @@ package FLTK is
     type Color_Component is mod 256;
     type Color_Component_Array is array (Positive range <>) of aliased Color_Component;
 
-    --  Examples of RGB colors
+    function RGB_Color
+           (R, G, B : in Color_Component)
+        return Color;
+
+    --  Examples of RGB colors without the above function
     --  The lowest byte has to be 00 for the color to be RGB
     RGB_Red_Color   : constant Color := 16#ff000000#;
     RGB_Green_Color : constant Color := 16#00ff0000#;
@@ -423,6 +427,7 @@ private
 
     for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT;
     pragma Convention (C, Color_Component_Array);
+    pragma Pack (Color_Component_Array);
 
 
 
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;
+
+
diff --git a/tests.gpr b/tests.gpr
index 4ff8cfc..cb95919 100644
--- a/tests.gpr
+++ b/tests.gpr
@@ -14,10 +14,16 @@ project Tests is
     for Object_Dir use "obj";
     for Exec_Dir use "bin";
 
-    for Main use ("adjuster.adb", "compare.adb", "dirlist.adb", "page_formats.adb");
+    for Main use
+       ("adjuster.adb",
+        "animated.adb",
+        "compare.adb",
+        "dirlist.adb",
+        "page_formats.adb");
 
     package Builder is
         for Executable ("adjuster.adb")     use "adjuster";
+        for Executable ("animated.adb")     use "animated";
         for Executable ("compare.adb")      use "compare";
         for Executable ("dirlist.adb")      use "dirlist";
         for Executable ("page_formats.adb") use "page_formats";