diff options
-rw-r--r-- | body/c_fl.cpp | 57 | ||||
-rw-r--r-- | body/c_fl.h | 18 | ||||
-rw-r--r-- | body/c_fl_screen.cpp | 9 | ||||
-rw-r--r-- | body/c_fl_screen.h | 3 | ||||
-rw-r--r-- | body/fltk-screen.adb | 21 | ||||
-rw-r--r-- | body/fltk.adb | 220 | ||||
-rw-r--r-- | doc/enumerations.html | 80 | ||||
-rw-r--r-- | doc/fl_(fltk-screen).html | 5 | ||||
-rw-r--r-- | doc/fl_image.html | 5 | ||||
-rw-r--r-- | spec/fltk-images.ads | 2 | ||||
-rw-r--r-- | spec/fltk-screen.ads | 10 | ||||
-rw-r--r-- | 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<unsigned int>(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<unsigned int>(fl_rgb_color(r, g, b)); +} + +unsigned int fl_enum_color_cube(int r, int g, int b) { + return static_cast<unsigned int>(fl_color_cube(r, g, b)); +} + +unsigned int fl_enum_gray_ramp(int l) { + return static_cast<unsigned int>(fl_gray_ramp(l)); +} + +unsigned int fl_enum_darker(unsigned int c) { + return static_cast<unsigned int>(fl_darker(static_cast<Fl_Color>(c))); +} + +unsigned int fl_enum_lighter(unsigned int c) { + return static_cast<unsigned int>(fl_lighter(static_cast<Fl_Color>(c))); } unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { - return fl_contrast(f, b); + return static_cast<unsigned int>(fl_contrast + (static_cast<Fl_Color>(f), static_cast<Fl_Color>(b))); +} + +unsigned int fl_enum_inactive(unsigned int c) { + return static_cast<unsigned int>(fl_inactive(static_cast<Fl_Color>(c))); +} + +unsigned int fl_enum_color_average(unsigned int c1, unsigned int c2, float w) { + return static_cast<unsigned int>(fl_color_average + (static_cast<Fl_Color>(c1), static_cast<Fl_Color>(c2), w)); +} + + + + +int fl_enum_box(int b) { + return static_cast<int>(fl_box(static_cast<Fl_Boxtype>(b))); +} + +int fl_enum_frame(int b) { + return static_cast<int>(fl_frame(static_cast<Fl_Boxtype>(b))); +} + +int fl_enum_down(int b) { + return static_cast<int>(fl_down(static_cast<Fl_Boxtype>(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,6 +11,7 @@ with use type Interfaces.C.int, + Interfaces.C.unsigned_char, Interfaces.C.unsigned_long; @@ -18,26 +19,115 @@ 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 @@ -129,6 +219,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 begin @@ -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 @@ -57,6 +57,11 @@ </tr> <tr> + <td>float</td> + <td>Blend</td> + </tr> + + <tr> <td>Fl_Align</td> <td>Alignment</td> </tr> @@ -72,7 +77,11 @@ </tr> <tr> - <td>#define</td> + <td> + #define FL_LEFT_MOUSE 1<br /> + #define FL_MIDDLE_MOUSE 2<br /> + #define FL_RIGHT_MOUSE 3 + </td> <td>Mouse_Button</td> </tr> @@ -142,21 +151,34 @@ <td><pre> inline Fl_Boxtype fl_box(Fl_Boxtype b); </pre></td> -<td> </td> +<td><pre> +function Filled + (Box : in Box_Kind) + return Box_Kind; +</pre></td> </tr> <tr> <td><pre> Fl_Color fl_color_average(Fl_Color c1, Fl_Color c2, float weight); </pre></td> -<td> </td> +<td><pre> +function Color_Average + (Tone1, Tone2 : in Color; + Weight : in Blend := 0.5) + return Color; +</pre></td> </tr> <tr> <td><pre> inline Fl_Color fl_color_cube(int r, int g, int b); </pre></td> -<td> </td> +<td><pre> +function Color_Cube + (R, G, B : in Color_Component) + return Color; +</pre></td> </tr> <tr> @@ -174,49 +196,85 @@ function Contrast <td><pre> inline Fl_Color fl_darker(Fl_Color c); </pre></td> -<td> </td> +<td><pre> +function Darker + (Tone : in Color) + return Color; +</pre></td> </tr> <tr> <td><pre> inline Fl_Boxtype fl_down(Fl_Boxtype b); </pre></td> -<td> </td> +<td><pre> +function Down + (Box : in Box_Kind) + return Box_Kind; +</pre></td> </tr> <tr> <td><pre> inline Fl_Boxtype fl_frame(Fl_Boxtype b); </pre></td> -<td> </td> +<td><pre> +function Frame + (Box : in Box_Kind) + return Box_Kind; +</pre></td> </tr> <tr> <td><pre> inline Fl_Color fl_gray_ramp(int i); </pre></td> -<td> </td> +<td><pre> +function Grey_Ramp + (Light : in Greyscale) + return Color; + +function Grey_Ramp + (Light : in Color_Component) + return Color; +</pre></td> </tr> <tr> <td><pre> Fl_Color fl_inactive(Fl_Color c); </pre></td> -<td> </td> +<td><pre> +function Inactive + (Tone : in Color) + return Color; +</pre></td> </tr> <tr> <td><pre> inline Fl_Color fl_lighter(Fl_Color c); </pre></td> -<td> </td> +<td><pre> +function Lighter + (Tone : in Color) + return Color; +</pre></td> </tr> <tr> <td><pre> inline Fl_Color fl_rgb_color(uchar g); </pre></td> -<td> </td> +<td><pre> +function RGB_Color + (Light : in Greyscale) + return Color; + +function RGB_Color + (Light : in Color_Component) + return Color; +</pre></td> </tr> <tr> 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 @@ <td><pre> static void display(const char *); </pre></td> -<td> </td> +<td><pre> +procedure Set_Display_Var + (Value : in String); +</pre></td> </tr> <tr> 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 @@ <td>Scaling_Kind</td> </tr> - <tr> - <td>float</td> - <td>Blend</td> - </tr> - </table> 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); |