From a4703a65b015140cd4a7a985db66264875ade734 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Tue, 21 Jan 2025 20:51:57 +1300 Subject: Alpha animation assessment algorithm added --- src/c_fl.cpp | 8 +++ src/c_fl.h | 3 + src/fltk.adb | 22 +++++++ src/fltk.ads | 7 ++- test/animated.adb | 179 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests.gpr | 8 ++- 6 files changed, 225 insertions(+), 2 deletions(-) create mode 100644 test/animated.adb 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 #include #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"; -- cgit