From 446989277ad276e9820e54ea1fb4ed550b93e998 Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Mon, 10 Feb 2025 22:50:09 +1300 Subject: Filled holes in Enumerations and FLTK (Screen) APIs --- body/c_fl.cpp | 57 +++++++++++- body/c_fl.h | 18 ++++ body/c_fl_screen.cpp | 9 ++ body/c_fl_screen.h | 3 + body/fltk-screen.adb | 21 +++++ body/fltk.adb | 220 ++++++++++++++++++++++++++++++++++++++++++++++ doc/enumerations.html | 80 ++++++++++++++--- doc/fl_(fltk-screen).html | 5 +- doc/fl_image.html | 5 -- spec/fltk-images.ads | 2 - spec/fltk-screen.ads | 10 +++ spec/fltk.ads | 58 ++++++++++++ 12 files changed, 467 insertions(+), 21 deletions(-) diff --git a/body/c_fl.cpp b/body/c_fl.cpp index 24119a6..42d9a45 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -52,12 +52,65 @@ size_t c_pointer_size() { +const int fl_enum_num_red = FL_NUM_RED; +const int fl_enum_num_green = FL_NUM_GREEN; +const int fl_enum_num_blue = FL_NUM_BLUE; +const int fl_enum_num_gray = FL_NUM_GRAY; + + + + +unsigned int fl_enum_rgb_color2(unsigned char l) { + return static_cast(fl_rgb_color(l)); +} + unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b) { - return fl_rgb_color(r, g, b); + return static_cast(fl_rgb_color(r, g, b)); +} + +unsigned int fl_enum_color_cube(int r, int g, int b) { + return static_cast(fl_color_cube(r, g, b)); +} + +unsigned int fl_enum_gray_ramp(int l) { + return static_cast(fl_gray_ramp(l)); +} + +unsigned int fl_enum_darker(unsigned int c) { + return static_cast(fl_darker(static_cast(c))); +} + +unsigned int fl_enum_lighter(unsigned int c) { + return static_cast(fl_lighter(static_cast(c))); } unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { - return fl_contrast(f, b); + return static_cast(fl_contrast + (static_cast(f), static_cast(b))); +} + +unsigned int fl_enum_inactive(unsigned int c) { + return static_cast(fl_inactive(static_cast(c))); +} + +unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w) { + return static_cast(fl_color_average + (static_cast(c1), static_cast(c2), w)); +} + + + + +int fl_enum_box(int b) { + return static_cast(fl_box(static_cast(b))); +} + +int fl_enum_frame(int b) { + return static_cast(fl_frame(static_cast(b))); +} + +int fl_enum_down(int b) { + return static_cast(fl_down(static_cast(b))); } diff --git a/body/c_fl.h b/body/c_fl.h index b12f560..f85c36f 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -43,8 +43,26 @@ extern "C" const short fl_mod_command; extern "C" size_t c_pointer_size(); +extern "C" const int fl_enum_num_red; +extern "C" const int fl_enum_num_green; +extern "C" const int fl_enum_num_blue; +extern "C" const int fl_enum_num_gray; + + +extern "C" unsigned int fl_enum_rgb_color2(unsigned char l); extern "C" unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b); +extern "C" unsigned int fl_enum_color_cube(int r, int g, int b); +extern "C" unsigned int fl_enum_gray_ramp(int l); +extern "C" unsigned int fl_enum_darker(unsigned int c); +extern "C" unsigned int fl_enum_lighter(unsigned int c); extern "C" unsigned int fl_enum_contrast(unsigned int f, unsigned int b); +extern "C" unsigned int fl_enum_inactive(unsigned int c); +extern "C" unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w); + + +extern "C" int fl_enum_box(int b); +extern "C" int fl_enum_frame(int b); +extern "C" int fl_enum_down(int b); extern "C" int fl_abi_check(int v); diff --git a/body/c_fl_screen.cpp b/body/c_fl_screen.cpp index 88550bd..d0e8019 100644 --- a/body/c_fl_screen.cpp +++ b/body/c_fl_screen.cpp @@ -8,6 +8,15 @@ #include "c_fl_screen.h" + + +void fl_screen_display(const char * v) { + Fl::display(v); +} + + + + int fl_screen_x() { return Fl::x(); } diff --git a/body/c_fl_screen.h b/body/c_fl_screen.h index 9b4d4ec..8fff58d 100644 --- a/body/c_fl_screen.h +++ b/body/c_fl_screen.h @@ -8,6 +8,9 @@ #define FL_SCREEN_GUARD +extern "C" void fl_screen_display(const char * v); + + extern "C" int fl_screen_x(); extern "C" int fl_screen_y(); extern "C" int fl_screen_w(); diff --git a/body/fltk-screen.adb b/body/fltk-screen.adb index c7c7957..54618fe 100644 --- a/body/fltk-screen.adb +++ b/body/fltk-screen.adb @@ -20,6 +20,16 @@ package body FLTK.Screen is -- Functions From C -- ------------------------ + -- Environment -- + + procedure fl_screen_display + (V : in Interfaces.C.char_array); + pragma Import (C, fl_screen_display, "fl_screen_display"); + pragma Inline (fl_screen_display); + + + + -- Basic Dimensions -- function fl_screen_x @@ -127,6 +137,17 @@ package body FLTK.Screen is -- API Subprograms -- ----------------------- + -- Environment -- + + procedure Set_Display_Var + (Value : in String) is + begin + fl_screen_display (Interfaces.C.To_C (Value)); + end Set_Display_Var; + + + + -- Basic Dimensions -- function Get_X return Integer is diff --git a/body/fltk.adb b/body/fltk.adb index aaef1fd..cebf1a9 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,33 +11,123 @@ with use type Interfaces.C.int, + Interfaces.C.unsigned_char, Interfaces.C.unsigned_long; package body FLTK is + ------------------------ + -- Constants From C -- + ------------------------ + + fl_enum_num_red : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_red); + + fl_enum_num_green : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_green); + + fl_enum_num_blue : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_blue); + + fl_enum_num_gray : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_gray); + + + + ------------------------ -- Functions From C -- ------------------------ -- Enumerations.H -- + -- Color -- + + function fl_enum_rgb_color2 + (L : in Interfaces.C.unsigned_char) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_rgb_color2, "fl_enum_rgb_color2"); + pragma Inline (fl_enum_rgb_color2); + 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_enum_color_cube + (R, G, B : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_cube, "fl_enum_color_cube"); + pragma Inline (fl_enum_color_cube); + + function fl_enum_gray_ramp + (L : in Interfaces.C.int) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_gray_ramp, "fl_enum_gray_ramp"); + pragma Inline (fl_enum_gray_ramp); + + function fl_enum_darker + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_darker, "fl_enum_darker"); + pragma Inline (fl_enum_darker); + + function fl_enum_lighter + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_lighter, "fl_enum_lighter"); + pragma Inline (fl_enum_lighter); + function fl_enum_contrast (F, B : in Interfaces.C.unsigned) return Interfaces.C.unsigned; pragma Import (C, fl_enum_contrast, "fl_enum_contrast"); pragma Inline (fl_enum_contrast); + function fl_enum_inactive + (T : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_inactive, "fl_enum_inactive"); + pragma Inline (fl_enum_inactive); + + function fl_enum_color_average + (T1, T2 : in Interfaces.C.unsigned; + W : in Interfaces.C.C_float) + return Interfaces.C.unsigned; + pragma Import (C, fl_enum_color_average, "fl_enum_color_average"); + pragma Inline (fl_enum_color_average); + + + + + -- Box Types -- + + function fl_enum_box + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_box, "fl_enum_box"); + pragma Inline (fl_enum_box); + + function fl_enum_frame + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_frame, "fl_enum_frame"); + pragma Inline (fl_enum_frame); + + function fl_enum_down + (B : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_enum_down, "fl_enum_down"); + pragma Inline (fl_enum_down); + + -- Fl.H -- + -- Versioning -- function fl_abi_check @@ -128,6 +218,26 @@ package body FLTK is -- Color -- + function RGB_Color + (Light : in Greyscale) + return Color is + begin + case Light is + when 'A' .. 'W' => return Color (fl_enum_rgb_color2 + ((Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First)) * 11)); + when 'X' => return Color (fl_enum_rgb_color2 (255)); + end case; + end RGB_Color; + + + function RGB_Color + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_rgb_color2 (Interfaces.C.unsigned_char (Light))); + end RGB_Color; + + function RGB_Color (R, G, B : in Color_Component) return Color is @@ -139,6 +249,50 @@ package body FLTK is end RGB_Color; + function Color_Cube + (R, G, B : in Color_Component) + return Color is + begin + return Color (fl_enum_color_cube + (Interfaces.C.int (Float'Rounding (Float (R) * Float (fl_enum_num_red - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (G) * Float (fl_enum_num_green - 1) / 255.0)), + Interfaces.C.int (Float'Rounding (Float (B) * Float (fl_enum_num_blue - 1) / 255.0)))); + end Color_Cube; + + + function Grey_Ramp + (Light : in Greyscale) + return Color is + begin + return Color (fl_enum_gray_ramp (Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First))); + end Grey_Ramp; + + + function Grey_Ramp + (Light : in Color_Component) + return Color is + begin + return Color (fl_enum_gray_ramp (Interfaces.C.int + (Float'Rounding (Float (Light) * Float (fl_enum_num_gray - 1) / 255.0)))); + end Grey_Ramp; + + + function Darker + (Tone : in Color) + return Color is + begin + return Color (fl_enum_darker (Interfaces.C.unsigned (Tone))); + end Darker; + + + function Lighter + (Tone : in Color) + return Color is + begin + return Color (fl_enum_lighter (Interfaces.C.unsigned (Tone))); + end Lighter; + + function Contrast (Fore, Back : in Color) return Color is @@ -149,6 +303,26 @@ package body FLTK is end Contrast; + function Inactive + (Tone : in Color) + return Color is + begin + return Color (fl_enum_inactive (Interfaces.C.unsigned (Tone))); + end Inactive; + + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color is + begin + return Color (fl_enum_color_average + (Interfaces.C.unsigned (Tone1), + Interfaces.C.unsigned (Tone2), + Interfaces.C.C_float (Weight))); + end Color_Average; + + -- Alignment -- @@ -361,6 +535,52 @@ package body FLTK is + -- Box Types -- + + function Filled + (Box : in Box_Kind) + return Box_Kind + is + Result : Interfaces.C.int := fl_enum_box (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_box in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Filled; + + + function Frame + (Box : in Box_Kind) + return Box_Kind + is + Result : Interfaces.C.int := fl_enum_frame (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_frame in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Frame; + + + function Down + (Box : in Box_Kind) + return Box_Kind + is + Result : Interfaces.C.int := fl_enum_down (Box_Kind'Pos (Box)); + begin + return Box_Kind'Val (Result); + exception + when Constraint_Error => raise Internal_FLTK_Error with + "fl_down in Enumerations.H returned unexpected int value of " & + Interfaces.C.int'Image (Result); + end Down; + + + + -- Menu Flags -- function "+" diff --git a/doc/enumerations.html b/doc/enumerations.html index 9106ff3..937a7a9 100644 --- a/doc/enumerations.html +++ b/doc/enumerations.html @@ -56,6 +56,11 @@ Color_Component_Array + + float + Blend + + Fl_Align Alignment @@ -72,7 +77,11 @@ - #define + + #define FL_LEFT_MOUSE 1
+ #define FL_MIDDLE_MOUSE 2
+ #define FL_RIGHT_MOUSE 3 + Mouse_Button @@ -142,21 +151,34 @@ 
 inline Fl_Boxtype fl_box(Fl_Boxtype b);
