diff options
| -rw-r--r-- | body/c_fl.cpp | 4 | ||||
| -rw-r--r-- | body/c_fl.h | 1 | ||||
| -rw-r--r-- | body/c_fl_ask.cpp | 9 | ||||
| -rw-r--r-- | body/c_fl_ask.h | 4 | ||||
| -rw-r--r-- | body/fltk-asks.adb | 14 | ||||
| -rw-r--r-- | body/fltk.adb | 16 | ||||
| -rw-r--r-- | doc/fl_ask.html | 16 | ||||
| -rw-r--r-- | spec/fltk-asks.ads | 7 | ||||
| -rw-r--r-- | spec/fltk.ads | 17 | ||||
| -rw-r--r-- | test/button.adb | 67 | ||||
| -rw-r--r-- | test/buttons.adb | 59 | ||||
| -rw-r--r-- | test/clock.adb | 50 | ||||
| -rw-r--r-- | test/color_chooser.adb | 162 | ||||
| -rw-r--r-- | test/cursor.adb | 116 | ||||
| -rw-r--r-- | test/curve.adb | 164 | ||||
| -rw-r--r-- | test/hello.adb | 45 | ||||
| -rw-r--r-- | tests.gpr | 26 | ||||
| -rw-r--r-- | tests_2022.gpr | 6 |
18 files changed, 767 insertions, 16 deletions
diff --git a/body/c_fl.cpp b/body/c_fl.cpp index ec5f7e5..a9e6d16 100644 --- a/body/c_fl.cpp +++ b/body/c_fl.cpp @@ -55,6 +55,10 @@ unsigned int fl_enum_rgb_color(unsigned char r, unsigned char g, unsigned char b return fl_rgb_color(r, g, b); } +unsigned int fl_enum_contrast(unsigned int f, unsigned int b) { + return fl_contrast(f, b); +} + diff --git a/body/c_fl.h b/body/c_fl.h index 9f79979..51dbedb 100644 --- a/body/c_fl.h +++ b/body/c_fl.h @@ -41,6 +41,7 @@ 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" unsigned int fl_enum_contrast(unsigned int f, unsigned int b); extern "C" int fl_abi_check(int v); diff --git a/body/c_fl_ask.cpp b/body/c_fl_ask.cpp index 20af2e3..30dd480 100644 --- a/body/c_fl_ask.cpp +++ b/body/c_fl_ask.cpp @@ -5,6 +5,7 @@ #include <FL/fl_ask.H> +#include <FL/fl_show_colormap.H> #include <FL/Fl_File_Chooser.H> #include <FL/Fl_Color_Chooser.H> #include "c_fl_ask.h" @@ -90,10 +91,16 @@ int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int return fl_color_chooser(n, r, g, b, m); } -int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m) { +int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m) +{ return fl_color_chooser(n, r, g, b, m); } +unsigned int fl_ask_show_colormap(unsigned int h) { + return static_cast<unsigned int>(fl_show_colormap(static_cast<Fl_Color>(h))); +} + char * fl_ask_dir_chooser(const char * m, const char * d, int r) { return fl_dir_chooser(m, d, r); } diff --git a/body/c_fl_ask.h b/body/c_fl_ask.h index f68bc85..4c18391 100644 --- a/body/c_fl_ask.h +++ b/body/c_fl_ask.h @@ -30,7 +30,9 @@ extern "C" const char * fl_ask_password(const char * m, const char * d); extern "C" int fl_ask_color_chooser(const char * n, double & r, double & g, double & b, int m); -extern "C" int fl_ask_color_chooser2(const char * n, uchar & r, uchar & g, uchar & b, int m); +extern "C" int fl_ask_color_chooser2(const char * n, + unsigned char & r, unsigned char & g, unsigned char & b, int m); +extern "C" unsigned int fl_ask_show_colormap(unsigned int h); extern "C" char * fl_ask_dir_chooser(const char * m, const char * d, int r); extern "C" char * fl_ask_file_chooser(const char * m, const char * p, const char * d, int r); extern "C" void fl_ask_file_chooser_callback(void(*cb)(const char *)); diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb index d6eb8ee..2b27940 100644 --- a/body/fltk-asks.adb +++ b/body/fltk-asks.adb @@ -140,6 +140,12 @@ package body FLTK.Asks is pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2"); pragma Inline (fl_ask_color_chooser2); + function fl_ask_show_colormap + (H : in Interfaces.C.unsigned) + return Interfaces.C.unsigned; + pragma Import (C, fl_ask_show_colormap, "fl_ask_show_colormap"); + pragma Inline (fl_ask_show_colormap); + function fl_ask_dir_chooser (M, D : in Interfaces.C.char_array; R : in Interfaces.C.int) @@ -554,6 +560,14 @@ package body FLTK.Asks is end Color_Chooser; + function Show_Colormap + (Old_Hue : in Color) + return Color is + begin + return Color (fl_ask_show_colormap (Interfaces.C.unsigned (Old_Hue))); + end Show_Colormap; + + function Dir_Chooser (Message, Default : in String; Relative : in Boolean := False) diff --git a/body/fltk.adb b/body/fltk.adb index d729364..0e391e3 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -23,6 +23,12 @@ package body FLTK is pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color"); pragma Inline (fl_enum_rgb_color); + 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); + @@ -120,6 +126,16 @@ package body FLTK is end RGB_Color; + function Contrast + (Fore, Back : in Color) + return Color is + begin + return Color (fl_enum_contrast + (Interfaces.C.unsigned (Fore), + Interfaces.C.unsigned (Back))); + end Contrast; + + function "+" diff --git a/doc/fl_ask.html b/doc/fl_ask.html index 6d72892..146c17b 100644 --- a/doc/fl_ask.html +++ b/doc/fl_ask.html @@ -24,6 +24,11 @@ <td>FLTK.Asks</td> </tr> + <tr> + <td>fl_show_colormap</td> + <td> </td> + </tr> + </table> @@ -383,6 +388,17 @@ function Password </pre></td> </tr> + <tr> +<td><pre> +Fl_Color fl_show_colormap(Fl_Color oldcol); +</pre></td> +<td><pre> +function Show_Colormap + (Old_Hue : in Color) + return Color; +</pre></td> + </tr> + </table> diff --git a/spec/fltk-asks.ads b/spec/fltk-asks.ads index fc6e150..f0d58f8 100644 --- a/spec/fltk-asks.ads +++ b/spec/fltk-asks.ads @@ -30,7 +30,7 @@ package FLTK.Asks is type RGB_Float is new Long_Float range 0.0 .. 1.0; - type RGB_Int is mod 256; + subtype RGB_Int is Color_Component; type File_Chooser_Callback is access procedure (Item : in String); @@ -131,6 +131,10 @@ package FLTK.Asks is FLTK.Widgets.Groups.Color_Choosers.RGB) return Confirm_Result; + function Show_Colormap + (Old_Hue : in Color) + return Color; + function Dir_Chooser (Message, Default : in String; Relative : in Boolean := False) @@ -195,6 +199,7 @@ private pragma Inline (Password); pragma Inline (Color_Chooser); + pragma Inline (Show_Colormap); pragma Inline (Dir_Chooser); pragma Inline (File_Chooser); pragma Inline (Set_File_Chooser_Callback); diff --git a/spec/fltk.ads b/spec/fltk.ads index 6e5ef0f..f341ac2 100644 --- a/spec/fltk.ads +++ b/spec/fltk.ads @@ -48,6 +48,10 @@ package FLTK is (R, G, B : in Color_Component) return Color; + function Contrast + (Fore, Back : in Color) + 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#; @@ -61,6 +65,9 @@ package FLTK is Inactive_Color : constant Color := 8; Selection_Color : constant Color := 15; + -- X allocation area + Free_Color : constant Color := 16; + -- Standard boxtype colors Grey0_Color : constant Color := 32; Dark3_Color : constant Color := 39; @@ -145,7 +152,8 @@ package FLTK is SW_Mouse, W_Mouse, NW_Mouse, - None_Mouse); + None_Mouse) + with Default_Value => Default_Mouse; @@ -620,23 +628,23 @@ private + pragma Inline (RGB_Color); + pragma Inline (Contrast); + pragma Inline (ABI_Check); pragma Inline (ABI_Version); pragma Inline (API_Version); pragma Inline (Version); - pragma Inline (Awake); pragma Inline (Lock); pragma Inline (Unlock); - pragma Inline (Is_Damaged); pragma Inline (Set_Damaged); pragma Inline (Flush); pragma Inline (Redraw); - pragma Inline (Check); pragma Inline (Ready); pragma Inline (Wait); @@ -645,3 +653,4 @@ private end FLTK; + diff --git a/test/button.adb b/test/button.adb new file mode 100644 index 0000000..9ca6102 --- /dev/null +++ b/test/button.adb @@ -0,0 +1,67 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Button/callback test program functionality reproduced in Ada + + +with + + Ada.Command_Line, + FLTK.Asks, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Windows; + + +function Button + return Integer +is + + + package ACom renames Ada.Command_Line; + + package Ask renames FLTK.Asks; + package Wdg renames FLTK.Widgets; + package Btn renames FLTK.Widgets.Buttons; + package Win renames FLTK.Widgets.Groups.Windows; + + + procedure Beep_Callback + (This : in out Wdg.Widget'Class) is + begin + Ask.Beep; + end Beep_Callback; + + + The_Window : Win.Window := Win.Forge.Create (320, 65); + + + procedure Exit_Callback + (This : in out Wdg.Widget'Class) is + begin + ACom.Set_Exit_Status (ACom.Success); + The_Window.Hide; + end Exit_Callback; + + + Button_One : Btn.Button := Btn.Forge.Create (The_Window, 20, 20, 80, 25, "&Beep"); + Button_Two : Btn.Button := Btn.Forge.Create (The_Window, 120, 20, 80, 25, "&No Op"); + Button_Three : Btn.Button := Btn.Forge.Create (The_Window, 220, 20, 80, 25, "E&xit"); + + +begin + + + Button_One.Set_Callback (Beep_Callback'Unrestricted_Access); + Button_Three.Set_Callback (Exit_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Button; + + diff --git a/test/buttons.adb b/test/buttons.adb new file mode 100644 index 0000000..e93da8e --- /dev/null +++ b/test/buttons.adb @@ -0,0 +1,59 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Another button test program functionality reproduced in Ada + + +with + + FLTK.Tooltips, + FLTK.Widgets.Buttons.Enter, + FLTK.Widgets.Buttons.Light.Check, + FLTK.Widgets.Buttons.Light.Round, + FLTK.Widgets.Buttons.Repeat, + FLTK.Widgets.Groups.Windows; + + +function Buttons + return Integer +is + + + package Btn renames FLTK.Widgets.Buttons; + package Ent renames FLTK.Widgets.Buttons.Enter; + package Lit renames FLTK.Widgets.Buttons.Light; + package Chk renames FLTK.Widgets.Buttons.Light.Check; + package Ond renames FLTK.Widgets.Buttons.Light.Round; + package Rpt renames FLTK.Widgets.Buttons.Repeat; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Win : Win.Window := Win.Forge.Create (320, 130); + + + Base : Btn.Button := Btn.Forge.Create (The_Win, 10, 10, 130, 30, "Fl_Button"); + + + Enter : Ent.Enter_Button := Ent.Forge.Create (The_Win, 150, 10, 160, 30, "Fl_Return_Button"); + Repeat : Rpt.Repeat_Button := Rpt.Forge.Create (The_Win, 10, 50, 130, 30, "Fl_Repeat_Button"); + Light : Lit.Light_Button := Lit.Forge.Create (The_Win, 10, 90, 130, 30, "Fl_Light_Button"); + Round : Ond.Round_Button := Ond.Forge.Create (The_Win, 150, 50, 160, 30, "Fl_Round_Button"); + Check : Chk.Check_Button := Chk.Forge.Create (The_Win, 150, 90, 160, 30, "Fl_Check_Button"); + + +begin + + + Base.Set_Tooltip ("This is a Tooltip."); + + The_Win.Show_With_Args; + + return FLTK.Run; + + +end Buttons; + + diff --git a/test/clock.adb b/test/clock.adb new file mode 100644 index 0000000..b4d8f40 --- /dev/null +++ b/test/clock.adb @@ -0,0 +1,50 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Clock test program functionality reproduced in Ada + + +with + + FLTK.Widgets.Clocks.Updated.Round, + FLTK.Widgets.Groups.Windows.Double; + + +function Clock + return Integer +is + + + package CL renames FLTK.Widgets.Clocks.Updated; + package CR renames FLTK.Widgets.Clocks.Updated.Round; + package WD renames FLTK.Widgets.Groups.Windows.Double; + + + Window_One : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Clock"); + Clock_One : CL.Updated_Clock := CL.Forge.Create (Window_One, 0, 0, 220, 220); + + Window_Two : WD.Double_Window := WD.Forge.Create (220, 220, "Fl_Round_Clock"); + Clock_Two : CR.Round_Clock := CR.Forge.Create (Window_Two, 0, 0, 220, 220); + + +begin + + + Window_One.Set_Resizable (Clock_One); + Window_Two.Set_Resizable (Clock_Two); + + Window_One.Set_X_Class ("Fl_Clock"); + Window_Two.Set_X_Class ("Fl_Clock"); + + Window_One.Show_With_Args; + Window_Two.Show; + + return FLTK.Run; + + +end Clock; + + diff --git a/test/color_chooser.adb b/test/color_chooser.adb new file mode 100644 index 0000000..09003b9 --- /dev/null +++ b/test/color_chooser.adb @@ -0,0 +1,162 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Color chooser test program functionality reproduced in Ada + + +with + + FLTK.Asks, + FLTK.Draw, + FLTK.Images.RGB, + FLTK.Static, + FLTK.Widgets.Boxes, + FLTK.Widgets.Buttons, + FLTK.Widgets.Groups.Color_Choosers, + FLTK.Widgets.Groups.Windows; + +use type + + FLTK.Color, + FLTK.Asks.Confirm_Result; + + +function Color_Chooser + return Integer +is + + + package Ask renames FLTK.Asks; + package FD renames FLTK.Draw; + package Img renames FLTK.Images.RGB; + package Stc renames FLTK.Static; + package Bx renames FLTK.Widgets.Boxes; + package Btn renames FLTK.Widgets.Buttons; + package CC renames FLTK.Widgets.Groups.Color_Choosers; + package Win renames FLTK.Widgets.Groups.Windows; + + + function Make_Image_Data + (W, H : in Positive) + return FLTK.Color_Component_Array + is + X_Frac, Y_Frac : Long_Float; + Offset : Integer; + begin + return Data : FLTK.Color_Component_Array (1 .. W * H * 3) do + for Y in 0 .. H - 1 loop + Y_Frac := Long_Float (Y) / Long_Float (H - 1); + for X in 0 .. W - 1 loop + X_Frac := Long_Float (X) / Long_Float (W - 1); + Offset := 3 * (Y * W + X); + Data (Offset + 1) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * (1.0 - Y_Frac)); + Data (Offset + 2) := + FLTK.Color_Component (255.0 * (1.0 - X_Frac) * Y_Frac); + Data (Offset + 3) := + FLTK.Color_Component (255.0 * X_Frac * Y_Frac); + end loop; + end loop; + end return; + end Make_Image_Data; + + + Image_Width, Image_Height : constant Natural := 100; + + The_Image_Data : FLTK.Color_Component_Array := Make_Image_Data (Image_Width, Image_Height); + + + type Pens is new Bx.Box with null record; + + procedure Draw + (This : in out Pens) is + begin + for Offset in 0 .. 3 * 8 - 1 loop + FD.Set_Color (FLTK.Grey0_Color + FLTK.Color (Offset)); + FD.Line + (This.Get_X + Offset, This.Get_Y, + This.Get_X + Offset, This.Get_Y + This.Get_H); + end loop; + end Draw; + + + The_Window : Win.Window := Win.Forge.Create (400, 400); + + The_Box : Bx.Box := Bx.Forge.Create + (The_Window, 30, 30, 340, 340); + Hint_Box : Bx.Box := Bx.Forge.Create + (The_Window, 40, 40, 320, 30, "Pick background color with buttons:"); + + Button_One : Btn.Button := Btn.Forge.Create + (The_Window, 120, 80, 180, 30, "fl_show_colormap()"); + Button_Two : Btn.Button := Btn.Forge.Create + (The_Window, 120, 120, 180, 30, "fl_color_chooser()"); + + Image_Box : Bx.Box := Bx.Forge.Create (The_Window, 160, 190, Image_Width, Image_Height); + The_Image : Img.RGB_Image := Img.Forge.Create (The_Image_Data, Image_Width, Image_Height); + + Box_B : Bx.Box := Bx.Forge.Create (The_Window, 160, 310, 120, 30, "Example of fl_draw_image()"); + + My_Pens : Pens := + (Bx.Forge.Create (The_Window, 60, 180, 3 * 8, 120, "lines") + with null record); + + My_Color : FLTK.Color := FLTK.Background_Color; + + + procedure Callback_One + (This : in out FLTK.Widgets.Widget'Class) is + begin + My_Color := Ask.Show_Colormap (My_Color); + The_Box.Set_Background_Color (My_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, My_Color)); + The_Box.Parent.Redraw; + end Callback_One; + + + procedure Callback_Two + (This : in out FLTK.Widgets.Widget'Class) + is + R, G, B : FLTK.Color_Component; + begin + Stc.Get_Color (My_Color, R, G, B); + if Ask.Color_Chooser ("New color:", R, G, B, CC.HSV) = Ask.Cancel then + return; + end if; + My_Color := FLTK.Free_Color; + Stc.Set_Color (FLTK.Free_Color, R, G, B); + The_Box.Set_Background_Color (FLTK.Free_Color); + Hint_Box.Set_Label_Color (FLTK.Contrast (FLTK.Black_Color, FLTK.Free_Color)); + The_Box.Parent.Redraw; + end Callback_Two; + + +begin + + + Stc.Set_Color (FLTK.Free_Color, 145, 159, 170); + My_Color := FLTK.Free_Color; + + The_Box.Set_Box (FLTK.Thin_Down_Box); + The_Box.Set_Background_Color (My_Color); + + Hint_Box.Set_Alignment (FLTK.Align_Inside); + + Button_One.Set_Callback (Callback_One'Unrestricted_Access); + Button_Two.Set_Callback (Callback_Two'Unrestricted_Access); + + Image_Box.Set_Image (The_Image); + + My_Pens.Set_Alignment (FLTK.Align_Top); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Color_Chooser; + + diff --git a/test/cursor.adb b/test/cursor.adb new file mode 100644 index 0000000..e968b6f --- /dev/null +++ b/test/cursor.adb @@ -0,0 +1,116 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Cursor test program functionality reproduced in Ada + + +with + + FLTK.Draw, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Menus.Choices, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + +use type + + FLTK.Widgets.Callback_Flag; + + +function Cursor + return Integer +is + + + package FD renames FLTK.Draw; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package MC renames FLTK.Widgets.Menus.Choices; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + The_Cursor : FLTK.Mouse_Cursor_Kind := FLTK.Default_Mouse; + + Cursor_Index_Low : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'First)); + Cursor_Index_High : constant Long_Float := + Long_Float (FLTK.Mouse_Cursor_Kind'Pos (FLTK.Mouse_Cursor_Kind'Last)); + + + The_Window : WD.Double_Window := WD.Forge.Create (400, 300); + + The_Choices : MC.Choice := MC.Forge.Create + (The_Window, 80, 100, 200, 25, "Cursor:"); + + The_Slider : HV.Horizontal_Value_Slider := HV.Forge.Create + (The_Window, 80, 180, 310, 30, "Cursor:"); + + + procedure Choice_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Choice : MC.Choice renames MC.Choice (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (My_Choice.Chosen_Index - 1); + The_Slider.Set_Value (Long_Float (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor))); + FD.Set_Cursor (The_Cursor); + end Choice_Callback; + + + procedure Slider_Callback + (This : in out FLTK.Widgets.Widget'Class) + is + My_Slider : HV.Horizontal_Value_Slider renames HV.Horizontal_Value_Slider (This); + begin + The_Cursor := FLTK.Mouse_Cursor_Kind'Val (Integer (My_Slider.Get_Value)); + The_Choices.Set_Chosen (FLTK.Mouse_Cursor_Kind'Pos (The_Cursor) + 1); + FD.Set_Cursor (The_Cursor); + end Slider_Callback; + + +begin + + + The_Choices.Add ("FL_CURSOR_DEFAULT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_ARROW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_CROSS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WAIT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_INSERT", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HAND", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_HELP", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_MOVE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NS", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_WE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NWSE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NESW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_N", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_E", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SE", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_S", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_SW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_W", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NW", Choice_Callback'Unrestricted_Access); + The_Choices.Add ("FL_CURSOR_NONE", Choice_Callback'Unrestricted_Access); + + The_Choices.Set_Callback (Choice_Callback'Unrestricted_Access); + The_Choices.Set_When (FLTK.Widgets.When_Release + FLTK.Widgets.When_Interact); + The_Choices.Set_Chosen (1); + + The_Slider.Set_Alignment (FLTK.Align_Left); + The_Slider.Set_Step_Bottom (1); + The_Slider.Set_Precision (0); + The_Slider.Set_Bounds (Cursor_Index_Low, Cursor_Index_High); + The_Slider.Set_Value (Cursor_Index_Low); + The_Slider.Set_Callback (Slider_Callback'Unrestricted_Access); + + The_Window.Set_Resizable (The_Window); + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Cursor; + + diff --git a/test/curve.adb b/test/curve.adb new file mode 100644 index 0000000..45269e8 --- /dev/null +++ b/test/curve.adb @@ -0,0 +1,164 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Curve drawing test program functionality duplicated in Ada + + +pragma Ada_2022; + + +with + + FLTK.Draw, + FLTK.Widgets.Buttons.Toggle, + FLTK.Widgets.Groups.Windows.Double, + FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + +function Curve + return Integer +is + + + package FDR renames FLTK.Draw; + package Tog renames FLTK.Widgets.Buttons.Toggle; + package WD renames FLTK.Widgets.Groups.Windows.Double; + package HV renames FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + + -- More convenient to have these all as floats instead of integers + Arg_Values : array (Positive range <>) of aliased Long_Float := + (20.0, 20.0, 50.0, 200.0, 100.0, 20.0, 200.0, 200.0, 0.0); + + Points : Boolean := False; + + + type Drawing_Widget is new FLTK.Widgets.Widget with null record; + + procedure Draw + (This : in out Drawing_Widget) is + begin + FDR.Push_Clip (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Set_Color (FLTK.Dark3_Color); + FDR.Rect_Fill (This.Get_X, This.Get_Y, This.Get_W, This.Get_H); + FDR.Push_Matrix; + if Arg_Values (9) > 0.001 then + FDR.Translate + (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0, + Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0); + FDR.Rotate (Arg_Values (9)); + FDR.Translate + (-1.0 * (Long_Float (This.Get_X) + Long_Float (This.Get_W) / 2.0), + -1.0 * (Long_Float (This.Get_Y) + Long_Float (This.Get_H) / 2.0)); + end if; + FDR.Translate (Long_Float (This.Get_X), Long_Float (This.Get_Y)); + if not Points then + FDR.Set_Color (FLTK.White_Color); + FDR.Begin_Complex_Polygon; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + FDR.End_Complex_Polygon; + end if; + FDR.Set_Color (FLTK.Black_Color); + FDR.Begin_Line; + FDR.Vertex (Arg_Values (1), Arg_Values (2)); + FDR.Vertex (Arg_Values (3), Arg_Values (4)); + FDR.Vertex (Arg_Values (5), Arg_Values (6)); + FDR.Vertex (Arg_Values (7), Arg_Values (8)); + FDR.End_Line; + FDR.Set_Color ((if Points then FLTK.White_Color else FLTK.Red_Color)); + if Points then FDR.Begin_Points; else FDR.Begin_Line; end if; + FDR.Curve + (Arg_Values (1), Arg_Values (2), Arg_Values (3), Arg_Values (4), + Arg_Values (5), Arg_Values (6), Arg_Values (7), Arg_Values (8)); + if Points then FDR.End_Points; else FDR.End_Line; end if; + FDR.Pop_Matrix; + FDR.Pop_Clip; + end Draw; + + + The_Window : WD.Double_Window := WD.Forge.Create (300, 555, "Curve Testing"); + + The_Drawing : Drawing_Widget := + (FLTK.Widgets.Forge.Create (The_Window, 10, 10, 280, 280) + with null record); + + The_Toggle : Tog.Toggle_Button := Tog.Forge.Create (The_Window, 50, 525, 50, 25, "points"); + + + type My_Slider is new HV.Horizontal_Value_Slider with record + Index : Integer range Arg_Values'Range; + end record; + + X0_Str : aliased constant String := "X0"; + Y0_Str : aliased constant String := "Y0"; + X1_Str : aliased constant String := "X1"; + Y1_Str : aliased constant String := "Y1"; + X2_Str : aliased constant String := "X2"; + Y2_Str : aliased constant String := "Y2"; + X3_Str : aliased constant String := "X3"; + Y3_Str : aliased constant String := "Y3"; + Rotate_Str : aliased constant String := "rotate"; + + -- A straight up array of strings is not possible because of the different lengths + Slider_Labels : constant array (Positive range <>) of access constant String := + (X0_Str'Access, Y0_Str'Access, X1_Str'Access, Y1_Str'Access, + X2_Str'Access, Y2_Str'Access, X3_Str'Access, Y3_Str'Access, Rotate_Str'Access); + + -- This syntax requires Ada 2022, but it allows all overt heap usage to be avoided + Sliders : array (Positive range <>) of My_Slider := + (for Place in Slider_Labels'Range => + (HV.Forge.Create (The_Window, 50, 275 + Place * 25, 240, 25, Slider_Labels (Place).all) + with Index => Place)); + + + procedure Slider_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Slide : My_Slider renames My_Slider (Item); + begin + Arg_Values (Slide.Index) := Slide.Get_Value; + The_Drawing.Redraw; + end Slider_Callback; + + + procedure Points_Callback + (Item : in out FLTK.Widgets.Widget'Class) + is + Toggle : Tog.Toggle_Button renames Tog.Toggle_Button (Item); + begin + Points := Toggle.Is_On; + The_Drawing.Redraw; + end Points_Callback; + + +begin + + + for Place in Sliders'Range loop + Sliders (Place).Set_Minimum (0.0); + if Place = 9 then + Sliders (Place).Set_Maximum (360.0); + else + Sliders (Place).Set_Maximum (280.0); + end if; + Sliders (Place).Set_Step_Bottom (1); + Sliders (Place).Set_Value (Arg_Values (Place)); + Sliders (Place).Set_Alignment (FLTK.Align_Left); + Sliders (Place).Set_Callback (Slider_Callback'Unrestricted_Access); + end loop; + + The_Toggle.Set_Callback (Points_Callback'Unrestricted_Access); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Curve; + + diff --git a/test/hello.adb b/test/hello.adb new file mode 100644 index 0000000..1fcdf9d --- /dev/null +++ b/test/hello.adb @@ -0,0 +1,45 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Hello, World! program functionality reproduced in Ada + + +with + + FLTK.Widgets.Boxes, + FLTK.Widgets.Groups.Windows; + + +function Hello + return Integer +is + + + package Bx renames FLTK.Widgets.Boxes; + package Win renames FLTK.Widgets.Groups.Windows; + + + The_Window : Win.Window := Win.Forge.Create (340, 180); + + The_Box : Bx.Box := Bx.Forge.Create (The_Window, 20, 40, 300, 100, "Hello, World!"); + + +begin + + + The_Box.Set_Box (FLTK.Up_Box); + The_Box.Set_Label_Font (FLTK.Helvetica_Bold_Italic); + The_Box.Set_Label_Size (36); + The_Box.Set_Label_Kind (FLTK.Shadow_Label); + + The_Window.Show_With_Args; + + return FLTK.Run; + + +end Hello; + + @@ -19,19 +19,31 @@ project Tests is ("adjuster.adb", "ask.adb", "bitmap.adb", + "button.adb", + "buttons.adb", "compare.adb", + "clock.adb", + "color_chooser.adb", + "cursor.adb", "dirlist.adb", + "hello.adb", "page_formats.adb", "pixmap.adb"); package Builder is - for Executable ("adjuster.adb") use "adjuster"; - for Executable ("ask.adb") use "ask"; - for Executable ("bitmap.adb") use "bitmap"; - for Executable ("compare.adb") use "compare"; - for Executable ("dirlist.adb") use "dirlist"; - for Executable ("page_formats.adb") use "page_formats"; - for Executable ("pixmap.adb") use "pixmap"; + for Executable ("adjuster.adb") use "adjuster"; + for Executable ("ask.adb") use "ask"; + for Executable ("bitmap.adb") use "bitmap"; + for Executable ("button.adb") use "button"; + for Executable ("buttons.adb") use "buttons"; + for Executable ("compare.adb") use "compare"; + for Executable ("clock.adb") use "clock"; + for Executable ("color_chooser.adb") use "color_chooser"; + for Executable ("cursor.adb") use "cursor"; + for Executable ("dirlist.adb") use "dirlist"; + for Executable ("hello.adb") use "hello"; + for Executable ("page_formats.adb") use "page_formats"; + for Executable ("pixmap.adb") use "pixmap"; end Builder; package Compiler renames Common.Compiler; diff --git a/tests_2022.gpr b/tests_2022.gpr index 4217c08..84ed425 100644 --- a/tests_2022.gpr +++ b/tests_2022.gpr @@ -17,11 +17,13 @@ project Tests_2022 is for Main use ("animated.adb", - "arc.adb"); + "arc.adb", + "curve.adb"); package Builder is for Executable ("animated.adb") use "animated"; - for Executable ("arc.adb") use "arc"; + for Executable ("arc.adb") use "arc"; + for Executable ("curve.adb") use "curve"; end Builder; package Compiler renames Common.Compiler; |