-  +
+function Filled
+       (Box : in Box_Kind)
+    return Box_Kind;
+
 Fl_Color fl_color_average(Fl_Color c1, Fl_Color c2, float weight);
-  +
+function Color_Average
+       (Tone1, Tone2 : in Color;
+        Weight       : in Blend := 0.5)
+    return Color;
+
 inline Fl_Color fl_color_cube(int r, int g, int b);
-  +
+function Color_Cube
+       (R, G, B : in Color_Component)
+    return Color;
+
@@ -174,49 +196,85 @@ function Contrast 
 inline Fl_Color fl_darker(Fl_Color c);
-  +
+function Darker
+       (Tone : in Color)
+    return Color;
+
 inline Fl_Boxtype fl_down(Fl_Boxtype b);
-  +
+function Down
+       (Box : in Box_Kind)
+    return Box_Kind;
+
 inline Fl_Boxtype fl_frame(Fl_Boxtype b);
-  +
+function Frame
+       (Box : in Box_Kind)
+    return Box_Kind;
+
 inline Fl_Color fl_gray_ramp(int i);
-  +
+function Grey_Ramp
+       (Light : in Greyscale)
+    return Color;
+
+function Grey_Ramp
+       (Light : in Color_Component)
+    return Color;
+
 Fl_Color fl_inactive(Fl_Color c);
-  +
+function Inactive
+       (Tone : in Color)
+    return Color;
+
 inline Fl_Color fl_lighter(Fl_Color c);
-  +
+function Lighter
+       (Tone : in Color)
+    return Color;
+
 inline Fl_Color fl_rgb_color(uchar g);
-  +
+function RGB_Color
+       (Light : in Greyscale)
+    return Color;
+
+function RGB_Color
+       (Light : in Color_Component)
+    return Color;
+
diff --git a/doc/fl_(fltk-screen).html b/doc/fl_(fltk-screen).html index b44267c..fddc17d 100644 --- a/doc/fl_(fltk-screen).html +++ b/doc/fl_(fltk-screen).html @@ -35,7 +35,10 @@ 
 static void display(const char *);
-  +
+procedure Set_Display_Var
+       (Value : in String);
+
diff --git a/doc/fl_image.html b/doc/fl_image.html index 10c9ed8..201a2fa 100644 --- a/doc/fl_image.html +++ b/doc/fl_image.html @@ -46,11 +46,6 @@ Scaling_Kind - - float - Blend - - diff --git a/spec/fltk-images.ads b/spec/fltk-images.ads index 165c203..6afb788 100644 --- a/spec/fltk-images.ads +++ b/spec/fltk-images.ads @@ -14,8 +14,6 @@ package FLTK.Images is type Scaling_Kind is (Nearest, Bilinear); - type Blend is new Float range 0.0 .. 1.0; - No_Image_Error, File_Access_Error, Format_Error : exception; diff --git a/spec/fltk-screen.ads b/spec/fltk-screen.ads index b7d5521..8a26d9c 100644 --- a/spec/fltk-screen.ads +++ b/spec/fltk-screen.ads @@ -7,6 +7,14 @@ package FLTK.Screen is + -- Environment -- + + procedure Set_Display_Var + (Value : in String); + + + + -- Basic Dimensions -- function Get_X @@ -82,6 +90,8 @@ package FLTK.Screen is private + pragma Inline (Set_Display_Var); + pragma Inline (Get_X); pragma Inline (Get_Y); pragma Inline (Get_W); diff --git a/spec/fltk.ads b/spec/fltk.ads index db75720..24e68fe 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -46,14 +46,53 @@ package FLTK is type Color_Component is mod 256; type Color_Component_Array is array (Positive range <>) of aliased Color_Component; + subtype Blend is Float range 0.0 .. 1.0; + + function RGB_Color + (Light : in Greyscale) + return Color; + + function RGB_Color + (Light : in Color_Component) + return Color; + function RGB_Color (R, G, B : in Color_Component) return Color; + function Color_Cube + (R, G, B : in Color_Component) + return Color; + + function Grey_Ramp + (Light : in Greyscale) + return Color; + + function Grey_Ramp + (Light : in Color_Component) + return Color; + + function Darker + (Tone : in Color) + return Color; + + function Lighter + (Tone : in Color) + return Color; + function Contrast (Fore, Back : in Color) return Color; + function Inactive + (Tone : in Color) + return Color; + + function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + 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#; @@ -282,6 +321,18 @@ package FLTK is Gleam_Round_Down_Box, Free_Box); + function Filled + (Box : in Box_Kind) + return Box_Kind; + + function Frame + (Box : in Box_Kind) + return Box_Kind; + + function Down + (Box : in Box_Kind) + return Box_Kind; + @@ -662,7 +713,14 @@ private pragma Inline (RGB_Color); + pragma Inline (Color_Cube); + pragma Inline (Contrast); + pragma Inline (Grey_Ramp); + pragma Inline (Darker); + pragma Inline (Lighter); pragma Inline (Contrast); + pragma Inline (Inactive); + pragma Inline (Color_Average); pragma Inline (ABI_Check); pragma Inline (ABI_Version); -- cgit