diff options
Diffstat (limited to 'spec')
116 files changed, 20458 insertions, 0 deletions
diff --git a/spec/fltk-asks.ads b/spec/fltk-asks.ads new file mode 100644 index 0000000..23e2076 --- /dev/null +++ b/spec/fltk-asks.ads @@ -0,0 +1,238 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Boxes, + FLTK.Widgets.Groups.Color_Choosers; + +private with + + Ada.Finalization, + Interfaces.C.Strings; + + +package FLTK.Asks is + + + type Beep_Kind is + (Default_Beep, Message_Beep, Error_Beep, + Question_Beep, Password_Beep, Notification_Beep); + + type Confirm_Result is (Cancel, Confirm); + + type Choice_Result is (First, Second, Third); + + type Extended_Choice_Result is (First, Second, Third, Blocked, Closed, Escaped); + + type RGB_Float is new Long_Float range 0.0 .. 1.0; + + subtype RGB_Int is Color_Component; + + type File_Chooser_Callback is access procedure + (Item : in String); + + + + + -- Static Attributes -- + + function Get_Cancel_String + return String; + + procedure Set_Cancel_String + (Value : in String); + + function Get_Close_String + return String; + + procedure Set_Close_String + (Value : in String); + + function Get_No_String + return String; + + procedure Set_No_String + (Value : in String); + + function Get_OK_String + return String; + + procedure Set_OK_String + (Value : in String); + + function Get_Yes_String + return String; + + procedure Set_Yes_String + (Value : in String); + + + + + -- Simple Messages -- + + procedure Alert + (Message : String); + + procedure Beep + (Kind : in Beep_Kind := Default_Beep); + + function Choice + (Message, Button1 : in String) + return Choice_Result; + + function Choice + (Message, Button1, Button2 : in String) + return Choice_Result; + + function Choice + (Message, Button1, Button2, Button3 : in String) + return Choice_Result; + + function Extended_Choice + (Message, Button1 : in String) + return Extended_Choice_Result; + + function Extended_Choice + (Message, Button1, Button2 : in String) + return Extended_Choice_Result; + + function Extended_Choice + (Message, Button1, Button2, Button3 : in String) + return Extended_Choice_Result; + + function Text_Input + (Message : in String; + Default : in String := "") + return String; + + procedure Message_Box + (Message : in String); + + function Password + (Message : in String; + Default : in String := "") + return String; + + + + + -- Choosers -- + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Float; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + FLTK.Widgets.Groups.Color_Choosers.RGB) + return Confirm_Result; + + function Color_Chooser + (Title : in String; + R, G, B : in out RGB_Int; + Mode : in FLTK.Widgets.Groups.Color_Choosers.Color_Mode := + 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) + return String; + + function File_Chooser + (Message, Filter_Pattern, Default : in String; + Relative : in Boolean := False) + return String; + + procedure Set_File_Chooser_Callback + (Func : in File_Chooser_Callback); + + procedure Set_File_Chooser_OK_String + (Value : in String); + + + + + -- Settings -- + + function Get_Message_Hotspot + return Boolean; + + procedure Set_Message_Hotspot + (To : in Boolean); + + procedure Set_Message_Font + (Font : in Font_Kind; + Size : in Font_Size); + + -- Technically the returned Box should have a parent, but you can't access + -- it for annoying technical reasons relating to how the Choice functions + -- work in C++. You shouldn't be trying to poke at those internals anyway. + -- Just stick to calling subprograms to change stuff about this Box. + function Get_Message_Icon + return FLTK.Widgets.Boxes.Box_Reference; + + procedure Set_Message_Title + (To : in String); + + procedure Set_Message_Title_Default + (To : in String); + + +private + + + Icon_Box : aliased FLTK.Widgets.Boxes.Box; + + + Cancel_Str, Close_Str, No_Str, OK_Str, Yes_Str : Interfaces.C.Strings.chars_ptr; + + Chooser_OK_Str : Interfaces.C.Strings.chars_ptr; + Chooser_Func : File_Chooser_Callback; + + + pragma Inline (Get_Cancel_String); + pragma Inline (Get_Close_String); + pragma Inline (Get_No_String); + pragma Inline (Get_OK_String); + pragma Inline (Get_Yes_String); + + pragma Inline (Alert); + pragma Inline (Beep); + pragma Inline (Text_Input); + pragma Inline (Message_Box); + 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); + + pragma Inline (Get_Message_Hotspot); + pragma Inline (Set_Message_Hotspot); + pragma Inline (Set_Message_Font); + pragma Inline (Get_Message_Icon); + pragma Inline (Set_Message_Title); + pragma Inline (Set_Message_Title_Default); + + + -- Needed to ensure chars_ptr storage is properly cleaned up + type Dialog_String_Final_Controller is new Ada.Finalization.Controlled with null record; + + overriding procedure Finalize + (This : in out Dialog_String_Final_Controller); + + Cleanup : Dialog_String_Final_Controller; + + +end FLTK.Asks; + + diff --git a/spec/fltk-devices-graphics.ads b/spec/fltk-devices-graphics.ads new file mode 100644 index 0000000..2a1761f --- /dev/null +++ b/spec/fltk-devices-graphics.ads @@ -0,0 +1,96 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images; + + +package FLTK.Devices.Graphics is + + + type Graphics_Driver is new Device with private; + + type Graphics_Driver_Reference (Data : not null access Graphics_Driver'Class) is + limited null record with Implicit_Dereference => Data; + + + + + -- Color -- + + function Get_Color + (This : in Graphics_Driver) + return Color; + + + + + -- Text -- + + function Get_Text_Descent + (This : in Graphics_Driver) + return Integer; + + function Get_Line_Height + (This : in Graphics_Driver) + return Integer; + + function Get_Width + (This : in Graphics_Driver; + Char : in Character) + return Long_Float; + + function Get_Width + (This : in Graphics_Driver; + Str : in String) + return Long_Float; + + function Get_Font_Kind + (This : in Graphics_Driver) + return Font_Kind; + + function Get_Font_Size + (This : in Graphics_Driver) + return Font_Size; + + procedure Set_Font + (This : in Graphics_Driver; + Face : in Font_Kind; + Size : in Font_Size); + + + + + -- Images -- + + procedure Draw_Scaled_Image + (This : in Graphics_Driver; + Img : in FLTK.Images.Image'Class; + X, Y, W, H : in Integer); + + +private + + + type Graphics_Driver is new Device with null record; + + + pragma Inline (Get_Color); + + pragma Inline (Get_Text_Descent); + pragma Inline (Get_Line_Height); + pragma Inline (Get_Width); + pragma Inline (Get_Font_Kind); + pragma Inline (Get_Font_Size); + pragma Inline (Set_Font); + + pragma Inline (Draw_Scaled_Image); + + +end FLTK.Devices.Graphics; + + diff --git a/spec/fltk-devices-surface-copy.ads b/spec/fltk-devices-surface-copy.ads new file mode 100644 index 0000000..1bc2d93 --- /dev/null +++ b/spec/fltk-devices-surface-copy.ads @@ -0,0 +1,95 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Copy is + + + type Copy_Surface is new Surface_Device with private; + + type Copy_Surface_Reference (Data : not null access Copy_Surface'Class) is + limited null record with Implicit_Dereference => Data; + + + + + -- The initial Graphics_Driver this is supposed to have upon construction + -- is not currently implemented properly. Please wait warmly until the + -- binding for the Graphics sub-hierarchy is done. + + + + + package Forge is + + function Create + (W, H : in Natural) + return Copy_Surface; + + end Forge; + + + + + -- Dimensions -- + + function Get_W + (This : in Copy_Surface) + return Integer; + + function Get_H + (This : in Copy_Surface) + return Integer; + + + + + -- Drawing -- + + procedure Draw_Widget + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Draw_Decorated_Window + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + + + + -- Surfaces -- + + procedure Set_Current + (This : in out Copy_Surface); + + +private + + + type Copy_Surface is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Copy_Surface); + + + pragma Inline (Get_W); + pragma Inline (Get_H); + + pragma Inline (Draw_Widget); + pragma Inline (Draw_Decorated_Window); + + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface.Copy; + + diff --git a/spec/fltk-devices-surface-display.ads b/spec/fltk-devices-surface-display.ads new file mode 100644 index 0000000..3faaa22 --- /dev/null +++ b/spec/fltk-devices-surface-display.ads @@ -0,0 +1,55 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Devices.Graphics; + + +package FLTK.Devices.Surface.Display is + + + type Display_Device is new Surface_Device with private; + + type Display_Device_Reference (Data : not null access Display_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + -- Docs say you shouldn't ever need to use this, but it's here anyway. + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Display_Device; + + end Forge; + + + + + -- Displays -- + + function Get_Platform_Display + return Display_Device_Reference; + + +private + + + type Display_Device is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Display_Device); + + + pragma Inline (Get_Platform_Display); + + +end FLTK.Devices.Surface.Display; + + diff --git a/spec/fltk-devices-surface-image.ads b/spec/fltk-devices-surface-image.ads new file mode 100644 index 0000000..7711771 --- /dev/null +++ b/spec/fltk-devices-surface-image.ads @@ -0,0 +1,104 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images.RGB, + FLTK.Images.Shared, + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Image is + + + type Image_Surface is new Surface_Device with private; + + type Image_Surface_Reference (Data : not null access Image_Surface'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (W, H : in Integer; + Highres : in Boolean := False) + return Image_Surface; + + end Forge; + + + + + -- Resolution -- + + function Is_Highres + (This : in Image_Surface) + return Boolean; + + + + + -- Drawing -- + + procedure Draw_Widget + (This : in out Image_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Draw_Decorated_Window + (This : in out Image_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + + + + -- Images -- + + function Get_Image + (This : in Image_Surface) + return FLTK.Images.RGB.RGB_Image; + + function Get_Highres_Image + (This : in Image_Surface) + return FLTK.Images.Shared.Shared_Image; + + + + + -- Surfaces -- + + procedure Set_Current + (This : in out Image_Surface); + + +private + + + type Image_Surface is new Surface_Device with record + High : Boolean := False; + end record; + + overriding procedure Finalize + (This : in out Image_Surface); + + + pragma Inline (Is_Highres); + + pragma Inline (Draw_Widget); + pragma Inline (Draw_Decorated_Window); + + pragma Inline (Get_Image); + pragma Inline (Get_Highres_Image); + + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface.Image; + + diff --git a/spec/fltk-devices-surface-paged-postscript.ads b/spec/fltk-devices-surface-paged-postscript.ads new file mode 100644 index 0000000..22e2eca --- /dev/null +++ b/spec/fltk-devices-surface-paged-postscript.ads @@ -0,0 +1,222 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Devices.Graphics; + +private with + + Ada.Finalization, + Interfaces.C.Strings; + + +package FLTK.Devices.Surface.Paged.Postscript is + + + type Postscript_File_Device is new Paged_Device with private; + + type Postscript_File_Device_Reference (Data : not null access Postscript_File_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + -- This will autoclose when it goes out of scope. + type File_Type is tagged limited private; + + -- Calling this on a file already open will close it then open the new name. + procedure Open + (File : in out File_Type; + Name : in String); + + function Is_Open + (File : in File_Type) + return Boolean; + + -- Calling this on a file already closed will have no effect. + procedure Close + (File : in out File_Type); + + + File_Open_Error : exception; + + File_Close_Error : exception; + + User_Cancel_Error : exception; + + + + + -- The initial Graphics_Driver this is supposed to have upon construction + -- is not currently implemented properly. Please wait warmly until the + -- binding for the Graphics sub-hierarchy is done. + + + + + package Forge is + + function Create + return Postscript_File_Device; + + end Forge; + + + + + -- Static Attributes -- + + function Get_File_Chooser_Title + return String; + + procedure Set_File_Chooser_Title + (Value : in String); + + + + + -- Driver -- + + -- Not currently implemented, + -- will return a Postscript_Graphics_Driver when done. + function Get_Postscript_Driver + (This : in out Postscript_File_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference; + + + + + -- Job Control -- + + -- Docs say don't use this version. + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0); + + -- Docs say don't use this version. + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0; + From, To : out Positive); + + procedure Start_Job + (This : in out Postscript_File_Device; + Output : in File_Type'Class; + Count : in Natural := 0; + Format : in Page_Format := A4; + Layout : in Page_Layout := Portrait) + with Pre => Output.Is_Open; + + procedure Start_Job + (This : in out Postscript_File_Device; + Count : in Natural := 0; + Format : in Page_Format := A4; + Layout : in Page_Layout := Portrait); + + procedure End_Job + (This : in out Postscript_File_Device); + + procedure Start_Page + (This : in out Postscript_File_Device); + + procedure End_Page + (This : in out Postscript_File_Device); + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Postscript_File_Device; + Left, Top, Right, Bottom : out Integer); + + procedure Get_Printable_Rect + (This : in Postscript_File_Device; + W, H : out Integer); + + procedure Get_Origin + (This : in Postscript_File_Device; + X, Y : out Integer); + + procedure Set_Origin + (This : in out Postscript_File_Device; + X, Y : in Integer); + + procedure Rotate + (This : in out Postscript_File_Device; + Degrees : in Float); + + procedure Scale + (This : in out Postscript_File_Device; + Factor : in Float); + + procedure Scale + (This : in out Postscript_File_Device; + Factor_X, Factor_Y : in Float); + + procedure Translate + (This : in out Postscript_File_Device; + Delta_X, Delta_Y : in Integer); + + procedure Untranslate + (This : in out Postscript_File_Device); + + +private + + + type File_Type is new Ada.Finalization.Limited_Controlled with record + C_File : Storage.Integer_Address; + Open_State : Boolean := False; + end record; + + overriding procedure Finalize + (This : in out File_Type); + + + type Postscript_File_Device is new Paged_Device with null record; + + overriding procedure Finalize + (This : in out Postscript_File_Device); + + + File_Chooser_Title : Interfaces.C.Strings.chars_ptr; + + + pragma Inline (Is_Open); + + pragma Inline (Get_File_Chooser_Title); + + pragma Inline (Get_Postscript_Driver); + + pragma Inline (Start_Job); + pragma Inline (End_Job); + pragma Inline (Start_Page); + pragma Inline (End_Page); + + pragma Inline (Get_Margins); + pragma Inline (Get_Printable_Rect); + pragma Inline (Get_Origin); + pragma Inline (Set_Origin); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Translate); + pragma Inline (Untranslate); + + + -- Needed to ensure chars_ptr storage is properly cleaned up + type Postscript_File_Device_Final_Controller is new Ada.Finalization.Limited_Controlled + with null record; + + overriding procedure Finalize + (This : in out Postscript_File_Device_Final_Controller); + + Cleanup : Postscript_File_Device_Final_Controller; + + +end FLTK.Devices.Surface.Paged.Postscript; + + diff --git a/spec/fltk-devices-surface-paged-printers.ads b/spec/fltk-devices-surface-paged-printers.ads new file mode 100644 index 0000000..b9c0169 --- /dev/null +++ b/spec/fltk-devices-surface-paged-printers.ads @@ -0,0 +1,333 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + +private with + + Ada.Finalization, + Interfaces.C.Strings; + + +package FLTK.Devices.Surface.Paged.Printers is + + + type Printer is new Paged_Device with private; + + type Printer_Reference (Data : not null access Printer'Class) is limited null record + with Implicit_Dereference => Data; + + + + + -- The initial Graphics_Driver this is supposed to have upon construction + -- is not currently implemented properly. Please wait warmly until the + -- binding for the Graphics sub-hierarchy is done. + + + + + package Forge is + + function Create + return Printer; + + end Forge; + + + + + -- Static Attributes -- + + function Get_Dialog_Title + return String; + + procedure Set_Dialog_Title + (Value : in String); + + function Get_Dialog_Printer + return String; + + procedure Set_Dialog_Printer + (Value : in String); + + function Get_Dialog_Range + return String; + + procedure Set_Dialog_Range + (Value : in String); + + function Get_Dialog_Copies + return String; + + procedure Set_Dialog_Copies + (Value : in String); + + function Get_Dialog_All + return String; + + procedure Set_Dialog_All + (Value : in String); + + function Get_Dialog_Pages + return String; + + procedure Set_Dialog_Pages + (Value : in String); + + function Get_Dialog_From + return String; + + procedure Set_Dialog_From + (Value : in String); + + function Get_Dialog_To + return String; + + procedure Set_Dialog_To + (Value : in String); + + function Get_Dialog_Properties + return String; + + procedure Set_Dialog_Properties + (Value : in String); + + function Get_Dialog_Number_Copies + return String; + + procedure Set_Dialog_Number_Copies + (Value : in String); + + function Get_Dialog_Print_Button + return String; + + procedure Set_Dialog_Print_Button + (Value : in String); + + function Get_Dialog_Cancel_Button + return String; + + procedure Set_Dialog_Cancel_Button + (Value : in String); + + function Get_Dialog_Print_To_File + return String; + + procedure Set_Dialog_Print_To_File + (Value : in String); + + function Get_Property_Title + return String; + + procedure Set_Property_Title + (Value : in String); + + function Get_Property_Page_Size + return String; + + procedure Set_Property_Page_Size + (Value : in String); + + function Get_Property_Mode + return String; + + procedure Set_Property_Mode + (Value : in String); + + function Get_Property_Use + return String; + + procedure Set_Property_Use + (Value : in String); + + function Get_Property_Save + return String; + + procedure Set_Property_Save + (Value : in String); + + function Get_Property_Cancel + return String; + + procedure Set_Property_Cancel + (Value : in String); + + + + + -- Driver -- + + -- Not currently implemented + function Get_Original_Driver + (This : in out Printer) + return FLTK.Devices.Graphics.Graphics_Driver_Reference; + + + + + -- Job Control -- + + procedure Start_Job + (This : in out Printer; + Count : in Natural := 0); + + procedure Start_Job + (This : in out Printer; + Count : in Natural := 0; + From, To : out Positive); + + procedure End_Job + (This : in out Printer); + + procedure Start_Page + (This : in out Printer); + + procedure End_Page + (This : in out Printer); + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Printer; + Left, Top, Right, Bottom : out Integer); + + procedure Get_Printable_Rect + (This : in Printer; + W, H : out Integer); + + procedure Get_Origin + (This : in Printer; + X, Y : out Integer); + + procedure Set_Origin + (This : in out Printer; + X, Y : in Integer); + + procedure Rotate + (This : in out Printer; + Degrees : in Float); + + procedure Scale + (This : in out Printer; + Factor : in Float); + + procedure Scale + (This : in out Printer; + Factor_X, Factor_Y : in Float); + + procedure Translate + (This : in out Printer; + Delta_X, Delta_Y : in Integer); + + procedure Untranslate + (This : in out Printer); + + + + + -- Printing -- + + procedure Print_Widget + (This : in out Printer; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window_Part + (This : in out Printer; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0); + + + + + -- Printer -- + + procedure Set_Current + (This : in out Printer); + + +private + + + type Printer is new Paged_Device with null record; + + overriding procedure Finalize + (This : in out Printer); + + + Dialog_Title, Dialog_Printer, + Dialog_Range, Dialog_Copies, + Dialog_All, Dialog_Pages, + Dialog_From, Dialog_To, + Dialog_Properties, Dialog_Copyno, + Dialog_Print_Button, Dialog_Cancel_Button, + Dialog_Print_To_File, + Property_Title, Property_Pagesize, + Property_Mode, Property_Use, + Property_Save, Property_Cancel : Interfaces.C.Strings.chars_ptr; + + + pragma Inline (Get_Dialog_Title); + pragma Inline (Get_Dialog_Printer); + pragma Inline (Get_Dialog_Range); + pragma Inline (Get_Dialog_Copies); + pragma Inline (Get_Dialog_All); + pragma Inline (Get_Dialog_Pages); + pragma Inline (Get_Dialog_From); + pragma Inline (Get_Dialog_To); + pragma Inline (Get_Dialog_Properties); + pragma Inline (Get_Dialog_Number_Copies); + pragma Inline (Get_Dialog_Print_Button); + pragma Inline (Get_Dialog_Cancel_Button); + pragma Inline (Get_Dialog_Print_To_File); + pragma Inline (Get_Property_Title); + pragma Inline (Get_Property_Page_Size); + pragma Inline (Get_Property_Mode); + pragma Inline (Get_Property_Use); + pragma Inline (Get_Property_Save); + pragma Inline (Get_Property_Cancel); + + pragma Inline (Get_Original_Driver); + + pragma Inline (Start_Job); + pragma Inline (End_Job); + pragma Inline (Start_Page); + pragma Inline (End_Page); + + pragma Inline (Get_Margins); + pragma Inline (Get_Printable_Rect); + pragma Inline (Get_Origin); + pragma Inline (Set_Origin); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Translate); + pragma Inline (Untranslate); + + pragma Inline (Print_Widget); + pragma Inline (Print_Window_Part); + + pragma Inline (Set_Current); + + + -- Needed to ensure chars_ptr storage is properly cleaned up + type Printer_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out Printer_Final_Controller); + + Cleanup : Printer_Final_Controller; + + +end FLTK.Devices.Surface.Paged.Printers; + + diff --git a/spec/fltk-devices-surface-paged.ads b/spec/fltk-devices-surface-paged.ads new file mode 100644 index 0000000..cb820e6 --- /dev/null +++ b/spec/fltk-devices-surface-paged.ads @@ -0,0 +1,223 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + +private with + + Ada.Strings.Unbounded; + + +package FLTK.Devices.Surface.Paged is + + + pragma Elaborate_Body (FLTK.Devices.Surface.Paged); + + + type Paged_Device is new Surface_Device with private; + + type Paged_Device_Reference (Data : not null access Paged_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + type Page_Format is + (A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, + B0, B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, + C5E, DLE, Executive, Folio, Ledger, + Legal, Letter, Tabloid, Envelope, Media); + + + -- Note that the Name in the format information may not quite + -- correspond to the 'Image of the indexing Page_Format enumeration! + type Page_Format_Info is tagged private; + + function Name + (This : in Page_Format_Info) + return String; + + function Width + (This : in Page_Format_Info) + return Natural; + + function Height + (This : in Page_Format_Info) + return Natural; + + type Page_Format_Info_Array is array (Page_Format range <>) of Page_Format_Info; + + + type Page_Layout is + (Portrait, Landscape, Reversed, Orientation); + + + -- Information for everything except for Media + Page_Formats : constant Page_Format_Info_Array (A0 .. Envelope); + + + Page_Error : exception; + + + + + package Forge is + + -- Docs say there should be no reason to use this but it's here anyway. + function Create + return Paged_Device; + + end Forge; + + + + + -- Job Control -- + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural := 0); + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural := 0; + From, To : out Positive); + + procedure End_Job + (This : in out Paged_Device); + + procedure Start_Page + (This : in out Paged_Device); + + procedure End_Page + (This : in out Paged_Device); + + + + + -- Spacing and Orientation -- + + procedure Get_Margins + (This : in Paged_Device; + Left, Top, Right, Bottom : out Integer); + + procedure Get_Printable_Rect + (This : in Paged_Device; + W, H : out Integer); + + procedure Get_Origin + (This : in Paged_Device; + X, Y : out Integer); + + procedure Set_Origin + (This : in out Paged_Device; + X, Y : in Integer); + + procedure Rotate + (This : in out Paged_Device; + Degrees : in Float); + + procedure Scale + (This : in out Paged_Device; + Factor : in Float); + + procedure Scale + (This : in out Paged_Device; + Factor_X, Factor_Y : in Float); + + procedure Translate + (This : in out Paged_Device; + Delta_X, Delta_Y : in Integer); + + procedure Untranslate + (This : in out Paged_Device); + + + + + -- Printing -- + + procedure Print_Widget + (This : in out Paged_Device; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window_Part + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0); + + +private + + + type Paged_Device is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Paged_Device); + + + function To_Cint + (Value : in Page_Format) + return Interfaces.C.int; + + function To_Page_Format + (Value : in Interfaces.C.int) + return Page_Format; + + function To_Cint + (Value : in Page_Layout) + return Interfaces.C.int; + + function To_Page_Layout + (Value : in Interfaces.C.int) + return Page_Layout; + + + type Page_Format_Info is tagged record + My_Name : Ada.Strings.Unbounded.Unbounded_String; + My_Width : Natural; + My_Height : Natural; + end record; + + function Get_Page_Formats + return Page_Format_Info_Array; + + Page_Formats : constant Page_Format_Info_Array (A0 .. Envelope) := Get_Page_Formats; + + + pragma Inline (Name); + pragma Inline (Width); + pragma Inline (Height); + + pragma Inline (Start_Job); + pragma Inline (End_Job); + pragma Inline (Start_Page); + pragma Inline (End_Page); + + pragma Inline (Get_Margins); + pragma Inline (Get_Printable_Rect); + pragma Inline (Get_Origin); + pragma Inline (Set_Origin); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Translate); + pragma Inline (Untranslate); + + pragma Inline (Print_Widget); + pragma Inline (Print_Window); + pragma Inline (Print_Window_Part); + + +end FLTK.Devices.Surface.Paged; + + diff --git a/spec/fltk-devices-surface.ads b/spec/fltk-devices-surface.ads new file mode 100644 index 0000000..7aa9e87 --- /dev/null +++ b/spec/fltk-devices-surface.ads @@ -0,0 +1,88 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Devices.Graphics; + + +package FLTK.Devices.Surface is + + + type Surface_Device is new Device with private; + + type Surface_Device_Reference (Data : not null access Surface_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Surface_Device; + + end Forge; + + + + + -- Surfaces -- + + function Get_Current + return Surface_Device_Reference; + + procedure Set_Current + (This : in out Surface_Device); + + function Get_Original + return Surface_Device_Reference; + + + + + -- Drivers -- + + function Has_Driver + (This : in Surface_Device) + return Boolean; + + function Get_Driver + (This : in out Surface_Device) + return FLTK.Devices.Graphics.Graphics_Driver_Reference; + + procedure Set_Driver + (This : in out Surface_Device; + Driver : in out FLTK.Devices.Graphics.Graphics_Driver'Class); + + +private + + + type Surface_Device is new Device with record + My_Driver : access FLTK.Devices.Graphics.Graphics_Driver'Class; + end record; + + overriding procedure Finalize + (This : in out Surface_Device); + + + procedure Set_Current_Bookkeep + (Surface : in out Surface_Device'Class) + with Inline; + + + pragma Inline (Get_Current); + pragma Inline (Get_Original); + + pragma Inline (Has_Driver); + pragma Inline (Get_Driver); + + +end FLTK.Devices.Surface; + + diff --git a/spec/fltk-devices.ads b/spec/fltk-devices.ads new file mode 100644 index 0000000..6e9873f --- /dev/null +++ b/spec/fltk-devices.ads @@ -0,0 +1,24 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Devices is + + + type Device is new Wrapper with private; + + type Device_Reference (Data : not null access Device'Class) is + limited null record with Implicit_Dereference => Data; + + +private + + + type Device is new Wrapper with null record; + + +end FLTK.Devices; + + diff --git a/spec/fltk-draw.ads b/spec/fltk-draw.ads new file mode 100644 index 0000000..a2c66f3 --- /dev/null +++ b/spec/fltk-draw.ads @@ -0,0 +1,646 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Strings.Unbounded, + FLTK.Images.Pixmaps, + FLTK.Widgets.Groups.Windows; + + +package FLTK.Draw is + + + type Line_Kind is + (Solid_Line, + Dash_Line, + Dot_Line, + Dashdot_Line, + Dashdotdot_Line); + + type Cap_Kind is + (Default_Cap, + Flat_Cap, + Round_Cap, + Square_Cap); + + type Join_Kind is + (Default_Join, + Miter_Join, + Round_Join, + Bevel_Join); + + type Dash_Length is new Integer range 1 .. 255; + + type Dash_Gap is record + Solid : Dash_Length; + Blank : Dash_Length; + end record; + + type Dash_Gap_Array is array (Positive range <>) of Dash_Gap; + + Empty_Dashes : constant Dash_Gap_Array (1 .. 0) := (others => (1, 1)); + + type Image_Draw_Function is access procedure + (X, Y : in Natural; + Data : out Color_Component_Array); + + type Symbol_Draw_Function is access procedure + (Hue : in Color); + + type Text_Draw_Function is access procedure + (X, Y : in Integer; + Text : in String); + + type Area_Draw_Function is access procedure + (X, Y, W, H : in Integer); + + Draw_Error : exception; + + + + + -- No Documentation -- + + procedure Reset_Spot; + + procedure Set_Spot + (X, Y, W, H : in Integer; + Font : in Font_Kind; + Size : in Font_Size); + + procedure Set_Spot + (X, Y, W, H : in Integer; + Font : in Font_Kind; + Size : in Font_Size; + Pane : in FLTK.Widgets.Groups.Windows.Window'Class); + + procedure Set_Status + (X, Y, W, H : in Integer); + + + + + -- Utility -- + + function Can_Do_Alpha_Blending + return Boolean; + + function Shortcut_Label + (Keys : in Key_Combo) + return String; + + + + + -- Charset Conversion -- + + function Latin1_To_Local + (From : in String) + return String; + + function Local_To_Latin1 + (From : in String) + return String; + + function Mac_Roman_To_Local + (From : in String) + return String; + + function Local_To_Mac_Roman + (From : in String) + return String; + + + + + -- Clipping -- + + function Clip_Box + (X, Y, W, H : in Integer; + BX, BY, BW, BH : out Integer) + return Boolean; + + function Clip_Intersects + (X, Y, W, H : in Integer) + return Boolean; + + procedure Pop_Clip; + + procedure Push_Clip + (X, Y, W, H : in Integer); + + procedure Push_No_Clip; + + procedure Restore_Clip; + + + + + -- Overlay -- + + procedure Overlay_Clear; + + procedure Overlay_Rect + (X, Y, W, H : in Integer); + + + + + -- Settings -- + + function Get_Color + return Color; + + procedure Set_Color + (To : in Color); + + procedure Set_Color + (R, G, B : in Color_Component); + + procedure Set_Cursor + (To : in Mouse_Cursor_Kind); + + procedure Set_Cursor + (To : in Mouse_Cursor_Kind; + Fore : in Color; + Back : in Color := White_Color); + + function Get_Font + return Font_Kind; + + function Get_Font_Size + return Font_Size; + + procedure Set_Font + (Kind : in Font_Kind; + Size : in Font_Size); + + function Font_Line_Spacing + return Integer; + + function Font_Descent + return Integer; + + function Font_Height + (Kind : in Font_Kind; + Size : in Font_Size) + return Natural; + + procedure Set_Line_Style + (Line : in Line_Kind := Solid_Line; + Cap : in Cap_Kind := Default_Cap; + Join : in Join_Kind := Default_Join; + Width : in Natural := 0; + Dashes : in Dash_Gap_Array := Empty_Dashes); + + + + + -- Matrix Operations -- + + procedure Mult_Matrix + (A, B, C, D, X, Y : in Long_Float); + + procedure Pop_Matrix; + + procedure Push_Matrix; + + procedure Rotate + (Angle : in Long_Float); + + procedure Scale + (Factor : in Long_Float); + + procedure Scale + (Factor_X, Factor_Y : in Long_Float); + + function Transform_DX + (X, Y : in Long_Float) + return Long_Float; + + function Transform_DY + (X, Y : in Long_Float) + return Long_Float; + + function Transform_X + (X, Y : in Long_Float) + return Long_Float; + + function Transform_Y + (X, Y : in Long_Float) + return Long_Float; + + procedure Transformed_Vertex + (XF, YF : in Long_Float); + + procedure Translate + (X, Y : in Long_Float); + + procedure Vertex + (X, Y : in Long_Float); + + + + + -- Image Drawing -- + + procedure Draw_Image + (X, Y, W, H : in Integer; + Data : in Color_Component_Array; + Depth : in Positive := 3; + Line_Size : in Natural := 0; + Flip_Horizontal : in Boolean := False; + Flip_Vertical : in Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); + + procedure Draw_Image + (X, Y, W, H : in Integer; + Callback : in Image_Draw_Function; + Depth : in Positive := 3); + + procedure Draw_Image_Mono + (X, Y, W, H : in Integer; + Data : in Color_Component_Array; + Depth : in Positive := 1; + Line_Size : in Natural := 0; + Flip_Horizontal : Boolean := False; + Flip_Vertical : Boolean := False) + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (W) * Size_Type (H) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (H)); + + procedure Draw_Image_Mono + (X, Y, W, H : in Integer; + Callback : in Image_Draw_Function; + Depth : in Positive := 1); + + procedure Draw_Pixmap + (Values : in FLTK.Images.Pixmaps.Header; + Colors : in FLTK.Images.Pixmaps.Color_Definition_Array; + Pixels : in FLTK.Images.Pixmaps.Pixmap_Data; + X, Y : in Integer; + Tone : in Color := Grey0_Color) + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + + function Read_Image + (X, Y, W, H : in Integer; + Alpha : in Integer := 0) + return Color_Component_Array + with Post => + (if Alpha = 0 + then Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 3 + else Read_Image'Result'Length = Size_Type (W) * Size_Type (H) * 4); + + + + + -- Special Drawing -- + + procedure Add_Symbol + (Text : in String; + Callback : in Symbol_Draw_Function; + Scalable : in Boolean); + + procedure Draw_Text + (X, Y : in Integer; + Text : in String) + with Pre => Text'Length > 0; + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Symbols : in Boolean := True); + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Picture : in FLTK.Images.Image'Class; + Symbols : in Boolean := True); + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Callback : in Text_Draw_Function; + Symbols : in Boolean := True); + + procedure Draw_Text + (X, Y, W, H : in Integer; + Text : in String; + Align : in Alignment; + Callback : in Text_Draw_Function; + Picture : in FLTK.Images.Image'Class; + Symbols : in Boolean := True); + + procedure Draw_Text + (X, Y : in Integer; + Text : in String; + Angle : in Integer); + + procedure Draw_Text_Right_Left + (X, Y : in Integer; + Text : in String); + + procedure Draw_Box + (X, Y, W, H : in Integer; + Kind : in Box_Kind; + Hue : in Color); + + procedure Draw_Symbol + (X, Y, W, H : in Integer; + Name : in String; + Hue : in Color); + + procedure Measure + (Text : in String; + W, H : out Natural; + Symbols : in Boolean := True; + Wrap : in Natural := 0); + + procedure Scroll + (X, Y, W, H : in Integer; + DX, DY : in Integer; + Callback : in Area_Draw_Function); + + procedure Text_Extents + (Text : in String; + DX, DY, W, H : out Integer); + + -- Last is the index of the last character processed in Text which + -- would normally be one before the index of the char pointed at by + -- the return value in the C++ version. Instead, the return value + -- here is the processed text buffer. + function Expand_Text + (Text : in String; + Max_Width : in Long_Float; + Width : out Long_Float; + Last : out Natural; + Wrap : in Boolean; + Symbols : in Boolean := False) + return String; + + function Width + (Text : in String) + return Long_Float; + + function Width + (Glyph : in Character) + return Long_Float; + + function Width + (Glyph : in Wide_Character) + return Long_Float; + + function Width + (Glyph : in Wide_Wide_Character) + return Long_Float; + + + + + -- Manual Drawing -- + + procedure Begin_Complex_Polygon; + procedure Begin_Line; + procedure Begin_Loop; + procedure Begin_Points; + procedure Begin_Polygon; + + procedure Arc + (X, Y, R, Start, Finish : in Long_Float); + + procedure Arc + (X, Y, W, H : in Integer; + Start, Finish : in Long_Float); + + -- As per 1.3.9 docs, currently a placeholder + procedure Chord + (X, Y, W, H : in Integer; + Angle1, Angle2 : in Long_Float); + + procedure Circle + (X, Y, R : in Long_Float); + + procedure Curve + (X0, Y0 : in Long_Float; + X1, Y1 : in Long_Float; + X2, Y2 : in Long_Float; + X3, Y3 : in Long_Float); + + procedure Frame + (X, Y, W, H : in Integer; + Top, Left, Bottom, Right : in Greyscale); + + procedure Gap; + + procedure Line + (X0, Y0 : in Integer; + X1, Y1 : in Integer); + + procedure Line + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer); + + procedure Outline + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer); + + procedure Outline + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer; + X3, Y3 : in Integer); + + procedure Pie + (X, Y, W, H : in Integer; + Angle1, Angle2 : in Long_Float); + + procedure Point + (X, Y : in Integer); + + procedure Polygon + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer); + + procedure Polygon + (X0, Y0 : in Integer; + X1, Y1 : in Integer; + X2, Y2 : in Integer; + X3, Y3 : in Integer); + + procedure Rect + (X, Y, W, H : in Integer); + + procedure Rect + (X, Y, W, H : in Integer; + Hue : in Color); + + procedure Rect_Fill + (X, Y, W, H : in Integer); + + procedure Rect_Fill + (X, Y, W, H : in Integer; + Hue : in Color); + + procedure Rect_Fill + (X, Y, W, H : in Integer; + R, G, B : in Color_Component); + + procedure Ecks_Why_Line + (X0, Y0, X1 : in Integer); + + procedure Ecks_Why_Line + (X0, Y0, X1, Y2 : in Integer); + + procedure Ecks_Why_Line + (X0, Y0, X1, Y2, X3 : in Integer); + + procedure Why_Ecks_Line + (X0, Y0, Y1 : in Integer); + + procedure Why_Ecks_Line + (X0, Y0, Y1, X2 : in Integer); + + procedure Why_Ecks_Line + (X0, Y0, Y1, X2, Y3 : in Integer); + + procedure End_Complex_Polygon; + procedure End_Line; + procedure End_Loop; + procedure End_Points; + procedure End_Polygon; + + +private + + + pragma Convention (C, Symbol_Draw_Function); + + + pragma Import (C, Reset_Spot, "fl_draw_reset_spot"); + + pragma Import (C, Pop_Clip, "fl_draw_pop_clip"); + pragma Import (C, Push_No_Clip, "fl_draw_push_no_clip"); + pragma Import (C, Restore_Clip, "fl_draw_restore_clip"); + + pragma Import (C, Overlay_Clear, "fl_draw_overlay_clear"); + + pragma Import (C, Pop_Matrix, "fl_draw_pop_matrix"); + pragma Import (C, Push_Matrix, "fl_draw_push_matrix"); + + pragma Import (C, Begin_Complex_Polygon, "fl_draw_begin_complex_polygon"); + pragma Import (C, Begin_Line, "fl_draw_begin_line"); + pragma Import (C, Begin_Loop, "fl_draw_begin_loop"); + pragma Import (C, Begin_Points, "fl_draw_begin_points"); + pragma Import (C, Begin_Polygon, "fl_draw_begin_polygon"); + + pragma Import (C, Gap, "fl_draw_gap"); + + pragma Import (C, End_Complex_Polygon, "fl_draw_end_complex_polygon"); + pragma Import (C, End_Line, "fl_draw_end_line"); + pragma Import (C, End_Loop, "fl_draw_end_loop"); + pragma Import (C, End_Points, "fl_draw_end_points"); + pragma Import (C, End_Polygon, "fl_draw_end_polygon"); + + + pragma Inline (Reset_Spot); + pragma Inline (Set_Spot); + pragma Inline (Set_Status); + + pragma Inline (Can_Do_Alpha_Blending); + pragma Inline (Shortcut_Label); + + pragma Inline (Latin1_To_Local); + pragma Inline (Local_To_Latin1); + pragma Inline (Mac_Roman_To_Local); + pragma Inline (Local_To_Mac_Roman); + + pragma Inline (Clip_Intersects); + pragma Inline (Pop_Clip); + pragma Inline (Push_Clip); + pragma Inline (Push_No_Clip); + pragma Inline (Restore_Clip); + + pragma Inline (Overlay_Clear); + pragma Inline (Overlay_Rect); + + pragma Inline (Get_Color); + pragma Inline (Set_Color); + pragma Inline (Get_Font); + pragma Inline (Get_Font_Size); + pragma Inline (Set_Font); + pragma Inline (Font_Line_Spacing); + pragma Inline (Font_Descent); + pragma Inline (Font_Height); + + pragma Inline (Mult_Matrix); + pragma Inline (Pop_Matrix); + pragma Inline (Push_Matrix); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Transform_DX); + pragma Inline (Transform_DY); + pragma Inline (Transform_X); + pragma Inline (Transform_Y); + pragma Inline (Transformed_Vertex); + pragma Inline (Translate); + pragma Inline (Vertex); + + pragma Inline (Add_Symbol); + pragma Inline (Draw_Text); + pragma Inline (Draw_Text_Right_Left); + pragma Inline (Draw_Box); + pragma Inline (Draw_Symbol); + pragma Inline (Measure); + pragma Inline (Scroll); + pragma Inline (Text_Extents); + pragma Inline (Width); + + pragma Inline (Begin_Complex_Polygon); + pragma Inline (Begin_Line); + pragma Inline (Begin_Loop); + pragma Inline (Begin_Points); + pragma Inline (Begin_Polygon); + + pragma Inline (Arc); + pragma Inline (Chord); + pragma Inline (Circle); + pragma Inline (Curve); + pragma Inline (Frame); + pragma Inline (Gap); + pragma Inline (Line); + pragma Inline (Outline); + pragma Inline (Pie); + pragma Inline (Point); + pragma Inline (Polygon); + pragma Inline (Rect); + pragma Inline (Rect_Fill); + pragma Inline (Ecks_Why_Line); + pragma Inline (Why_Ecks_Line); + + pragma Inline (End_Complex_Polygon); + pragma Inline (End_Line); + pragma Inline (End_Loop); + pragma Inline (End_Points); + pragma Inline (End_Polygon); + + +end FLTK.Draw; + + diff --git a/spec/fltk-environment.ads b/spec/fltk-environment.ads new file mode 100644 index 0000000..9ab7f7c --- /dev/null +++ b/spec/fltk-environment.ads @@ -0,0 +1,359 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces; + +private with + + Interfaces.C; + + +package FLTK.Environment is + + + type Database is new Wrapper with private; + + type Database_Reference (Data : not null access Database'Class) is + limited null record with Implicit_Dereference => Data; + + type Pref_Group is new Wrapper with private; + + type Pref_Group_Reference (Data : not null access Pref_Group'Class) is + limited null record with Implicit_Dereference => Data; + + type Scope is (Global, User); + + type Binary_Data is array (Positive range <>) of Interfaces.Unsigned_8; + + + Preference_Error : exception; + + + + + package Forge is + + function From_Filesystem + (Directory, Vendor, Application : in String) + return Database; + + function From_Scope + (Extent : in Scope; + Vendor, Application : in String) + return Database; + + function Root + (From : in Database) + return Pref_Group'Class; + + function In_Memory + (Name : in String) + return Pref_Group; + + function By_Name + (From : in Pref_Group; + Name : in String) + return Pref_Group'Class; + + function By_Index + (From : in Pref_Group; + Index : in Positive) + return Pref_Group'Class; + + end Forge; + + + + + -- Static -- + + function New_UUID + return String; + + + + + -- Disk Activity -- + + procedure Flush + (This : in Database); + + function Userdata_Path + (This : in Database) + return String; + + + + + -- Deletion -- + + procedure Delete_Entry + (This : in out Pref_Group; + Key : in String) + with Post => This.Key_Exists (Key) = False; + + procedure Delete_All_Entries + (This : in out Pref_Group) + with Post => This.Number_Of_Entries = 0; + + procedure Delete_Group + (This : in out Pref_Group; + Name : in String) + with Post => This.Group_Exists (Name) = False; + + procedure Delete_All_Groups + (This : in out Pref_Group) + with Post => This.Number_Of_Groups = 0; + + procedure Clear + (This : in out Pref_Group) + with Post => This.Number_Of_Entries = 0 and + This.Number_Of_Groups = 0; + + + + + -- Key Values -- + + function Number_Of_Entries + (This : in Pref_Group) + return Natural; + + function Entry_Key + (This : in Pref_Group; + Index : in Positive) + return String + with Pre => Index in 1 .. This.Number_Of_Entries; + + function Key_Exists + (This : in Pref_Group; + Key : in String) + return Boolean; + + function Value_Size + (This : in Pref_Group; + Key : in String) + return Natural; + + + + + -- Groups -- + + function Number_Of_Groups + (This : in Pref_Group) + return Natural; + + function Group_Name + (This : in Pref_Group; + Index : in Positive) + return String + with Pre => Index in 1 .. This.Number_Of_Groups; + + function Group_Exists + (This : in Pref_Group; + Name : in String) + return Boolean; + + + + + -- Names -- + + function At_Name + (This : in Pref_Group) + return String; + + function At_Path + (This : in Pref_Group) + return String; + + + + + -- Retrieval -- + + function Get + (This : in Pref_Group; + Key : in String) + return Integer; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Integer) + return Integer; + + function Get + (This : in Pref_Group; + Key : in String) + return Float; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Float) + return Float; + + function Get + (This : in Pref_Group; + Key : in String) + return Long_Float; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Long_Float) + return Long_Float; + + function Get + (This : in Pref_Group; + Key : in String) + return String; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in String) + return String; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in String; + Max_Length : in Natural) + return String + with Post => Get'Result'Length <= Max_Length; + + function Get + (This : in Pref_Group; + Key : in String) + return Binary_Data; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Binary_Data) + return Binary_Data; + + function Get + (This : in Pref_Group; + Key : in String; + Default : in Binary_Data; + Max_Length : in Natural) + return Binary_Data + with Post => Get'Result'Length <= Max_Length; + + + + + -- Storage -- + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Integer) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Float) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Float; + Precision : in Natural) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Long_Float) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Long_Float; + Precision : in Natural) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in String) + with Post => This.Key_Exists (Key); + + procedure Set + (This : in out Pref_Group; + Key : in String; + Value : in Binary_Data) + with Post => This.Key_Exists (Key); + + +private + + + type Database is new Wrapper with null record; + + overriding procedure Finalize + (This : in out Database); + + + type Pref_Group is new Wrapper with record + Root_Ptr : Storage.Integer_Address := Null_Pointer; + end record; + + overriding procedure Finalize + (This : in out Pref_Group); + + + pragma Convention (C, Binary_Data); + for Binary_Data'Component_Size use Interfaces.C.CHAR_BIT; + + + pragma Inline (New_UUID); + + pragma Inline (Flush); + + pragma Inline (Delete_Entry); + pragma Inline (Delete_All_Entries); + pragma Inline (Delete_Group); + pragma Inline (Delete_All_Groups); + pragma Inline (Clear); + + pragma Inline (Number_Of_Entries); + pragma Inline (Entry_Key); + pragma Inline (Key_Exists); + pragma Inline (Value_Size); + + pragma Inline (Number_Of_Groups); + pragma Inline (Group_Name); + pragma Inline (Group_Exists); + + pragma Inline (At_Name); + pragma Inline (At_Path); + + pragma Inline (Set); + + + function To_Cint + (Extent : in Scope) + return Interfaces.C.int; + + function To_Scope + (Num : in Interfaces.C.int) + return Scope; + + +end FLTK.Environment; + + diff --git a/spec/fltk-errors.ads b/spec/fltk-errors.ads new file mode 100644 index 0000000..6cdea54 --- /dev/null +++ b/spec/fltk-errors.ads @@ -0,0 +1,39 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Errors is + + + type Error_Function is not null access procedure + (Message : in String); + + + procedure Default_Warning + (Message : in String); + + procedure Default_Error + (Message : in String); + + procedure Default_Fatal + (Message : in String); + + + Current_Warning : Error_Function := Default_Warning'Access; + Current_Error : Error_Function := Default_Error'Access; + Current_Fatal : Error_Function := Default_Fatal'Access; + + +private + + + pragma Inline (Default_Warning); + pragma Inline (Default_Error); + pragma Inline (Default_Fatal); + + +end FLTK.Errors; + + diff --git a/spec/fltk-events.ads b/spec/fltk-events.ads new file mode 100644 index 0000000..5dbc573 --- /dev/null +++ b/spec/fltk-events.ads @@ -0,0 +1,364 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows, + System; + +private with + + Ada.Finalization, + System.Address_To_Access_Conversions; + + +package FLTK.Events is + + + type Event_Handler is access function + (Event : in Event_Kind) + return Event_Outcome; + + type Event_Dispatch is access function + (Event : in Event_Kind; + Win : access FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + type System_Event is new System.Address; + + type System_Handler is access function + (Event : in System_Event) + return Event_Outcome; + + + + + -- Handlers -- + + procedure Add_Handler + (Func : in not null Event_Handler); + + procedure Remove_Handler + (Func : in not null Event_Handler); + + procedure Add_System_Handler + (Func : in not null System_Handler); + + procedure Remove_System_Handler + (Func : in not null System_Handler); + + + + + -- Dispatch -- + + function Get_Dispatch + return Event_Dispatch; + + -- Any Event_Dispatch function set must call Handle + -- if you want the Event to actually be acknowledged. + procedure Set_Dispatch + (Func : in Event_Dispatch); + + function Handle_Dispatch + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + function Handle + (Event : in Event_Kind; + Origin : in out FLTK.Widgets.Groups.Windows.Window'Class) + return Event_Outcome; + + + + + -- Receiving -- + + function Get_Grab + return access FLTK.Widgets.Groups.Windows.Window'Class; + + procedure Set_Grab + (To : in FLTK.Widgets.Groups.Windows.Window'Class); + + procedure Release_Grab; + + function Get_Pushed + return access FLTK.Widgets.Widget'Class; + + procedure Set_Pushed + (To : in FLTK.Widgets.Widget'Class); + + function Get_Below_Mouse + return access FLTK.Widgets.Widget'Class; + + procedure Set_Below_Mouse + (To : in FLTK.Widgets.Widget'Class); + + function Get_Focus + return access FLTK.Widgets.Widget'Class; + + procedure Set_Focus + (To : in FLTK.Widgets.Widget'Class); + + function Has_Visible_Focus + return Boolean; + + procedure Set_Visible_Focus + (To : in Boolean); + + + + + -- Clipboard -- + + function Clipboard_Text + return String; + + function Clipboard_Kind + return String; + + + + + -- Multikey -- + + function Compose + (Del : out Natural) + return Boolean; + + procedure Compose_Reset; + + function Text + return String; + + function Text_Length + return Natural; + + function Test_Shortcut + (Shortcut : in Key_Combo) + return Boolean; + + + + + -- Modifiers -- + + function Last + return Event_Kind; + + -- Focuses on keyboard modifiers only, not mouse buttons + function Last_Modifier + return Modifier; + + -- Focuses on keyboard modifiers only, not mouse buttons + function Last_Modifier + (Had : in Modifier) + return Boolean; + + + + + -- Mouse -- + + function Mouse_X + return Integer; + + function Mouse_X_Root + return Integer; + + function Mouse_Y + return Integer; + + function Mouse_Y_Root + return Integer; + + function Mouse_DX + return Integer; + + function Mouse_DY + return Integer; + + procedure Get_Mouse + (X, Y : out Integer); + + function Is_Click + return Boolean; + + procedure Clear_Click; + + function Is_Multi_Click + return Boolean; + + -- Returns the actual number of clicks. + -- So no clicks is 0, a single click is 1, a double click is 2, etc. + function Get_Clicks + return Natural; + + -- Will set the actual number of clicks. + -- This means setting it to 0 will make Is_Click return False. + procedure Set_Clicks + (To : in Natural); + + function Last_Button + return Mouse_Button; + + function Mouse_Left + return Boolean; + + function Mouse_Middle + return Boolean; + + function Mouse_Right + return Boolean; + + function Mouse_Back + return Boolean; + + function Mouse_Forward + return Boolean; + + procedure Mouse_Buttons + (Left, Middle, Right, Back, Forward : out Boolean); + + function Is_Inside + (Child : in FLTK.Widgets.Widget'Class) + return Boolean; + + function Is_Inside + (X, Y, W, H : in Integer) + return Boolean; + + + + + -- Keyboard -- + + function Last_Key + return Keypress; + + function Original_Last_Key + return Keypress; + + function Pressed_During + (Key : in Keypress) + return Boolean; + + function Key_Now + (Key : in Keypress) + return Boolean; + + function Key_Ctrl + return Boolean; + + function Key_Alt + return Boolean; + + function Key_Command + return Boolean; + + function Key_Shift + return Boolean; + + +private + + + package Widget_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Widget'Class); + package Window_Convert is new System.Address_To_Access_Conversions + (FLTK.Widgets.Groups.Windows.Window'Class); + + + Current_Dispatch : Event_Dispatch := null; + + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + + + pragma Import (C, Compose_Reset, "fl_event_compose_reset"); + + + pragma Inline (Add_Handler); + pragma Inline (Remove_Handler); + pragma Inline (Add_System_Handler); + pragma Inline (Remove_System_Handler); + + pragma Inline (Get_Dispatch); + pragma Inline (Set_Dispatch); + pragma Inline (Handle_Dispatch); + pragma Inline (Handle); + + pragma Inline (Get_Grab); + pragma Inline (Set_Grab); + pragma Inline (Release_Grab); + pragma Inline (Get_Pushed); + pragma Inline (Set_Pushed); + pragma Inline (Get_Below_Mouse); + pragma Inline (Set_Below_Mouse); + pragma Inline (Get_Focus); + pragma Inline (Set_Focus); + pragma Inline (Has_Visible_Focus); + pragma Inline (Set_Visible_Focus); + + pragma Inline (Clipboard_Text); + pragma Inline (Clipboard_Kind); + + pragma Inline (Compose); + pragma Inline (Compose_Reset); + pragma Inline (Text); + pragma Inline (Text_Length); + pragma Inline (Test_Shortcut); + + pragma Inline (Last); + pragma Inline (Last_Modifier); + + pragma Inline (Mouse_X); + pragma Inline (Mouse_X_Root); + pragma Inline (Mouse_Y); + pragma Inline (Mouse_Y_Root); + pragma Inline (Mouse_DX); + pragma Inline (Mouse_DY); + pragma Inline (Get_Mouse); + pragma Inline (Is_Click); + pragma Inline (Clear_Click); + pragma Inline (Is_Multi_Click); + pragma Inline (Get_Clicks); + pragma Inline (Set_Clicks); + pragma Inline (Mouse_Left); + pragma Inline (Mouse_Middle); + pragma Inline (Mouse_Right); + pragma Inline (Mouse_Back); + pragma Inline (Mouse_Forward); + pragma Inline (Is_Inside); + + pragma Inline (Last_Key); + pragma Inline (Original_Last_Key); + pragma Inline (Pressed_During); + pragma Inline (Key_Now); + pragma Inline (Key_Ctrl); + pragma Inline (Key_Alt); + pragma Inline (Key_Command); + pragma Inline (Key_Shift); + + + -- Needed to deregister the handlers + type FLTK_Events_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Events_Final_Controller); + + Cleanup : FLTK_Events_Final_Controller; + + +end FLTK.Events; + + diff --git a/spec/fltk-file_choosers.ads b/spec/fltk-file_choosers.ads new file mode 100644 index 0000000..3445d4f --- /dev/null +++ b/spec/fltk-file_choosers.ads @@ -0,0 +1,422 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Filenames, + FLTK.Widgets.Buttons.Light.Check; + +private with + + Ada.Finalization, + Interfaces.C.Strings; + + +package FLTK.File_Choosers is + + + type File_Chooser is new Wrapper with private; + + type File_Chooser_Reference (Data : not null access File_Chooser'Class) is + limited null record with Implicit_Dereference => Data; + + type Chooser_Kind is (Single, Multi, Create, Directory); + + type Chooser_Callback is access procedure + (Item : in out File_Chooser'Class); + + type Icon_Size is mod 256; + + + + + package Forge is + + function Create + (Title : in String; + Pattern : in String; + Pathname : in String; + Kind : in Chooser_Kind := Single) + return File_Chooser; + + end Forge; + + + + + -- Sorting -- + + Sort_Method : not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access; + + + + + -- Buttons -- + + function New_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Button_Reference; + + function Preview_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference; + + function Show_Hidden_Button + (This : in out File_Chooser) + return FLTK.Widgets.Buttons.Light.Check.Check_Button_Reference; + + + + + -- Static Labels -- + + function Get_Add_Favorites_Label + return String; + + procedure Set_Add_Favorites_Label + (Value : in String); + + function Get_All_Files_Label + return String; + + procedure Set_All_Files_Label + (Value : in String); + + function Get_Custom_Filter_Label + return String; + + procedure Set_Custom_Filter_Label + (Value : in String); + + function Get_Existing_File_Label + return String; + + procedure Set_Existing_File_Label + (Value : in String); + + function Get_Favorites_Label + return String; + + procedure Set_Favorites_Label + (Value : in String); + + function Get_Filename_Label + return String; + + procedure Set_Filename_Label + (Value : in String); + + function Get_Filesystems_Label + return String; + + procedure Set_Filesystems_Label + (Value : in String); + + function Get_Hidden_Label + return String; + + procedure Set_Hidden_Label + (Value : in String); + + function Get_Manage_Favorites_Label + return String; + + procedure Set_Manage_Favorites_Label + (Value : in String); + + function Get_New_Directory_Label + return String; + + procedure Set_New_Directory_Label + (Value : in String); + + function Get_New_Directory_Tooltip + return String; + + procedure Set_New_Directory_Tooltip + (Value : in String); + + function Get_Preview_Label + return String; + + procedure Set_Preview_Label + (Value : in String); + + function Get_Save_Label + return String; + + procedure Set_Save_Label + (Value : in String); + + function Get_Show_Label + return String; + + procedure Set_Show_Label + (Value : in String); + + + + + -- Callback and Extra -- + + procedure Add_Extra + (This : in out File_Chooser; + Item : in out Widgets.Widget'Class); + + procedure Remove_Extra + (This : in out File_Chooser); + + function Eject_Extra + (This : in out File_Chooser; + Item : in out Widgets.Widget'Class) + return access Widgets.Widget'Class; + + procedure Set_Callback + (This : in out File_Chooser; + Func : in Chooser_Callback); + + + + + -- Settings -- + + function Get_Background_Color + (This : in File_Chooser) + return Color; + + procedure Set_Background_Color + (This : in out File_Chooser; + Value : in Color); + + function Get_Icon_Size + (This : in File_Chooser) + return Icon_Size; + + procedure Set_Icon_Size + (This : in out File_Chooser; + Value : in Icon_Size); + + function Get_Label + (This : in File_Chooser) + return String; + + procedure Set_Label + (This : in out File_Chooser; + Text : in String); + + function Get_OK_Label + (This : in File_Chooser) + return String; + + procedure Set_OK_Label + (This : in out File_Chooser; + Text : in String); + + function Has_Preview + (This : in File_Chooser) + return Boolean; + + procedure Set_Preview + (This : in out File_Chooser; + Value : in Boolean); + + function Get_Text_Color + (This : in File_Chooser) + return Color; + + procedure Set_Text_Color + (This : in out File_Chooser; + Value : in Color); + + function Get_Text_Font + (This : in File_Chooser) + return Font_Kind; + + procedure Set_Text_Font + (This : in out File_Chooser; + Font : in Font_Kind); + + function Get_Text_Size + (This : in File_Chooser) + return Font_Size; + + procedure Set_Text_Size + (This : in out File_Chooser; + Size : in Font_Size); + + function Get_Kind + (This : in File_Chooser) + return Chooser_Kind; + + procedure Set_Kind + (This : in out File_Chooser; + Kind : in Chooser_Kind); + + + + + -- File Selection -- + + function Number_Selected + (This : in File_Chooser) + return Natural; + + function Get_Directory + (This : in File_Chooser) + return String; + + procedure Set_Directory + (This : in out File_Chooser; + Value : in String); + + function Get_Filter + (This : in File_Chooser) + return String; + + procedure Set_Filter + (This : in out File_Chooser; + Value : in String); + + function Get_Filter_Index + (This : in File_Chooser) + return Positive; + + procedure Set_Filter_Index + (This : in out File_Chooser; + Value : in Positive); + + procedure Rescan + (This : in out File_Chooser); + + procedure Rescan_Keep_Filename + (This : in out File_Chooser); + + function Get_Selected + (This : in File_Chooser; + Index : in Positive := 1) + return String + with Pre => Index <= This.Number_Selected; + + procedure Set_Selected + (This : in out File_Chooser; + Value : in String); + + + + + -- Visibility -- + + procedure Show + (This : in out File_Chooser); + + procedure Hide + (This : in out File_Chooser); + + function Is_Shown + (This : in File_Chooser) + return Boolean; + + function Is_Visible + (This : in File_Chooser) + return Boolean; + + +private + + + type File_Chooser is new Wrapper with record + New_Butt : aliased Widgets.Buttons.Button; + Preview_Butt : aliased Widgets.Buttons.Light.Check.Check_Button; + Hidden_Butt : aliased Widgets.Buttons.Light.Check.Check_Button; + My_Callback : Chooser_Callback; + My_Label : Interfaces.C.Strings.chars_ptr; + My_OK_Label : Interfaces.C.Strings.chars_ptr; + end record; + + overriding procedure Finalize + (This : in out File_Chooser); + + procedure Extra_Init + (This : in out File_Chooser); + + procedure Extra_Final + (This : in out File_Chooser); + + + Add_Favorites_Label, All_Files_Label, + Custom_Filter_Label, Existing_File_Label, + Favorites_Label, Filename_Label, + Filesystems_Label, Hidden_Label, + Manage_Favorites_Label, New_Directory_Label, + New_Directory_Tooltip, Preview_Label, + Save_Label, Show_Label : Interfaces.C.Strings.chars_ptr; + + + pragma Inline (New_Button); + pragma Inline (Preview_Button); + pragma Inline (Show_Hidden_Button); + + pragma Inline (Get_Add_Favorites_Label); + pragma Inline (Get_All_Files_Label); + pragma Inline (Get_Custom_Filter_Label); + pragma Inline (Get_Existing_File_Label); + pragma Inline (Get_Favorites_Label); + pragma Inline (Get_Filename_Label); + pragma Inline (Get_Filesystems_Label); + pragma Inline (Get_Hidden_Label); + pragma Inline (Get_Manage_Favorites_Label); + pragma Inline (Get_New_Directory_Label); + pragma Inline (Get_New_Directory_Tooltip); + pragma Inline (Get_Preview_Label); + pragma Inline (Get_Save_Label); + pragma Inline (Get_Show_Label); + + pragma Inline (Add_Extra); + pragma Inline (Remove_Extra); + pragma Inline (Eject_Extra); + pragma Inline (Set_Callback); + + pragma Inline (Get_Background_Color); + pragma Inline (Set_Background_Color); + pragma Inline (Get_Icon_Size); + pragma Inline (Set_Icon_Size); + pragma Inline (Get_Label); + pragma Inline (Get_OK_Label); + pragma Inline (Set_Preview); + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + pragma Inline (Set_Kind); + + pragma Inline (Number_Selected); + pragma Inline (Get_Filter_Index); + pragma Inline (Set_Filter_Index); + pragma Inline (Rescan); + pragma Inline (Rescan_Keep_Filename); + pragma Inline (Set_Selected); + + pragma Inline (Show); + pragma Inline (Hide); + pragma Inline (Is_Shown); + pragma Inline (Is_Visible); + + + -- Needed to ensure chars_ptr storage is properly cleaned up + type File_Chooser_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out File_Chooser_Final_Controller); + + Cleanup : File_Chooser_Final_Controller; + + +end FLTK.File_Choosers; + + diff --git a/spec/fltk-filenames.ads b/spec/fltk-filenames.ads new file mode 100644 index 0000000..5d9b5ff --- /dev/null +++ b/spec/fltk-filenames.ads @@ -0,0 +1,167 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Filenames is + + + Max_Path_Length : constant Natural; + + subtype Path_String is String + with Dynamic_Predicate => Path_String'Length <= Max_Path_Length; + + + type Comparison is (Lesser, Equal, Greater); + + type Compare_Function is access function + (A, B : in String) + return Comparison; + + function Alpha_Sort + (A, B : in String) + return Comparison; + + function Case_Alpha_Sort + (A, B : in String) + return Comparison; + + function Numeric_Sort + (A, B : in String) + return Comparison; + + function Case_Numeric_Sort + (A, B : in String) + return Comparison; + + + type File_List is new Wrapper with private; + + function Length + (This : in File_List) + return Natural; + + function Item + (This : in File_List; + Index : in Positive) + return Path_String + with Pre => Index in 1 .. This.Length; + + + Open_URI_Error : exception; + + + + + -- Uniform Resource Identifiers -- + + function Decode_URI + (URI : in Path_String) + return Path_String; + + procedure Open_URI + (URI : in Path_String); + + + + + -- Pathnames -- + + function Absolute + (Name : in Path_String) + return Path_String; + + function Absolute + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + function Relative + (Name : in Path_String) + return Path_String; + + function Relative + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + function Expand + (Name : in Path_String) + return Path_String; + + function Expand + (Name : in Path_String; + Changed : out Boolean) + return Path_String; + + + + + -- Filenames -- + + function Base_Name + (Name : in Path_String) + return Path_String; + + function Extension + (Name : in Path_String) + return Path_String; + + function Set_Extension + (Name : in Path_String; + Suffix : in String) + return Path_String; + + + + + -- Directories -- + + function Is_Directory + (Name : in Path_String) + return Boolean; + + function Get_Listing + (Name : in Path_String; + Sort : in not null Compare_Function := Numeric_Sort'Access) + return File_List; + + + + + -- Patterns -- + + function Match + (Input, Pattern : in String) + return Boolean; + + +private + + + type File_List is new Wrapper with record + Entries : Interfaces.C.int := 0; + end record; + + overriding procedure Finalize + (This : in out File_List); + + + fl_path_max : constant Interfaces.C.int; + pragma Import (C, fl_path_max, "fl_path_max"); + + Max_Path_Length : constant Natural := Natural (fl_path_max); + + + pragma Inline (Length); + pragma Inline (Item); + + pragma Inline (Is_Directory); + + pragma Inline (Match); + + +end FLTK.Filenames; + + diff --git a/spec/fltk-help_dialogs.ads b/spec/fltk-help_dialogs.ads new file mode 100644 index 0000000..fa0b94b --- /dev/null +++ b/spec/fltk-help_dialogs.ads @@ -0,0 +1,155 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Help_Dialogs is + + + type Help_Dialog is new Wrapper with private; + + type Help_Dialog_Reference (Data : not null access Help_Dialog'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + return Help_Dialog; + + function Create + (X, Y, W, H : in Integer) + return Help_Dialog; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Help_Dialog); + + procedure Show_With_Args + (This : in out Help_Dialog); + + procedure Hide + (This : in out Help_Dialog); + + function Is_Visible + (This : in Help_Dialog) + return Boolean; + + + + + -- Topline -- + + procedure Set_Topline_Number + (This : in out Help_Dialog; + Line : in Positive); + + procedure Set_Topline_Target + (This : in out Help_Dialog; + Value : in String); + + + + + -- Content -- + + -- Name here can be either a ftp/http/https/ipp/mailto/news URL or a filename. + -- See Load procedure in FLTK.Widgets.Groups.Help_Views + procedure Load + (This : in out Help_Dialog; + Name : in String); + + function Get_Content + (This : in Help_Dialog) + return String; + + procedure Set_Content + (This : in out Help_Dialog; + Value : in String); + + + + + -- Settings -- + + function Get_Text_Size + (This : in Help_Dialog) + return Font_Size; + + procedure Set_Text_Size + (This : in out Help_Dialog; + Size : in Font_Size); + + + + + -- Dimensions -- + + function Get_X + (This : in Help_Dialog) + return Integer; + + function Get_Y + (This : in Help_Dialog) + return Integer; + + function Get_W + (This : in Help_Dialog) + return Integer; + + function Get_H + (This : in Help_Dialog) + return Integer; + + procedure Resize + (This : in out Help_Dialog; + X, Y, W, H : in Integer); + + procedure Reposition + (This : in out Help_Dialog; + X, Y : in Integer); + + +private + + + type Help_Dialog is new Wrapper with null record; + + overriding procedure Finalize + (This : in out Help_Dialog); + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Hide); + pragma Inline (Is_Visible); + + pragma Inline (Set_Topline_Number); + pragma Inline (Set_Topline_Target); + + pragma Inline (Load); + pragma Inline (Set_Content); + + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Get_X); + pragma Inline (Get_Y); + pragma Inline (Get_W); + pragma Inline (Get_H); + pragma Inline (Resize); + pragma Inline (Reposition); + + +end FLTK.Help_Dialogs; + + diff --git a/spec/fltk-images-bitmaps-xbm.ads b/spec/fltk-images-bitmaps-xbm.ads new file mode 100644 index 0000000..5805332 --- /dev/null +++ b/spec/fltk-images-bitmaps-xbm.ads @@ -0,0 +1,38 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.Bitmaps.XBM is + + + type XBM_Image is new Bitmap with private; + + type XBM_Image_Reference (Data : not null access XBM_Image'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return XBM_Image; + + end Forge; + + +private + + + type XBM_Image is new Bitmap with null record; + + overriding procedure Finalize + (This : in out XBM_Image); + + +end FLTK.Images.Bitmaps.XBM; + + diff --git a/spec/fltk-images-bitmaps.ads b/spec/fltk-images-bitmaps.ads new file mode 100644 index 0000000..9577273 --- /dev/null +++ b/spec/fltk-images-bitmaps.ads @@ -0,0 +1,145 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.Bitmaps is + + + type Bitmap is new Image with private; + + type Bitmap_Reference (Data : not null access Bitmap'Class) is limited null record + with Implicit_Dereference => Data; + + + + + -- Calculates the bytes needed to hold a given number of bits. + + function Bytes_Needed + (Bits : in Natural) + return Natural; + + + + + package Forge is + + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting Bitmap. + + function Create + (Data : in Color_Component_Array; + Width, Height : in Natural) + return Bitmap + with Pre => + Data'Length >= Size_Type (Bytes_Needed (Width)) * Size_Type (Height); + + end Forge; + + + + + -- Copying -- + + function Copy + (This : in Bitmap; + Width, Height : in Natural) + return Bitmap'Class; + + function Copy + (This : in Bitmap) + return Bitmap'Class; + + + + + -- Activity -- + + procedure Uncache + (This : in out Bitmap); + + + + + -- Pixel Data -- + + function Data_Size + (This : in Bitmap) + return Size_Type; + + function Get_Datum + (This : in Bitmap; + Place : in Positive_Size) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out Bitmap; + Place : in Positive_Size; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in Bitmap; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out Bitmap; + Place : in Positive_Size; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in Bitmap) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + + -- Drawing -- + + procedure Draw + (This : in Bitmap; + X, Y : in Integer); + + procedure Draw + (This : in Bitmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); + + +private + + + type Bitmap is new Image with null record; + + overriding procedure Finalize + (This : in out Bitmap); + + + pragma Inline (Bytes_Needed); + + pragma Inline (Copy); + + pragma Inline (Uncache); + + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); + + pragma Inline (Draw); + + +end FLTK.Images.Bitmaps; + + diff --git a/spec/fltk-images-pixmaps-gif.ads b/spec/fltk-images-pixmaps-gif.ads new file mode 100644 index 0000000..5720138 --- /dev/null +++ b/spec/fltk-images-pixmaps-gif.ads @@ -0,0 +1,38 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.Pixmaps.GIF is + + + type GIF_Image is new Pixmap with private; + + type GIF_Image_Reference (Data : not null access GIF_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return GIF_Image; + + end Forge; + + +private + + + type GIF_Image is new Pixmap with null record; + + overriding procedure Finalize + (This : in out GIF_Image); + + +end FLTK.Images.Pixmaps.GIF; + + diff --git a/spec/fltk-images-pixmaps-xpm.ads b/spec/fltk-images-pixmaps-xpm.ads new file mode 100644 index 0000000..c703264 --- /dev/null +++ b/spec/fltk-images-pixmaps-xpm.ads @@ -0,0 +1,38 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.Pixmaps.XPM is + + + type XPM_Image is new Pixmap with private; + + type XPM_Image_Reference (Data : not null access XPM_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return XPM_Image; + + end Forge; + + +private + + + type XPM_Image is new Pixmap with null record; + + overriding procedure Finalize + (This : in out XPM_Image); + + +end FLTK.Images.Pixmaps.XPM; + + diff --git a/spec/fltk-images-pixmaps.ads b/spec/fltk-images-pixmaps.ads new file mode 100644 index 0000000..64d8330 --- /dev/null +++ b/spec/fltk-images-pixmaps.ads @@ -0,0 +1,135 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Strings.Unbounded; + +private with + + Interfaces.C.Strings; + + +package FLTK.Images.Pixmaps is + + + type Pixmap is new Image with private; + + type Pixmap_Reference (Data : not null access Pixmap'Class) is limited null record + with Implicit_Dereference => Data; + + + type Header is record + Width, Height, Colors, Per_Pixel : Positive; + end record; + + type Color_Kind is (Colorful, Monochrome, Greyscale, Symbolic); + + type Color_Definition is record + Name : Ada.Strings.Unbounded.Unbounded_String; + Kind : Color_Kind; + Value : Ada.Strings.Unbounded.Unbounded_String; + end record; + + type Color_Definition_Array is array (Positive range <>) of Color_Definition; + + type Pixmap_Data is array (Positive range <>, Positive range <>) of Character; + + + + + package Forge is + + -- Unlike Bitmaps or RGB_Images, you do NOT have to keep this data around. + -- A copy will be allocated and deallocated internally. + + function Create + (Values : in Header; + Colors : in Color_Definition_Array; + Pixels : in Pixmap_Data) + return Pixmap + with Pre => + Colors'Length = Values.Colors and + Pixels'Length (1) = Values.Height and + (for all Definition of Colors => + Ada.Strings.Unbounded.Length (Definition.Name) = Values.Per_Pixel) and + Pixels'Length (2) = Values.Width * Values.Per_Pixel; + + end Forge; + + + + + -- Copying -- + + function Copy + (This : in Pixmap; + Width, Height : in Natural) + return Pixmap'Class; + + function Copy + (This : in Pixmap) + return Pixmap'Class; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Pixmap; + Col : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Pixmap); + + + + + -- Activity -- + + procedure Uncache + (This : in out Pixmap); + + + + + -- Drawing -- + + procedure Draw + (This : in Pixmap; + X, Y : in Integer); + + procedure Draw + (This : in Pixmap; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); + + +private + + + type Pixmap is new Image with record + Loose_Ptr : access Interfaces.C.Strings.chars_ptr_array; + end record; + + overriding procedure Finalize + (This : in out Pixmap); + + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + pragma Inline (Uncache); + + pragma Inline (Copy); + pragma Inline (Draw); + + +end FLTK.Images.Pixmaps; + + diff --git a/spec/fltk-images-rgb-bmp.ads b/spec/fltk-images-rgb-bmp.ads new file mode 100644 index 0000000..f2bf103 --- /dev/null +++ b/spec/fltk-images-rgb-bmp.ads @@ -0,0 +1,38 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.RGB.BMP is + + + type BMP_Image is new RGB_Image with private; + + type BMP_Image_Reference (Data : not null access BMP_Image'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return BMP_Image; + + end Forge; + + +private + + + type BMP_Image is new RGB_Image with null record; + + overriding procedure Finalize + (This : in out BMP_Image); + + +end FLTK.Images.RGB.BMP; + + diff --git a/spec/fltk-images-rgb-jpeg.ads b/spec/fltk-images-rgb-jpeg.ads new file mode 100644 index 0000000..8bb21ba --- /dev/null +++ b/spec/fltk-images-rgb-jpeg.ads @@ -0,0 +1,43 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.RGB.JPEG is + + + type JPEG_Image is new RGB_Image with private; + + type JPEG_Image_Reference (Data : not null access JPEG_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return JPEG_Image; + + function Create + (Name : in String := ""; + Data : in Color_Component_Array) + return JPEG_Image; + + end Forge; + + +private + + + type JPEG_Image is new RGB_Image with null record; + + overriding procedure Finalize + (This : in out JPEG_Image); + + +end FLTK.Images.RGB.JPEG; + + diff --git a/spec/fltk-images-rgb-png.ads b/spec/fltk-images-rgb-png.ads new file mode 100644 index 0000000..dcfbd4f --- /dev/null +++ b/spec/fltk-images-rgb-png.ads @@ -0,0 +1,43 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.RGB.PNG is + + + type PNG_Image is new RGB_Image with private; + + type PNG_Image_Reference (Data : not null access PNG_Image'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return PNG_Image; + + function Create + (Name : in String := ""; + Data : in Color_Component_Array) + return PNG_Image; + + end Forge; + + +private + + + type PNG_Image is new RGB_Image with null record; + + overriding procedure Finalize + (This : in out PNG_Image); + + +end FLTK.Images.RGB.PNG; + + diff --git a/spec/fltk-images-rgb-pnm.ads b/spec/fltk-images-rgb-pnm.ads new file mode 100644 index 0000000..847b149 --- /dev/null +++ b/spec/fltk-images-rgb-pnm.ads @@ -0,0 +1,38 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.RGB.PNM is + + + type PNM_Image is new RGB_Image with private; + + type PNM_Image_Reference (Data : not null access PNM_Image'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String) + return PNM_Image; + + end Forge; + + +private + + + type PNM_Image is new RGB_Image with null record; + + overriding procedure Finalize + (This : in out PNM_Image); + + +end FLTK.Images.RGB.PNM; + + diff --git a/spec/fltk-images-rgb.ads b/spec/fltk-images-rgb.ads new file mode 100644 index 0000000..d893cec --- /dev/null +++ b/spec/fltk-images-rgb.ads @@ -0,0 +1,180 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images.Pixmaps; + + +package FLTK.Images.RGB is + + + type RGB_Image is new Image with private; + + type RGB_Image_Reference (Data : not null access RGB_Image'Class) is limited null record + with Implicit_Dereference => Data; + + type RGB_Image_Array is array (Positive range <>) of RGB_Image; + + + + + -- Static Settings -- + + function Get_Max_Size + return Size_Type; + + procedure Set_Max_Size + (Value : in Size_Type); + + + + + package Forge is + + -- Please note that input data should be some declared item + -- that lives at least as long as the resulting RGB_Image. + + function Create + (Data : in Color_Component_Array; + Width, Height : in Natural; + Depth : in Natural := 3; + Line_Size : in Natural := 0) + return RGB_Image + with Pre => (if Line_Size = 0 + then Data'Length >= Size_Type (Width) * Size_Type (Height) * Size_Type (Depth) + else Data'Length >= Size_Type (Line_Size) * Size_Type (Height)) + and Data'Length <= Get_Max_Size; + + function Create + (Data : in FLTK.Images.Pixmaps.Pixmap'Class; + Background : in Color := Background_Color) + return RGB_Image; + + end Forge; + + + + + -- Copying -- + + function Copy + (This : in RGB_Image; + Width, Height : in Natural) + return RGB_Image'Class; + + function Copy + (This : in RGB_Image) + return RGB_Image'Class; + + + + + -- Colors -- + + procedure Color_Average + (This : in out RGB_Image; + Col : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out RGB_Image); + + + + + -- Activity -- + + procedure Uncache + (This : in out RGB_Image); + + + + + -- Pixel Data -- + + function Data_Size + (This : in RGB_Image) + return Size_Type; + + function Get_Datum + (This : in RGB_Image; + Place : in Positive_Size) + return Color_Component + with Pre => Place <= This.Data_Size; + + procedure Set_Datum + (This : in out RGB_Image; + Place : in Positive_Size; + Value : in Color_Component) + with Pre => Place <= This.Data_Size; + + function Slice + (This : in RGB_Image; + Low : in Positive_Size; + High : in Size_Type) + return Color_Component_Array + with Pre => High <= This.Data_Size, + Post => Slice'Result'Length = Size_Type'Max (0, High - Low + 1); + + procedure Overwrite + (This : in out RGB_Image; + Place : in Positive_Size; + Values : in Color_Component_Array) + with Pre => Place + Values'Length - 1 <= This.Data_Size; + + function All_Data + (This : in RGB_Image) + return Color_Component_Array + with Post => All_Data'Result'Length = This.Data_Size; + + + + + -- Drawing -- + + procedure Draw + (This : in RGB_Image; + X, Y : in Integer); + + procedure Draw + (This : in RGB_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); + + +private + + + type RGB_Image is new Image with null record; + + overriding procedure Finalize + (This : in out RGB_Image); + + + pragma Inline (Get_Max_Size); + pragma Inline (Set_Max_Size); + + pragma Inline (Copy); + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + pragma Inline (Uncache); + + pragma Inline (Data_Size); + pragma Inline (Get_Datum); + pragma Inline (Set_Datum); + pragma Inline (Slice); + pragma Inline (Overwrite); + pragma Inline (All_Data); + + pragma Inline (Draw); + + +end FLTK.Images.RGB; + + diff --git a/spec/fltk-images-shared.ads b/spec/fltk-images-shared.ads new file mode 100644 index 0000000..c1bbdbd --- /dev/null +++ b/spec/fltk-images-shared.ads @@ -0,0 +1,146 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images.RGB; + + +package FLTK.Images.Shared is + + + type Shared_Image is new Image with private; + + type Shared_Image_Reference (Data : not null access Shared_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Filename : in String; + W, H : in Integer) + return Shared_Image; + + function Create + (From : in FLTK.Images.RGB.RGB_Image'Class) + return Shared_Image; + + function Find + (Name : in String; + W, H : in Integer := 0) + return Shared_Image; + + end Forge; + + + + + -- Copying -- + + function Copy + (This : in Shared_Image; + Width, Height : in Natural) + return Shared_Image'Class; + + function Copy + (This : in Shared_Image) + return Shared_Image'Class; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Shared_Image; + Col : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Shared_Image); + + + + + -- Activity -- + + function Number_Of_Images + return Natural; + + function Name + (This : in Shared_Image) + return String; + + function Original + (This : in Shared_Image) + return Boolean; + + function Reference_Count + (This : in Shared_Image) + return Natural; + + procedure Reload + (This : in out Shared_Image); + + procedure Uncache + (This : in out Shared_Image); + + + + + -- Drawing -- + + procedure Set_Scaling_Algorithm + (To : in Scaling_Kind); + + procedure Scale + (This : in out Shared_Image; + W, H : in Integer; + Proportional : in Boolean := True; + Can_Expand : in Boolean := False); + + procedure Draw + (This : in Shared_Image; + X, Y, W, H : in Integer; + CX, CY : in Integer := 0); + + procedure Draw + (This : in Shared_Image; + X, Y : in Integer); + + +private + + + type Shared_Image is new Image with null record; + + overriding procedure Finalize + (This : in out Shared_Image); + + + pragma Inline (Copy); + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + pragma Inline (Number_Of_Images); + pragma Inline (Name); + pragma Inline (Original); + pragma Inline (Reference_Count); + pragma Inline (Reload); + pragma Inline (Uncache); + + pragma Inline (Set_Scaling_Algorithm); + pragma Inline (Scale); + pragma Inline (Draw); + + +end FLTK.Images.Shared; + + diff --git a/spec/fltk-images-tiled.ads b/spec/fltk-images-tiled.ads new file mode 100644 index 0000000..a7470fc --- /dev/null +++ b/spec/fltk-images-tiled.ads @@ -0,0 +1,105 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images.Tiled is + + + type Tiled_Image is new Image with private; + + type Tiled_Image_Reference (Data : not null access Tiled_Image'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (From : in out Image'Class; + W, H : in Integer := 0) + return Tiled_Image; + + end Forge; + + + + + -- Copying -- + + function Copy + (This : in Tiled_Image; + Width, Height : in Natural) + return Tiled_Image'Class; + + function Copy + (This : in Tiled_Image) + return Tiled_Image'Class; + + + + + -- Miscellaneous -- + + procedure Inactive + (This : in out Tiled_Image); + + function Tile + (This : in out Tiled_Image) + return Image_Reference; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Tiled_Image; + Hue : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Tiled_Image); + + + + + -- Drawing -- + + procedure Draw + (This : in Tiled_Image; + X, Y : in Integer); + + procedure Draw + (This : in Tiled_Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer); + + +private + + + type Tiled_Image is new Image with record + Dummy : aliased Image; + end record; + + overriding procedure Finalize + (This : in out Tiled_Image); + + + pragma Inline (Copy); + + pragma Inline (Inactive); + pragma Inline (Tile); + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + pragma Inline (Draw); + + +end FLTK.Images.Tiled; + + diff --git a/spec/fltk-images.ads b/spec/fltk-images.ads new file mode 100644 index 0000000..6afb788 --- /dev/null +++ b/spec/fltk-images.ads @@ -0,0 +1,169 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Images is + + + type Image is new Wrapper with private; + + type Image_Reference (Data : not null access Image'Class) is limited null record + with Implicit_Dereference => Data; + + type Scaling_Kind is (Nearest, Bilinear); + + + No_Image_Error, File_Access_Error, Format_Error : exception; + + + + + package Forge is + + -- This creates an empty image with no data, so not that useful. + + function Create + (Width, Height, Depth : in Natural) + return Image; + + end Forge; + + + + + -- Copying -- + + function Get_Copy_Algorithm + return Scaling_Kind; + + procedure Set_Copy_Algorithm + (To : in Scaling_Kind); + + function Copy + (This : in Image; + Width, Height : in Natural) + return Image'Class; + + function Copy + (This : in Image) + return Image'Class; + + + + + -- Colors -- + + procedure Color_Average + (This : in out Image; + Col : in Color; + Amount : in Blend); + + procedure Desaturate + (This : in out Image); + + + + + -- Activity -- + + procedure Inactive + (This : in out Image); + + function Is_Empty + (This : in Image) + return Boolean; + + procedure Uncache + (This : in out Image); + + + + + -- Dimensions -- + + function Get_W + (This : in Image) + return Natural; + + function Get_H + (This : in Image) + return Natural; + + function Get_D + (This : in Image) + return Natural; + + function Get_Line_Size + (This : in Image) + return Natural; + + + + + -- Drawing -- + + procedure Draw + (This : in Image; + X, Y : in Integer); + + procedure Draw + (This : in Image; + X, Y, W, H : in Integer; + Clip_X, Clip_Y : in Integer := 0); + + procedure Draw_Empty + (This : in Image; + X, Y : in Integer); + + +private + + + type Image is new Wrapper with null record; + + overriding procedure Finalize + (This : in out Image); + + + procedure Raise_Fail_Errors + (This : in Image'Class); + + + function fl_image_data + (I : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_data, "fl_image_data"); + pragma Inline (fl_image_data); + + function fl_image_count + (I : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_image_count, "fl_image_count"); + pragma Inline (fl_image_count); + + + pragma Inline (Get_Copy_Algorithm); + pragma Inline (Set_Copy_Algorithm); + pragma Inline (Copy); + + pragma Inline (Color_Average); + pragma Inline (Desaturate); + + pragma Inline (Inactive); + pragma Inline (Is_Empty); + pragma Inline (Uncache); + + pragma Inline (Get_W); + pragma Inline (Get_H); + pragma Inline (Get_D); + pragma Inline (Get_Line_Size); + + pragma Inline (Draw); + pragma Inline (Draw_Empty); + + +end FLTK.Images; + + diff --git a/spec/fltk-labels.ads b/spec/fltk-labels.ads new file mode 100644 index 0000000..e9da5f1 --- /dev/null +++ b/spec/fltk-labels.ads @@ -0,0 +1,159 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images; + +private with + + Interfaces.C.Strings; + + +package FLTK.Labels is + + + type Label is new Wrapper with private; + + type Label_Reference (Data : not null access Label'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Value : in String; + Font : in Font_Kind := Helvetica; + Size : in Font_Size := Normal_Size; + Hue : in Color := Foreground_Color; + Kind : in Label_Kind := Normal_Label; + Place : in Alignment := Align_Center; + Active : access FLTK.Images.Image'Class := null; + Inactive : access FLTK.Images.Image'Class := null) + return Label; + + end Forge; + + + + + -- Attributes -- + + function Get_Value + (This : in Label) + return String; + + procedure Set_Value + (This : in out Label; + Text : in String); + + function Get_Font + (This : in Label) + return Font_Kind; + + procedure Set_Font + (This : in out Label; + Font : in Font_Kind); + + function Get_Size + (This : in Label) + return Font_Size; + + procedure Set_Size + (This : in out Label; + Size : in Font_Size); + + function Get_Color + (This : in Label) + return Color; + + procedure Set_Color + (This : in out Label; + Hue : in Color); + + function Get_Kind + (This : in Label) + return Label_Kind; + + procedure Set_Kind + (This : in out Label; + Kind : in Label_Kind); + + function Get_Alignment + (This : in Label) + return Alignment; + + procedure Set_Alignment + (This : in out Label; + Place : in Alignment); + + function Get_Active + (This : in Label) + return access FLTK.Images.Image'Class; + + procedure Set_Active + (This : in out Label; + Pic : access FLTK.Images.Image'Class); + + function Get_Inactive + (This : in Label) + return access FLTK.Images.Image'Class; + + procedure Set_Inactive + (This : in out Label; + Pic : access FLTK.Images.Image'Class); + + + + + -- Drawing -- + + procedure Draw + (This : in out Label; + X, Y, W, H : in Integer; + Place : in Alignment); + + procedure Measure + (This : in Label; + W, H : out Integer); + + +private + + + type Label is new Wrapper with record + My_Active : access FLTK.Images.Image'Class; + My_Inactive : access FLTK.Images.Image'Class; + My_Text : Interfaces.C.Strings.chars_ptr; + end record; + + overriding procedure Finalize + (This : in out Label); + + + pragma Inline (Get_Value); + pragma Inline (Get_Font); + pragma Inline (Set_Font); + pragma Inline (Get_Size); + pragma Inline (Set_Size); + pragma Inline (Get_Color); + pragma Inline (Set_Color); + pragma Inline (Get_Kind); + pragma Inline (Set_Kind); + pragma Inline (Get_Alignment); + pragma Inline (Set_Alignment); + pragma Inline (Get_Active); + pragma Inline (Get_Inactive); + + pragma Inline (Draw); + pragma Inline (Measure); + + +end FLTK.Labels; + + diff --git a/spec/fltk-menu_items.ads b/spec/fltk-menu_items.ads new file mode 100644 index 0000000..ced27ec --- /dev/null +++ b/spec/fltk-menu_items.ads @@ -0,0 +1,256 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images, + FLTK.Widgets; + + +package FLTK.Menu_Items is + + + type Menu_Item is new Wrapper with private; + + type Menu_Item_Reference (Data : not null access Menu_Item'Class) is limited null record + with Implicit_Dereference => Data; + + type Menu_Item_Array is array (Positive range <>) of Menu_Item; + + + + + package Forge is + + -- Usually you don't bother with this and just add items + -- to Menus directly using the Add/Insert subprograms in that package. + + function Create + (Text : in String; + Action : in FLTK.Widgets.Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Menu_Item; + + end Forge; + + + + + -- Callback -- + + function Get_Callback + (This : in Menu_Item) + return FLTK.Widgets.Widget_Callback; + + procedure Set_Callback + (This : in out Menu_Item; + Func : in FLTK.Widgets.Widget_Callback); + + procedure Do_Callback + (This : in out Menu_Item; + Widget : in out FLTK.Widgets.Widget'Class); + + + + + -- Settings -- + + function Has_Checkbox + (This : in Menu_Item) + return Boolean; + + function Is_Radio + (This : in Menu_Item) + return Boolean; + + function Is_Submenu + (This : in Menu_Item) + return Boolean; + + function Get_State + (This : in Menu_Item) + return Boolean; + + procedure Set_State + (This : in out Menu_Item; + To : in Boolean); + + procedure Set + (This : in out Menu_Item); + + procedure Clear + (This : in out Menu_Item); + + procedure Set_Only + (This : in out Menu_Item); + + + + + -- Label -- + + function Get_Label + (This : in Menu_Item) + return String; + + procedure Set_Label + (This : in out Menu_Item; + Text : in String); + + procedure Set_Label + (This : in out Menu_Item; + Kind : in Label_Kind; + Text : in String); + + function Get_Label_Color + (This : in Menu_Item) + return Color; + + procedure Set_Label_Color + (This : in out Menu_Item; + To : in Color); + + function Get_Label_Font + (This : in Menu_Item) + return Font_Kind; + + procedure Set_Label_Font + (This : in out Menu_Item; + To : in Font_Kind); + + function Get_Label_Size + (This : in Menu_Item) + return Font_Size; + + procedure Set_Label_Size + (This : in out Menu_Item; + To : in Font_Size); + + function Get_Label_Kind + (This : in Menu_Item) + return Label_Kind; + + procedure Set_Label_Kind + (This : in out Menu_Item; + To : in Label_Kind); + + + + + -- Shortcut and Flags -- + + function Get_Shortcut + (This : in Menu_Item) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Menu_Item; + To : in Key_Combo); + + function Get_Flags + (This : in Menu_Item) + return Menu_Flag; + + procedure Set_Flags + (This : in out Menu_Item; + To : in Menu_Flag); + + + + + -- Image -- + + function Get_Image + (This : in Menu_Item) + return access FLTK.Images.Image'Class; + + procedure Set_Image + (This : in out Menu_Item; + Pict : in out FLTK.Images.Image'Class); + + + + + -- Activity and Visibility -- + + procedure Activate + (This : in out Menu_Item); + + procedure Deactivate + (This : in out Menu_Item); + + procedure Show + (This : in out Menu_Item); + + procedure Hide + (This : in out Menu_Item); + + function Is_Active + (This : in Menu_Item) + return Boolean; + + function Is_Visible + (This : in Menu_Item) + return Boolean; + + function Is_Active_And_Visible + (This : in Menu_Item) + return Boolean; + + +private + + + type Menu_Item is new Wrapper with record + Current_Image : access FLTK.Images.Image'Class; + end record; + + overriding procedure Finalize + (This : in out Menu_Item); + + + pragma Inline (Get_Callback); + pragma Inline (Set_Callback); + pragma Inline (Do_Callback); + + pragma Inline (Has_Checkbox); + pragma Inline (Is_Radio); + pragma Inline (Get_State); + pragma Inline (Set_State); + pragma Inline (Set_Only); + + pragma Inline (Get_Label); + pragma Inline (Set_Label); + pragma Inline (Get_Label_Color); + pragma Inline (Set_Label_Color); + pragma Inline (Get_Label_Font); + pragma Inline (Set_Label_Font); + pragma Inline (Get_Label_Size); + pragma Inline (Set_Label_Size); + pragma Inline (Get_Label_Kind); + pragma Inline (Set_Label_Kind); + + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + pragma Inline (Get_Flags); + pragma Inline (Set_Flags); + + pragma Inline (Get_Image); + pragma Inline (Set_Image); + + pragma Inline (Activate); + pragma Inline (Deactivate); + pragma Inline (Show); + pragma Inline (Hide); + pragma Inline (Is_Active); + pragma Inline (Is_Visible); + pragma Inline (Is_Active_And_Visible); + + +end FLTK.Menu_Items; + + diff --git a/spec/fltk-screen.ads b/spec/fltk-screen.ads new file mode 100644 index 0000000..38db9aa --- /dev/null +++ b/spec/fltk-screen.ads @@ -0,0 +1,147 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Screen is + + + type Visual_Mode is (RGB, RGB_24bit, Double_Buffer, Double_RGB, Double_RGB_24bit); + + + + + -- Environment -- + + procedure Set_Display_String + (Value : in String); + + procedure Set_Visual_Mode + (Value : in Visual_Mode); + + function Set_Visual_Mode + (Value : in Visual_Mode) + return Boolean; + + + + + -- Basic Dimensions -- + + function Get_X + return Integer; + + function Get_Y + return Integer; + + function Get_W + return Integer; + + function Get_H + return Integer; + + + + + -- Pixel Density -- + + function Count + return Integer; + + -- Screen numbers in the range 1 .. Count + procedure DPI + (Horizontal, Vertical : out Float; + Screen_Number : in Integer := 1); + + + + + -- Position Lookup -- + + function Containing + (X, Y : in Integer) + return Integer; + + function Containing + (X, Y, W, H : in Integer) + return Integer; + + + + + -- Bounding Boxes -- + + procedure Work_Area + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer); + + procedure Work_Area + (X, Y, W, H : out Integer; + Screen_Num : in Integer); + + procedure Work_Area + (X, Y, W, H : out Integer); + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + Pos_X, Pos_Y : in Integer); + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + Screen_Num : in Integer); + + procedure Bounding_Rect + (X, Y, W, H : out Integer); + + procedure Bounding_Rect + (X, Y, W, H : out Integer; + PX, PY, PW, PH : in Integer); + + + + + -- Drawing -- + + function Is_Damaged + return Boolean; + + procedure Set_Damaged + (To : in Boolean); + + procedure Flush; + + procedure Redraw; + + +private + + + pragma Import (C, Flush, "fl_screen_flush"); + pragma Import (C, Redraw, "fl_screen_redraw"); + + + pragma Inline (Set_Display_String); + pragma Inline (Set_Visual_Mode); + + pragma Inline (Get_X); + pragma Inline (Get_Y); + pragma Inline (Get_W); + pragma Inline (Get_H); + + pragma Inline (Count); + pragma Inline (DPI); + + pragma Inline (Containing); + pragma Inline (Work_Area); + pragma Inline (Bounding_Rect); + + pragma Inline (Is_Damaged); + pragma Inline (Set_Damaged); + pragma Inline (Flush); + pragma Inline (Redraw); + + +end FLTK.Screen; + + diff --git a/spec/fltk-static.ads b/spec/fltk-static.ads new file mode 100644 index 0000000..4f71244 --- /dev/null +++ b/spec/fltk-static.ads @@ -0,0 +1,594 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Labels, + FLTK.Widgets.Groups.Windows; + +private with + + Ada.Finalization, + Ada.Unchecked_Conversion, + FLTK.Args_Marshal, + Interfaces.C.Strings; + + +package FLTK.Static is + + + -- Input is the argument index usable with Ada.Command_Line. + -- Output is how many arguments parsed starting from that index. + type Args_Handler is access function + (Index : in Positive) + return Natural; + + type Awake_Handler is access procedure; + + type Idle_Handler is access procedure; + + type Timeout_Handler is access procedure; + + + type Buffer_Kind is (Selection, Clipboard); + + type Clipboard_Notify_Handler is access procedure + (Kind : in Buffer_Kind); + + + type File_Descriptor is new Integer; + + type File_Mode is record + Read : Boolean := False; + Write : Boolean := False; + Except : Boolean := False; + end record; + + function "+" (Left, Right : in File_Mode) return File_Mode; + function "-" (Left, Right : in File_Mode) return File_Mode; + + Read_Mode : constant File_Mode; + Write_Mode : constant File_Mode; + Except_Mode : constant File_Mode; + + type File_Handler is access procedure + (FD : in File_Descriptor); + + + subtype Byte_Integer is Integer range 0 .. 255; + + type Box_Draw_Function is access procedure + (X, Y, W, H : in Integer; + Tone : in Color); + + + type Label_Draw_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + X, Y, W, H : in Integer; + Position : in Alignment); + + type Label_Measure_Function is access procedure + (Item : in FLTK.Labels.Label'Class; + W, H : out Integer); + + + type Option is + (Arrow_Focus, + Visible_Focus, + DND_Text, + Show_Tooltips, + FNFC_Uses_GTK); + + + -- According to docs this should be customisable, + -- but in C++ it is a constant pointer to constant. + Help_Message : constant String; + + + Argument_Error : exception; + + + + + -- Command Line Arguments -- + + function Parse_Arg + (Index : in Positive) + return Natural; + + procedure Parse_Args; + + -- Not task safe, but you won't need to call this more than once anyway. + procedure Parse_Args + (Count : out Natural; + Func : in Args_Handler := null); + + + + + -- Thread Notify -- + + -- Unsure if it is worth actually using this or if mixing tasks, pthreads, + -- and whatever other platforms use causes errors in some unexpected way. + -- Might be better to rely on FLTK.Check, Ada tasking, and Ada protected types. + -- You'll need appropriately declared protected objects to pass messages anyway. + + procedure Add_Awake_Handler + (Func : in Awake_Handler); + + function Get_Awake_Handler + return Awake_Handler; + + procedure Awake + (Func : in Awake_Handler); + + procedure Awake; + + procedure Lock; + + procedure Unlock; + + + + + -- Pre-Eventloop Callbacks -- + + procedure Add_Check + (Func : in not null Timeout_Handler); + + function Has_Check + (Func : in not null Timeout_Handler) + return Boolean; + + procedure Remove_Check + (Func : in not null Timeout_Handler); + + + + + -- Timer Callbacks -- + + procedure Add_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); + + function Has_Timeout + (Func : in not null Timeout_Handler) + return Boolean; + + procedure Remove_Timeout + (Func : in not null Timeout_Handler); + + procedure Repeat_Timeout + (Seconds : in Long_Float; + Func : in not null Timeout_Handler); + + + + + -- Clipboard Callbacks -- + + procedure Add_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler); + + procedure Remove_Clipboard_Notify + (Func : in not null Clipboard_Notify_Handler); + + + + + -- File Descriptor Waiting Callbacks -- + + procedure Add_File_Descriptor + (FD : in File_Descriptor; + Func : in not null File_Handler); + + procedure Add_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode; + Func : in not null File_Handler); + + procedure Remove_File_Descriptor + (FD : in File_Descriptor); + + procedure Remove_File_Descriptor + (FD : in File_Descriptor; + Mode : in File_Mode); + + + + + -- Idle Callbacks -- + + procedure Add_Idle + (Func : in not null Idle_Handler); + + function Has_Idle + (Func : in not null Idle_Handler) + return Boolean; + + procedure Remove_Idle + (Func : in not null Idle_Handler); + + + + + -- Custom Colors -- + + function Get_Color + (From : in Color) + return Color; + + procedure Get_Color + (From : in Color; + R, G, B : out Color_Component); + + procedure Set_Color + (Target, Source : in Color); + + procedure Set_Color + (Target : in Color; + R, G, B : in Color_Component); + + procedure Free_Color + (Value : in Color; + Overlay : in Boolean := False); + + function Get_Box_Color + (Tone : in Color) + return Color; + + procedure Set_Box_Color + (Tone : in Color); + + procedure Own_Colormap; + + procedure Set_Foreground + (R, G, B : in Color_Component); + + procedure Set_Background + (R, G, B : in Color_Component); + + procedure Set_Alt_Background + (R, G, B : in Color_Component); + + procedure System_Colors; + + + + + -- Custom Fonts -- + + function Font_Image + (Kind : in Font_Kind) + return String; + + function Font_Family_Image + (Kind : in Font_Kind) + return String; + + procedure Set_Font_Kind + (Target, Source : in Font_Kind); + + procedure Set_Font_Kind + (Target : in Font_Kind; + Source : in String); + + function Font_Sizes + (Kind : in Font_Kind) + return Font_Size_Array; + + procedure Setup_Fonts + (How_Many_Set_Up : out Natural); + + + + + -- Box_Kind Attributes -- + + function Get_Box_Height_Offset + (Kind : in Box_Kind) + return Integer; + + function Get_Box_Width_Offset + (Kind : in Box_Kind) + return Integer; + + function Get_Box_X_Offset + (Kind : in Box_Kind) + return Integer; + + function Get_Box_Y_Offset + (Kind : in Box_Kind) + return Integer; + + procedure Set_Box_Kind + (To, From : in Box_Kind); + + function Draw_Box_Active + return Boolean; + + function Get_Box_Draw_Function + (Kind : in Box_Kind) + return Box_Draw_Function; + + procedure Set_Box_Draw_Function + (Kind : in Box_Kind; + Func : in Box_Draw_Function; + Offset_X, Offset_Y : in Byte_Integer := 0; + Offset_W, Offset_H : in Byte_Integer := 0); + + + + + -- Label_Kind Attributes -- + + procedure Set_Label_Kind + (Target, Source : in Label_Kind); + + procedure Set_Label_Draw_Function + (Kind : in Label_Kind; + Draw_Func : in Label_Draw_Function; + Measure_Func : in Label_Measure_Function); + + + + + -- Clipboard / Selection -- + + procedure Copy + (Text : in String; + Dest : in Buffer_Kind); + + procedure Paste + (Receiver : in FLTK.Widgets.Widget'Class; + Source : in Buffer_Kind); + + procedure Selection + (Owner : in FLTK.Widgets.Widget'Class; + Text : in String); + + function Clipboard_Contains + (Kind : in String) + return Boolean; + + + + + -- Dragon Drop -- + + procedure Drag_Drop_Start; + + function Get_Drag_Drop_Text_Support + return Boolean; + + procedure Set_Drag_Drop_Text_Support + (To : in Boolean); + + + + + -- Input Methods -- + + procedure Enable_System_Input; + + procedure Disable_System_Input; + + + + + -- Windows -- + + procedure Default_Window_Close + (Item : in out FLTK.Widgets.Widget'Class); + + function Get_First_Window + return access FLTK.Widgets.Groups.Windows.Window'Class; + + procedure Set_First_Window + (To : in FLTK.Widgets.Groups.Windows.Window'Class); + + function Get_Next_Window + (From : in FLTK.Widgets.Groups.Windows.Window'Class) + return access FLTK.Widgets.Groups.Windows.Window'Class; + + function Get_Top_Modal + return access FLTK.Widgets.Groups.Windows.Window'Class; + + + + + -- Queue -- + + function Read_Queue + return access FLTK.Widgets.Widget'Class; + + + + + -- Schemes -- + + function Get_Scheme + return String; + + procedure Set_Scheme + (To : in String); + + function Is_Scheme + (Scheme : in String) + return Boolean; + + procedure Reload_Scheme; + + + + + -- Library Options -- + + function Get_Option + (Opt : in Option) + return Boolean; + + procedure Set_Option + (Opt : in Option; + To : in Boolean); + + + + + -- Scrollbars -- + + function Get_Default_Scrollbar_Size + return Natural; + + procedure Set_Default_Scrollbar_Size + (To : in Natural); + + +private + + + The_Argv : Interfaces.C.Strings.chars_ptr_array := FLTK.Args_Marshal.Create_Argv; + + + for File_Mode use record + Read at 0 range 0 .. 0; + -- bit position 1 is unused + Write at 0 range 2 .. 2; + Except at 0 range 3 .. 3; + end record; + + for File_Mode'Size use Interfaces.C.int'Size; + + Read_Mode : constant File_Mode := (Read => True, others => False); + Write_Mode : constant File_Mode := (Write => True, others => False); + Except_Mode : constant File_Mode := (Except => True, others => False); + + function FMode_To_Cint is new + Ada.Unchecked_Conversion (File_Mode, Interfaces.C.int); + + + help_usage_string_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, help_usage_string_ptr, "fl_help_usage_string_ptr"); + + Help_Message : constant String := Interfaces.C.Strings.Value (help_usage_string_ptr); + + + Font_Overrides : array (Font_Kind) of Interfaces.C.Strings.chars_ptr; + + + pragma Import (C, Lock, "fl_static_lock"); + pragma Import (C, Unlock, "fl_static_unlock"); + + pragma Import (C, Own_Colormap, "fl_static_own_colormap"); + pragma Import (C, System_Colors, "fl_static_get_system_colors"); + + pragma Import (C, Enable_System_Input, "fl_static_enable_im"); + pragma Import (C, Disable_System_Input, "fl_static_disable_im"); + + pragma Import (C, Reload_Scheme, "fl_static_reload_scheme"); + + + pragma Inline (Parse_Arg); + + pragma Inline (Add_Awake_Handler); + pragma Inline (Get_Awake_Handler); + pragma Inline (Awake); + pragma Inline (Lock); + pragma Inline (Unlock); + + pragma Inline (Add_Check); + pragma Inline (Has_Check); + pragma Inline (Remove_Check); + + pragma Inline (Add_Timeout); + pragma Inline (Has_Timeout); + pragma Inline (Remove_Timeout); + pragma Inline (Repeat_Timeout); + + pragma Inline (Add_Clipboard_Notify); + pragma Inline (Remove_Clipboard_Notify); + + pragma Inline (Add_File_Descriptor); + pragma Inline (Remove_File_Descriptor); + + pragma Inline (Add_Idle); + pragma Inline (Has_Idle); + pragma Inline (Remove_Idle); + + pragma Inline (Get_Color); + pragma Inline (Set_Color); + pragma Inline (Free_Color); + pragma Inline (Get_Box_Color); + pragma Inline (Set_Box_Color); + pragma Inline (Own_Colormap); + pragma Inline (Set_Foreground); + pragma Inline (Set_Background); + pragma Inline (Set_Alt_Background); + pragma Inline (System_Colors); + + pragma Inline (Font_Image); + pragma Inline (Font_Family_Image); + pragma Inline (Set_Font_Kind); + pragma Inline (Font_Sizes); + pragma Inline (Setup_Fonts); + + pragma Inline (Get_Box_Height_Offset); + pragma Inline (Get_Box_Width_Offset); + pragma Inline (Get_Box_X_Offset); + pragma Inline (Get_Box_Y_Offset); + pragma Inline (Set_Box_Kind); + pragma Inline (Draw_Box_Active); + pragma Inline (Get_Box_Draw_Function); + pragma Inline (Set_Box_Draw_Function); + + pragma Inline (Set_Label_Kind); + pragma Inline (Set_Label_Draw_Function); + + pragma Inline (Copy); + pragma Inline (Paste); + pragma Inline (Selection); + pragma Inline (Clipboard_Contains); + + pragma Inline (Drag_Drop_Start); + pragma Inline (Get_Drag_Drop_Text_Support); + pragma Inline (Set_Drag_Drop_Text_Support); + + pragma Inline (Enable_System_Input); + pragma Inline (Disable_System_Input); + + pragma Inline (Default_Window_Close); + pragma Inline (Get_First_Window); + pragma Inline (Set_First_Window); + pragma Inline (Get_Next_Window); + pragma Inline (Get_Top_Modal); + + pragma Inline (Read_Queue); + + pragma Inline (Get_Scheme); + pragma Inline (Set_Scheme); + pragma Inline (Is_Scheme); + pragma Inline (Reload_Scheme); + + pragma Inline (Get_Option); + pragma Inline (Set_Option); + + pragma Inline (Get_Default_Scrollbar_Size); + pragma Inline (Set_Default_Scrollbar_Size); + + + -- Needed to dealloc the argv array and deregister the clipboard notify handler + type FLTK_Static_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out FLTK_Static_Final_Controller); + + Cleanup : FLTK_Static_Final_Controller; + + +end FLTK.Static; + + diff --git a/spec/fltk-text_buffers.ads b/spec/fltk-text_buffers.ads new file mode 100644 index 0000000..9430c57 --- /dev/null +++ b/spec/fltk-text_buffers.ads @@ -0,0 +1,493 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +private with + + Ada.Containers.Vectors, + System.Address_To_Access_Conversions, + Interfaces.C.Strings; + + +package FLTK.Text_Buffers is + + + type Text_Buffer is new Wrapper with private; + + type Text_Buffer_Reference (Data : access Text_Buffer'Class) is limited null record + with Implicit_Dereference => Data; + + subtype Position is Natural; + + type Modification is (Insert, Restyle, Delete, None); + + type Modify_Callback is access procedure + (Action : in Modification; + Place : in Position; + Length : in Natural; + Deleted_Text : in String); + + type Predelete_Callback is access procedure + (Place : in Position; + Length : in Natural); + + + + + package Forge is + + function Create + (Requested_Size : in Natural := 0; + Preferred_Gap_Size : in Natural := 1024) + return Text_Buffer; + + end Forge; + + + + + -- Callbacks -- + + procedure Add_Modify_Callback + (This : in out Text_Buffer; + Func : in Modify_Callback); + + procedure Add_Predelete_Callback + (This : in out Text_Buffer; + Func : in Predelete_Callback); + + procedure Remove_Modify_Callback + (This : in out Text_Buffer; + Func : in Modify_Callback); + + procedure Remove_Predelete_Callback + (This : in out Text_Buffer; + Func : in Predelete_Callback); + + procedure Call_Modify_Callbacks + (This : in out Text_Buffer); + + procedure Call_Predelete_Callbacks + (This : in out Text_Buffer); + + procedure Enable_Callbacks + (This : in out Text_Buffer); + + procedure Disable_Callbacks + (This : in out Text_Buffer); + + + + + -- Files -- + + procedure Load_File + (This : in out Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024); + + procedure Append_File + (This : in out Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024); + + procedure Insert_File + (This : in out Text_Buffer; + Name : in String; + Place : in Position; + Buffer : in Natural := 128 * 1024); + + procedure Output_File + (This : in Text_Buffer; + Name : in String; + Start, Finish : in Position; + Buffer : in Natural := 128 * 1024); + + procedure Save_File + (This : in Text_Buffer; + Name : in String; + Buffer : in Natural := 128 * 1024); + + + + + -- Modification -- + + procedure Insert_Text + (This : in out Text_Buffer; + Place : in Position; + Text : in String); + + procedure Append_Text + (This : in out Text_Buffer; + Text : in String); + + procedure Replace_Text + (This : in out Text_Buffer; + Start, Finish : in Position; + Text : in String); + + procedure Remove_Text + (This : in out Text_Buffer; + Start, Finish : in Position); + + function Get_Entire_Text + (This : in Text_Buffer) + return String; + + procedure Set_Entire_Text + (This : in out Text_Buffer; + Text : in String); + + function Byte_At + (This : in Text_Buffer; + Place : in Position) + return Character; + + function Character_At + (This : in Text_Buffer; + Place : in Position) + return Character; + + function Text_At + (This : in Text_Buffer; + Start, Finish : in Position) + return String; + + function Next_Char + (This : in Text_Buffer; + Place : in Position) + return Character; + + function Prev_Char + (This : in Text_Buffer; + Place : in Position) + return Character; + + + + + -- Measurement -- + + function Count_Displayed_Characters + (This : in Text_Buffer; + Start, Finish : in Position) + return Integer; + + function Count_Lines + (This : in Text_Buffer; + Start, Finish : in Position) + return Integer; + + function Length + (This : in Text_Buffer) + return Natural; + + function Get_Tab_Width + (This : in Text_Buffer) + return Natural; + + procedure Set_Tab_Width + (This : in out Text_Buffer; + To : in Natural); + + + + + -- Selection -- + + function Get_Selection + (This : in Text_Buffer; + Start, Finish : out Position) + return Boolean; + + function Get_Secondary_Selection + (This : in Text_Buffer; + Start, Finish : out Position) + return Boolean; + + procedure Set_Selection + (This : in out Text_Buffer; + Start, Finish : in Position); + + procedure Set_Secondary_Selection + (This : in out Text_Buffer; + Start, Finish : in Position); + + function Has_Selection + (This : in Text_Buffer) + return Boolean; + + function Has_Secondary_Selection + (This : in Text_Buffer) + return Boolean; + + function Selection_Text + (This : in Text_Buffer) + return String; + + function Secondary_Selection_Text + (This : in Text_Buffer) + return String; + + procedure Replace_Selection + (This : in out Text_Buffer; + Text : in String); + + procedure Replace_Secondary_Selection + (This : in out Text_Buffer; + Text : in String); + + procedure Remove_Selection + (This : in out Text_Buffer); + + procedure Remove_Secondary_Selection + (This : in out Text_Buffer); + + procedure Unselect + (This : in out Text_Buffer); + + procedure Secondary_Unselect + (This : in out Text_Buffer); + + + + + -- Highlighting -- + + procedure Get_Highlight + (This : in Text_Buffer; + Start, Finish : out Position); + + procedure Set_Highlight + (This : in out Text_Buffer; + Start, Finish : in Position); + + function Get_Highlighted_Text + (This : in Text_Buffer) + return String; + + procedure Unhighlight + (This : in out Text_Buffer); + + + + + -- Search -- + + function Findchar_Forward + (This : in Text_Buffer; + Start_At : in Position; + Item : in Character; + Found_At : out Position) + return Boolean; + + function Findchar_Backward + (This : in Text_Buffer; + Start_At : in Position; + Item : in Character; + Found_At : out Position) + return Boolean; + + function Search_Forward + (This : in Text_Buffer; + Start_At : in Position; + Item : in String; + Found_At : out Position; + Match_Case : in Boolean := False) + return Boolean; + + function Search_Backward + (This : in Text_Buffer; + Start_At : in Position; + Item : in String; + Found_At : out Position; + Match_Case : in Boolean := False) + return Boolean; + + + + + -- Navigation -- + + function Word_Start + (This : in Text_Buffer; + Place : in Position) + return Position; + + function Word_End + (This : in Text_Buffer; + Place : in Position) + return Position; + + function Line_Start + (This : in Text_Buffer; + Place : in Position) + return Position; + + function Line_End + (This : in Text_Buffer; + Place : in Position) + return Position; + + function Line_Text + (This : in Text_Buffer; + Place : in Position) + return String; + + -- only takes into account newline characters, not word wrap + function Skip_Lines + (This : in out Text_Buffer; + Start : in Position; + Lines : in Natural) + return Position; + + -- only takes into account newline characters, not word wrap + function Rewind_Lines + (This : in out Text_Buffer; + Start : in Position; + Lines : in Natural) + return Position; + + function Skip_Displayed_Characters + (This : in Text_Buffer; + Start : in Position; + Chars : in Natural) + return Position; + + + + + -- Miscellaneous -- + + procedure Can_Undo + (This : in out Text_Buffer; + Flag : in Boolean); + + procedure Copy + (This : in out Text_Buffer; + From : in Text_Buffer; + Start, Finish : in Position; + Insert_Pos : in Position); + + function UTF8_Align + (This : in Text_Buffer; + Place : in Position) + return Position; + + +private + + + package Modify_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Modify_Callback); + package Predelete_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Predelete_Callback); + + + type Text_Buffer is new Wrapper with + record + CB_Active : Boolean := True; + Modify_CBs : Modify_Vectors.Vector; + Predelete_CBs : Predelete_Vectors.Vector; + High_From, High_To : Natural := 0; + end record; + + overriding procedure Finalize + (This : in out Text_Buffer); + + + procedure Modify_Callback_Hook + (Pos, Inserted, Deleted, Restyled : in Interfaces.C.int; + Text : in Interfaces.C.Strings.chars_ptr; + UD : in Storage.Integer_Address); + pragma Convention (C, Modify_Callback_Hook); + + procedure Predelete_Callback_Hook + (Pos, Deleted : in Interfaces.C.int; + UD : in Storage.Integer_Address); + pragma Convention (C, Predelete_Callback_Hook); + + + package Text_Buffer_Convert is new System.Address_To_Access_Conversions (Text_Buffer); + + + pragma Inline (Add_Modify_Callback); + pragma Inline (Add_Predelete_Callback); + pragma Inline (Remove_Modify_Callback); + pragma Inline (Remove_Predelete_Callback); + pragma Inline (Call_Modify_Callbacks); + pragma Inline (Call_Predelete_Callbacks); + pragma Inline (Enable_Callbacks); + pragma Inline (Disable_Callbacks); + + pragma Inline (Load_File); + pragma Inline (Append_File); + pragma Inline (Insert_File); + pragma Inline (Output_File); + pragma Inline (Save_File); + + pragma Inline (Insert_Text); + pragma Inline (Append_Text); + pragma Inline (Replace_Text); + pragma Inline (Remove_Text); + pragma Inline (Get_Entire_Text); + pragma Inline (Set_Entire_Text); + pragma Inline (Byte_At); + pragma Inline (Character_At); + pragma Inline (Text_At); + pragma Inline (Next_Char); + pragma Inline (Prev_Char); + + pragma Inline (Count_Displayed_Characters); + pragma Inline (Count_Lines); + pragma Inline (Length); + pragma Inline (Get_Tab_Width); + pragma Inline (Set_Tab_Width); + + pragma Inline (Get_Selection); + pragma Inline (Get_Secondary_Selection); + pragma Inline (Set_Selection); + pragma Inline (Set_Secondary_Selection); + pragma Inline (Has_Selection); + pragma Inline (Has_Secondary_Selection); + pragma Inline (Selection_Text); + pragma Inline (Secondary_Selection_Text); + pragma Inline (Replace_Selection); + pragma Inline (Replace_Secondary_Selection); + pragma Inline (Remove_Selection); + pragma Inline (Remove_Secondary_Selection); + pragma Inline (Unselect); + pragma Inline (Secondary_Unselect); + + pragma Inline (Get_Highlight); + pragma Inline (Set_Highlight); + pragma Inline (Get_Highlighted_Text); + pragma Inline (Unhighlight); + + pragma Inline (Findchar_Forward); + pragma Inline (Findchar_Backward); + pragma Inline (Search_Forward); + pragma Inline (Search_Backward); + + pragma Inline (Word_Start); + pragma Inline (Word_End); + pragma Inline (Line_Start); + pragma Inline (Line_End); + pragma Inline (Line_Text); + pragma Inline (Skip_Lines); + pragma Inline (Rewind_Lines); + pragma Inline (Skip_Displayed_Characters); + + pragma Inline (Can_Undo); + pragma Inline (Copy); + pragma Inline (UTF8_Align); + + +end FLTK.Text_Buffers; + + diff --git a/spec/fltk-tooltips.ads b/spec/fltk-tooltips.ads new file mode 100644 index 0000000..46a50d5 --- /dev/null +++ b/spec/fltk-tooltips.ads @@ -0,0 +1,140 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets; + + +package FLTK.Tooltips is + + + -- Activity -- + + function Get_Target + return access FLTK.Widgets.Widget'Class; + + procedure Set_Target + (To : in FLTK.Widgets.Widget'Class); + + function Is_Enabled + return Boolean; + + procedure Set_Enabled + (To : in Boolean := True); + + procedure Disable; + + procedure Enter_Area + (Item : in FLTK.Widgets.Widget'Class; + X, Y, W, H : in Integer; + Tip : in String); + + + + + -- Delay -- + + function Get_Delay + return Float; + + procedure Set_Delay + (To : in Float); + + function Get_Hover_Delay + return Float; + + procedure Set_Hover_Delay + (To : in Float); + + + + + -- Color, Margins, Wrap -- + + function Get_Background_Color + return Color; + + procedure Set_Background_Color + (To : in Color); + + function Get_Margin_Height + return Natural; + + procedure Set_Margin_Height + (To : in Natural); + + function Get_Margin_Width + return Natural; + + procedure Set_Margin_Width + (To : in Natural); + + function Get_Wrap_Width + return Natural; + + procedure Set_Wrap_Width + (To : in Natural); + + + + + -- Text Settings -- + + function Get_Text_Color + return Color; + + procedure Set_Text_Color + (To : in Color); + + function Get_Text_Font + return Font_Kind; + + procedure Set_Text_Font + (To : in Font_Kind); + + function Get_Text_Size + return Font_Size; + + procedure Set_Text_Size + (To : in Font_Size); + + +private + + + pragma Inline (Get_Target); + pragma Inline (Set_Target); + pragma Inline (Is_Enabled); + pragma Inline (Set_Enabled); + pragma Inline (Disable); + pragma Inline (Enter_Area); + + pragma Inline (Get_Delay); + pragma Inline (Set_Delay); + pragma Inline (Get_Hover_Delay); + pragma Inline (Set_Hover_Delay); + + pragma Inline (Get_Background_Color); + pragma Inline (Set_Background_Color); + pragma Inline (Get_Margin_Height); + pragma Inline (Set_Margin_Height); + pragma Inline (Get_Margin_Width); + pragma Inline (Set_Margin_Width); + pragma Inline (Get_Wrap_Width); + pragma Inline (Set_Wrap_Width); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + +end FLTK.Tooltips; + + diff --git a/spec/fltk-widgets-boxes.ads b/spec/fltk-widgets-boxes.ads new file mode 100644 index 0000000..d9674e5 --- /dev/null +++ b/spec/fltk-widgets-boxes.ads @@ -0,0 +1,93 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Boxes is + + + type Box is new Widget with private; + + type Box_Reference (Data : not null access Box'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Box; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Box; + + function Create + (Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Box; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Box; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Box); + + function Handle + (This : in out Box; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Box is new Widget with null record; + + overriding procedure Initialize + (This : in out Box); + + overriding procedure Finalize + (This : in out Box); + + procedure Extra_Init + (This : in out Box; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Box) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Boxes; + + diff --git a/spec/fltk-widgets-buttons-enter.ads b/spec/fltk-widgets-buttons-enter.ads new file mode 100644 index 0000000..896df8d --- /dev/null +++ b/spec/fltk-widgets-buttons-enter.ads @@ -0,0 +1,83 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Return Buttons, but return is a reserved word, so they're Enter Buttons instead + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Enter is + + + type Enter_Button is new Button with private; + + type Enter_Button_Reference (Data : not null access Enter_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Enter_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Enter_Button; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Enter_Button); + + function Handle + (This : in out Enter_Button; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Enter_Button is new Button with null record; + + overriding procedure Initialize + (This : in out Enter_Button); + + overriding procedure Finalize + (This : in out Enter_Button); + + procedure Extra_Init + (This : in out Enter_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Enter_Button) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Buttons.Enter; + + diff --git a/spec/fltk-widgets-buttons-light-check.ads b/spec/fltk-widgets-buttons-light-check.ads new file mode 100644 index 0000000..b6f353b --- /dev/null +++ b/spec/fltk-widgets-buttons-light-check.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Light.Check is + + + type Check_Button is new Light_Button with private; + + type Check_Button_Reference (Data : not null access Check_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Check_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Check_Button; + + end Forge; + + +private + + + type Check_Button is new Light_Button with null record; + + overriding procedure Initialize + (This : in out Check_Button); + + overriding procedure Finalize + (This : in out Check_Button); + + procedure Extra_Init + (This : in out Check_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Check_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Light.Check; + + diff --git a/spec/fltk-widgets-buttons-light-radio.ads b/spec/fltk-widgets-buttons-light-radio.ads new file mode 100644 index 0000000..02c16e9 --- /dev/null +++ b/spec/fltk-widgets-buttons-light-radio.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Light.Radio is + + + type Radio_Light_Button is new Light_Button with private; + + type Radio_Light_Button_Reference (Data : not null access Radio_Light_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Light_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Light_Button; + + end Forge; + + +private + + + type Radio_Light_Button is new Light_Button with null record; + + overriding procedure Initialize + (This : in out Radio_Light_Button); + + overriding procedure Finalize + (This : in out Radio_Light_Button); + + procedure Extra_Init + (This : in out Radio_Light_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Radio_Light_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Light.Radio; + + diff --git a/spec/fltk-widgets-buttons-light-round-radio.ads b/spec/fltk-widgets-buttons-light-round-radio.ads new file mode 100644 index 0000000..34f0c1b --- /dev/null +++ b/spec/fltk-widgets-buttons-light-round-radio.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Light.Round.Radio is + + + type Radio_Round_Button is new Round_Button with private; + + type Radio_Round_Button_Reference (Data : not null access Radio_Round_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Round_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Round_Button; + + end Forge; + + +private + + + type Radio_Round_Button is new Round_Button with null record; + + overriding procedure Initialize + (This : in out Radio_Round_Button); + + overriding procedure Finalize + (This : in out Radio_Round_Button); + + procedure Extra_Init + (This : in out Radio_Round_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Radio_Round_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Light.Round.Radio; + + diff --git a/spec/fltk-widgets-buttons-light-round.ads b/spec/fltk-widgets-buttons-light-round.ads new file mode 100644 index 0000000..6e07607 --- /dev/null +++ b/spec/fltk-widgets-buttons-light-round.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Light.Round is + + + type Round_Button is new Light_Button with private; + + type Round_Button_Reference (Data : not null access Round_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Round_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Round_Button; + + end Forge; + + +private + + + type Round_Button is new Light_Button with null record; + + overriding procedure Initialize + (This : in out Round_Button); + + overriding procedure Finalize + (This : in out Round_Button); + + procedure Extra_Init + (This : in out Round_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Round_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Light.Round; + + diff --git a/spec/fltk-widgets-buttons-light.ads b/spec/fltk-widgets-buttons-light.ads new file mode 100644 index 0000000..c4761a8 --- /dev/null +++ b/spec/fltk-widgets-buttons-light.ads @@ -0,0 +1,80 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Light is + + + type Light_Button is new Button with private; + + type Light_Button_Reference (Data : not null access Light_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Light_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Light_Button; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Light_Button); + + function Handle + (This : in out Light_Button; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Light_Button is new Button with null record; + + overriding procedure Initialize + (This : in out Light_Button); + + overriding procedure Finalize + (This : in out Light_Button); + + procedure Extra_Init + (This : in out Light_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Light_Button) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Buttons.Light; + + diff --git a/spec/fltk-widgets-buttons-radio.ads b/spec/fltk-widgets-buttons-radio.ads new file mode 100644 index 0000000..3aadcac --- /dev/null +++ b/spec/fltk-widgets-buttons-radio.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Radio is + + + type Radio_Button is new Button with private; + + type Radio_Button_Reference (Data : not null access Radio_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Radio_Button; + + end Forge; + + +private + + + type Radio_Button is new Button with null record; + + overriding procedure Initialize + (This : in out Radio_Button); + + overriding procedure Finalize + (This : in out Radio_Button); + + procedure Extra_Init + (This : in out Radio_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Radio_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Radio; + + diff --git a/spec/fltk-widgets-buttons-repeat.ads b/spec/fltk-widgets-buttons-repeat.ads new file mode 100644 index 0000000..451553a --- /dev/null +++ b/spec/fltk-widgets-buttons-repeat.ads @@ -0,0 +1,86 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Repeat is + + + type Repeat_Button is new Button with private; + + type Repeat_Button_Reference (Data : not null access Repeat_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Repeat_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Repeat_Button; + + end Forge; + + + + + -- Activity -- + + procedure Deactivate + (This : in out Repeat_Button); + + + + + -- Events -- + + function Handle + (This : in out Repeat_Button; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Repeat_Button is new Button with null record; + + overriding procedure Initialize + (This : in out Repeat_Button); + + overriding procedure Finalize + (This : in out Repeat_Button); + + procedure Extra_Init + (This : in out Repeat_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Repeat_Button) + with Inline; + + + pragma Inline (Deactivate); + + pragma Inline (Handle); + + +end FLTK.Widgets.Buttons.Repeat; + + diff --git a/spec/fltk-widgets-buttons-toggle.ads b/spec/fltk-widgets-buttons-toggle.ads new file mode 100644 index 0000000..b9c974b --- /dev/null +++ b/spec/fltk-widgets-buttons-toggle.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons.Toggle is + + + type Toggle_Button is new Button with private; + + type Toggle_Button_Reference (Data : not null access Toggle_Button'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Toggle_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Toggle_Button; + + end Forge; + + +private + + + type Toggle_Button is new Button with null record; + + overriding procedure Initialize + (This : in out Toggle_Button); + + overriding procedure Finalize + (This : in out Toggle_Button); + + procedure Extra_Init + (This : in out Toggle_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Toggle_Button) + with Inline; + + +end FLTK.Widgets.Buttons.Toggle; + + diff --git a/spec/fltk-widgets-buttons.ads b/spec/fltk-widgets-buttons.ads new file mode 100644 index 0000000..bff7c81 --- /dev/null +++ b/spec/fltk-widgets-buttons.ads @@ -0,0 +1,143 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Buttons is + + + type Button is new Widget with private; + + type Button_Reference (Data : not null access Button'Class) is limited null record + with Implicit_Dereference => Data; + + type State is (Off, On); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Button; + + end Forge; + + + + + -- State -- + + function Is_On + (This : in Button) + return Boolean; + + function Get_State + (This : in Button) + return State; + + procedure Set_State + (This : in out Button; + St : in State); + + procedure Set_Only + (This : in out Button); + + + + + -- Settings -- + + function Get_Down_Box + (This : in Button) + return Box_Kind; + + procedure Set_Down_Box + (This : in out Button; + To : in Box_Kind); + + function Get_Shortcut + (This : in Button) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Button; + Key : in Key_Combo); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Button); + + function Handle + (This : in out Button; + Event : in Event_Kind) + return Event_Outcome; + + + + + -- Miscellaneous -- + + procedure Simulate_Key_Action + (This : in out Button); + + +private + + + type Button is new Widget with null record; + + overriding procedure Initialize + (This : in out Button); + + overriding procedure Finalize + (This : in out Button); + + procedure Extra_Init + (This : in out Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Button) + with Inline; + + + pragma Inline (Is_On); + pragma Inline (Get_State); + pragma Inline (Set_State); + pragma Inline (Set_Only); + + pragma Inline (Get_Down_Box); + pragma Inline (Set_Down_Box); + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + + pragma Inline (Draw); + pragma Inline (Handle); + + pragma Inline (Simulate_Key_Action); + + +end FLTK.Widgets.Buttons; + + diff --git a/spec/fltk-widgets-charts.ads b/spec/fltk-widgets-charts.ads new file mode 100644 index 0000000..7df4df1 --- /dev/null +++ b/spec/fltk-widgets-charts.ads @@ -0,0 +1,195 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Charts is + + + type Chart is new Widget with private; + + type Chart_Reference (Data : not null access Chart'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Chart; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Chart; + + end Forge; + + + + + -- Data -- + + procedure Add + (This : in out Chart; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color); + + procedure Insert + (This : in out Chart; + Position : in Natural; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color); + + procedure Replace + (This : in out Chart; + Position : in Natural; + Data_Value : in Long_Float; + Data_Label : in String := ""; + Data_Color : in Color := Foreground_Color); + + procedure Clear + (This : in out Chart); + + + + + -- Settings -- + + function Will_Autosize + (This : in Chart) + return Boolean; + + procedure Set_Autosize + (This : in out Chart; + To : in Boolean); + + procedure Get_Bounds + (This : in Chart; + Lower, Upper : out Long_Float); + + procedure Set_Bounds + (This : in out Chart; + Lower, Upper : in Long_Float); + + function Get_Maximum_Size + (This : in Chart) + return Natural; + + procedure Set_Maximum_Size + (This : in out Chart; + To : in Natural); + + function Get_Size + (This : in Chart) + return Natural; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Chart) + return Color; + + procedure Set_Text_Color + (This : in out Chart; + To : in Color); + + function Get_Text_Font + (This : in Chart) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Chart; + To : in Font_Kind); + + function Get_Text_Size + (This : in Chart) + return Font_Size; + + procedure Set_Text_Size + (This : in out Chart; + To : in Font_Size); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Chart; + W, H : in Integer); + + + + + -- Drawing -- + + procedure Draw + (This : in out Chart); + + +private + + + type Chart is new Widget with null record; + + overriding procedure Initialize + (This : in out Chart); + + overriding procedure Finalize + (This : in out Chart); + + procedure Extra_Init + (This : in out Chart; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Chart) + with Inline; + + + pragma Inline (Add); + pragma Inline (Insert); + pragma Inline (Replace); + pragma Inline (Clear); + + pragma Inline (Will_Autosize); + pragma Inline (Set_Autosize); + pragma Inline (Get_Bounds); + pragma Inline (Set_Bounds); + pragma Inline (Get_Maximum_Size); + pragma Inline (Set_Maximum_Size); + pragma Inline (Get_Size); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Resize); + + pragma Inline (Draw); + + +end FLTK.Widgets.Charts; + + diff --git a/spec/fltk-widgets-clocks-updated-round.ads b/spec/fltk-widgets-clocks-updated-round.ads new file mode 100644 index 0000000..d679b0c --- /dev/null +++ b/spec/fltk-widgets-clocks-updated-round.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Clocks.Updated.Round is + + + type Round_Clock is new Updated_Clock with private; + + type Round_Clock_Reference (Data : not null access Round_Clock'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Round_Clock; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Round_Clock; + + end Forge; + + +private + + + type Round_Clock is new Updated_Clock with null record; + + overriding procedure Initialize + (This : in out Round_Clock); + + overriding procedure Finalize + (This : in out Round_Clock); + + procedure Extra_Init + (This : in out Round_Clock; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Round_Clock) + with Inline; + + +end FLTK.Widgets.Clocks.Updated.Round; + + diff --git a/spec/fltk-widgets-clocks-updated.ads b/spec/fltk-widgets-clocks-updated.ads new file mode 100644 index 0000000..b3389df --- /dev/null +++ b/spec/fltk-widgets-clocks-updated.ads @@ -0,0 +1,89 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Clocks.Updated is + + + type Updated_Clock is new Clock with private; + + type Updated_Clock_Reference (Data : not null access Updated_Clock'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock; + + function Create + (Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Updated_Clock; + + end Forge; + + + + + -- Events -- + + function Handle + (This : in out Updated_Clock; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Updated_Clock is new Clock with null record; + + overriding procedure Initialize + (This : in out Updated_Clock); + + overriding procedure Finalize + (This : in out Updated_Clock); + + procedure Extra_Init + (This : in out Updated_Clock; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Updated_Clock) + with Inline; + + + pragma Inline (Handle); + + +end FLTK.Widgets.Clocks.Updated; + + diff --git a/spec/fltk-widgets-clocks.ads b/spec/fltk-widgets-clocks.ads new file mode 100644 index 0000000..c729262 --- /dev/null +++ b/spec/fltk-widgets-clocks.ads @@ -0,0 +1,127 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Clocks is + + + type Clock is new Widget with private; + + type Clock_Reference (Data : not null access Clock'Class) is limited null record + with Implicit_Dereference => Data; + + subtype Hour is Integer range 0 .. 23; + subtype Minute is Integer range 0 .. 59; + subtype Second is Integer range 0 .. 60; + + type Time_Value is mod 2 ** 32; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Clock; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Clock; + + end Forge; + + + + + -- Individual Values -- + + function Get_Hour + (This : in Clock) + return Hour; + + function Get_Minute + (This : in Clock) + return Minute; + + function Get_Second + (This : in Clock) + return Second; + + + + + -- Full Value -- + + function Get_Time + (This : in Clock) + return Time_Value; + + procedure Set_Time + (This : in out Clock; + To : in Time_Value); + + procedure Set_Time + (This : in out Clock; + Hours : in Hour; + Minutes : in Minute; + Seconds : in Second); + + + + + -- Drawing -- + + procedure Draw + (This : in out Clock); + + procedure Draw + (This : in out Clock; + X, Y, W, H : in Integer); + + +private + + + type Clock is new Widget with null record; + + overriding procedure Initialize + (This : in out Clock); + + overriding procedure Finalize + (This : in out Clock); + + procedure Extra_Init + (This : in out Clock; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Clock) + with Inline; + + + pragma Inline (Get_Hour); + pragma Inline (Get_Minute); + pragma Inline (Get_Second); + + pragma Inline (Get_Time); + pragma Inline (Set_Time); + + pragma Inline (Draw); + + +end FLTK.Widgets.Clocks; + + diff --git a/spec/fltk-widgets-groups-browsers-check.ads b/spec/fltk-widgets-groups-browsers-check.ads new file mode 100644 index 0000000..46c9108 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-check.ads @@ -0,0 +1,209 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Browsers.Check is + + + -- Since the FLTK 1.3 implementation doesn't provide the following key functions: + -- + -- item_at / Item_At + -- item_last / Item_Last + -- item_swap / Item_Swap + -- item_text / Item_Text + -- + -- You can't use Sort on a Check_Browser unless you want a crash. The item_* + -- methods in C++ are also private which means with the way they had to be bound, + -- if you override those subprograms in Ada the behaviour in FLTK will not change. + -- + -- These problems are fixed in 1.4 so they will go away once I get there. + + + type Check_Browser is new Browser with private; + + type Check_Browser_Reference (Data : not null access Check_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Check_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Check_Browser; + + end Forge; + + + + + -- Items -- + + procedure Add + (This : in out Check_Browser; + Text : in String; + Checked : in Boolean := False); + + procedure Remove + (This : in out Check_Browser; + Index : in Positive); + + procedure Clear + (This : in out Check_Browser); + + function Number_Of_Items + (This : in Check_Browser) + return Natural; + + + + + -- Checkmarking -- + + procedure Check_All + (This : in out Check_Browser); + + procedure Check_None + (This : in out Check_Browser); + + function Is_Checked + (This : in Check_Browser; + Index : in Positive) + return Boolean; + + procedure Set_Checked + (This : in out Check_Browser; + Index : in Positive; + State : in Boolean := True); + + function Number_Checked + (This : in Check_Browser) + return Natural; + + + + + -- Text Selection -- + + -- Don't confuse this with the missing Item_Cursor version + function Item_Text + (This : in Check_Browser; + Index : in Positive) + return String; + + function Selected_Index + (This : in Check_Browser) + return Positive; + + + + + -- Item Implementation -- + + -- As mentioned at the start, due to issues with FLTK 1.3 if you override + -- these subprograms the behaviour in FLTK will not change. Should be able + -- to bind them properly once 1.4 comes around. + + function Item_Width + (This : in Check_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_Height + (This : in Check_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_First + (This : in Check_Browser) + return Item_Cursor; + + -- Item_Last missing in 1.3 + + function Item_Next + (This : in Check_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_Previous + (This : in Check_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + -- Item_At missing in 1.3 + + procedure Item_Select + (This : in out Check_Browser; + Item : in Item_Cursor; + State : in Boolean := True); + + function Item_Selected + (This : in Check_Browser; + Item : in Item_Cursor) + return Boolean; + + -- Item_Swap and Item_Text missing in 1.3 + + procedure Item_Draw + (This : in Check_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer); + + +private + + + type Check_Browser is new Browser with null record; + + overriding procedure Initialize + (This : in out Check_Browser); + + overriding procedure Finalize + (This : in out Check_Browser); + + procedure Extra_Init + (This : in out Check_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Check_Browser); + + + pragma Inline (Add); + pragma Inline (Remove); + pragma Inline (Clear); + pragma Inline (Number_Of_Items); + + pragma Inline (Check_All); + pragma Inline (Check_None); + pragma Inline (Is_Checked); + pragma Inline (Set_Checked); + pragma Inline (Number_Checked); + + pragma Inline (Item_Text); + pragma Inline (Selected_Index); + + pragma Inline (Item_Width); + pragma Inline (Item_Height); + pragma Inline (Item_First); + pragma Inline (Item_Next); + pragma Inline (Item_Previous); + pragma Inline (Item_Select); + pragma Inline (Item_Selected); + pragma Inline (Item_Draw); + + +end FLTK.Widgets.Groups.Browsers.Check; + + diff --git a/spec/fltk-widgets-groups-browsers-textline-choice.ads b/spec/fltk-widgets-groups-browsers-textline-choice.ads new file mode 100644 index 0000000..dcf3d60 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-textline-choice.ads @@ -0,0 +1,59 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Select_Browsers except select is a reserved word + + +package FLTK.Widgets.Groups.Browsers.Textline.Choice is + + + type Choice_Browser is new Textline_Browser with private; + + type Choice_Browser_Reference (Data : not null access Choice_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Choice_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Choice_Browser; + + end Forge; + + +private + + + type Choice_Browser is new Textline_Browser with null record; + + overriding procedure Initialize + (This : in out Choice_Browser); + + overriding procedure Finalize + (This : in out Choice_Browser); + + procedure Extra_Init + (This : in out Choice_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Choice_Browser); + + +end FLTK.Widgets.Groups.Browsers.Textline.Choice; + + diff --git a/spec/fltk-widgets-groups-browsers-textline-file.ads b/spec/fltk-widgets-groups-browsers-textline-file.ads new file mode 100644 index 0000000..d19bd50 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-textline-file.ads @@ -0,0 +1,181 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Filenames; + + +package FLTK.Widgets.Groups.Browsers.Textline.File is + + + -- Due to the inherited methods being made private in C++, overriding + -- + -- Item_Width + -- Item_Height + -- Item_Draw + -- Full_List_Height + -- Average_Item_Height + -- + -- will have no effect on the behaviour of this widget in FLTK. + -- + -- This may change in versions beyond 1.3. + + + type File_Browser is new Textline_Browser with private; + + type File_Browser_Reference (Data : not null access File_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + type File_Kind is (Files, Directories); + + type Icon_Size is mod 256; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return File_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return File_Browser; + + end Forge; + + + + + -- Directory -- + + function Load + (This : in out File_Browser; + Dir : in String; + Sort : in not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access) + return Natural; + + procedure Load + (This : in out File_Browser; + Dir : in String; + Sort : in not null FLTK.Filenames.Compare_Function := + FLTK.Filenames.Numeric_Sort'Access); + + + + + -- Settings -- + + function Get_File_Kind + (This : in File_Browser) + return File_Kind; + + procedure Set_File_Kind + (This : in out File_Browser; + Value : in File_Kind); + + function Get_Filter + (This : in File_Browser) + return String; + + procedure Set_Filter + (This : in out File_Browser; + Value : in String); + + function Get_Icon_Size + (This : in File_Browser) + return Icon_Size; + + procedure Set_Icon_Size + (This : in out File_Browser; + Value : in Icon_Size); + + function Get_Text_Size + (This : in File_Browser) + return Font_Size; + + procedure Set_Text_Size + (This : in out File_Browser; + Size : in Font_Size); + + + + + -- List Implementation -- + + function Full_List_Height + (This : in File_Browser) + return Integer; + + function Average_Item_Height + (This : in File_Browser) + return Integer; + + + + + -- Item Implementation -- + + function Item_Width + (This : in File_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_Height + (This : in File_Browser; + Item : in Item_Cursor) + return Integer; + + procedure Item_Draw + (This : in File_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer); + + +private + + + type File_Browser is new Textline_Browser with null record; + + overriding procedure Initialize + (This : in out File_Browser); + + overriding procedure Finalize + (This : in out File_Browser); + + procedure Extra_Init + (This : in out File_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out File_Browser); + + + pragma Inline (Set_File_Kind); + pragma Inline (Set_Filter); + pragma Inline (Get_Icon_Size); + pragma Inline (Set_Icon_Size); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Full_List_Height); + pragma Inline (Average_Item_Height); + + pragma Inline (Item_Width); + pragma Inline (Item_Height); + pragma Inline (Item_Draw); + + +end FLTK.Widgets.Groups.Browsers.Textline.File; + + diff --git a/spec/fltk-widgets-groups-browsers-textline-hold.ads b/spec/fltk-widgets-groups-browsers-textline-hold.ads new file mode 100644 index 0000000..3839dd1 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-textline-hold.ads @@ -0,0 +1,56 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Browsers.Textline.Hold is + + + type Hold_Browser is new Textline_Browser with private; + + type Hold_Browser_Reference (Data : not null access Hold_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Hold_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Hold_Browser; + + end Forge; + + +private + + + type Hold_Browser is new Textline_Browser with null record; + + overriding procedure Initialize + (This : in out Hold_Browser); + + overriding procedure Finalize + (This : in out Hold_Browser); + + procedure Extra_Init + (This : in out Hold_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Hold_Browser); + + +end FLTK.Widgets.Groups.Browsers.Textline.Hold; + + diff --git a/spec/fltk-widgets-groups-browsers-textline-multi.ads b/spec/fltk-widgets-groups-browsers-textline-multi.ads new file mode 100644 index 0000000..150b5b6 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-textline-multi.ads @@ -0,0 +1,56 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Browsers.Textline.Multi is + + + type Multi_Browser is new Textline_Browser with private; + + type Multi_Browser_Reference (Data : not null access Multi_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multi_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multi_Browser; + + end Forge; + + +private + + + type Multi_Browser is new Textline_Browser with null record; + + overriding procedure Initialize + (This : in out Multi_Browser); + + overriding procedure Finalize + (This : in out Multi_Browser); + + procedure Extra_Init + (This : in out Multi_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Multi_Browser); + + +end FLTK.Widgets.Groups.Browsers.Textline.Multi; + + diff --git a/spec/fltk-widgets-groups-browsers-textline.ads b/spec/fltk-widgets-groups-browsers-textline.ads new file mode 100644 index 0000000..3a66e12 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers-textline.ads @@ -0,0 +1,448 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images; + +private with + + Ada.Containers.Vectors, + Interfaces.C, + System; + + +package FLTK.Widgets.Groups.Browsers.Textline is + + + type Textline_Browser is new Browser with private; + + type Textline_Browser_Reference (Data : not null access Textline_Browser'Class) is + limited null record with Implicit_Dereference => Data; + + type Line_Position is (Top, Bottom, Middle); + + type Column_Widths is array (Positive range <>) of Integer; + + + Browser_Load_Error : exception; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Textline_Browser; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Textline_Browser; + + end Forge; + + + + + -- Lines -- + + procedure Add + (This : in out Textline_Browser; + Text : in String); + + procedure Insert + (This : in out Textline_Browser; + Above : in Positive; + Text : in String); + + -- To destination calculated after From line is removed. + -- Also, note that To/From ordering is opposite from C++ + procedure Move + (This : in out Textline_Browser; + From, To : in Positive); + + procedure Swap + (This : in out Textline_Browser; + A, B : in Positive); + + procedure Remove + (This : in out Textline_Browser; + Line : in Positive); + + procedure Clear + (This : in out Textline_Browser); + + function Number_Of_Lines + (This : in Textline_Browser) + return Natural; + + + + + -- Text Loading -- + + procedure Load + (This : in out Textline_Browser; + File : in String); + + function Get_Line_Text + (This : in Textline_Browser; + Line : in Positive) + return String; + + procedure Set_Line_Text + (This : in out Textline_Browser; + Line : in Positive; + Text : in String); + + function Get_Text_Size + (This : in Textline_Browser) + return Font_Size; + + procedure Set_Text_Size + (This : in out Textline_Browser; + Size : in Font_Size); + + + + + -- Columns, Formatting -- + + function Get_Column_Character + (This : in Textline_Browser) + return Character; + + procedure Set_Column_Character + (This : in out Textline_Browser; + Value : in Character); + + function Get_Column_Widths + (This : in Textline_Browser) + return Column_Widths; + + -- An internal copy is kept of Widths, unlike the C++ version + procedure Set_Column_Widths + (This : in out Textline_Browser; + Widths : in Column_Widths); + + function Get_Format_Character + (This : in Textline_Browser) + return Character; + + procedure Set_Format_Character + (This : in out Textline_Browser; + Value : in Character); + + + + + -- Line Positions -- + + function Get_Top_Line + (This : in Textline_Browser) + return Positive; + + procedure Set_Top_Line + (This : in out Textline_Browser; + Line : in Positive); + + procedure Set_Middle_Line + (This : in out Textline_Browser; + Line : in Positive); + + procedure Set_Bottom_Line + (This : in out Textline_Browser; + Line : in Positive); + + procedure Set_Line_Position + (This : in out Textline_Browser; + Line : in Positive; + Place : in Line_Position); + + + + + -- Selection -- + + function Set_Select + (This : in out Textline_Browser; + Line : in Positive; + State : in Boolean := True) + return Boolean; + + procedure Set_Select + (This : in out Textline_Browser; + Line : in Positive; + State : in Boolean := True); + + function Is_Selected + (This : in Textline_Browser; + Line : in Positive) + return Boolean; + + function Selected_Index + (This : in Textline_Browser) + return Natural; + + + + + -- Visibility -- + + function Is_Visible + (This : in Textline_Browser; + Line : in Positive) + return Boolean; + + procedure Make_Visible + (This : in out Textline_Browser; + Line : in Positive); + + function Is_Displayed + (This : in Textline_Browser; + Line : in Positive) + return Boolean; + + procedure Show_Line + (This : in out Textline_Browser; + Line : in Positive); + + procedure Hide_Line + (This : in out Textline_Browser; + Line : in Positive); + + procedure Show + (This : in out Textline_Browser); + + procedure Hide + (This : in out Textline_Browser); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Textline_Browser; + W, H : in Integer); + + + + + -- Icons -- + + function Has_Icon + (This : in Textline_Browser; + Line : in Positive) + return Boolean; + + function Get_Icon + (This : in Textline_Browser; + Line : in Positive) + return FLTK.Images.Image_Reference; + + procedure Set_Icon + (This : in out Textline_Browser; + Line : in Positive; + Icon : in FLTK.Images.Image'Class); + + procedure Remove_Icon + (This : in out Textline_Browser; + Line : in Positive); + + + + + -- List Implementation -- + + function Full_List_Height + (This : in Textline_Browser) + return Integer; + + function Average_Item_Height + (This : in Textline_Browser) + return Integer; + + + + + -- Item Implementation -- + + function Item_Width + (This : in Textline_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_Height + (This : in Textline_Browser; + Item : in Item_Cursor) + return Integer; + + function Item_First + (This : in Textline_Browser) + return Item_Cursor; + + function Item_Last + (This : in Textline_Browser) + return Item_Cursor; + + function Item_Next + (This : in Textline_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_Previous + (This : in Textline_Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_At + (This : in Textline_Browser; + Index : in Positive) + return Item_Cursor; + + procedure Item_Select + (This : in out Textline_Browser; + Item : in Item_Cursor; + State : in Boolean := True); + + function Item_Selected + (This : in Textline_Browser; + Item : in Item_Cursor) + return Boolean; + + procedure Item_Swap + (This : in out Textline_Browser; + A, B : in Item_Cursor); + + function Item_Text + (This : in Textline_Browser; + Item : in Item_Cursor) + return String; + + procedure Item_Draw + (This : in Textline_Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer); + + + + + -- Line Numbers -- + + function Line_Number + (This : in Textline_Browser; + Item : in Item_Cursor) + return Natural; + + +private + + + type C_Col_Widths is array (Positive range <>) of aliased Interfaces.C.int + with Convention => C; + + type C_Col_Widths_Access is access C_Col_Widths; + + + type Image_Access is access FLTK.Images.Image'Class; + + package Image_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Image_Access); + + + type Item_Override_Fun is + (Item_Width_Ptr, Item_Height_Ptr, + Item_First_Ptr, Item_Last_Ptr, + Item_Next_Ptr, Item_Previous_Ptr, + Item_At_Ptr, Item_Select_Ptr, + Item_Selected_Ptr, Item_Swap_Ptr, + Item_Text_Ptr, Item_Draw_Ptr); + type Item_Override_Fun_Ptr_Array is array (Item_Override_Fun) of System.Address; + + + type Textline_Browser is new Browser with record + Columns : C_Col_Widths_Access; + Icons : Image_Vectors.Vector; + Item_Override_Ptrs : Item_Override_Fun_Ptr_Array; + end record; + + overriding procedure Initialize + (This : in out Textline_Browser); + + overriding procedure Finalize + (This : in out Textline_Browser); + + procedure Extra_Init + (This : in out Textline_Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Textline_Browser); + + + pragma Inline (Add); + pragma Inline (Insert); + pragma Inline (Move); + pragma Inline (Swap); + pragma Inline (Remove); + pragma Inline (Clear); + pragma Inline (Number_Of_Lines); + + pragma Inline (Set_Line_Text); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Get_Column_Character); + pragma Inline (Set_Column_Character); + pragma Inline (Get_Format_Character); + pragma Inline (Set_Format_Character); + + pragma Inline (Get_Top_Line); + pragma Inline (Set_Top_Line); + pragma Inline (Set_Middle_Line); + pragma Inline (Set_Bottom_Line); + pragma Inline (Set_Line_Position); + + pragma Inline (Selected_Index); + + pragma Inline (Is_Visible); + pragma Inline (Make_Visible); + pragma Inline (Show_Line); + pragma Inline (Hide_Line); + pragma Inline (Show); + pragma Inline (Hide); + + pragma Inline (Has_Icon); + pragma Inline (Get_Icon); + + pragma Inline (Full_List_Height); + pragma Inline (Average_Item_Height); + + pragma Inline (Item_Width); + pragma Inline (Item_Height); + pragma Inline (Item_First); + pragma Inline (Item_Last); + pragma Inline (Item_Next); + pragma Inline (Item_Previous); + pragma Inline (Item_At); + pragma Inline (Item_Select); + pragma Inline (Item_Swap); + pragma Inline (Item_Text); + pragma Inline (Item_Draw); + + pragma Inline (Line_Number); + + +end FLTK.Widgets.Groups.Browsers.Textline; + + diff --git a/spec/fltk-widgets-groups-browsers.ads b/spec/fltk-widgets-groups-browsers.ads new file mode 100644 index 0000000..c735fa2 --- /dev/null +++ b/spec/fltk-widgets-groups-browsers.ads @@ -0,0 +1,452 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Valuators.Sliders.Scrollbars, + System; + +private with + + Ada.Unchecked_Conversion, + Interfaces.C.Strings; + + +package FLTK.Widgets.Groups.Browsers is + + + type Browser is new Group with private; + + type Browser_Reference (Data : not null access Browser'Class) is + limited null record with Implicit_Dereference => Data; + + type Item_Cursor is mod System.Memory_Size; + + No_Item : constant Item_Cursor; + + type Sort_Order is (Ascending, Descending); + + type Scrollbar_Mode is record + Horizontal : Boolean := True; + Vertical : Boolean := True; + Always_On : Boolean := False; + end record; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Browser; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Browser; + + end Forge; + + + + + -- Attributes -- + + function H_Bar + (This : in out Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + function V_Bar + (This : in out Browser) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + + + + -- Items -- + + function Set_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True; + Do_Callbacks : in Boolean := False) + return Boolean; + + procedure Set_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True; + Do_Callbacks : in Boolean := False); + + function Select_Only + (This : in out Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False) + return Boolean; + + procedure Select_Only + (This : in out Browser; + Item : in Item_Cursor; + Do_Callbacks : in Boolean := False); + + function Current_Selection + (This : in Browser) + return Item_Cursor; + + function Deselect + (This : in out Browser; + Do_Callbacks : in Boolean := False) + return Boolean; + + procedure Deselect + (This : in out Browser; + Do_Callbacks : in Boolean := False); + + procedure Display + (This : in out Browser; + Item : in Item_Cursor); + + function Is_Displayed + (This : in Browser; + Item : in Item_Cursor) + return Boolean; + + function Find_Item + (This : in Browser; + Y_Pos : in Integer) + return Item_Cursor; + + function Top_Item + (This : in Browser) + return Item_Cursor; + + -- Not task safe due to internal issues with converting Ada Strings to char* in C. + -- Unsure how much that matters since unsure how task safe FLTK is anyway. + procedure Sort + (This : in out Browser; + Order : in Sort_Order); + + + + + -- Scrollbar Settings -- + + function Get_Scrollbar_Mode + (This : in Browser) + return Scrollbar_Mode; + + procedure Set_Scrollbar_Mode + (This : in out Browser; + Mode : in Scrollbar_Mode); + + function Get_H_Position + (This : in Browser) + return Integer; + + procedure Set_H_Position + (This : in out Browser; + Value : in Integer); + + function Get_V_Position + (This : in Browser) + return Integer; + + procedure Set_V_Position + (This : in out Browser; + Value : in Integer); + + procedure Set_Vertical_Left + (This : in out Browser); + + procedure Set_Vertical_Right + (This : in out Browser); + + function Get_Scrollbar_Size + (This : in Browser) + return Integer; + + procedure Set_Scrollbar_Size + (This : in out Browser; + Value : in Integer); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Browser) + return Color; + + procedure Set_Text_Color + (This : in out Browser; + Value : in Color); + + function Get_Text_Font + (This : in Browser) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Browser; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Browser) + return Font_Size; + + procedure Set_Text_Size + (This : in out Browser; + Size : in Font_Size); + + + + + -- Dimensions, Redrawing -- + + procedure Resize + (This : in out Browser; + X, Y, W, H : in Integer); + + procedure Bounding_Box + (This : in Browser; + X, Y, W, H : out Integer); + + function Left_Edge + (This : in Browser) + return Integer; + + procedure Redraw_Line + (This : in out Browser; + Item : in Item_Cursor); + + procedure Redraw_List + (This : in out Browser); + + + + + -- Optional Overrides -- + + -- You may override these subprograms to change the behaviour of the widget + -- even though these are called from within FLTK. + + function Full_List_Width + (This : in Browser) + return Integer; + + function Full_List_Height + (This : in Browser) + return Integer; + + function Average_Item_Height + (This : in Browser) + return Integer; + + function Item_Quick_Height + (This : in Browser; + Item : in Item_Cursor) + return Integer; + + + + + -- Mandatory Overrides -- + + -- You MUST override these subprograms if deriving a type from Browser or your + -- program will crash, since they are called from within FLTK and do not have + -- any implementations given. By default here they will raise an exception. + + function Item_Width + (This : in Browser; + Item : in Item_Cursor) + return Integer; + + function Item_Height + (This : in Browser; + Item : in Item_Cursor) + return Integer; + + function Item_First + (This : in Browser) + return Item_Cursor; + + function Item_Last + (This : in Browser) + return Item_Cursor; + + function Item_Next + (This : in Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_Previous + (This : in Browser; + Item : in Item_Cursor) + return Item_Cursor; + + function Item_At + (This : in Browser; + Index : in Positive) + return Item_Cursor; + + procedure Item_Select + (This : in out Browser; + Item : in Item_Cursor; + State : in Boolean := True); + + function Item_Selected + (This : in Browser; + Item : in Item_Cursor) + return Boolean; + + procedure Item_Swap + (This : in out Browser; + A, B : in Item_Cursor); + + function Item_Text + (This : in Browser; + Item : in Item_Cursor) + return String; + + procedure Item_Draw + (This : in Browser; + Item : in Item_Cursor; + X, Y, W, H : in Integer); + + + + + -- Cache Invalidation -- + + procedure New_List + (This : in out Browser); + + procedure Inserting + (This : in out Browser; + A, B : in Item_Cursor); + + procedure Deleting + (This : in out Browser; + Item : in Item_Cursor); + + procedure Replacing + (This : in out Browser; + A, B : in Item_Cursor); + + procedure Swapping + (This : in out Browser; + A, B : in Item_Cursor); + + +private + + + type Wide_High_Fun is + (Full_List_Width_Ptr, Full_List_Height_Ptr, + Average_Item_Height_Ptr, Item_Quick_Height_Ptr); + type Wide_High_Fun_Ptr_Array is array (Wide_High_Fun) of System.Address; + + + type Browser is new Group with record + Horizon : aliased Valuators.Sliders.Scrollbars.Scrollbar; + Vertigo : aliased Valuators.Sliders.Scrollbars.Scrollbar; + Text_Store : Interfaces.C.Strings.chars_ptr_array (1 .. 2); + Current : Interfaces.C.size_t := 1; + Wide_High_Ptrs : Wide_High_Fun_Ptr_Array; + end record; + + overriding procedure Initialize + (This : in out Browser); + + overriding procedure Finalize + (This : in out Browser); + + procedure Extra_Init + (This : in out Browser; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Browser); + + + pragma Assert + (Item_Cursor'Size = Storage.Integer_Address'Size, + "Size of Browser Item_Cursor does not match Ada address values"); + + function Address_To_Cursor is + new Ada.Unchecked_Conversion (Storage.Integer_Address, Item_Cursor); + function Cursor_To_Address is + new Ada.Unchecked_Conversion (Item_Cursor, Storage.Integer_Address); + + No_Item : constant Item_Cursor := Address_To_Cursor (Null_Pointer); + + + for Scrollbar_Mode use record + Horizontal at 0 range 0 .. 0; + Vertical at 0 range 1 .. 1; + Always_On at 0 range 2 .. 2; + end record; + + for Scrollbar_Mode'Size use Interfaces.C.unsigned_char'Size; + + function Mode_To_Uchar is + new Ada.Unchecked_Conversion (Scrollbar_Mode, Interfaces.C.unsigned_char); + function Uchar_To_Mode is + new Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Scrollbar_Mode); + + + pragma Inline (H_Bar); + pragma Inline (V_Bar); + + pragma Inline (Current_Selection); + pragma Inline (Display); + pragma Inline (Find_Item); + pragma Inline (Top_Item); + pragma Inline (Sort); + + pragma Inline (Get_Scrollbar_Mode); + pragma Inline (Set_Scrollbar_Mode); + pragma Inline (Get_H_Position); + pragma Inline (Set_H_Position); + pragma Inline (Get_V_Position); + pragma Inline (Set_V_Position); + pragma Inline (Set_Vertical_Left); + pragma Inline (Set_Vertical_Right); + pragma Inline (Get_Scrollbar_Size); + pragma Inline (Set_Scrollbar_Size); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Resize); + pragma Inline (Bounding_Box); + pragma Inline (Left_Edge); + pragma Inline (Redraw_Line); + pragma Inline (Redraw_List); + + pragma Inline (Full_List_Width); + pragma Inline (Full_List_Height); + pragma Inline (Average_Item_Height); + pragma Inline (Item_Quick_Height); + + pragma Inline (New_List); + pragma Inline (Inserting); + pragma Inline (Deleting); + pragma Inline (Replacing); + pragma Inline (Swapping); + + +end FLTK.Widgets.Groups.Browsers; + + diff --git a/spec/fltk-widgets-groups-color_choosers.ads b/spec/fltk-widgets-groups-color_choosers.ads new file mode 100644 index 0000000..d3b049f --- /dev/null +++ b/spec/fltk-widgets-groups-color_choosers.ads @@ -0,0 +1,155 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Color_Choosers is + + + type Color_Chooser is new Group with private; + + type Color_Chooser_Reference (Data : not null access Color_Chooser'Class) is + limited null record with Implicit_Dereference => Data; + + type Color_Mode is (RGB, Byte, Hex, HSV); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Color_Chooser; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Color_Chooser; + + end Forge; + + + + + -- RGB Color -- + + function Get_Red + (This : in Color_Chooser) + return Long_Float; + + function Get_Green + (This : in Color_Chooser) + return Long_Float; + + function Get_Blue + (This : in Color_Chooser) + return Long_Float; + + procedure Set_RGB + (This : in out Color_Chooser; + R, G, B : in Long_Float); + + function Set_RGB + (This : in out Color_Chooser; + R, G, B : in Long_Float) + return Boolean; + + + + + -- HSV Color -- + + function Get_Hue + (This : in Color_Chooser) + return Long_Float; + + function Get_Saturation + (This : in Color_Chooser) + return Long_Float; + + function Get_Value + (This : in Color_Chooser) + return Long_Float; + + procedure Set_HSV + (This : in out Color_Chooser; + H, S, V : in Long_Float); + + function Set_HSV + (This : in out Color_Chooser; + H, S, V : in Long_Float) + return Boolean; + + + + + -- RGB / HSV Conversion -- + + procedure HSV_To_RGB + (H, S, V : in Long_Float; + R, G, B : out Long_Float); + + procedure RGB_To_HSV + (R, G, B : in Long_Float; + H, S, V : out Long_Float); + + + + + -- Settings -- + + function Get_Mode + (This : in Color_Chooser) + return Color_Mode; + + procedure Set_Mode + (This : in out Color_Chooser; + To : in Color_Mode); + + +private + + + type Color_Chooser is new Group with null record; + + overriding procedure Initialize + (This : in out Color_Chooser); + + overriding procedure Finalize + (This : in out Color_Chooser); + + procedure Extra_Init + (This : in out Color_Chooser; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Color_Chooser) + with Inline; + + + pragma Inline (Get_Red); + pragma Inline (Get_Green); + pragma Inline (Get_Blue); + pragma Inline (Set_RGB); + + pragma Inline (Get_Hue); + pragma Inline (Get_Saturation); + pragma Inline (Get_Value); + pragma Inline (Set_HSV); + + pragma Inline (HSV_To_RGB); + pragma Inline (RGB_To_HSV); + + pragma Inline (Get_Mode); + pragma Inline (Set_Mode); + + +end FLTK.Widgets.Groups.Color_Choosers; + + diff --git a/spec/fltk-widgets-groups-help_views.ads b/spec/fltk-widgets-groups-help_views.ads new file mode 100644 index 0000000..d1dc75b --- /dev/null +++ b/spec/fltk-widgets-groups-help_views.ads @@ -0,0 +1,247 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +private with + + Interfaces.C.Strings; + + +package FLTK.Widgets.Groups.Help_Views is + + + type Help_View is new Group with private; + + type Help_View_Reference (Data : not null access Help_View'Class) is limited null record + with Implicit_Dereference => Data; + + subtype Position is Positive; + subtype Extended_Position is Natural; + + No_Position : constant Extended_Position := 0; + + type Link_Callback is access function + (Item : in out Help_View'Class; + URI : in String) + return String; + + + -- You have no idea how tempting it is to give this + -- a more tongue in cheek name. + Load_Help_Error : exception; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Help_View; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Help_View; + + end Forge; + + + + + -- Selection -- + + procedure Clear_Selection + (This : in out Help_View); + + procedure Select_All + (This : in out Help_View); + + + + + -- Position -- + + function Find + (This : in Help_View; + Item : in String; + From : in Position := 1) + return Extended_Position; + + function Get_Leftline_Pixel + (This : in Help_View) + return Natural; + + procedure Set_Leftline_Pixel + (This : in out Help_View; + Value : in Natural); + + function Get_Topline_Pixel + (This : in Help_View) + return Natural; + + procedure Set_Topline_Pixel + (This : in out Help_View; + Value : in Natural); + + procedure Set_Topline_Target + (This : in out Help_View; + Value : in String); + + + + + -- Content -- + + function Current_Directory + (This : in Help_View) + return String; + + function Current_File + (This : in Help_View) + return String; + + -- Name here can be either a ftp/http/https/ipp/mailto/news URL or a filename. + procedure Load + (This : in out Help_View; + Name : in String); + + function Document_Title + (This : in Help_View) + return String; + + function Get_Content + (This : in Help_View) + return String; + + procedure Set_Content + (This : in out Help_View; + Value : in String); + + procedure Set_Link_Callback + (This : in out Help_View; + Func : in Link_Callback); + + + + + -- Settings -- + + function Get_Scrollbar_Size + (This : in Help_View) + return Natural; + + procedure Set_Scrollbar_Size + (This : in out Help_View; + Value : in Natural); + + function Get_Size + (This : in Help_View) + return Integer; + + procedure Resize + (This : in out Help_View; + W, H : in Integer); + + procedure Resize + (This : in out Help_View; + X, Y, W, H : in Integer); + + function Get_Text_Color + (This : in Help_View) + return Color; + + procedure Set_Text_Color + (This : in out Help_View; + Value : in Color); + + function Get_Text_Font + (This : in Help_View) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Help_View; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Help_View) + return Font_Size; + + procedure Set_Text_Size + (This : in out Help_View; + Size : in Font_Size); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Help_View); + + function Handle + (This : in out Help_View; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Help_View is new Group with record + Zelda : Link_Callback; + Hilda : Interfaces.C.Strings.chars_ptr; + end record; + + overriding procedure Initialize + (This : in out Help_View); + + overriding procedure Finalize + (This : in out Help_View); + + procedure Extra_Init + (This : in out Help_View; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Help_View); + + + pragma Inline (Clear_Selection); + pragma Inline (Select_All); + + pragma Inline (Find); + pragma Inline (Get_Leftline_Pixel); + pragma Inline (Set_Leftline_Pixel); + pragma Inline (Get_Topline_Pixel); + pragma Inline (Set_Topline_Pixel); + pragma Inline (Set_Topline_Target); + + pragma Inline (Current_Directory); + pragma Inline (Current_File); + pragma Inline (Set_Content); + pragma Inline (Set_Link_Callback); + + pragma Inline (Get_Scrollbar_Size); + pragma Inline (Set_Scrollbar_Size); + pragma Inline (Get_Size); + pragma Inline (Resize); + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Help_Views; + + diff --git a/spec/fltk-widgets-groups-input_choices.ads b/spec/fltk-widgets-groups-input_choices.ads new file mode 100644 index 0000000..5843c44 --- /dev/null +++ b/spec/fltk-widgets-groups-input_choices.ads @@ -0,0 +1,195 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Menu_Items, + FLTK.Widgets.Inputs.Text, + FLTK.Widgets.Menus.Menu_Buttons; + + +package FLTK.Widgets.Groups.Input_Choices is + + + type Input_Choice is new Group with private; + + type Input_Choice_Reference (Data : not null access Input_Choice'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Input_Choice; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Input_Choice; + + end Forge; + + + + + -- Attributes -- + + function Text_Field + (This : in out Input_Choice) + return FLTK.Widgets.Inputs.Text.Text_Input_Reference; + + function Button_Menu + (This : in out Input_Choice) + return FLTK.Widgets.Menus.Menu_Buttons.Menu_Button_Reference; + + + + + -- Menu Items -- + + function Has_Item + (This : in Input_Choice; + Place : in FLTK.Widgets.Menus.Index) + return Boolean; + + function Item + (This : in Input_Choice; + Place : in FLTK.Widgets.Menus.Index) + return FLTK.Menu_Items.Menu_Item_Reference; + + procedure Use_Same_Items + (This : in out Input_Choice; + Donor : in FLTK.Widgets.Menus.Menu'Class); + + procedure Clear + (This : in out Input_Choice); + + + + + -- Settings -- + + function Has_Changed + (This : in Input_Choice) + return Boolean; + + procedure Clear_Changed + (This : in out Input_Choice); + + procedure Set_Changed + (This : in out Input_Choice; + To : in Boolean); + + function Get_Down_Box + (This : in Input_Choice) + return Box_Kind; + + procedure Set_Down_Box + (This : in out Input_Choice; + To : in Box_Kind); + + function Get_Text_Color + (This : in Input_Choice) + return Color; + + procedure Set_Text_Color + (This : in out Input_Choice; + To : in Color); + + function Get_Text_Font + (This : in Input_Choice) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Input_Choice; + To : in Font_Kind); + + function Get_Text_Size + (This : in Input_Choice) + return Font_Size; + + procedure Set_Text_Size + (This : in out Input_Choice; + To : in Font_Size); + + function Get_Input + (This : in Input_Choice) + return String; + + procedure Set_Input + (This : in out Input_Choice; + To : in String); + + procedure Set_Item + (This : in out Input_Choice; + Num : in Integer); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Input_Choice; + X, Y, W, H : in Integer); + + +private + + + type Input_Choice is new Group with record + My_Input : aliased Inputs.Text.Text_Input; + My_Menu_Button : aliased Menus.Menu_Buttons.Menu_Button; + end record; + + overriding procedure Initialize + (This : in out Input_Choice); + + overriding procedure Finalize + (This : in out Input_Choice); + + procedure Extra_Init + (This : in out Input_Choice; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Input_Choice); + + + pragma Inline (Text_Field); + pragma Inline (Button_Menu); + + pragma Inline (Has_Item); + pragma Inline (Item); + pragma Inline (Use_Same_Items); + pragma Inline (Clear); + + pragma Inline (Has_Changed); + pragma Inline (Clear_Changed); + pragma Inline (Get_Down_Box); + pragma Inline (Set_Down_Box); + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + pragma Inline (Get_Input); + pragma Inline (Set_Input); + pragma Inline (Set_Item); + + pragma Inline (Resize); + + +end FLTK.Widgets.Groups.Input_Choices; + + diff --git a/spec/fltk-widgets-groups-packed.ads b/spec/fltk-widgets-groups-packed.ads new file mode 100644 index 0000000..3d55749 --- /dev/null +++ b/spec/fltk-widgets-groups-packed.ads @@ -0,0 +1,97 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Packed is + + + type Packed_Group is new Group with private; + + type Packed_Group_Reference (Data : not null access Packed_Group'Class) is + limited null record with Implicit_Dereference => Data; + + type Pack_Kind is (Vertical_Pack, Horizontal_Pack); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Packed_Group; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Packed_Group; + + end Forge; + + + + + -- Settings -- + + function Get_Spacing + (This : in Packed_Group) + return Integer; + + procedure Set_Spacing + (This : in out Packed_Group; + To : in Integer); + + function Get_Kind + (This : in Packed_Group) + return Pack_Kind; + + procedure Set_Kind + (This : in out Packed_Group; + Kind : in Pack_Kind); + + + + + -- Drawing -- + + procedure Draw + (This : in out Packed_Group); + + +private + + + type Packed_Group is new Group with null record; + + overriding procedure Initialize + (This : in out Packed_Group); + + overriding procedure Finalize + (This : in out Packed_Group); + + procedure Extra_Init + (This : in out Packed_Group; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Packed_Group) + with Inline; + + + pragma Inline (Get_Spacing); + pragma Inline (Set_Spacing); + pragma Inline (Get_Kind); + pragma Inline (Set_Kind); + + pragma Inline (Draw); + + +end FLTK.Widgets.Groups.Packed; + + diff --git a/spec/fltk-widgets-groups-scrolls.ads b/spec/fltk-widgets-groups-scrolls.ads new file mode 100644 index 0000000..116fe42 --- /dev/null +++ b/spec/fltk-widgets-groups-scrolls.ads @@ -0,0 +1,200 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Valuators.Sliders.Scrollbars; + + +package FLTK.Widgets.Groups.Scrolls is + + + type Scroll is new Group with private; + + type Scroll_Reference (Data : not null access Scroll'Class) is limited null record + with Implicit_Dereference => Data; + + type Scroll_Kind is + (Horizontal, + Vertical, + Both, + Always_On, + Horizontal_Always, + Vertical_Always, + Both_Always); + + + type Region is record + X, Y, W, H : Integer; + end record; + + type Scrollbar_Data is record + X, Y, W, H : Integer; + Size, Total : Natural; + First, Position : Integer; + end record; + + type Scroll_Info is record + Child_Box : Region; + Inner_Inc, Inner_Ex : Region; + H_Needed, V_Needed : Boolean; + H_Data, V_Data : Scrollbar_Data; + Scroll_Size : Natural; + end record; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Scroll; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Scroll; + + end Forge; + + + + + -- Attributes -- + + function H_Bar + (This : in out Scroll) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + function V_Bar + (This : in out Scroll) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + + + + -- Contents -- + + procedure Clear + (This : in out Scroll); + + + + + -- Scrolling -- + + procedure Scroll_To + (This : in out Scroll; + X, Y : in Integer); + + -- These two functions are far too similar in name and + -- function to the Get_X and Get_Y for Widgets. + function Get_Scroll_X + (This : in Scroll) + return Integer; + + function Get_Scroll_Y + (This : in Scroll) + return Integer; + + + + + -- Scrollbar Settings -- + + function Get_Scrollbar_Size + (This : in Scroll) + return Integer; + + procedure Set_Scrollbar_Size + (This : in out Scroll; + To : in Integer); + + function Get_Kind + (This : in Scroll) + return Scroll_Kind; + + procedure Set_Kind + (This : in out Scroll; + Mode : in Scroll_Kind); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Scroll; + X, Y, W, H : in Integer); + + procedure Recalculate_Scrollbars + (This : in Scroll; + Data : out Scroll_Info); + + + + + -- Drawing, Events -- + + procedure Bounding_Box + (This : in Scroll; + X, Y, W, H : out Integer); + + procedure Draw + (This : in out Scroll); + + function Handle + (This : in out Scroll; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Scroll is new Group with record + Horizon, Vertigo : aliased Valuators.Sliders.Scrollbars.Scrollbar; + end record; + + overriding procedure Initialize + (This : in out Scroll); + + overriding procedure Finalize + (This : in out Scroll); + + procedure Extra_Init + (This : in out Scroll; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Scroll); + + + pragma Inline (Clear); + + pragma Inline (Scroll_To); + pragma Inline (Get_Scroll_X); + pragma Inline (Get_Scroll_Y); + + pragma Inline (Get_Scrollbar_Size); + pragma Inline (Set_Scrollbar_Size); + pragma Inline (Get_Kind); + pragma Inline (Set_Kind); + + pragma Inline (Resize); + + pragma Inline (Bounding_Box); + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Scrolls; + + diff --git a/spec/fltk-widgets-groups-spinners.ads b/spec/fltk-widgets-groups-spinners.ads new file mode 100644 index 0000000..681c4d7 --- /dev/null +++ b/spec/fltk-widgets-groups-spinners.ads @@ -0,0 +1,226 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +private with + + Interfaces.C.Strings; + + +package FLTK.Widgets.Groups.Spinners is + + + type Spinner is new Group with private; + + type Spinner_Reference (Data : not null access Spinner'Class) is limited null record + with Implicit_Dereference => Data; + + type Spinner_Kind is (Float_Spin, Int_Spin); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Spinner; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Spinner; + + end Forge; + + + + + -- Settings -- + + function Get_Background_Color + (This : in Spinner) + return Color; + + procedure Set_Background_Color + (This : in out Spinner; + To : in Color); + + function Get_Selection_Color + (This : in Spinner) + return Color; + + procedure Set_Selection_Color + (This : in out Spinner; + To : in Color); + + function Get_Text_Color + (This : in Spinner) + return Color; + + procedure Set_Text_Color + (This : in out Spinner; + To : in Color); + + function Get_Text_Font + (This : in Spinner) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Spinner; + To : in Font_Kind); + + function Get_Text_Size + (This : in Spinner) + return Font_Size; + + procedure Set_Text_Size + (This : in out Spinner; + To : in Font_Size); + + + + + -- Values -- + + function Get_Minimum + (This : in Spinner) + return Long_Float; + + procedure Set_Minimum + (This : in out Spinner; + To : in Long_Float); + + function Get_Maximum + (This : in Spinner) + return Long_Float; + + procedure Set_Maximum + (This : in out Spinner; + To : in Long_Float); + + procedure Get_Range + (This : in Spinner; + Min, Max : out Long_Float); + + procedure Set_Range + (This : in out Spinner; + Min, Max : in Long_Float); + + function Get_Step + (This : in Spinner) + return Long_Float; + + procedure Set_Step + (This : in out Spinner; + To : in Long_Float); + + function Get_Value + (This : in Spinner) + return Long_Float; + + procedure Set_Value + (This : in out Spinner; + To : in Long_Float); + + + + + -- Formatting -- + + function Get_Format + (This : in Spinner) + return String; + + procedure Set_Format + (This : in out Spinner; + To : in String); + + function Get_Kind + (This : in Spinner) + return Spinner_Kind; + + procedure Set_Kind + (This : in out Spinner; + To : in Spinner_Kind); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Spinner; + X, Y, W, H : in Integer); + + + + + -- Events -- + + function Handle + (This : in out Spinner; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Spinner is new Group with record + Format_Str : Interfaces.C.Strings.chars_ptr; + end record; + + overriding procedure Initialize + (This : in out Spinner); + + overriding procedure Finalize + (This : in out Spinner); + + procedure Extra_Init + (This : in out Spinner; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Spinner) + with Inline; + + + pragma Inline (Get_Background_Color); + pragma Inline (Set_Background_Color); + pragma Inline (Get_Selection_Color); + pragma Inline (Set_Selection_Color); + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Get_Minimum); + pragma Inline (Set_Minimum); + pragma Inline (Get_Maximum); + pragma Inline (Set_Maximum); + pragma Inline (Set_Range); + pragma Inline (Get_Step); + pragma Inline (Set_Step); + pragma Inline (Get_Value); + pragma Inline (Set_Value); + + pragma Inline (Get_Kind); + pragma Inline (Set_Kind); + + pragma Inline (Resize); + + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Spinners; + + diff --git a/spec/fltk-widgets-groups-tabbed.ads b/spec/fltk-widgets-groups-tabbed.ads new file mode 100644 index 0000000..a7b8d26 --- /dev/null +++ b/spec/fltk-widgets-groups-tabbed.ads @@ -0,0 +1,123 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Tabbed is + + + type Tabbed_Group is new Group with private; + + type Tabbed_Group_Reference (Data : not null access Tabbed_Group'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Tabbed_Group; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Tabbed_Group; + + end Forge; + + + + + -- Child Area -- + + procedure Get_Client_Area + (This : in Tabbed_Group; + Tab_Height : in Natural; + X, Y, W, H : out Integer); + + + + + -- Operation -- + + function Get_Push + (This : in Tabbed_Group) + return access Widget'Class; + + procedure Set_Push + (This : in out Tabbed_Group; + Item : in out Widget'Class); + + function Get_Visible + (This : in Tabbed_Group) + return access Widget'Class; + + procedure Set_Visible + (This : in out Tabbed_Group; + Item : in out Widget'Class); + + function Get_Which + (This : in Tabbed_Group; + Event_X, Event_Y : in Integer) + return access Widget'Class; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Tabbed_Group); + + procedure Redraw_Tabs + (This : in out Tabbed_Group); + + function Handle + (This : in out Tabbed_Group; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Tabbed_Group is new Group with null record; + + overriding procedure Initialize + (This : in out Tabbed_Group); + + overriding procedure Finalize + (This : in out Tabbed_Group); + + procedure Extra_Init + (This : in out Tabbed_Group; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Tabbed_Group) + with Inline; + + + pragma Inline (Get_Client_Area); + + pragma Inline (Get_Push); + pragma Inline (Set_Push); + pragma Inline (Get_Visible); + pragma Inline (Set_Visible); + pragma Inline (Get_Which); + + pragma Inline (Draw); + pragma Inline (Redraw_Tabs); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Tabbed; + + diff --git a/spec/fltk-widgets-groups-tables-row.ads b/spec/fltk-widgets-groups-tables-row.ads new file mode 100644 index 0000000..84d7191 --- /dev/null +++ b/spec/fltk-widgets-groups-tables-row.ads @@ -0,0 +1,145 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Tables.Row is + + + type Row_Table is new Table with private; + + type Row_Table_Reference (Data : not null access Row_Table'Class) is limited null record + with Implicit_Dereference => Data; + + type Row_Select_Mode is (Select_None, Select_Single, Select_Multiple); + + type Selection_State is (Deselected, Selected, Toggle); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Row_Table; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Row_Table; + + end Forge; + + + + + -- Contents Modification -- + + procedure Clear + (This : in out Row_Table); + + + + + -- Rows -- + + function Get_Rows + (This : in Row_Table) + return Natural; + + procedure Set_Rows + (This : in out Row_Table; + Value : in Natural); + + + + + -- Selection -- + + function Is_Row_Selected + (This : in Row_Table; + Row : in Positive) + return Boolean; + + procedure Select_Row + (This : in out Row_Table; + Row : in Positive; + Value : in Selection_State := Selected); + + function Select_Row + (This : in out Row_Table; + Row : in Positive; + Value : in Selection_State := Selected) + return Boolean; + + procedure Select_All_Rows + (This : in out Row_Table; + Value : in Selection_State := Selected); + + function Get_Row_Select_Mode + (This : in Row_Table) + return Row_Select_Mode; + + procedure Set_Row_Select_Mode + (This : in out Row_Table; + Value : in Row_Select_Mode); + + + + + -- Drawing, Events -- + + procedure Cell_Dimensions + (This : in Row_Table; + Context : in Table_Context; + Row, Column : in Positive; + X, Y, W, H : out Integer); + + function Handle + (This : in out Row_Table; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Row_Table is new Table with null record; + + overriding procedure Initialize + (This : in out Row_Table); + + overriding procedure Finalize + (This : in out Row_Table); + + procedure Extra_Init + (This : in out Row_Table; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Row_Table) + with Inline; + + + pragma Inline (Get_Rows); + pragma Inline (Set_Rows); + + pragma Inline (Is_Row_Selected); + pragma Inline (Select_Row); + pragma Inline (Select_All_Rows); + pragma Inline (Get_Row_Select_Mode); + pragma Inline (Set_Row_Select_Mode); + + pragma Inline (Cell_Dimensions); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Tables.Row; + + diff --git a/spec/fltk-widgets-groups-tables.ads b/spec/fltk-widgets-groups-tables.ads new file mode 100644 index 0000000..faabc6d --- /dev/null +++ b/spec/fltk-widgets-groups-tables.ads @@ -0,0 +1,636 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Scrolls, + FLTK.Widgets.Valuators.Sliders.Scrollbars; + +private with + + Interfaces.C, + System; + + +package FLTK.Widgets.Groups.Tables is + + + type Table is new Group with private; + + type Table_Reference (Data : not null access Table'Class) is limited null record + with Implicit_Dereference => Data; + + type Table_Context is + (No_Context, Start_Page, End_Page, Row_Header, + Column_Header, Within_Cell, Dead_Zone, Row_Column_Resize); + + type Resize_Flag is (Resize_None, Column_Left, Column_Right, Row_Above, Row_Below); + + type Tab_Navigation is (Widget_Focus, Navigate_Cells); + + + Range_Error : exception; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Table; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Table; + + end Forge; + + + + + -- Attributes -- + + function H_Bar + (This : in out Table) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + function V_Bar + (This : in out Table) + return Valuators.Sliders.Scrollbars.Scrollbar_Reference; + + function Scroll_Area + (This : in out Table) + return Scrolls.Scroll_Reference; + + + + + -- Contents Modification -- + + procedure Add + (This : in out Table; + Item : in out Widget'Class); + + procedure Insert + (This : in out Table; + Item : in out Widget'Class; + Place : in Index); + + procedure Insert + (This : in out Table; + Item : in out Widget'Class; + Before : in Widget'Class); + + procedure Remove + (This : in out Table; + Item : in out Widget'Class); + + procedure Clear + (This : in out Table); + + + + + -- Contents Query -- + + function Has_Child + (This : in Table; + Place : in Index) + return Boolean; + + function Has_Child + (Place : in Cursor) + return Boolean; + + function Child + (This : in Table; + Place : in Index) + return Widget_Reference + with Pre => This.Has_Child (Place); + + function Child + (This : in Table; + Place : in Cursor) + return Widget_Reference; + + function Find + (This : in Table; + Item : in Widget'Class) + return Extended_Index; + + function Number_Of_Children + (This : in Table) + return Natural; + + function Used_As_Container + (This : in Table) + return Boolean; + + + + + -- Current -- + + procedure Begin_Current + (This : in out Table); + + procedure End_Current + (This : in out Table); + + + + + -- Callbacks -- + + procedure Set_Callback + (This : in out Table; + Func : in Widget_Callback); + + function Callback_Column + (This : in Table) + return Positive; + + function Callback_Row + (This : in Table) + return Positive; + + function Callback_Context + (This : in Table) + return Table_Context; + + procedure Do_Callback + (This : in out Table; + Context : in Table_Context; + Row, Column : in Positive); + + procedure Set_When + (This : in out Table; + Value : in Callback_Flag); + + -- This is the callback used for the horizontal and vertical scrollbars + -- inside the Table object. Assigning it to other widgets will cause errors. + procedure Scroll_Callback + (Item : in out Widget'Class); + + + + + -- Columns -- + + function Column_Headers_Enabled + (This : in Table) + return Boolean; + + procedure Set_Column_Headers + (This : in out Table; + Value : in Boolean); + + function Get_Column_Header_Color + (This : in Table) + return Color; + + procedure Set_Column_Header_Color + (This : in out Table; + Value : in Color); + + function Get_Column_Header_Height + (This : in Table) + return Positive; + + procedure Set_Column_Header_Height + (This : in out Table; + Value : in Positive); + + function Get_Column_Width + (This : in Table; + Column : in Positive) + return Positive; + + procedure Set_Column_Width + (This : in out Table; + Column : in Positive; + Value : in Positive); + + procedure Set_All_Columns_Width + (This : in out Table; + Value : in Positive); + + function Get_Columns + (This : in Table) + return Natural; + + procedure Set_Columns + (This : in out Table; + Value : in Natural); + + function Get_Column_Position + (This : in Table) + return Positive; + + procedure Set_Column_Position + (This : in out Table; + Value : in Positive); + + function Get_Column_Scroll_Position + (This : in Table; + Column : in Positive) + return Long_Integer; + + function Column_Resize_Allowed + (This : in Table) + return Boolean; + + procedure Set_Column_Resize + (This : in out Table; + Value : in Boolean); + + function Get_Column_Resize_Minimum + (This : in Table) + return Positive; + + procedure Set_Column_Resize_Minimum + (This : in out Table; + Value : in Positive); + + + + + -- Rows -- + + function Row_Headers_Enabled + (This : in Table) + return Boolean; + + procedure Set_Row_Headers + (This : in out Table; + Value : in Boolean); + + function Get_Row_Header_Color + (This : in Table) + return Color; + + procedure Set_Row_Header_Color + (This : in out Table; + Value : in Color); + + function Get_Row_Header_Width + (This : in Table) + return Positive; + + procedure Set_Row_Header_Width + (This : in out Table; + Value : in Positive); + + function Get_Row_Height + (This : in Table; + Row : in Positive) + return Positive; + + procedure Set_Row_Height + (This : in out Table; + Row : in Positive; + Value : in Positive); + + procedure Set_All_Rows_Height + (This : in out Table; + Value : in Positive); + + function Get_Rows + (This : in Table) + return Natural; + + procedure Set_Rows + (This : in out Table; + Value : in Natural); + + function Get_Row_Position + (This : in Table) + return Positive; + + procedure Set_Row_Position + (This : in out Table; + Value : in Positive); + + function Get_Row_Scroll_Position + (This : in Table; + Row : in Positive) + return Long_Integer; + + function Row_Resize_Allowed + (This : in Table) + return Boolean; + + procedure Set_Row_Resize + (This : in out Table; + Value : in Boolean); + + function Get_Row_Resize_Minimum + (This : in Table) + return Positive; + + procedure Set_Row_Resize_Minimum + (This : in out Table; + Value : in Positive); + + function Get_Top_Row + (This : in Table) + return Positive; + + procedure Set_Top_Row + (This : in out Table; + Value : in Positive); + + + + + -- Selection -- + + procedure Set_Cursor_Kind + (This : in out Table; + Kind : in Mouse_Cursor_Kind); + + procedure Cursor_To_Row_Column + (This : in Table; + Row, Column : out Positive; + Context : out Table_Context; + Resize : out Resize_Flag); + + -- Unsure if Row_Bottom and Column_Right can ever be zero, but just to be safe... + procedure Get_Visible_Cells + (This : in Table; + Row_Top : out Positive; + Column_Left : out Positive; + Row_Bottom : out Natural; + Column_Right : out Natural); + + procedure Get_Selection + (This : in Table; + Row_Top : out Positive; + Column_Left : out Positive; + Row_Bottom : out Positive; + Column_Right : out Positive); + + procedure Set_Selection + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive); + + function Is_Selected + (This : in Table; + Row, Column : in Positive) + return Boolean; + + procedure Move_Cursor + (This : in out Table; + Row, Column : in Positive; + Shift_Select : in Boolean := True); + + function Move_Cursor + (This : in out Table; + Row, Column : in Positive; + Shift_Select : in Boolean := True) + return Boolean; + + function Get_Tab_Mode + (This : in Table) + return Tab_Navigation; + + procedure Set_Tab_Mode + (This : in out Table; + Value : in Tab_Navigation); + + function Get_Table_Box + (This : in Table) + return Box_Kind; + + procedure Set_Table_Box + (This : in out Table; + Box : in Box_Kind); + + + + + -- Dimensions -- + + function Get_Scrollbar_Size + (This : in Table) + return Integer; + + procedure Set_Scrollbar_Size + (This : in out Table; + Value : in Integer); + + procedure Resize + (This : in out Table; + X, Y, W, H : in Integer); + + function Is_Interactive_Resize + (This : in Table) + return Boolean; + + procedure Reset_Sizes + (This : in out Table); + + procedure Recalculate_Dimensions + (This : in out Table); + + procedure Table_Resized + (This : in out Table); + + procedure Table_Scrolled + (This : in out Table); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Table); + + -- Derived types must override this to handle drawing cells + procedure Draw_Cell + (This : in out Table; + Context : in Table_Context; + Row, Column : in Natural := 0; + X, Y, W, H : in Integer := 0); + + procedure Redraw_Range + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive); + + procedure Damage_Zone + (This : in out Table; + Row_Top : in Positive; + Column_Left : in Positive; + Row_Bottom : in Positive; + Column_Right : in Positive; + Reach_Row : in Positive := 1; + Reach_Column : in Positive := 1); + + procedure Cell_Dimensions + (This : in Table; + Context : in Table_Context; + Row, Column : in Positive; + X, Y, W, H : out Integer); + + procedure Bounding_Region + (This : in Table; + Context : in Table_Context; + X, Y, W, H : out Integer); + + procedure Row_Column_Clamp + (This : in Table; + Context : in Table_Context; + Row, Column : in out Integer); + + function Row_Column_Clamp + (This : in Table; + Context : in Table_Context; + Row, Column : in out Integer) + return Boolean; + + function Handle + (This : in out Table; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Table is new Group with record + Horizon, Vertigo : aliased Valuators.Sliders.Scrollbars.Scrollbar; + Playing_Area : aliased Scrolls.Scroll; + Draw_Cell_Ptr : System.Address; + end record; + + overriding procedure Initialize + (This : in out Table); + + overriding procedure Finalize + (This : in out Table); + + procedure Extra_Init + (This : in out Table; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Table); + + + function To_Cint + (Context : in Table_Context) + return Interfaces.C.int; + + function To_Context + (Value : in Interfaces.C.int) + return Table_Context; + + + pragma Inline (H_Bar); + pragma Inline (V_Bar); + pragma Inline (Scroll_Area); + + pragma Inline (Add); + pragma Inline (Insert); + pragma Inline (Remove); + + pragma Inline (Has_Child); + pragma Inline (Find); + pragma Inline (Number_Of_Children); + pragma Inline (Used_As_Container); + + pragma Inline (Begin_Current); + pragma Inline (End_Current); + + pragma Inline (Set_Callback); + pragma Inline (Callback_Column); + pragma Inline (Callback_Row); + pragma Inline (Callback_Context); + pragma Inline (Do_Callback); + pragma Inline (Set_When); + pragma Inline (Scroll_Callback); + + pragma Inline (Column_Headers_Enabled); + pragma Inline (Set_Column_Headers); + pragma Inline (Get_Column_Header_Color); + pragma Inline (Set_Column_Header_Color); + pragma Inline (Get_Column_Header_Height); + pragma Inline (Set_Column_Header_Height); + pragma Inline (Get_Column_Width); + pragma Inline (Set_Column_Width); + pragma Inline (Set_All_Columns_Width); + pragma Inline (Get_Columns); + pragma Inline (Set_Columns); + pragma Inline (Get_Column_Position); + pragma Inline (Set_Column_Position); + pragma Inline (Get_Column_Scroll_Position); + pragma Inline (Column_Resize_Allowed); + pragma Inline (Set_Column_Resize); + pragma Inline (Get_Column_Resize_Minimum); + pragma Inline (Set_Column_Resize_Minimum); + + pragma Inline (Row_Headers_Enabled); + pragma Inline (Set_Row_Headers); + pragma Inline (Get_Row_Header_Color); + pragma Inline (Set_Row_Header_Color); + pragma Inline (Get_Row_Header_Width); + pragma Inline (Set_Row_Header_Width); + pragma Inline (Get_Row_Height); + pragma Inline (Set_Row_Height); + pragma Inline (Set_All_Rows_Height); + pragma Inline (Get_Rows); + pragma Inline (Set_Rows); + pragma Inline (Get_Row_Position); + pragma Inline (Set_Row_Position); + pragma Inline (Get_Row_Scroll_Position); + pragma Inline (Row_Resize_Allowed); + pragma Inline (Set_Row_Resize); + pragma Inline (Get_Row_Resize_Minimum); + pragma Inline (Set_Row_Resize_Minimum); + pragma Inline (Get_Top_Row); + pragma Inline (Set_Top_Row); + + pragma Inline (Set_Cursor_Kind); + pragma Inline (Set_Selection); + pragma Inline (Is_Selected); + pragma Inline (Move_Cursor); + pragma Inline (Get_Tab_Mode); + pragma Inline (Set_Tab_Mode); + pragma Inline (Get_Table_Box); + pragma Inline (Set_Table_Box); + + pragma Inline (Get_Scrollbar_Size); + pragma Inline (Set_Scrollbar_Size); + pragma Inline (Resize); + pragma Inline (Is_Interactive_Resize); + pragma Inline (Reset_Sizes); + pragma Inline (Recalculate_Dimensions); + pragma Inline (Table_Resized); + pragma Inline (Table_Scrolled); + + pragma Inline (Draw); + pragma Inline (Redraw_Range); + pragma Inline (Damage_Zone); + pragma Inline (Cell_Dimensions); + pragma Inline (Bounding_Region); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Tables; + + diff --git a/spec/fltk-widgets-groups-text_displays-text_editors.ads b/spec/fltk-widgets-groups-text_displays-text_editors.ads new file mode 100644 index 0000000..641395b --- /dev/null +++ b/spec/fltk-widgets-groups-text_displays-text_editors.ads @@ -0,0 +1,577 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Containers.Vectors; + +private with + + Interfaces.C; + + +package FLTK.Widgets.Groups.Text_Displays.Text_Editors is + + + type Text_Editor is new Text_Display with private; + + type Text_Editor_Reference (Data : not null access Text_Editor'Class) is + limited null record with Implicit_Dereference => Data; + + type Insert_Mode is (Before, After); + + type Tab_Navigation is (Insert_Char, Widget_Focus); + + type Key_Func is access procedure + (This : in out Text_Editor'Class); + + type Default_Key_Func is access procedure + (This : in out Text_Editor'Class; + Key : in Key_Combo); + + type Key_Binding is record + Key : Key_Combo; + Func : Key_Func; + end record; + + type Key_Binding_Array is array (Positive range <>) of Key_Binding; + + package Key_Binding_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Key_Binding); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Editor; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Editor; + + end Forge; + + + + + -- Default Key Function -- + + procedure KF_Default + (This : in out Text_Editor'Class; + Key : in Key_Combo); + + + + + -- Operation Key Functions -- + + procedure KF_Undo + (This : in out Text_Editor'Class); + + procedure KF_Cut + (This : in out Text_Editor'Class); + + procedure KF_Copy + (This : in out Text_Editor'Class); + + procedure KF_Paste + (This : in out Text_Editor'Class); + + procedure KF_Delete + (This : in out Text_Editor'Class); + + procedure KF_Select_All + (This : in out Text_Editor'Class); + + + + + -- Special Key Functions -- + + procedure KF_Backspace + (This : in out Text_Editor'Class); + + procedure KF_Insert + (This : in out Text_Editor'Class); + + procedure KF_Enter + (This : in out Text_Editor'Class); + + procedure KF_Ignore + (This : in out Text_Editor'Class); + + procedure KF_Tab + (This : in out Text_Editor'Class); + + + + + -- Movement Key Functions -- + + procedure KF_Home + (This : in out Text_Editor'Class); + + procedure KF_End + (This : in out Text_Editor'Class); + + procedure KF_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Down + (This : in out Text_Editor'Class); + + procedure KF_Left + (This : in out Text_Editor'Class); + + procedure KF_Right + (This : in out Text_Editor'Class); + + procedure KF_Up + (This : in out Text_Editor'Class); + + + + + -- Shift Key Functions -- + + procedure KF_Shift_Home + (This : in out Text_Editor'Class); + + procedure KF_Shift_End + (This : in out Text_Editor'Class); + + procedure KF_Shift_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Shift_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Shift_Down + (This : in out Text_Editor'Class); + + procedure KF_Shift_Left + (This : in out Text_Editor'Class); + + procedure KF_Shift_Right + (This : in out Text_Editor'Class); + + procedure KF_Shift_Up + (This : in out Text_Editor'Class); + + + + + -- Control Key Functions -- + + procedure KF_Ctrl_Home + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_End + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Down + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Left + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Right + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Up + (This : in out Text_Editor'Class); + + + + + -- Control Shift Key Functions -- + + procedure KF_Ctrl_Shift_Home + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_End + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Down + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Left + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Right + (This : in out Text_Editor'Class); + + procedure KF_Ctrl_Shift_Up + (This : in out Text_Editor'Class); + + + + + -- Meta Key Functions -- + + procedure KF_Meta_Home + (This : in out Text_Editor'Class); + + procedure KF_Meta_End + (This : in out Text_Editor'Class); + + procedure KF_Meta_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Meta_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Meta_Down + (This : in out Text_Editor'Class); + + procedure KF_Meta_Left + (This : in out Text_Editor'Class); + + procedure KF_Meta_Right + (This : in out Text_Editor'Class); + + procedure KF_Meta_Up + (This : in out Text_Editor'Class); + + + + + -- Meta Shift Key Functions -- + + procedure KF_Meta_Shift_Home + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_End + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Page_Down + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Page_Up + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Down + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Left + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Right + (This : in out Text_Editor'Class); + + procedure KF_Meta_Shift_Up + (This : in out Text_Editor'Class); + + + + + -- Default / Global Key Bindings -- + + Default_Key_Bindings : constant Key_Binding_Array := + ((Mod_None + Escape_Key, KF_Ignore'Access), + (Mod_None + Enter_Key, KF_Enter'Access), + (Mod_None + Keypad_Enter_Key, KF_Enter'Access), + (Mod_None + Backspace_Key, KF_Backspace'Access), + (Mod_None + Insert_Key, KF_Insert'Access), + (Mod_None + Tab_Key, KF_Tab'Access), + + (Mod_None + Delete_Key, KF_Delete'Access), + (Mod_Command + 'c', KF_Copy'Access), + (Mod_Command + 'v', KF_Paste'Access), + (Mod_Command + 'x', KF_Cut'Access), + (Mod_Command + 'z', KF_Undo'Access), + (Mod_Command + 'a', KF_Select_All'Access), + + -- Ctrl+'/' Shift+Del Ctrl+Insert Shift+Insert all intentionally absent + + (Mod_None + Home_Key, KF_Home'Access), + (Mod_None + End_Key, KF_End'Access), + (Mod_None + Page_Down_Key, KF_Page_Down'Access), + (Mod_None + Page_Up_Key, KF_Page_Up'Access), + (Mod_None + Down_Key, KF_Down'Access), + (Mod_None + Left_Key, KF_Left'Access), + (Mod_None + Right_Key, KF_Right'Access), + (Mod_None + Up_Key, KF_Up'Access), + + (Mod_Shift + Home_Key, KF_Shift_Home'Access), + (Mod_Shift + End_Key, KF_Shift_End'Access), + (Mod_Shift + Page_Down_Key, KF_Shift_Page_Down'Access), + (Mod_Shift + Page_Up_Key, KF_Shift_Page_Up'Access), + (Mod_Shift + Down_Key, KF_Shift_Down'Access), + (Mod_Shift + Left_Key, KF_Shift_Left'Access), + (Mod_Shift + Right_Key, KF_Shift_Right'Access), + (Mod_Shift + Up_Key, KF_Shift_Up'Access), + + (Mod_Ctrl + Home_Key, KF_Ctrl_Home'Access), + (Mod_Ctrl + End_Key, KF_Ctrl_End'Access), + (Mod_Ctrl + Page_Down_Key, KF_Ctrl_Page_Down'Access), + (Mod_Ctrl + Page_Up_Key, KF_Ctrl_Page_Up'Access), + (Mod_Ctrl + Down_Key, KF_Ctrl_Down'Access), + (Mod_Ctrl + Left_Key, KF_Ctrl_Left'Access), + (Mod_Ctrl + Right_Key, KF_Ctrl_Right'Access), + (Mod_Ctrl + Up_Key, KF_Ctrl_Up'Access), + + (Mod_Ctrl + Mod_Shift + Home_Key, KF_Ctrl_Shift_Home'Access), + (Mod_Ctrl + Mod_Shift + End_Key, KF_Ctrl_Shift_End'Access), + (Mod_Ctrl + Mod_Shift + Page_Down_Key, KF_Ctrl_Shift_Page_Down'Access), + (Mod_Ctrl + Mod_Shift + Page_Up_Key, KF_Ctrl_Shift_Page_Up'Access), + (Mod_Ctrl + Mod_Shift + Down_Key, KF_Ctrl_Shift_Down'Access), + (Mod_Ctrl + Mod_Shift + Left_Key, KF_Ctrl_Shift_Left'Access), + (Mod_Ctrl + Mod_Shift + Right_Key, KF_Ctrl_Shift_Right'Access), + (Mod_Ctrl + Mod_Shift + Up_Key, KF_Ctrl_Shift_Up'Access), + + (Mod_Meta + Home_Key, KF_Meta_Home'Access), + (Mod_Meta + End_Key, KF_Meta_End'Access), + (Mod_Meta + Page_Down_Key, KF_Meta_Page_Down'Access), + (Mod_Meta + Page_Up_Key, KF_Meta_Page_Up'Access), + (Mod_Meta + Down_Key, KF_Meta_Down'Access), + (Mod_Meta + Left_Key, KF_Meta_Left'Access), + (Mod_Meta + Right_Key, KF_Meta_Right'Access), + (Mod_Meta + Up_Key, KF_Meta_Up'Access), + + (Mod_Meta + Mod_Shift + Home_Key, KF_Meta_Shift_Home'Access), + (Mod_Meta + Mod_Shift + End_Key, KF_Meta_Shift_End'Access), + (Mod_Meta + Mod_Shift + Page_Down_Key, KF_Meta_Shift_Page_Down'Access), + (Mod_Meta + Mod_Shift + Page_Up_Key, KF_Meta_Shift_Page_Up'Access), + (Mod_Meta + Mod_Shift + Down_Key, KF_Meta_Shift_Down'Access), + (Mod_Meta + Mod_Shift + Left_Key, KF_Meta_Shift_Left'Access), + (Mod_Meta + Mod_Shift + Right_Key, KF_Meta_Shift_Right'Access), + (Mod_Meta + Mod_Shift + Up_Key, KF_Meta_Shift_Up'Access)); + + + Global_Key_Bindings : Key_Binding_Vectors.Vector; + + + + + -- Key Binding Modification -- + + procedure Add_Key_Binding + (This : in out Text_Editor; + Key : in Key_Combo; + Func : in Key_Func); + + procedure Add_Key_Binding + (This : in out Text_Editor; + Bind : in Key_Binding); + + procedure Add_Key_Bindings + (This : in out Text_Editor; + Bind : in Key_Binding_Array); + + function Get_Bound_Key_Function + (This : in Text_Editor; + Key : in Key_Combo) + return Key_Func; + + function Get_All_Bound_Key_Functions + (This : in Text_Editor) + return Key_Binding_Array; + + procedure Remove_Key_Binding + (This : in out Text_Editor; + Key : in Key_Combo); + + procedure Remove_Key_Binding + (This : in out Text_Editor; + Bind : in Key_Binding); + + procedure Remove_Key_Bindings + (This : in out Text_Editor; + Bind : in Key_Binding_Array); + + procedure Remove_All_Key_Bindings + (This : in out Text_Editor); + + function Get_Default_Key_Function + (This : in Text_Editor) + return Default_Key_Func; + + procedure Set_Default_Key_Function + (This : in out Text_Editor; + Func : in Default_Key_Func); + + + + + -- Settings -- + + function Get_Insert_Mode + (This : in Text_Editor) + return Insert_Mode; + + procedure Set_Insert_Mode + (This : in out Text_Editor; + To : in Insert_Mode); + + function Get_Tab_Mode + (This : in Text_Editor) + return Tab_Navigation; + + procedure Set_Tab_Mode + (This : in out Text_Editor; + To : in Tab_Navigation); + + + + + -- Events -- + + function Handle + (This : in out Text_Editor; + Event : in Event_Kind) + return Event_Outcome; + + function Handle_Key + (This : in out Text_Editor) + return Event_Outcome; + + procedure Maybe_Do_Callback + (This : in out Text_Editor); + + +private + + + type Text_Editor is new Text_Display with record + Bindings : Key_Binding_Vectors.Vector; + Default_Func : Default_Key_Func; + end record; + + overriding procedure Initialize + (This : in out Text_Editor); + + overriding procedure Finalize + (This : in out Text_Editor); + + procedure Extra_Init + (This : in out Text_Editor; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Text_Editor); + + + function Key_Func_Hook + (K : in Interfaces.C.int; + E : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Convention (C, Key_Func_Hook); + + + package Editor_Convert is new System.Address_To_Access_Conversions (Text_Editor'Class); + + + pragma Inline (KF_Default); + + pragma Inline (KF_Undo); + pragma Inline (KF_Cut); + pragma Inline (KF_Copy); + pragma Inline (KF_Paste); + pragma Inline (KF_Delete); + pragma Inline (KF_Select_All); + + pragma Inline (KF_Backspace); + pragma Inline (KF_Insert); + pragma Inline (KF_Enter); + pragma Inline (KF_Ignore); + pragma Inline (KF_Tab); + + pragma Inline (KF_Home); + pragma Inline (KF_End); + pragma Inline (KF_Page_Down); + pragma Inline (KF_Page_Up); + pragma Inline (KF_Down); + pragma Inline (KF_Left); + pragma Inline (KF_Right); + pragma Inline (KF_Up); + + pragma Inline (KF_Shift_Home); + pragma Inline (KF_Shift_End); + pragma Inline (KF_Shift_Page_Down); + pragma Inline (KF_Shift_Page_Up); + pragma Inline (KF_Shift_Down); + pragma Inline (KF_Shift_Left); + pragma Inline (KF_Shift_Right); + pragma Inline (KF_Shift_Up); + + pragma Inline (KF_Ctrl_Home); + pragma Inline (KF_Ctrl_End); + pragma Inline (KF_Ctrl_Page_Down); + pragma Inline (KF_Ctrl_Page_Up); + pragma Inline (KF_Ctrl_Down); + pragma Inline (KF_Ctrl_Left); + pragma Inline (KF_Ctrl_Right); + pragma Inline (KF_Ctrl_Up); + + pragma Inline (KF_Ctrl_Shift_Home); + pragma Inline (KF_Ctrl_Shift_End); + pragma Inline (KF_Ctrl_Shift_Page_Down); + pragma Inline (KF_Ctrl_Shift_Page_Up); + pragma Inline (KF_Ctrl_Shift_Down); + pragma Inline (KF_Ctrl_Shift_Left); + pragma Inline (KF_Ctrl_Shift_Right); + pragma Inline (KF_Ctrl_Shift_Up); + + pragma Inline (KF_Meta_Home); + pragma Inline (KF_Meta_End); + pragma Inline (KF_Meta_Page_Down); + pragma Inline (KF_Meta_Page_Up); + pragma Inline (KF_Meta_Down); + pragma Inline (KF_Meta_Left); + pragma Inline (KF_Meta_Right); + pragma Inline (KF_Meta_Up); + + pragma Inline (KF_Meta_Shift_Home); + pragma Inline (KF_Meta_Shift_End); + pragma Inline (KF_Meta_Shift_Page_Down); + pragma Inline (KF_Meta_Shift_Page_Up); + pragma Inline (KF_Meta_Shift_Down); + pragma Inline (KF_Meta_Shift_Left); + pragma Inline (KF_Meta_Shift_Right); + pragma Inline (KF_Meta_Shift_Up); + + pragma Inline (Add_Key_Binding); + pragma Inline (Remove_All_Key_Bindings); + pragma Inline (Get_Default_Key_Function); + pragma Inline (Set_Default_Key_Function); + + pragma Inline (Get_Insert_Mode); + pragma Inline (Set_Insert_Mode); + pragma Inline (Get_Tab_Mode); + pragma Inline (Set_Tab_Mode); + + pragma Inline (Handle); + pragma Inline (Handle_Key); + pragma Inline (Maybe_Do_Callback); + + +end FLTK.Widgets.Groups.Text_Displays.Text_Editors; + + diff --git a/spec/fltk-widgets-groups-text_displays.ads b/spec/fltk-widgets-groups-text_displays.ads new file mode 100644 index 0000000..c057ce0 --- /dev/null +++ b/spec/fltk-widgets-groups-text_displays.ads @@ -0,0 +1,858 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Text_Buffers; + +private with + + Interfaces.C, + System.Address_To_Access_Conversions; + + +package FLTK.Widgets.Groups.Text_Displays is + + + type Text_Display is new Group with private; + + type Text_Display_Reference (Data : not null access Text_Display'Class) is + limited null record with Implicit_Dereference => Data; + + type Wrap_Mode is (None, Column, Pixel, Bounds); + + type Cursor_Style is (Normal, Caret, Dim, Block, Heavy, Simple); + + type Position_Kind is (Cursor_Position, Character_Position); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Display; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Display; + + end Forge; + + + + + package Styles is + + type Style_Entry is record + Hue : Color; + Font : Font_Kind; + Size : Font_Size; + end record; + + type Style_Index is new Character range 'A' .. '~'; + + type Style_Array is array (Style_Index range <>) of Style_Entry; + + type Unfinished_Style_Callback is access procedure + (Char : in Character; + Display : in out Text_Display); + + type Style_Mask is record + Fill : Boolean := False; + Secondary : Boolean := False; + Primary : Boolean := False; + Highlight : Boolean := False; + Background : Boolean := False; + Text_Only : Boolean := False; + end record; + + Empty_Mask : constant Style_Mask; + + type Style_Info is record + Mask : Style_Mask; + Index : Style_Index; + end record; + + private + + for Style_Entry use record + Hue at 1 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.unsigned'Size - 1; + Font at 2 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.int'Size - 1; + Size at 3 * Interfaces.C.unsigned'Size / System.Storage_Unit + range 0 .. Interfaces.C.int'Size - 1; + end record; + + for Style_Entry'Size use Interfaces.C.unsigned'Size * 3 + Interfaces.C.int'Size; + + for Style_Mask use record + Fill at 0 range 0 .. 0; + Secondary at 0 range 1 .. 1; + Primary at 0 range 2 .. 2; + Highlight at 0 range 3 .. 3; + Background at 0 range 4 .. 4; + Text_Only at 0 range 5 .. 5; + end record; + + for Style_Mask'Size use Interfaces.C.unsigned_char'Size; + + Empty_Mask : constant Style_Mask := (others => False); + + pragma Convention (C, Style_Entry); + pragma Convention (C, Style_Array); + + end Styles; + + + + + -- Buffers -- + + function Get_Buffer + (This : in Text_Display) + return FLTK.Text_Buffers.Text_Buffer_Reference; + + procedure Set_Buffer + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer); + + procedure Buffer_Modified_Callback + (This : in out Text_Display; + Action : in FLTK.Text_Buffers.Modification; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural; + Deleted_Text : in String); + + procedure Buffer_Predelete_Callback + (This : in out Text_Display; + Place : in FLTK.Text_Buffers.Position; + Length : in Natural); + + + + + -- Highlighting -- + + procedure Highlight_Data + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer; + Table : in Styles.Style_Array); + + procedure Highlight_Data + (This : in out Text_Display; + Buff : in out FLTK.Text_Buffers.Text_Buffer; + Table : in Styles.Style_Array; + Unfinished : in Character; + Callback : in Styles.Unfinished_Style_Callback); + + function Position_Style + (This : in Text_Display; + Line_Start : in Natural; + Line_Length : in Natural; + Line_Index : in Natural) + return Styles.Style_Info; + + + + + -- Measurement Conversion -- + + function Col_To_X + (This : in Text_Display; + Col_Num : in Integer) + return Integer; + + function X_To_Col + (This : in Text_Display; + X_Pos : in Integer) + return Integer; + + function In_Selection + (This : in Text_Display; + X, Y : in Integer) + return Boolean; + + procedure Position_To_XY + (This : in Text_Display; + Pos : in Integer; + X, Y : out Integer; + Vert_Out : out Boolean); + + procedure Find_Line_End + (This : in Text_Display; + Start : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Line_End : out Natural; + Next_Line_Start : out Natural); + + function Find_Character + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index; + X : in Integer) + return Natural; + + function Position_To_Line + (This : in Text_Display; + Position : in Natural) + return Natural; + + function Position_To_Line + (This : in Text_Display; + Position : in Natural; + Displayed : out Boolean) + return Natural; + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural); + + procedure Position_To_Line_Column + (This : in Text_Display; + Position : in Natural; + Line : out Natural; + Column : out Natural; + Displayed : out Boolean); + + function XY_To_Position + (This : in Text_Display; + X, Y : in Integer; + Kind : in Position_Kind := Character_Position) + return Natural; + + procedure XY_To_Row_Column + (This : in Text_Display; + X, Y : in Integer; + Row, Column : out Natural; + Kind : in Position_Kind := Character_Position); + + + + + -- Cursors -- + + function Get_Cursor_Color + (This : in Text_Display) + return Color; + + procedure Set_Cursor_Color + (This : in out Text_Display; + Col : in Color); + + procedure Set_Cursor_Style + (This : in out Text_Display; + Style : in Cursor_Style); + + procedure Hide_Cursor + (This : in out Text_Display); + + procedure Show_Cursor + (This : in out Text_Display); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Text_Display) + return Color; + + procedure Set_Text_Color + (This : in out Text_Display; + Col : in Color); + + function Get_Text_Font + (This : in Text_Display) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Text_Display; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Text_Display) + return Font_Size; + + procedure Set_Text_Size + (This : in out Text_Display; + Size : in Font_Size); + + + + + -- Text Insert -- + + procedure Insert_Text + (This : in out Text_Display; + Item : in String); + + procedure Overstrike + (This : in out Text_Display; + Text : in String); + + function Get_Insert_Position + (This : in Text_Display) + return Natural; + + procedure Set_Insert_Position + (This : in out Text_Display; + Pos : in Natural); + + procedure Show_Insert_Position + (This : in out Text_Display); + + + + + -- Words -- + + function Word_Start + (This : in out Text_Display; + Pos : in Natural) + return Natural; + + function Word_End + (This : in out Text_Display; + Pos : in Natural) + return Natural; + + procedure Next_Word + (This : in out Text_Display); + + procedure Previous_Word + (This : in out Text_Display); + + + + + -- Wrapping -- + + procedure Set_Wrap_Mode + (This : in out Text_Display; + Mode : in Wrap_Mode; + Margin : in Natural := 0); + + function Wrapped_Row + (This : in Text_Display; + Row : in Natural) + return Natural; + + function Wrapped_Column + (This : in Text_Display; + Row, Column : in Natural) + return Natural; + + function Wrap_Uses_Character + (This : in Text_Display; + Line_End : in Natural) + return Boolean; + + procedure Count_Wrapped_Lines + (This : in Text_Display; + Buffer : in FLTK.Text_Buffers.Text_Buffer; + Start : in Natural; + Max_Position, Max_Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean; + Style_Offset : in Natural; + Finish, Line_Count : out Natural; + End_Count_Line_Start : out Natural; + Last_Line_End : out Natural; + Count_Last_Missing_Newline : in Boolean := True); + + + + + -- Lines -- + + -- Takes into account word wrap + function Line_Start + (This : in Text_Display; + Pos : in Natural) + return Natural; + + -- Takes into account word wrap + function Line_End + (This : in Text_Display; + Pos : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural; + + function Count_Lines + (This : in Text_Display; + Start, Finish : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural; + + -- Takes into account word wrap as well as newline characters + function Skip_Lines + (This : in Text_Display; + Start, Lines : in Natural; + Start_Pos_Is_Line_Start : in Boolean := False) + return Natural; + + -- Takes into account word wrap as well as newline characters + function Rewind_Lines + (This : in Text_Display; + Start, Lines : in Natural) + return Natural; + + procedure Calculate_Last_Character + (This : in out Text_Display); + + procedure Calculate_Line_Starts + (This : in out Text_Display; + Start, Finish : in Natural); + + procedure Offset_Line_Starts + (This : in out Text_Display; + New_Top : in Natural); + + + + + -- Absolute Lines -- + + procedure Redo_Absolute_Top_Line + (This : in out Text_Display; + Old_First : in Natural); + + function Get_Absolute_Top_Line + (This : in Text_Display) + return Natural; + + procedure Maintain_Absolute_Top_Line + (This : in out Text_Display; + State : in Boolean := True); + + function Maintaining_Absolute_Top_Line + (This : in Text_Display) + return Boolean; + + procedure Reset_Absolute_Top_Line + (This : in out Text_Display); + + + + + -- Visible Lines -- + + function Has_Empty_Visible_Lines + (This : in Text_Display) + return Boolean; + + function Get_Longest_Visible_Line + (This : in Text_Display) + return Natural; + + function Visible_Line_Length + (This : in Text_Display; + Line : in Natural) + return Natural; + + + + + -- Line Numbers -- + + function Get_Linenumber_Alignment + (This : in Text_Display) + return Alignment; + + procedure Set_Linenumber_Alignment + (This : in out Text_Display; + To : in Alignment); + + function Get_Linenumber_Back_Color + (This : in Text_Display) + return Color; + + procedure Set_Linenumber_Back_Color + (This : in out Text_Display; + To : in Color); + + function Get_Linenumber_Fore_Color + (This : in Text_Display) + return Color; + + procedure Set_Linenumber_Fore_Color + (This : in out Text_Display; + To : in Color); + + function Get_Linenumber_Font + (This : in Text_Display) + return Font_Kind; + + procedure Set_Linenumber_Font + (This : in out Text_Display; + To : in Font_Kind); + + function Get_Linenumber_Size + (This : in Text_Display) + return Font_Size; + + procedure Set_Linenumber_Size + (This : in out Text_Display; + To : in Font_Size); + + function Get_Linenumber_Width + (This : in Text_Display) + return Natural; + + procedure Set_Linenumber_Width + (This : in out Text_Display; + Width : in Natural); + + function Get_Linenumber_Format + (This : in Text_Display) + return String; + + procedure Set_Linenumber_Format + (This : in out Text_Display; + Value : in String); + + + + + -- Text Measurement -- + + function Measure_Character + (This : in Text_Display; + Text : in String; + X : in Integer; + Index : in Positive) + return Long_Float; + + function Measure_Visible_Line + (This : in Text_Display; + Line : in Natural) + return Natural; + + function Measure_String + (This : in Text_Display; + Text : in String; + Style : in Styles.Style_Index) + return Long_Float; + + + + + -- Movement -- + + procedure Move_Down + (This : in out Text_Display); + + function Move_Down + (This : in out Text_Display) + return Boolean; + + procedure Move_Left + (This : in out Text_Display); + + function Move_Left + (This : in out Text_Display) + return Boolean; + + procedure Move_Right + (This : in out Text_Display); + + function Move_Right + (This : in out Text_Display) + return Boolean; + + procedure Move_Up + (This : in out Text_Display); + + function Move_Up + (This : in out Text_Display) + return Boolean; + + + + + -- Scrolling -- + + procedure Scroll_To + (This : in out Text_Display; + Line : in Natural; + Column : in Natural := 0); + + function Scroll_To + (This : in out Text_Display; + Line : in Natural; + Pixel : in Natural := 0) + return Boolean; + + function Get_Scrollbar_Alignment + (This : in Text_Display) + return Alignment; + + procedure Set_Scrollbar_Alignment + (This : in out Text_Display; + Align : in Alignment); + + function Get_Scrollbar_Width + (This : in Text_Display) + return Natural; + + procedure Set_Scrollbar_Width + (This : in out Text_Display; + Width : in Natural); + + procedure Update_Horizontal_Scrollbar + (This : in out Text_Display); + + procedure Update_Vertical_Scrollbar + (This : in out Text_Display); + + + + + -- Shortcuts -- + + function Get_Shortcut + (This : in Text_Display) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Text_Display; + Value : in Key_Combo); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Text_Display; + X, Y, W, H : in Integer); + + + + + -- Drawing, Events -- + + procedure Clear_Rect + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y, W, H : in Integer); + + procedure Display_Insert + (This : in out Text_Display); + + procedure Redisplay_Range + (This : in out Text_Display; + Start, Finish : in Natural); + + procedure Draw + (This : in out Text_Display); + + procedure Draw_Cursor + (This : in out Text_Display; + X, Y : in Integer); + + procedure Draw_Line_Numbers + (This : in out Text_Display; + Clear : in Boolean := False); + + procedure Draw_Range + (This : in out Text_Display; + Start, Finish : in Natural); + + procedure Draw_String + (This : in out Text_Display; + Style : in Styles.Style_Info; + X, Y : in Integer; + Right : in Integer; + Text : in String; + Num_Chars : in Natural); + + procedure Draw_Text + (This : in out Text_Display; + X, Y, W, H : in Integer); + + procedure Draw_Visible_Line + (This : in out Text_Display; + Line : in Natural; + Left_Clip, Right_Clip : in Integer; + Left_Char, Right_Char : in Natural); + + function Handle + (This : in out Text_Display; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Text_Display is new Group with + record + Buffer : access FLTK.Text_Buffers.Text_Buffer; + Raw_Buffer : Storage.Integer_Address := Null_Pointer; + Style_Callback : Styles.Unfinished_Style_Callback; + end record; + + overriding procedure Initialize + (This : in out Text_Display); + + overriding procedure Finalize + (This : in out Text_Display); + + procedure Extra_Init + (This : in out Text_Display; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Text_Display) + with Inline; + + + package Text_Display_Convert is new System.Address_To_Access_Conversions (Text_Display'Class); + + + -- Adds some basic reference counting on the C side to help ensure any Text_Buffers + -- do not get deallocated before all Text_Displays they might be attached to. + procedure upref_fl_text_buffer + (TB : in Storage.Integer_Address); + pragma Import (C, upref_fl_text_buffer, "upref_fl_text_buffer"); + pragma Inline (upref_fl_text_buffer); + + procedure free_fl_text_buffer + (TB : in Storage.Integer_Address); + pragma Import (C, free_fl_text_buffer, "free_fl_text_buffer"); + pragma Inline (free_fl_text_buffer); + + + pragma Inline (Get_Buffer); + pragma Inline (Set_Buffer); + pragma Inline (Buffer_Predelete_Callback); + + pragma Inline (Highlight_Data); + + pragma Inline (Col_To_X); + pragma Inline (X_To_Col); + pragma Inline (In_Selection); + pragma Inline (Position_To_XY); + pragma Inline (Find_Line_End); + pragma Inline (Find_Character); + pragma Inline (Position_To_Line); + pragma Inline (Position_To_Line_Column); + pragma Inline (XY_To_Position); + pragma Inline (XY_To_Row_Column); + + pragma Inline (Get_Cursor_Color); + pragma Inline (Set_Cursor_Color); + pragma Inline (Set_Cursor_Style); + pragma Inline (Hide_Cursor); + pragma Inline (Show_Cursor); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Insert_Text); + pragma Inline (Overstrike); + pragma Inline (Get_Insert_Position); + pragma Inline (Set_Insert_Position); + pragma Inline (Show_Insert_Position); + + pragma Inline (Word_Start); + pragma Inline (Word_End); + pragma Inline (Next_Word); + pragma Inline (Previous_Word); + + pragma Inline (Set_Wrap_Mode); + pragma Inline (Wrapped_Row); + pragma Inline (Wrapped_Column); + pragma Inline (Wrap_Uses_Character); + pragma Inline (Count_Wrapped_Lines); + + pragma Inline (Line_Start); + pragma Inline (Line_End); + pragma Inline (Count_Lines); + pragma Inline (Skip_Lines); + pragma Inline (Rewind_Lines); + pragma Inline (Calculate_Last_Character); + pragma Inline (Calculate_Line_Starts); + pragma Inline (Offset_Line_Starts); + + pragma Inline (Redo_Absolute_Top_Line); + pragma Inline (Get_Absolute_Top_Line); + pragma Inline (Maintain_Absolute_Top_Line); + pragma Inline (Maintaining_Absolute_Top_Line); + pragma Inline (Reset_Absolute_Top_Line); + + pragma Inline (Has_Empty_Visible_Lines); + pragma Inline (Get_Longest_Visible_Line); + pragma Inline (Visible_Line_Length); + + pragma Inline (Get_Linenumber_Alignment); + pragma Inline (Set_Linenumber_Alignment); + pragma Inline (Get_Linenumber_Back_Color); + pragma Inline (Set_Linenumber_Back_Color); + pragma Inline (Get_Linenumber_Fore_Color); + pragma Inline (Set_Linenumber_Fore_Color); + pragma Inline (Get_Linenumber_Font); + pragma Inline (Set_Linenumber_Font); + pragma Inline (Get_Linenumber_Size); + pragma Inline (Set_Linenumber_Size); + pragma Inline (Get_Linenumber_Width); + pragma Inline (Set_Linenumber_Width); + pragma Inline (Get_Linenumber_Format); + pragma Inline (Set_Linenumber_Format); + + pragma Inline (Measure_Character); + pragma Inline (Measure_Visible_Line); + pragma Inline (Measure_String); + + pragma Inline (Move_Down); + pragma Inline (Move_Left); + pragma Inline (Move_Right); + pragma Inline (Move_Up); + + pragma Inline (Scroll_To); + pragma Inline (Get_Scrollbar_Alignment); + pragma Inline (Set_Scrollbar_Alignment); + pragma Inline (Get_Scrollbar_Width); + pragma Inline (Set_Scrollbar_Width); + pragma Inline (Update_Horizontal_Scrollbar); + pragma Inline (Update_Vertical_Scrollbar); + + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + + pragma Inline (Resize); + + pragma Inline (Clear_Rect); + pragma Inline (Display_Insert); + pragma Inline (Redisplay_Range); + pragma Inline (Draw); + pragma Inline (Draw_Cursor); + pragma Inline (Draw_Line_Numbers); + pragma Inline (Draw_Range); + pragma Inline (Draw_String); + pragma Inline (Draw_Text); + pragma Inline (Draw_Visible_Line); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Text_Displays; + + diff --git a/spec/fltk-widgets-groups-tiled.ads b/spec/fltk-widgets-groups-tiled.ads new file mode 100644 index 0000000..43c7d51 --- /dev/null +++ b/spec/fltk-widgets-groups-tiled.ads @@ -0,0 +1,88 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Tiled is + + + type Tiled_Group is new Group with private; + + type Tiled_Group_Reference (Data : not null access Tiled_Group'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Tiled_Group; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Tiled_Group; + + end Forge; + + + + + -- Dimensions -- + + procedure Position + (This : in out Tiled_Group; + Old_X, Old_Y : in Integer; + New_X, New_Y : in Integer); + + procedure Resize + (This : in out Tiled_Group; + X, Y, W, H : in Integer); + + + + + -- Events -- + + function Handle + (This : in out Tiled_Group; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Tiled_Group is new Group with null record; + + overriding procedure Initialize + (This : in out Tiled_Group); + + overriding procedure Finalize + (This : in out Tiled_Group); + + procedure Extra_Init + (This : in out Tiled_Group; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Tiled_Group) + with Inline; + + + pragma Inline (Position); + pragma Inline (Resize); + + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Tiled; + + diff --git a/spec/fltk-widgets-groups-windows-double-cairo.ads b/spec/fltk-widgets-groups-windows-double-cairo.ads new file mode 100644 index 0000000..a5430c4 --- /dev/null +++ b/spec/fltk-widgets-groups-windows-double-cairo.ads @@ -0,0 +1,119 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + System; + + +package FLTK.Widgets.Groups.Windows.Double.Cairo is + + + -- If FLTK has not been built with Cairo support then + -- this will just be a duplicate of Double_Window and the + -- callback set with Set_Cairo_Draw will never be triggered. + + -- Building with Cairo support requires either of + -- 1. CMake option FLTK_OPTION_CAIRO_WINDOW + -- 2. configure -enable-cairo + -- when building FLTK itself. + + + type Cairo_Window is new Double_Window with private; + + type Cairo_Window_Reference (Data : not null access Cairo_Window'Class) is + limited null record with Implicit_Dereference => Data; + + type Cairo_Callback is access procedure + (This : in out Cairo_Window; + Context : in System.Address); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Cairo_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Cairo_Window; + + function Create + (W, H : in Integer; + Text : in String) + return Cairo_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String) + return Cairo_Window; + + function Create + (W, H : in Integer) + return Cairo_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer) + return Cairo_Window; + + end Forge; + + + + + -- Cairo Callback -- + + procedure Set_Cairo_Draw + (This : in out Cairo_Window; + Func : in Cairo_Callback); + + + + + -- Drawing -- + + procedure Draw + (This : in out Cairo_Window); + + +private + + + type Cairo_Window is new Double_Window with record + My_Func : Cairo_Callback; + end record; + + overriding procedure Initialize + (This : in out Cairo_Window); + + overriding procedure Finalize + (This : in out Cairo_Window); + + procedure Extra_Init + (This : in out Cairo_Window; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Cairo_Window); + + + pragma Inline (Set_Cairo_Draw); + + pragma Inline (Draw); + + +end FLTK.Widgets.Groups.Windows.Double.Cairo; + + diff --git a/spec/fltk-widgets-groups-windows-double-overlay.ads b/spec/fltk-widgets-groups-windows-double-overlay.ads new file mode 100644 index 0000000..a6d271c --- /dev/null +++ b/spec/fltk-widgets-groups-windows-double-overlay.ads @@ -0,0 +1,122 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Windows.Double.Overlay is + + + type Overlay_Window is new Double_Window with private; + + type Overlay_Window_Reference (Data : not null access Overlay_Window'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Overlay_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Overlay_Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return Overlay_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String := "") + return Overlay_Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Overlay_Window); + + procedure Show_With_Args + (This : in out Overlay_Window); + + procedure Hide + (This : in out Overlay_Window); + + procedure Flush + (This : in out Overlay_Window); + + + + + -- Settings -- + + function Can_Do_Overlay + (This : in Overlay_Window) + return Boolean; + + procedure Resize + (This : in out Overlay_Window; + X, Y, W, H : in Integer); + + + + + -- Drawing -- + + -- You must override this subprogram + procedure Draw_Overlay + (This : in out Overlay_Window); + + procedure Redraw_Overlay + (This : in out Overlay_Window); + + +private + + + type Overlay_Window is new Double_Window with null record; + + overriding procedure Initialize + (This : in out Overlay_Window); + + overriding procedure Finalize + (This : in out Overlay_Window); + + procedure Extra_Init + (This : in out Overlay_Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Overlay_Window) + with Inline; + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Hide); + pragma Inline (Flush); + + pragma Inline (Can_Do_Overlay); + pragma Inline (Resize); + + pragma Inline (Redraw_Overlay); + + +end FLTK.Widgets.Groups.Windows.Double.Overlay; + + diff --git a/spec/fltk-widgets-groups-windows-double.ads b/spec/fltk-widgets-groups-windows-double.ads new file mode 100644 index 0000000..f9ccf85 --- /dev/null +++ b/spec/fltk-widgets-groups-windows-double.ads @@ -0,0 +1,107 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Windows.Double is + + + type Double_Window is new Window with private; + + type Double_Window_Reference (Data : not null access Double_Window'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Double_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Double_Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return Double_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String := "") + return Double_Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Double_Window); + + procedure Show_With_Args + (This : in out Double_Window); + + procedure Hide + (This : in out Double_Window); + + procedure Flush + (This : in out Double_Window); + + procedure Flush_All + (This : in out Double_Window); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Double_Window; + X, Y, W, H : in Integer); + + +private + + + type Double_Window is new Window with null record; + + overriding procedure Initialize + (This : in out Double_Window); + + overriding procedure Finalize + (This : in out Double_Window); + + procedure Extra_Init + (This : in out Double_Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Double_Window) + with Inline; + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Hide); + pragma Inline (Flush); + pragma Inline (Flush_All); + + pragma Inline (Resize); + + +end FLTK.Widgets.Groups.Windows.Double; + + diff --git a/spec/fltk-widgets-groups-windows-opengl.ads b/spec/fltk-widgets-groups-windows-opengl.ads new file mode 100644 index 0000000..825df4f --- /dev/null +++ b/spec/fltk-widgets-groups-windows-opengl.ads @@ -0,0 +1,272 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + System; + +private with + + Interfaces.C; + + +package FLTK.Widgets.Groups.Windows.OpenGL is + + + type GL_Window is new Window with private; + + type GL_Window_Reference (Data : not null access GL_Window'Class) is + limited null record with Implicit_Dereference => Data; + + -- RGB mode is achieved by Index being set to False + -- Single buffer mode is achieved by Double being set to False + type Mode_Mask is record + Index : Boolean := False; + Double : Boolean := False; + Accum : Boolean := False; + Alpha : Boolean := False; + Depth : Boolean := False; + Stencil : Boolean := False; + RGB8 : Boolean := False; + Multisample : Boolean := False; + Stereo : Boolean := False; + Fake_Single : Boolean := False; + OpenGL3 : Boolean := False; + end record; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return GL_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return GL_Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return GL_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String := "") + return GL_Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out GL_Window); + + procedure Show_With_Args + (This : in out GL_Window); + + procedure Hide + (This : in out GL_Window); + + procedure Hide_Overlay + (This : in out GL_Window); + + procedure Flush + (This : in out GL_Window); + + + + + -- Dimensions -- + + function Pixel_H + (This : in GL_Window) + return Integer; + + function Pixel_W + (This : in GL_Window) + return Integer; + + function Pixels_Per_Unit + (This : in GL_Window) + return Float; + + procedure Resize + (This : in out GL_Window; + X, Y, W, H : in Integer); + + + + + -- OpenGL Modes -- + + function Get_Mode + (This : in GL_Window) + return Mode_Mask; + + procedure Set_Mode + (This : in out GL_Window; + Mask : in Mode_Mask); + + function Can_Do + (Mask : in Mode_Mask) + return Boolean; + + function Can_Do + (This : in GL_Window) + return Boolean; + + function Can_Do_Overlay + (This : in GL_Window) + return Boolean; + + + + + -- OpenGL Contexts -- + + function Get_Context + (This : in GL_Window) + return System.Address; + + procedure Set_Context + (This : in out GL_Window; + Struct : in System.Address; + Destroy : in Boolean := False); + + function Get_Context_Valid + (This : in GL_Window) + return Boolean; + + procedure Set_Context_Valid + (This : in out GL_Window; + Value : in Boolean); + + function Get_Valid + (This : in GL_Window) + return Boolean; + + procedure Set_Valid + (This : in out GL_Window; + Value : in Boolean); + + procedure Invalidate + (This : in out GL_Window); + + procedure Make_Current + (This : in out GL_Window); + + procedure Make_Overlay_Current + (This : in out GL_Window); + + + + + -- Drawing, Events -- + + procedure Ortho + (This : in out GL_Window); + + procedure Redraw_Overlay + (This : in out GL_Window); + + procedure Swap_Buffers + (This : in out GL_Window); + + procedure Draw + (This : in out GL_Window); + + function Handle + (This : in out GL_Window; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type GL_Window is new Window with null record; + + overriding procedure Initialize + (This : in out GL_Window); + + overriding procedure Finalize + (This : in out GL_Window); + + procedure Extra_Init + (This : in out GL_Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out GL_Window) + with Inline; + + + for Mode_Mask use record + Index at 0 range 0 .. 0; + Double at 0 range 1 .. 1; + Accum at 0 range 2 .. 2; + Alpha at 0 range 3 .. 3; + Depth at 0 range 4 .. 4; + Stencil at 0 range 5 .. 5; + RGB8 at 0 range 6 .. 6; + Multisample at 0 range 7 .. 7; + Stereo at 0 range 8 .. 8; + Fake_Single at 0 range 9 .. 9; + OpenGL3 at 0 range 10 .. Interfaces.C.unsigned'Size - 1; + end record; + + for Mode_Mask'Size use Interfaces.C.unsigned'Size; + + pragma Convention (C_Pass_By_Copy, Mode_Mask); + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Hide); + pragma Inline (Hide_Overlay); + pragma Inline (Flush); + + pragma Inline (Pixel_H); + pragma Inline (Pixel_W); + pragma Inline (Pixels_Per_Unit); + + pragma Inline (Get_Mode); + pragma Inline (Set_Mode); + pragma Inline (Can_Do); + pragma Inline (Can_Do_Overlay); + + pragma Inline (Get_Context); + pragma Inline (Set_Context); + pragma Inline (Get_Context_Valid); + pragma Inline (Set_Context_Valid); + pragma Inline (Get_Valid); + pragma Inline (Set_Valid); + pragma Inline (Invalidate); + pragma Inline (Make_Current); + pragma Inline (Make_Overlay_Current); + + pragma Inline (Ortho); + pragma Inline (Redraw_Overlay); + pragma Inline (Swap_Buffers); + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups.Windows.OpenGL; + + diff --git a/spec/fltk-widgets-groups-windows-single-menu.ads b/spec/fltk-widgets-groups-windows-single-menu.ads new file mode 100644 index 0000000..c9dd1ea --- /dev/null +++ b/spec/fltk-widgets-groups-windows-single-menu.ads @@ -0,0 +1,112 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Windows.Single.Menu is + + + type Menu_Window is new Single_Window with private; + + type Menu_Window_Reference (Data : not null access Menu_Window'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return Menu_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String := "") + return Menu_Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Menu_Window); + + procedure Hide + (This : in out Menu_Window); + + procedure Flush + (This : in out Menu_Window); + + procedure Erase + (This : in out Menu_Window); + + + + + -- Overlay -- + + function Is_Overlay + (This : in Menu_Window) + return Boolean; + + procedure Set_Overlay + (This : in out Menu_Window; + Value : in Boolean := True); + + procedure Clear_Overlay + (This : in out Menu_Window); + + +private + + + type Menu_Window is new Single_Window with null record; + + overriding procedure Initialize + (This : in out Menu_Window); + + overriding procedure Finalize + (This : in out Menu_Window); + + procedure Extra_Init + (This : in out Menu_Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Menu_Window) + with Inline; + + + pragma Inline (Show); + pragma Inline (Hide); + pragma Inline (Flush); + pragma Inline (Erase); + + pragma Inline (Is_Overlay); + pragma Inline (Set_Overlay); + pragma Inline (Clear_Overlay); + + +end FLTK.Widgets.Groups.Windows.Single.Menu; + + diff --git a/spec/fltk-widgets-groups-windows-single.ads b/spec/fltk-widgets-groups-windows-single.ads new file mode 100644 index 0000000..1517fbf --- /dev/null +++ b/spec/fltk-widgets-groups-windows-single.ads @@ -0,0 +1,98 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Windows.Single is + + + type Single_Window is new Window with private; + + type Single_Window_Reference (Data : not null access Single_Window'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Single_Window; + + function Create + (Parent : in out Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Single_Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return Single_Window; + + function Create + (Parent : in out Groups.Group'Class; + W, H : in Integer; + Text : in String := "") + return Single_Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Single_Window); + + procedure Show_With_Args + (This : in out Single_Window); + + procedure Flush + (This : in out Single_Window); + + + + + -- Current -- + + procedure Make_Current + (This : in out Single_Window); + + +private + + + type Single_Window is new Window with null record; + + overriding procedure Initialize + (This : in out Single_Window); + + overriding procedure Finalize + (This : in out Single_Window); + + procedure Extra_Init + (This : in out Single_Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Single_Window) + with Inline; + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Flush); + + pragma Inline (Make_Current); + + +end FLTK.Widgets.Groups.Windows.Single; + + diff --git a/spec/fltk-widgets-groups-windows.ads b/spec/fltk-widgets-groups-windows.ads new file mode 100644 index 0000000..e2f9b3e --- /dev/null +++ b/spec/fltk-widgets-groups-windows.ads @@ -0,0 +1,403 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images.RGB; + + +package FLTK.Widgets.Groups.Windows is + + + type Window is new Group with private; + + type Window_Reference (Data : not null access Window'Class) is limited null record + with Implicit_Dereference => Data; + + type Modal_State is (Normal, Non_Modal, Modal); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Window; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Window; + + function Create + (W, H : in Integer; + Text : in String := "") + return Window; + + function Create + (Parent : in out Group'Class; + W, H : in Integer; + Text : in String := "") + return Window; + + end Forge; + + + + + -- Visibility -- + + procedure Show + (This : in out Window); + + procedure Show_With_Args + (This : in out Window); + + procedure Hide + (This : in out Window); + + function Is_Shown + (This : in Window) + return Boolean; + + procedure Wait_For_Expose + (This : in out Window); + + procedure Iconify + (This : in out Window); + + procedure Make_Current + (This : in out Window); + + function Last_Made_Current + return access Window'Class; + + + + + -- Fullscreen -- + + function Is_Fullscreen + (This : in Window) + return Boolean; + + procedure Fullscreen_On + (This : in out Window); + + procedure Fullscreen_Off + (This : in out Window); + + procedure Fullscreen_Off + (This : in out Window; + X, Y, W, H : in Integer); + + procedure Fullscreen_Screens + (This : in out Window; + Top, Bottom, Left, Right : in Natural); + + + + + -- Icons, Cursors -- + + procedure Set_Icon + (This : in out Window; + Pic : in FLTK.Images.RGB.RGB_Image'Class); + + procedure Set_Icons + (This : in out Window; + Pics : in FLTK.Images.RGB.RGB_Image_Array); + + procedure Reset_Icons + (This : in out Window); + + procedure Set_Default_Icon + (Pic : in FLTK.Images.RGB.RGB_Image'Class); + + procedure Set_Default_Icons + (Pics : in FLTK.Images.RGB.RGB_Image_Array); + + procedure Reset_Default_Icons; + + function Get_Icon_Label + (This : in Window) + return String; + + procedure Set_Icon_Label + (This : in out Window; + To : in String); + + procedure Set_Cursor + (This : in out Window; + To : in Mouse_Cursor_Kind); + + procedure Set_Cursor + (This : in out Window; + Pic : in FLTK.Images.RGB.RGB_Image'Class; + Hot_X, Hot_Y : in Integer); + + procedure Set_Default_Cursor + (This : in out Window; + To : in Mouse_Cursor_Kind); + + + + + -- Settings -- + + function Has_Border + (This : in Window) + return Boolean; + + procedure Set_Border + (This : in out Window; + Value : in Boolean := True); + + procedure Clear_Border + (This : in out Window); + + function Is_Override + (This : in Window) + return Boolean; + + procedure Set_Override + (This : in out Window); + + function Is_Modal + (This : in Window) + return Boolean; + + function Is_Non_Modal + (This : in Window) + return Boolean; + + function Get_Modal_State + (This : in Window) + return Modal_State; + + procedure Set_Modal + (This : in out Window); + + procedure Set_Non_Modal + (This : in out Window); + + procedure Set_Modal_State + (This : in out Window; + Value : in Modal_State); + + procedure Clear_Modal_State + (This : in out Window); + + + + + -- Labels, Hotspot, Shape -- + + function Get_Label + (This : in Window) + return String; + + procedure Set_Label + (This : in out Window; + Text : in String); + + procedure Set_Labels + (This : in out Window; + Text, Icon_Text : in String); + + procedure Hotspot + (This : in out Window; + X, Y : in Integer; + Offscreen : in Boolean := False); + + procedure Hotspot + (This : in out Window; + Item : in Widget'Class; + Offscreen : in Boolean := False); + + procedure Shape + (This : in out Window; + Pic : in FLTK.Images.Image'Class); + + + + + -- Dimensions -- + + procedure Set_Size_Range + (This : in out Window; + Min_W, Min_H : in Integer; + Max_W, Max_H, Incre_W, Incre_H : in Integer := 0; + Keep_Aspect : in Boolean := False); + + procedure Resize + (This : in out Window; + X, Y, W, H : in Integer); + + function Is_Position_Forced + (This : in Window) + return Boolean; + + procedure Force_Position + (This : in out Window; + State : in Boolean := True); + + function Get_X_Root + (This : in Window) + return Integer; + + function Get_Y_Root + (This : in Window) + return Integer; + + function Get_Decorated_W + (This : in Window) + return Integer; + + function Get_Decorated_H + (This : in Window) + return Integer; + + + + + -- Class Info -- + + function Get_X_Class + (This : in Window) + return String; + + procedure Set_X_Class + (This : in out Window; + Value : in String); + + function Get_Default_X_Class + return String; + + procedure Set_Default_X_Class + (Value : in String); + + function Is_Menu_Window + (This : in Window) + return Boolean; + + function Is_Tooltip_Window + (This : in Window) + return Boolean; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Window); + + procedure Flush + (This : in out Window); + + function Handle + (This : in out Window; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Window is new Group with null record; + + overriding procedure Initialize + (This : in out Window); + + overriding procedure Finalize + (This : in out Window); + + procedure Extra_Init + (This : in out Window; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Window) + with Inline; + + + pragma Inline (Show); + pragma Inline (Show_With_Args); + pragma Inline (Hide); + pragma Inline (Is_Shown); + pragma Inline (Wait_For_Expose); + pragma Inline (Iconify); + pragma Inline (Make_Current); + pragma Inline (Last_Made_Current); + + pragma Inline (Is_Fullscreen); + pragma Inline (Fullscreen_On); + pragma Inline (Fullscreen_Off); + pragma Inline (Fullscreen_Screens); + + pragma Inline (Set_Icon); + pragma Inline (Set_Icons); + pragma Inline (Reset_Icons); + pragma Inline (Set_Default_Icon); + pragma Inline (Set_Default_Icons); + pragma Inline (Reset_Default_Icons); + pragma Inline (Get_Icon_Label); + pragma Inline (Set_Icon_Label); + pragma Inline (Set_Cursor); + pragma Inline (Set_Default_Cursor); + + pragma Inline (Has_Border); + pragma Inline (Set_Border); + pragma Inline (Clear_Border); + pragma Inline (Is_Override); + pragma Inline (Set_Override); + pragma Inline (Is_Modal); + pragma Inline (Is_Non_Modal); + pragma Inline (Get_Modal_State); + pragma Inline (Set_Modal); + pragma Inline (Set_Non_Modal); + pragma Inline (Set_Modal_State); + pragma Inline (Clear_Modal_State); + + pragma Inline (Get_Label); + pragma Inline (Set_Label); + pragma Inline (Set_Labels); + pragma Inline (Hotspot); + pragma Inline (Shape); + + pragma Inline (Set_Size_Range); + pragma Inline (Resize); + pragma Inline (Is_Position_Forced); + pragma Inline (Force_Position); + pragma Inline (Get_X_Root); + pragma Inline (Get_Y_Root); + pragma Inline (Get_Decorated_W); + pragma Inline (Get_Decorated_H); + + pragma Inline (Get_X_Class); + pragma Inline (Set_X_Class); + pragma Inline (Get_Default_X_Class); + pragma Inline (Set_Default_X_Class); + pragma Inline (Is_Menu_Window); + pragma Inline (Is_Tooltip_Window); + + pragma Inline (Draw); + pragma Inline (Flush); + pragma Inline (Handle); + + + Last_Current : access Window'Class := null; + + +end FLTK.Widgets.Groups.Windows; + + diff --git a/spec/fltk-widgets-groups-wizards.ads b/spec/fltk-widgets-groups-wizards.ads new file mode 100644 index 0000000..1d748be --- /dev/null +++ b/spec/fltk-widgets-groups-wizards.ads @@ -0,0 +1,99 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package FLTK.Widgets.Groups.Wizards is + + + type Wizard is new Group with private; + + type Wizard_Reference (Data : not null access Wizard'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Wizard; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Wizard; + + end Forge; + + + + + -- Navigation -- + + procedure Next + (This : in out Wizard); + + procedure Prev + (This : in out Wizard); + + + + + -- Visibility -- + + function Get_Visible + (This : in Wizard) + return access Widget'Class; + + procedure Set_Visible + (This : in out Wizard; + Item : in out Widget'Class); + + + + + -- Drawing -- + + procedure Draw + (This : in out Wizard); + + +private + + + type Wizard is new Group with null record; + + overriding procedure Initialize + (This : in out Wizard); + + overriding procedure Finalize + (This : in out Wizard); + + procedure Extra_Init + (This : in out Wizard; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Wizard) + with Inline; + + + pragma Inline (Next); + pragma Inline (Prev); + + pragma Inline (Get_Visible); + pragma Inline (Set_Visible); + + pragma Inline (Draw); + + +end FLTK.Widgets.Groups.Wizards; + + diff --git a/spec/fltk-widgets-groups.ads b/spec/fltk-widgets-groups.ads new file mode 100644 index 0000000..9532084 --- /dev/null +++ b/spec/fltk-widgets-groups.ads @@ -0,0 +1,297 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Iterator_Interfaces; + +private with + + System.Address_To_Access_Conversions; + + +package FLTK.Widgets.Groups is + + + type Group is new Widget with private + with Default_Iterator => Iterate, + Iterator_Element => Widget_Reference, + Variable_Indexing => Child; + + type Group_Reference (Data : not null access Group'Class) is limited null record + with Implicit_Dereference => Data; + + subtype Index is Positive; + subtype Extended_Index is Natural; + No_Index : constant Extended_Index := Extended_Index'First; + + type Clip_Mode is (No_Clip, Clip); + + type Cursor is private; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Group; + + function Create + (Parent : in out Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Group; + + end Forge; + + + + + -- Contents Modification -- + + procedure Add + (This : in out Group; + Item : in out Widget'Class); + + procedure Insert + (This : in out Group; + Item : in out Widget'Class; + Place : in Index); + + procedure Insert + (This : in out Group; + Item : in out Widget'Class; + Before : in Widget'Class); + + procedure Remove + (This : in out Group; + Item : in out Widget'Class); + + procedure Remove + (This : in out Group; + Place : in Index); + + procedure Clear + (This : in out Group); + + + + + -- Contents Query -- + + function Has_Child + (This : in Group; + Place : in Index) + return Boolean; + + function Has_Child + (Place : in Cursor) + return Boolean; + + function Child + (This : in Group; + Place : in Index) + return Widget_Reference + with Pre => This.Has_Child (Place); + + function Child + (This : in Group; + Place : in Cursor) + return Widget_Reference; + + function Find + (This : in Group; + Item : in Widget'Class) + return Extended_Index; + + function Number_Of_Children + (This : in Group) + return Natural; + + + + + -- Iteration -- + + package Group_Iterators is + new Ada.Iterator_Interfaces (Cursor, Has_Child); + + function Iterate + (This : in Group) + return Group_Iterators.Reversible_Iterator'Class; + + + + + -- Clipping -- + + function Get_Clip_Mode + (This : in Group) + return Clip_Mode; + + procedure Set_Clip_Mode + (This : in out Group; + Mode : in Clip_Mode := Clip); + + + + + -- Dimensions -- + + procedure Add_Resizable + (This : in out Group; + Item : in out Widget'Class); + + function Get_Resizable + (This : in Group) + return access Widget'Class; + + procedure Set_Resizable + (This : in out Group; + Item : in Widget'Class); + + procedure Reset_Sizes + (This : in out Group); + + procedure Resize + (This : in out Group; + X, Y, W, H : in Integer); + + + + + -- Current -- + + function Get_Current + return access Group'Class; + + procedure Set_Current + (To : in Group'Class); + + procedure Begin_Current + (This : in out Group); + + procedure End_Current + (This : in out Group); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Group); + + procedure Draw_Child + (This : in out Group; + Item : in out Widget'Class); + + procedure Draw_Children + (This : in out Group); + + procedure Draw_Outside_Label + (This : in out Group; + Item : in out Widget'Class); + + procedure Update_Child + (This : in out Group; + Item : in out Widget'Class); + + function Handle + (This : in out Group; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Group is new Widget with null record; + + overriding procedure Initialize + (This : in out Group); + + overriding procedure Finalize + (This : in out Group); + + procedure Extra_Init + (This : in out Group; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Group); + + + package Group_Convert is new System.Address_To_Access_Conversions (Group); + + + type Cursor is record + My_Container : access Group; + My_Index : Index'Base := Index'First; + end record; + + type Iterator is new Group_Iterators.Reversible_Iterator with record + My_Container : access Group; + end record; + + overriding function First + (Object : in Iterator) + return Cursor; + + overriding function Next + (Object : in Iterator; + Place : in Cursor) + return Cursor; + + overriding function Last + (Object : in Iterator) + return Cursor; + + overriding function Previous + (Object : in Iterator; + Place : in Cursor) + return Cursor; + + + pragma Inline (Add); + pragma Inline (Insert); + pragma Inline (Remove); + pragma Inline (Clear); + + pragma Inline (Has_Child); + pragma Inline (Child); + pragma Inline (Find); + pragma Inline (Number_Of_Children); + + pragma Inline (Iterate); + + pragma Inline (Get_Clip_Mode); + pragma Inline (Set_Clip_Mode); + + pragma Inline (Add_Resizable); + pragma Inline (Set_Resizable); + pragma Inline (Reset_Sizes); + pragma Inline (Resize); + + pragma Inline (Set_Current); + pragma Inline (Begin_Current); + pragma Inline (End_Current); + + pragma Inline (Draw); + pragma Inline (Draw_Child); + pragma Inline (Draw_Children); + pragma Inline (Draw_Outside_Label); + pragma Inline (Update_Child); + pragma Inline (Handle); + + +end FLTK.Widgets.Groups; + + diff --git a/spec/fltk-widgets-inputs-text-file.ads b/spec/fltk-widgets-inputs-text-file.ads new file mode 100644 index 0000000..7bc2564 --- /dev/null +++ b/spec/fltk-widgets-inputs-text-file.ads @@ -0,0 +1,122 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.File is + + + type File_Input is new Text_Input with private; + + type File_Input_Reference (Data : not null access File_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return File_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return File_Input; + + end Forge; + + + + + -- Settings -- + + function Get_Down_Box + (This : in File_Input) + return Box_Kind; + + procedure Set_Down_Box + (This : in out File_Input; + To : in Box_Kind); + + function Get_Error_Color + (This : in File_Input) + return Color; + + procedure Set_Error_Color + (This : in out File_Input; + To : in Color); + + + + + -- Text Field -- + + function Get_Value + (This : in File_Input) + return String; + + procedure Set_Value + (This : in out File_Input; + To : in String); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out File_Input); + + function Handle + (This : in out File_Input; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type File_Input is new Text_Input with null record; + + overriding procedure Initialize + (This : in out File_Input); + + overriding procedure Finalize + (This : in out File_Input); + + procedure Extra_Init + (This : in out File_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out File_Input) + with Inline; + + + pragma Inline (Get_Down_Box); + pragma Inline (Set_Down_Box); + pragma Inline (Get_Error_Color); + pragma Inline (Set_Error_Color); + + pragma Inline (Get_Value); + pragma Inline (Set_Value); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Inputs.Text.File; + + diff --git a/spec/fltk-widgets-inputs-text-floating_point.ads b/spec/fltk-widgets-inputs-text-floating_point.ads new file mode 100644 index 0000000..3d24652 --- /dev/null +++ b/spec/fltk-widgets-inputs-text-floating_point.ads @@ -0,0 +1,78 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Naming this package Float would have caused ambiguity with the Float type + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Floating_Point is + + + type Float_Input is new Text_Input with private; + + type Float_Input_Reference (Data : not null access Float_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Float_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Float_Input; + + end Forge; + + + + + -- Text Field -- + + function Get_Value + (This : in Float_Input) + return Long_Float; + + +private + + + type Float_Input is new Text_Input with null record; + + overriding procedure Initialize + (This : in out Float_Input); + + overriding procedure Finalize + (This : in out Float_Input); + + procedure Extra_Init + (This : in out Float_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Float_Input) + with Inline; + + + pragma Inline (Get_Value); + + +end FLTK.Widgets.Inputs.Text.Floating_Point; + + diff --git a/spec/fltk-widgets-inputs-text-multiline.ads b/spec/fltk-widgets-inputs-text-multiline.ads new file mode 100644 index 0000000..36de2e6 --- /dev/null +++ b/spec/fltk-widgets-inputs-text-multiline.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Multiline is + + + type Multiline_Input is new Text_Input with private; + + type Multiline_Input_Reference (Data : not null access Multiline_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Input; + + end Forge; + + +private + + + type Multiline_Input is new Text_Input with null record; + + overriding procedure Initialize + (This : in out Multiline_Input); + + overriding procedure Finalize + (This : in out Multiline_Input); + + procedure Extra_Init + (This : in out Multiline_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Multiline_Input) + with Inline; + + +end FLTK.Widgets.Inputs.Text.Multiline; + + diff --git a/spec/fltk-widgets-inputs-text-outputs-multiline.ads b/spec/fltk-widgets-inputs-text-outputs-multiline.ads new file mode 100644 index 0000000..13da14d --- /dev/null +++ b/spec/fltk-widgets-inputs-text-outputs-multiline.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Outputs.Multiline is + + + type Multiline_Output is new Output with private; + + type Multiline_Output_Reference (Data : not null access Multiline_Output'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Output; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Multiline_Output; + + end Forge; + + +private + + + type Multiline_Output is new Output with null record; + + overriding procedure Initialize + (This : in out Multiline_Output); + + overriding procedure Finalize + (This : in out Multiline_Output); + + procedure Extra_Init + (This : in out Multiline_Output; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Multiline_Output) + with Inline; + + +end FLTK.Widgets.Inputs.Text.Outputs.Multiline; + + diff --git a/spec/fltk-widgets-inputs-text-outputs.ads b/spec/fltk-widgets-inputs-text-outputs.ads new file mode 100644 index 0000000..851451e --- /dev/null +++ b/spec/fltk-widgets-inputs-text-outputs.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Outputs is + + + type Output is new Text_Input with private; + + type Output_Reference (Data : not null access Output'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Output; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Output; + + end Forge; + + +private + + + type Output is new Text_Input with null record; + + overriding procedure Initialize + (This : in out Output); + + overriding procedure Finalize + (This : in out Output); + + procedure Extra_Init + (This : in out Output; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Output) + with Inline; + + +end FLTK.Widgets.Inputs.Text.Outputs; + + diff --git a/spec/fltk-widgets-inputs-text-secret.ads b/spec/fltk-widgets-inputs-text-secret.ads new file mode 100644 index 0000000..aa94b45 --- /dev/null +++ b/spec/fltk-widgets-inputs-text-secret.ads @@ -0,0 +1,76 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Secret is + + + type Secret_Input is new Text_Input with private; + + type Secret_Input_Reference (Data : not null access Secret_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Secret_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Secret_Input; + + end Forge; + + + + + -- Events -- + + function Handle + (This : in out Secret_Input; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Secret_Input is new Text_Input with null record; + + overriding procedure Initialize + (This : in out Secret_Input); + + overriding procedure Finalize + (This : in out Secret_Input); + + procedure Extra_Init + (This : in out Secret_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Secret_Input) + with Inline; + + + pragma Inline (Handle); + + +end FLTK.Widgets.Inputs.Text.Secret; + + diff --git a/spec/fltk-widgets-inputs-text-whole_number.ads b/spec/fltk-widgets-inputs-text-whole_number.ads new file mode 100644 index 0000000..7ff8514 --- /dev/null +++ b/spec/fltk-widgets-inputs-text-whole_number.ads @@ -0,0 +1,78 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +-- Naming this package Integer would have caused ambiguity with the Integer type + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text.Whole_Number is + + + type Integer_Input is new Text_Input with private; + + type Integer_Input_Reference (Data : not null access Integer_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Integer_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Integer_Input; + + end Forge; + + + + + -- Text Field -- + + function Get_Value + (This : in Integer_Input) + return Long_Integer; + + +private + + + type Integer_Input is new Text_Input with null record; + + overriding procedure Initialize + (This : in out Integer_Input); + + overriding procedure Finalize + (This : in out Integer_Input); + + procedure Extra_Init + (This : in out Integer_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Integer_Input) + with Inline; + + + pragma Inline (Get_Value); + + +end FLTK.Widgets.Inputs.Text.Whole_Number; + + diff --git a/spec/fltk-widgets-inputs-text.ads b/spec/fltk-widgets-inputs-text.ads new file mode 100644 index 0000000..64ece1c --- /dev/null +++ b/spec/fltk-widgets-inputs-text.ads @@ -0,0 +1,80 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Inputs.Text is + + + type Text_Input is new Input with private; + + type Text_Input_Reference (Data : not null access Text_Input'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Text_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Text_Input; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Text_Input); + + function Handle + (This : in out Text_Input; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Text_Input is new Input with null record; + + overriding procedure Initialize + (This : in out Text_Input); + + overriding procedure Finalize + (This : in out Text_Input); + + procedure Extra_Init + (This : in out Text_Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Text_Input) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Inputs.Text; + + diff --git a/spec/fltk-widgets-inputs.ads b/spec/fltk-widgets-inputs.ads new file mode 100644 index 0000000..6de80da --- /dev/null +++ b/spec/fltk-widgets-inputs.ads @@ -0,0 +1,398 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + +private with + + Interfaces.C.Strings; + + +package FLTK.Widgets.Inputs is + + + type Input is new Widget with private; + + type Input_Reference (Data : not null access Input'Class) is limited null record + with Implicit_Dereference => Data; + + type Input_Kind is + (Normal_Field, Float_Field, Integer_Field, Multi_In_Field, + Secret_Field, Output_Field, Multi_Out_Field, Wrap_Field, + Multi_In_Wrap_Field, Multi_Out_Wrap_Field); + + type Clipboard_Kind is (Selection_Buffer, Cut_Paste_Board); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Input; + + end Forge; + + + + + -- Clipboard -- + + procedure Copy + (This : in out Input; + Destination : in Clipboard_Kind := Cut_Paste_Board); + + function Copy + (This : in out Input; + Destination : in Clipboard_Kind := Cut_Paste_Board) + return Boolean; + + procedure Cut + (This : in out Input); + + function Cut + (This : in out Input) + return Boolean; + + procedure Cut + (This : in out Input; + Num_Bytes : in Integer); + + function Cut + (This : in out Input; + Num_Bytes : in Integer) + return Boolean; + + procedure Cut + (This : in out Input; + Start, Finish : in Integer); + + function Cut + (This : in out Input; + Start, Finish : in Integer) + return Boolean; + + procedure Copy_Cuts + (This : in out Input); + + function Copy_Cuts + (This : in out Input) + return Boolean; + + procedure Undo + (This : in out Input); + + function Undo + (This : in out Input) + return Boolean; + + + + + -- Readonly, Tabs, Wrap -- + + function Is_Readonly + (This : in Input) + return Boolean; + + procedure Set_Readonly + (This : in out Input; + To : in Boolean); + + function Is_Tab_Nav + (This : in Input) + return Boolean; + + procedure Set_Tab_Nav + (This : in out Input; + To : in Boolean); + + function Is_Wrap + (This : in Input) + return Boolean; + + procedure Set_Wrap + (This : in out Input; + To : in Boolean); + + + + + -- Shortcut, Input Position -- + + function Get_Kind + (This : in Input) + return Input_Kind; + + function Get_Shortcut + (This : in Input) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Input; + To : in Key_Combo); + + function Get_Mark + (This : in Input) + return Natural; + + procedure Set_Mark + (This : in out Input; + To : in Natural); + + function Set_Mark + (This : in out Input; + To : in Natural) + return Boolean; + + function Get_Position + (This : in Input) + return Natural; + + procedure Set_Position + (This : in out Input; + To : in Natural); + + function Set_Position + (This : in out Input; + To : in Natural) + return Boolean; + + procedure Set_Position_Mark + (This : in out Input; + Place : in Natural; + Mark : in Natural); + + function Set_Position_Mark + (This : in out Input; + Place : in Natural; + Mark : in Natural) + return Boolean; + + + + + -- Text Field -- + + function Index + (This : in Input; + Place : in Integer) + return Character; + + procedure Insert + (This : in out Input; + Str : in String); + + function Insert + (This : in out Input; + Str : in String) + return Boolean; + + procedure Replace + (This : in out Input; + From, To : in Natural; + New_Text : in String); + + function Replace + (This : in out Input; + From, To : in Natural; + New_Text : in String) + return Boolean; + + function Get_Value + (This : in Input) + return String; + + procedure Set_Value + (This : in out Input; + To : in String); + + function Set_Value + (This : in out Input; + To : in String) + return Boolean; + + + + + -- Input Size -- + + function Get_Maximum_Size + (This : in Input) + return Natural; + + procedure Set_Maximum_Size + (This : in out Input; + To : in Natural); + + function Size + (This : in Input) + return Natural; + + + + + -- Cursors, Text Settings -- + + function Get_Cursor_Color + (This : in Input) + return Color; + + procedure Set_Cursor_Color + (This : in out Input; + To : in Color); + + function Get_Text_Color + (This : in Input) + return Color; + + procedure Set_Text_Color + (This : in out Input; + To : in Color); + + function Get_Text_Font + (This : in Input) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Input; + To : in Font_Kind); + + function Get_Text_Size + (This : in Input) + return Font_Size; + + procedure Set_Text_Size + (This : in out Input; + To : in Font_Size); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Input; + W, H : in Integer); + + procedure Resize + (This : in out Input; + X, Y, W, H : in Integer); + + + + + -- Changing Input Type -- + + package Extra is + + procedure Set_Kind + (This : in out Input; + To : in Input_Kind); + + end Extra; + + +private + + + type Input is new Widget with null record; + + overriding procedure Initialize + (This : in out Input); + + overriding procedure Finalize + (This : in out Input); + + procedure Extra_Init + (This : in out Input; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Input) + with Inline; + + + pragma Inline (Copy); + pragma Inline (Cut); + pragma Inline (Copy_Cuts); + pragma Inline (Undo); + + pragma Inline (Is_Readonly); + pragma Inline (Set_Readonly); + pragma Inline (Is_Tab_Nav); + pragma Inline (Set_Tab_Nav); + pragma Inline (Is_Wrap); + pragma Inline (Set_Wrap); + + pragma Inline (Get_Kind); + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + pragma Inline (Get_Mark); + pragma Inline (Set_Mark); + pragma Inline (Get_Position); + pragma Inline (Set_Position); + + pragma Inline (Index); + pragma Inline (Insert); + pragma Inline (Replace); + pragma Inline (Get_Value); + pragma Inline (Set_Value); + + pragma Inline (Get_Maximum_Size); + pragma Inline (Set_Maximum_Size); + pragma Inline (Size); + + pragma Inline (Get_Cursor_Color); + pragma Inline (Set_Cursor_Color); + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Resize); + + pragma Inline (Draw); + pragma Inline (Handle); + + + Input_Kind_Values : array (Input_Kind) of Interfaces.C.int := + (Normal_Field => 0, + Float_Field => 1, + Integer_Field => 2, + Multi_In_Field => 4, + Secret_Field => 5, + Output_Field => 8, + Multi_Out_Field => 12, + Wrap_Field => 16, + Multi_In_Wrap_Field => 20, + Multi_Out_Wrap_Field => 28); + + + function fl_input_get_value + (F : in Storage.Integer_Address) + return Interfaces.C.Strings.chars_ptr; + pragma Import (C, fl_input_get_value, "fl_input_get_value"); + pragma Inline (fl_input_get_value); + + +end FLTK.Widgets.Inputs; + + diff --git a/spec/fltk-widgets-menus-choices.ads b/spec/fltk-widgets-menus-choices.ads new file mode 100644 index 0000000..cda6b64 --- /dev/null +++ b/spec/fltk-widgets-menus-choices.ads @@ -0,0 +1,110 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Menus.Choices is + + + type Choice is new Menu with private; + + type Choice_Reference (Data : not null access Choice'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Choice; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Choice; + + end Forge; + + + + + -- Selection -- + + function Chosen_Index + (This : in Choice) + return Extended_Index; + + procedure Set_Chosen + (This : in out Choice; + Item : in FLTK.Menu_Items.Menu_Item); + + function Set_Chosen + (This : in out Choice; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean; + + procedure Set_Chosen + (This : in out Choice; + Place : in Index); + + function Set_Chosen + (This : in out Choice; + Place : in Index) + return Boolean; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Choice); + + function Handle + (This : in out Choice; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Choice is new Menu with null record; + + overriding procedure Initialize + (This : in out Choice); + + overriding procedure Finalize + (This : in out Choice); + + procedure Extra_Init + (This : in out Choice; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Choice) + with Inline; + + + pragma Inline (Chosen_Index); + pragma Inline (Set_Chosen); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Menus.Choices; + + diff --git a/spec/fltk-widgets-menus-menu_bars-systemwide.ads b/spec/fltk-widgets-menus-menu_bars-systemwide.ads new file mode 100644 index 0000000..08f97d2 --- /dev/null +++ b/spec/fltk-widgets-menus-menu_bars-systemwide.ads @@ -0,0 +1,232 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Menu_Items; + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Menus.Menu_Bars.Systemwide is + + + type System_Menu_Bar is new Menu_Bar with private; + + type System_Menu_Bar_Reference (Data : not null access System_Menu_Bar'Class) is limited + null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return System_Menu_Bar; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return System_Menu_Bar; + + end Forge; + + + + + -- Menu Items -- + + procedure Add + (This : in out System_Menu_Bar; + Text : in String); + + function Add + (This : in out System_Menu_Bar; + Text : in String) + return Index; + + procedure Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal); + + function Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Add + (This : in out System_Menu_Bar; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal); + + function Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Insert + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Use_Same_Items + (This : in out System_Menu_Bar; + Donor : in Menu'Class); + + procedure Remove + (This : in out System_Menu_Bar; + Place : in Index); + + procedure Clear + (This : in out System_Menu_Bar); + + procedure Clear_Submenu + (This : in out System_Menu_Bar; + Place : in Index); + + + + + -- Item Query -- + + function Item + (This : in System_Menu_Bar; + Place : in Index) + return FLTK.Menu_Items.Menu_Item_Reference; + + + + + -- Label, Shortcut, Flags -- + + procedure Set_Only + (This : in out System_Menu_Bar; + Item : in out FLTK.Menu_Items.Menu_Item); + + procedure Set_Label + (This : in out System_Menu_Bar; + Place : in Index; + Text : in String); + + procedure Set_Shortcut + (This : in out System_Menu_Bar; + Place : in Index; + Press : in Key_Combo); + + function Get_Flags + (This : in System_Menu_Bar; + Place : in Index) + return Menu_Flag; + + procedure Set_Flags + (This : in out System_Menu_Bar; + Place : in Index; + Flags : in Menu_Flag); + + + + + -- Global -- + + procedure Make_Global + (This : in out System_Menu_Bar); + + procedure Update + (This : in out System_Menu_Bar); + + + + + -- Drawing -- + + procedure Draw + (This : in out System_Menu_Bar); + + +private + + + type System_Menu_Bar is new Menu_Bar with null record; + + overriding procedure Initialize + (This : in out System_Menu_Bar); + + overriding procedure Finalize + (This : in out System_Menu_Bar); + + procedure Extra_Init + (This : in out System_Menu_Bar; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out System_Menu_Bar) + with Inline; + + + pragma Inline (Item); + + pragma Inline (Set_Only); + pragma Inline (Set_Label); + pragma Inline (Set_Shortcut); + pragma Inline (Get_Flags); + pragma Inline (Set_Flags); + + pragma Inline (Make_Global); + pragma Inline (Update); + + pragma Inline (Draw); + + +end FLTK.Widgets.Menus.Menu_Bars.Systemwide; + + diff --git a/spec/fltk-widgets-menus-menu_bars.ads b/spec/fltk-widgets-menus-menu_bars.ads new file mode 100644 index 0000000..72c40de --- /dev/null +++ b/spec/fltk-widgets-menus-menu_bars.ads @@ -0,0 +1,80 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Menus.Menu_Bars is + + + type Menu_Bar is new Menu with private; + + type Menu_Bar_Reference (Data : not null access Menu_Bar'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Bar; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Bar; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Menu_Bar); + + function Handle + (This : in out Menu_Bar; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Menu_Bar is new Menu with null record; + + overriding procedure Initialize + (This : in out Menu_Bar); + + overriding procedure Finalize + (This : in out Menu_Bar); + + procedure Extra_Init + (This : in out Menu_Bar; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Menu_Bar) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Menus.Menu_Bars; + + diff --git a/spec/fltk-widgets-menus-menu_buttons.ads b/spec/fltk-widgets-menus-menu_buttons.ads new file mode 100644 index 0000000..7a93a6d --- /dev/null +++ b/spec/fltk-widgets-menus-menu_buttons.ads @@ -0,0 +1,104 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Menus.Menu_Buttons is + + + type Menu_Button is new Menu with private; + + type Menu_Button_Reference (Data : access Menu_Button'Class) is limited null record + with Implicit_Dereference => Data; + + -- Signifies which mouse buttons cause the menu to appear + type Popup_Buttons is (No_Popup, Popup1, Popup2, Popup12, Popup3, Popup13, Popup23, Popup123); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Button; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu_Button; + + end Forge; + + + + + -- Popup -- + + function Get_Popup_Kind + (This : in Menu_Button) + return Popup_Buttons; + + procedure Set_Popup_Kind + (This : in out Menu_Button; + Kind : in Popup_Buttons); + + function Popup + (This : in out Menu_Button) + return Extended_Index; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Menu_Button); + + function Handle + (This : in out Menu_Button; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Menu_Button is new Menu with null record; + + overriding procedure Initialize + (This : in out Menu_Button); + + overriding procedure Finalize + (This : in out Menu_Button); + + procedure Extra_Init + (This : in out Menu_Button; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Menu_Button) + with Inline; + + + pragma Inline (Get_Popup_Kind); + pragma Inline (Set_Popup_Kind); + pragma Inline (Popup); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Menus.Menu_Buttons; + + diff --git a/spec/fltk-widgets-menus.ads b/spec/fltk-widgets-menus.ads new file mode 100644 index 0000000..d24ebbe --- /dev/null +++ b/spec/fltk-widgets-menus.ads @@ -0,0 +1,540 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Menu_Items, + Ada.Iterator_Interfaces; + +limited with + + FLTK.Widgets.Groups; + +private with + + Ada.Containers.Vectors, + Ada.Finalization, + Interfaces, + System; + + +package FLTK.Widgets.Menus is + + + type Menu is new Widget with private + with Default_Iterator => Iterate, + Iterator_Element => FLTK.Menu_Items.Menu_Item_Reference, + Variable_Indexing => Item; + + type Menu_Reference (Data : not null access Menu'Class) is limited null record + with Implicit_Dereference => Data; + + subtype Index is Positive; + subtype Extended_Index is Natural; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Cursor is private; + + + -- If your menu item path names are longer than this, + -- then calls to Item_Pathname will raise an exception. + Item_Path_Max : constant Natural := Integer'Max (0, FLTK.Buffer_Size - 1); + + + No_Reference_Error : exception; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Menu; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Menu; + + end Forge; + + + + + -- Menu Items -- + + procedure Add + (This : in out Menu; + Text : in String); + + function Add + (This : in out Menu; + Text : in String) + return Index; + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal); + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Add + (This : in out Menu; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal); + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in Key_Combo := No_Key; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal); + + function Insert + (This : in out Menu; + Place : in Index; + Text : in String; + Action : in Widget_Callback := null; + Shortcut : in String; + Flags : in Menu_Flag := Flag_Normal) + return Index; + + procedure Set_Items + (This : in out Menu; + Items : in FLTK.Menu_Items.Menu_Item_Array); + + procedure Use_Same_Items + (This : in out Menu; + Donor : in Menu'Class); + + procedure Remove + (This : in out Menu; + Place : in Index); + + procedure Clear + (This : in out Menu); + + procedure Clear_Submenu + (This : in out Menu; + Place : in Index); + + + + + -- Item Query -- + + function Has_Item + (This : in Menu; + Place : in Index) + return Boolean; + + function Has_Item + (Place : in Cursor) + return Boolean; + + function Item + (This : in Menu; + Place : in Index) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Item + (This : in Menu; + Place : in Cursor) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Find_Item + (This : in Menu; + Name : in String) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Find_Item + (This : in Menu; + Action : in Widget_Callback) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Find_Index + (This : in Menu; + Name : in String) + return Extended_Index; + + function Find_Index + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Extended_Index; + + function Find_Index + (This : in Menu; + Action : in Widget_Callback) + return Extended_Index; + + function Item_Pathname + (This : in Menu) + return String; + + function Item_Pathname + (This : in Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return String; + + -- May not be what you expect due to submenu terminators + function Number_Of_Items + (This : in Menu) + return Natural; + + + + + -- Iteration -- + + package Menu_Iterators is + new Ada.Iterator_Interfaces (Cursor, Has_Item); + + function Iterate + (This : in Menu) + return Menu_Iterators.Reversible_Iterator'Class; + + + + + -- Selection -- + + function Chosen + (This : in Menu) + return FLTK.Menu_Items.Menu_Item_Reference; + + function Chosen_Label + (This : in Menu) + return String; + + function Chosen_Index + (This : in Menu) + return Extended_Index; + + procedure Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item); + + function Set_Chosen + (This : in out Menu; + Item : in FLTK.Menu_Items.Menu_Item) + return Boolean; + + procedure Set_Chosen + (This : in out Menu; + Place : in Index); + + function Set_Chosen + (This : in out Menu; + Place : in Index) + return Boolean; + + + + + -- Label, Shortcut, Flags -- + + procedure Set_Only + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item); + + function Get_Label + (This : in Menu; + Place : in Index) + return String; + + procedure Set_Label + (This : in out Menu; + Place : in Index; + Text : in String); + + procedure Set_Shortcut + (This : in out Menu; + Place : in Index; + Press : in Key_Combo); + + function Get_Flags + (This : in Menu; + Place : in Index) + return Menu_Flag; + + procedure Set_Flags + (This : in out Menu; + Place : in Index; + Flags : in Menu_Flag); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Menu) + return Color; + + procedure Set_Text_Color + (This : in out Menu; + To : in Color); + + function Get_Text_Font + (This : in Menu) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Menu; + To : in Font_Kind); + + function Get_Text_Size + (This : in Menu) + return Font_Size; + + procedure Set_Text_Size + (This : in out Menu; + To : in Font_Size); + + + + + -- Miscellaneous -- + + function Get_Down_Box + (This : in Menu) + return Box_Kind; + + procedure Set_Down_Box + (This : in out Menu; + To : in Box_Kind); + + procedure Make_Global + (This : in out Menu); + + procedure Measure_Item + (This : in Menu; + Item : in Index; + W, H : out Integer); + + + + + -- Menu Item Methods -- + + function Popup + (This : in Menu; + X, Y : in Integer; + Title : in String := ""; + Initial : in Extended_Index := No_Index) + return Extended_Index; + + function Pulldown + (This : in Menu; + X, Y, W, H : in Integer; + Initial : in Extended_Index := No_Index) + return Extended_Index; + + procedure Picked + (This : in out Menu; + Item : in out FLTK.Menu_Items.Menu_Item); + + function Find_Shortcut + (This : in out Menu; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class; + + function Find_Shortcut + (This : in out Menu; + Place : out Extended_Index; + Require_Alt : in Boolean := False) + return access FLTK.Menu_Items.Menu_Item'Class; + + function Test_Shortcut + (This : in out Menu) + return access FLTK.Menu_Items.Menu_Item'Class; + + + + + -- Dimensions -- + + procedure Resize + (This : in out Menu; + W, H : in Integer); + + + + + -- Drawing -- + + procedure Draw_Item + (This : in out Menu; + Item : in Index; + X, Y, W, H : in Integer; + Selected : in Boolean := False); + + +private + + + -- I'm not very happy with using a Vector of dynamically allocated + -- Menu_Item wrappers like this, but I kinda painted myself into a + -- corner with use of Limited_Controlled and the way the Add method + -- works for Menus. + + type Item_Access is access FLTK.Menu_Items.Menu_Item; + + package Item_Vectors is new Ada.Containers.Vectors + (Index_Type => Positive, + Element_Type => Item_Access); + + type Menu is new Widget with record + My_Items : Item_Vectors.Vector; + My_Find : aliased FLTK.Menu_Items.Menu_Item; + My_Pick : aliased FLTK.Menu_Items.Menu_Item; + Get_Item_Ptr : System.Address; + Value_Ptr : System.Address; + end record; + + overriding procedure Initialize + (This : in out Menu); + + overriding procedure Finalize + (This : in out Menu); + + procedure Extra_Init + (This : in out Menu; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Menu); + + + -- Used internally after every time the number of menu items is meddled with + procedure Adjust_Item_Store + (This : in out Menu); + + + type Cursor is record + My_Container : access Menu; + My_Index : Index'Base := Index'First; + end record; + + type Iterator is new Menu_Iterators.Reversible_Iterator with record + My_Container : access Menu; + end record; + + overriding function First + (Object : in Iterator) + return Cursor; + + overriding function Next + (Object : in Iterator; + Place : in Cursor) + return Cursor; + + overriding function Last + (Object : in Iterator) + return Cursor; + + overriding function Previous + (Object : in Iterator; + Place : in Cursor) + return Cursor; + + + pragma Inline (Has_Item); + pragma Inline (Item); + pragma Inline (Find_Item); + pragma Inline (Find_Index); + pragma Inline (Number_Of_Items); + + pragma Inline (Iterate); + + pragma Inline (Chosen); + pragma Inline (Chosen_Label); + pragma Inline (Chosen_Index); + pragma Inline (Set_Chosen); + + pragma Inline (Set_Only); + pragma Inline (Get_Label); + pragma Inline (Set_Label); + pragma Inline (Set_Shortcut); + pragma Inline (Get_Flags); + pragma Inline (Set_Flags); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Get_Down_Box); + pragma Inline (Set_Down_Box); + pragma Inline (Make_Global); + pragma Inline (Measure_Item); + + pragma Inline (Popup); + pragma Inline (Pulldown); + pragma Inline (Picked); + pragma Inline (Test_Shortcut); + + pragma Inline (Resize); + + pragma Inline (Draw_Item); + + + type Menu_Final_Controller is new Ada.Finalization.Limited_Controlled with null record; + + overriding procedure Finalize + (This : in out Menu_Final_Controller); + + Cleanup : Menu_Final_Controller; + + +end FLTK.Widgets.Menus; + + diff --git a/spec/fltk-widgets-positioners.ads b/spec/fltk-widgets-positioners.ads new file mode 100644 index 0000000..4e06155 --- /dev/null +++ b/spec/fltk-widgets-positioners.ads @@ -0,0 +1,213 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Positioners is + + + type Positioner is new Widget with private; + + type Positioner_Reference (Data : not null access Positioner'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Positioner; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Positioner; + + end Forge; + + + + + -- Targeting -- + + procedure Get_Coords + (This : in Positioner; + X, Y : out Long_Float); + + procedure Set_Coords + (This : in out Positioner; + X, Y : in Long_Float); + + function Set_Coords + (This : in out Positioner; + X, Y : in Long_Float) + return Boolean; + + + + + -- X Axis -- + + procedure Set_Ecks_Bounds + (This : in out Positioner; + Low, High : in Long_Float); + + procedure Set_Ecks_Step + (This : in out Positioner; + Value : in Long_Float); + + function Get_Ecks_Minimum + (This : in Positioner) + return Long_Float; + + procedure Set_Ecks_Minimum + (This : in out Positioner; + Value : in Long_Float); + + function Get_Ecks_Maximum + (This : in Positioner) + return Long_Float; + + procedure Set_Ecks_Maximum + (This : in out Positioner; + Value : in Long_Float); + + function Get_Ecks + (This : in Positioner) + return Long_Float; + + procedure Set_Ecks + (This : in out Positioner; + Value : in Long_Float); + + function Set_Ecks + (This : in out Positioner; + Value : in Long_Float) + return Boolean; + + + + + -- Y Axis -- + + procedure Set_Why_Bounds + (This : in out Positioner; + Low, High : in Long_Float); + + procedure Set_Why_Step + (This : in out Positioner; + Value : in Long_Float); + + function Get_Why_Minimum + (This : in Positioner) + return Long_Float; + + procedure Set_Why_Minimum + (This : in out Positioner; + Value : in Long_Float); + + function Get_Why_Maximum + (This : in Positioner) + return Long_Float; + + procedure Set_Why_Maximum + (This : in out Positioner; + Value : in Long_Float); + + function Get_Why + (This : in Positioner) + return Long_Float; + + procedure Set_Why + (This : in out Positioner; + Value : in Long_Float); + + function Set_Why + (This : in out Positioner; + Value : in Long_Float) + return Boolean; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Positioner); + + procedure Draw + (This : in out Positioner; + X, Y, W, H : in Integer); + + function Handle + (This : in out Positioner; + Event : in Event_Kind) + return Event_Outcome; + + function Handle + (This : in out Positioner; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome; + + +private + + + type Positioner is new Widget with null record; + + overriding procedure Initialize + (This : in out Positioner); + + overriding procedure Finalize + (This : in out Positioner); + + procedure Extra_Init + (This : in out Positioner; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Positioner) + with Inline; + + + pragma Inline (Get_Coords); + pragma Inline (Set_Coords); + + pragma Inline (Set_Ecks_Bounds); + pragma Inline (Set_Ecks_Step); + pragma Inline (Get_Ecks_Minimum); + pragma Inline (Set_Ecks_Minimum); + pragma Inline (Get_Ecks_Maximum); + pragma Inline (Set_Ecks_Maximum); + pragma Inline (Get_Ecks); + pragma Inline (Set_Ecks); + + pragma Inline (Set_Why_Bounds); + pragma Inline (Set_Why_Step); + pragma Inline (Get_Why_Minimum); + pragma Inline (Set_Why_Minimum); + pragma Inline (Get_Why_Maximum); + pragma Inline (Set_Why_Maximum); + pragma Inline (Get_Why); + pragma Inline (Set_Why); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Positioners; + + diff --git a/spec/fltk-widgets-progress_bars.ads b/spec/fltk-widgets-progress_bars.ads new file mode 100644 index 0000000..068f8a7 --- /dev/null +++ b/spec/fltk-widgets-progress_bars.ads @@ -0,0 +1,110 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Progress_Bars is + + + type Progress_Bar is new Widget with private; + + type Progress_Bar_Reference (Data : not null access Progress_Bar'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Progress_Bar; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Progress_Bar; + + end Forge; + + + + + -- Values -- + + function Get_Minimum + (This : in Progress_Bar) + return Float; + + procedure Set_Minimum + (This : in out Progress_Bar; + To : in Float); + + function Get_Maximum + (This : in Progress_Bar) + return Float; + + procedure Set_Maximum + (This : in out Progress_Bar; + To : in Float); + + function Get_Value + (This : in Progress_Bar) + return Float; + + procedure Set_Value + (This : in out Progress_Bar; + To : in Float); + + + + + -- Drawing -- + + procedure Draw + (This : in out Progress_Bar); + + +private + + + type Progress_Bar is new Widget with null record; + + overriding procedure Initialize + (This : in out Progress_Bar); + + overriding procedure Finalize + (This : in out Progress_Bar); + + procedure Extra_Init + (This : in out Progress_Bar; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Progress_Bar) + with Inline; + + + pragma Inline (Get_Minimum); + pragma Inline (Set_Minimum); + pragma Inline (Get_Maximum); + pragma Inline (Set_Maximum); + pragma Inline (Get_Value); + pragma Inline (Set_Value); + + pragma Inline (Draw); + + +end FLTK.Widgets.Progress_Bars; + + diff --git a/spec/fltk-widgets-valuators-adjusters.ads b/spec/fltk-widgets-valuators-adjusters.ads new file mode 100644 index 0000000..fb8fc9f --- /dev/null +++ b/spec/fltk-widgets-valuators-adjusters.ads @@ -0,0 +1,100 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Adjusters is + + + type Adjuster is new Valuator with private; + + type Adjuster_Reference (Data : not null access Adjuster'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Adjuster; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Adjuster; + + end Forge; + + + + + -- Allow Outside Range -- + + function Is_Soft + (This : in Adjuster) + return Boolean; + + procedure Set_Soft + (This : in out Adjuster; + To : in Boolean); + + + + + -- Drawing, Events -- + + procedure Value_Damage + (This : in out Adjuster); + + procedure Draw + (This : in out Adjuster); + + function Handle + (This : in out Adjuster; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Adjuster is new Valuator with null record; + + overriding procedure Initialize + (This : in out Adjuster); + + overriding procedure Finalize + (This : in out Adjuster); + + procedure Extra_Init + (This : in out Adjuster; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Adjuster) + with Inline; + + + pragma Inline (Is_Soft); + pragma Inline (Set_Soft); + + pragma Inline (Value_Damage); + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Adjusters; + + diff --git a/spec/fltk-widgets-valuators-counters-simple.ads b/spec/fltk-widgets-valuators-counters-simple.ads new file mode 100644 index 0000000..fd7e0e6 --- /dev/null +++ b/spec/fltk-widgets-valuators-counters-simple.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Counters.Simple is + + + type Simple_Counter is new Counter with private; + + type Simple_Counter_Reference (Data : not null access Simple_Counter'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Simple_Counter; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Simple_Counter; + + end Forge; + + +private + + + type Simple_Counter is new Counter with null record; + + overriding procedure Initialize + (This : in out Simple_Counter); + + overriding procedure Finalize + (This : in out Simple_Counter); + + procedure Extra_Init + (This : in out Simple_Counter; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Simple_Counter) + with Inline; + + +end FLTK.Widgets.Valuators.Counters.Simple; + + diff --git a/spec/fltk-widgets-valuators-counters.ads b/spec/fltk-widgets-valuators-counters.ads new file mode 100644 index 0000000..0bea0a6 --- /dev/null +++ b/spec/fltk-widgets-valuators-counters.ads @@ -0,0 +1,171 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Counters is + + + type Counter is new Valuator with private; + + type Counter_Reference (Data : not null access Counter'Class) is + limited null record with Implicit_Dereference => Data; + + type Counter_Kind is (Normal_Counter, Simple_Counter); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Counter; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Counter; + + end Forge; + + + + + -- Button Steps -- + + function Get_Step + (This : in Counter) + return Long_Float; + + procedure Set_Step_Top + (This : in out Counter; + To : in Long_Float); + + function Get_Long_Step + (This : in Counter) + return Long_Float; + + procedure Set_Long_Step + (This : in out Counter; + To : in Long_Float); + + procedure Set_Step_Both + (This : in out Counter; + Short, Long : in Long_Float); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Counter) + return Color; + + procedure Set_Text_Color + (This : in out Counter; + To : in Color); + + function Get_Text_Font + (This : in Counter) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Counter; + To : in Font_Kind); + + function Get_Text_Size + (This : in Counter) + return Font_Size; + + procedure Set_Text_Size + (This : in out Counter; + To : in Font_Size); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Counter); + + function Handle + (This : in out Counter; + Event : in Event_Kind) + return Event_Outcome; + + + + + -- Counter Type -- + + function Get_Kind + (This : in out Counter) + return Counter_Kind; + + package Extra is + + procedure Set_Kind + (This : in out Counter; + Value : in Counter_Kind); + + end Extra; + + +private + + + type Counter is new Valuator with record + -- Needed because Fl_Counter doesn't have + -- a way to retrieve this value otherwise. + Long_Step : Long_Float := 1.0; + end record; + + overriding procedure Initialize + (This : in out Counter); + + overriding procedure Finalize + (This : in out Counter); + + procedure Extra_Init + (This : in out Counter; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Counter) + with Inline; + + + pragma Inline (Get_Step); + pragma Inline (Set_Step); + pragma Inline (Get_Long_Step); + pragma Inline (Set_Long_Step); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Draw); + pragma Inline (Handle); + + pragma Inline (Get_Kind); + + +end FLTK.Widgets.Valuators.Counters; + + diff --git a/spec/fltk-widgets-valuators-dials-fill.ads b/spec/fltk-widgets-valuators-dials-fill.ads new file mode 100644 index 0000000..fdf02a8 --- /dev/null +++ b/spec/fltk-widgets-valuators-dials-fill.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Dials.Fill is + + + type Fill_Dial is new Dial with private; + + type Fill_Dial_Reference (Data : not null access Fill_Dial'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Dial; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Dial; + + end Forge; + + +private + + + type Fill_Dial is new Dial with null record; + + overriding procedure Initialize + (This : in out Fill_Dial); + + overriding procedure Finalize + (This : in out Fill_Dial); + + procedure Extra_Init + (This : in out Fill_Dial; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Fill_Dial) + with Inline; + + +end FLTK.Widgets.Valuators.Dials.Fill; + + diff --git a/spec/fltk-widgets-valuators-dials-line.ads b/spec/fltk-widgets-valuators-dials-line.ads new file mode 100644 index 0000000..f21d02c --- /dev/null +++ b/spec/fltk-widgets-valuators-dials-line.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Dials.Line is + + + type Line_Dial is new Dial with private; + + type Line_Dial_Reference (Data : not null access Line_Dial'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Line_Dial; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Line_Dial; + + end Forge; + + +private + + + type Line_Dial is new Dial with null record; + + overriding procedure Initialize + (This : in out Line_Dial); + + overriding procedure Finalize + (This : in out Line_Dial); + + procedure Extra_Init + (This : in out Line_Dial; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Line_Dial) + with Inline; + + +end FLTK.Widgets.Valuators.Dials.Line; + + diff --git a/spec/fltk-widgets-valuators-dials.ads b/spec/fltk-widgets-valuators-dials.ads new file mode 100644 index 0000000..ff16ea6 --- /dev/null +++ b/spec/fltk-widgets-valuators-dials.ads @@ -0,0 +1,142 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Dials is + + + type Dial is new Valuator with private; + + type Dial_Reference (Data : not null access Dial'Class) is limited null record + with Implicit_Dereference => Data; + + type Dial_Kind is (Normal_Dial, Line_Dial, Fill_Dial); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Dial; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Dial; + + end Forge; + + + + + -- Limit Angles -- + + function Get_First_Angle + (This : in Dial) + return Short_Integer; + + procedure Set_First_Angle + (This : in out Dial; + To : in Short_Integer); + + function Get_Second_Angle + (This : in Dial) + return Short_Integer; + + procedure Set_Second_Angle + (This : in out Dial; + To : in Short_Integer); + + procedure Set_Angles + (This : in out Dial; + One, Two : in Short_Integer); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Dial); + + procedure Draw + (This : in out Dial; + X, Y, W, H : in Integer); + + function Handle + (This : in out Dial; + Event : in Event_Kind) + return Event_Outcome; + + function Handle + (This : in out Dial; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome; + + + + + -- Dial Type -- + + function Get_Kind + (This : in Dial) + return Dial_Kind; + + package Extra is + + procedure Set_Kind + (This : in out Dial; + To : in Dial_Kind); + + end Extra; + + +private + + + type Dial is new Valuator with null record; + + overriding procedure Initialize + (This : in out Dial); + + overriding procedure Finalize + (This : in out Dial); + + procedure Extra_Init + (This : in out Dial; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Dial) + with Inline; + + + pragma Inline (Get_First_Angle); + pragma Inline (Set_First_Angle); + pragma Inline (Get_Second_Angle); + pragma Inline (Set_Second_Angle); + pragma Inline (Set_Angles); + + pragma Inline (Draw); + pragma Inline (Handle); + + pragma Inline (Get_Kind); + + +end FLTK.Widgets.Valuators.Dials; + + diff --git a/spec/fltk-widgets-valuators-rollers.ads b/spec/fltk-widgets-valuators-rollers.ads new file mode 100644 index 0000000..782fefc --- /dev/null +++ b/spec/fltk-widgets-valuators-rollers.ads @@ -0,0 +1,80 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Rollers is + + + type Roller is new Valuator with private; + + type Roller_Reference (Data : not null access Roller'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Roller; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Roller; + + end Forge; + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Roller); + + function Handle + (This : in out Roller; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Roller is new Valuator with null record; + + overriding procedure Initialize + (This : in out Roller); + + overriding procedure Finalize + (This : in out Roller); + + procedure Extra_Init + (This : in out Roller; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Roller) + with Inline; + + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Rollers; + + diff --git a/spec/fltk-widgets-valuators-sliders-fill.ads b/spec/fltk-widgets-valuators-sliders-fill.ads new file mode 100644 index 0000000..56d71a2 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-fill.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Fill is + + + type Fill_Slider is new Slider with private; + + type Fill_Slider_Reference (Data : not null access Fill_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Fill_Slider; + + end Forge; + + +private + + + type Fill_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Fill_Slider); + + overriding procedure Finalize + (This : in out Fill_Slider); + + procedure Extra_Init + (This : in out Fill_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Fill_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Fill; + + diff --git a/spec/fltk-widgets-valuators-sliders-horizontal.ads b/spec/fltk-widgets-valuators-sliders-horizontal.ads new file mode 100644 index 0000000..94d6eb3 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-horizontal.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Horizontal is + + + type Horizontal_Slider is new Slider with private; + + type Horizontal_Slider_Reference (Data : not null access Horizontal_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Slider; + + end Forge; + + +private + + + type Horizontal_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Horizontal_Slider); + + overriding procedure Finalize + (This : in out Horizontal_Slider); + + procedure Extra_Init + (This : in out Horizontal_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Horizontal_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal; + + diff --git a/spec/fltk-widgets-valuators-sliders-horizontal_fill.ads b/spec/fltk-widgets-valuators-sliders-horizontal_fill.ads new file mode 100644 index 0000000..be365db --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-horizontal_fill.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Horizontal_Fill is + + + type Horizontal_Fill_Slider is new Slider with private; + + type Horizontal_Fill_Slider_Reference (Data : not null access Horizontal_Fill_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Fill_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Fill_Slider; + + end Forge; + + +private + + + type Horizontal_Fill_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Horizontal_Fill_Slider); + + overriding procedure Finalize + (This : in out Horizontal_Fill_Slider); + + procedure Extra_Init + (This : in out Horizontal_Fill_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Horizontal_Fill_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal_Fill; + + diff --git a/spec/fltk-widgets-valuators-sliders-horizontal_nice.ads b/spec/fltk-widgets-valuators-sliders-horizontal_nice.ads new file mode 100644 index 0000000..d049586 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-horizontal_nice.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Horizontal_Nice is + + + type Horizontal_Nice_Slider is new Slider with private; + + type Horizontal_Nice_Slider_Reference (Data : not null access Horizontal_Nice_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Nice_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Nice_Slider; + + end Forge; + + +private + + + type Horizontal_Nice_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Horizontal_Nice_Slider); + + overriding procedure Finalize + (This : in out Horizontal_Nice_Slider); + + procedure Extra_Init + (This : in out Horizontal_Nice_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Horizontal_Nice_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Horizontal_Nice; + + diff --git a/spec/fltk-widgets-valuators-sliders-nice.ads b/spec/fltk-widgets-valuators-sliders-nice.ads new file mode 100644 index 0000000..b56c783 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-nice.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Nice is + + + type Nice_Slider is new Slider with private; + + type Nice_Slider_Reference (Data : not null access Nice_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Nice_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Nice_Slider; + + end Forge; + + +private + + + type Nice_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Nice_Slider); + + overriding procedure Finalize + (This : in out Nice_Slider); + + procedure Extra_Init + (This : in out Nice_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Nice_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Nice; + + diff --git a/spec/fltk-widgets-valuators-sliders-scrollbars.ads b/spec/fltk-widgets-valuators-sliders-scrollbars.ads new file mode 100644 index 0000000..5ab2a54 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-scrollbars.ads @@ -0,0 +1,114 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Scrollbars is + + + type Scrollbar is new Slider with private; + + type Scrollbar_Reference (Data : not null access Scrollbar'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Scrollbar; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Scrollbar; + + end Forge; + + + + + -- Line Position -- + + function Get_Line_Size + (This : in Scrollbar) + return Natural; + + procedure Set_Line_Size + (This : in out Scrollbar; + To : in Natural); + + function Get_Position + (This : in Scrollbar) + return Natural; + + procedure Set_Position + (This : in out Scrollbar; + To : in Natural); + + procedure Set_All + (This : in out Scrollbar; + Position : in Natural; + Win_Size : in Natural; + First_Line : in Natural; + Total_Lines : in Natural); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Scrollbar); + + function Handle + (This : in out Scrollbar; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Scrollbar is new Slider with null record; + + overriding procedure Initialize + (This : in out Scrollbar); + + overriding procedure Finalize + (This : in out Scrollbar); + + procedure Extra_Init + (This : in out Scrollbar; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Scrollbar) + with Inline; + + + pragma Inline (Get_Line_Size); + pragma Inline (Set_Line_Size); + pragma Inline (Get_Position); + pragma Inline (Set_Position); + pragma Inline (Set_All); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Sliders.Scrollbars; + + diff --git a/spec/fltk-widgets-valuators-sliders-value-horizontal.ads b/spec/fltk-widgets-valuators-sliders-value-horizontal.ads new file mode 100644 index 0000000..99d3993 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-value-horizontal.ads @@ -0,0 +1,63 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Value.Horizontal is + + + type Horizontal_Value_Slider is new Value_Slider with private; + + type Horizontal_Value_Slider_Reference (Data : not null access Horizontal_Value_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Value_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Horizontal_Value_Slider; + + end Forge; + + +private + + + type Horizontal_Value_Slider is new Value_Slider with null record; + + overriding procedure Initialize + (This : in out Horizontal_Value_Slider); + + overriding procedure Finalize + (This : in out Horizontal_Value_Slider); + + procedure Extra_Init + (This : in out Horizontal_Value_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Horizontal_Value_Slider) + with Inline; + + +end FLTK.Widgets.Valuators.Sliders.Value.Horizontal; + + diff --git a/spec/fltk-widgets-valuators-sliders-value.ads b/spec/fltk-widgets-valuators-sliders-value.ads new file mode 100644 index 0000000..a68c404 --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders-value.ads @@ -0,0 +1,116 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders.Value is + + + type Value_Slider is new Slider with private; + + type Value_Slider_Reference (Data : not null access Value_Slider'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Slider; + + end Forge; + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Slider) + return Color; + + procedure Set_Text_Color + (This : in out Value_Slider; + To : in Color); + + function Get_Text_Font + (This : in Value_Slider) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Value_Slider; + To : in Font_Kind); + + function Get_Text_Size + (This : in Value_Slider) + return Font_Size; + + procedure Set_Text_Size + (This : in out Value_Slider; + To : in Font_Size); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Slider); + + function Handle + (This : in out Value_Slider; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Value_Slider is new Slider with null record; + + overriding procedure Initialize + (This : in out Value_Slider); + + overriding procedure Finalize + (This : in out Value_Slider); + + procedure Extra_Init + (This : in out Value_Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Value_Slider) + with Inline; + + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Sliders.Value; + + diff --git a/spec/fltk-widgets-valuators-sliders.ads b/spec/fltk-widgets-valuators-sliders.ads new file mode 100644 index 0000000..9f4b7db --- /dev/null +++ b/spec/fltk-widgets-valuators-sliders.ads @@ -0,0 +1,166 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Sliders is + + + type Slider is new Valuator with private; + + type Slider_Reference (Data : not null access Slider'Class) is limited null record + with Implicit_Dereference => Data; + + type Slider_Kind is + (Vertical_Slider, Horizontal_Slider, + Vertical_Fill_Slider, Horizontal_Fill_Slider, + Vertical_Nice_Slider, Horizontal_Nice_Slider); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider; + + function Create + (Kind : in Slider_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + Kind : in Slider_Kind; + X, Y, W, H : in Integer; + Text : in String := "") + return Slider; + + end Forge; + + + + + -- Settings -- + + procedure Set_Bounds + (This : in out Slider; + Min, Max : in Long_Float); + + function Get_Box + (This : in Slider) + return Box_Kind; + + procedure Set_Box + (This : in out Slider; + To : in Box_Kind); + + function Get_Slide_Size + (This : in Slider) + return Float; + + procedure Set_Slide_Size + (This : in out Slider; + To : in Long_Float); + + procedure Set_Scrollvalue + (This : in out Slider; + Pos_First_Line : in Natural; + Lines_In_Window : in Natural; + First_Line_Num : in Natural; + Total_Lines : in Natural); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Slider); + + procedure Draw + (This : in out Slider; + X, Y, W, H : in Integer); + + function Handle + (This : in out Slider; + Event : in Event_Kind) + return Event_Outcome; + + function Handle + (This : in out Slider; + Event : in Event_Kind; + X, Y, W, H : in Integer) + return Event_Outcome; + + + + + -- Slider Type -- + + function Get_Kind + (This : in Slider) + return Slider_Kind; + + package Extra is + + procedure Set_Kind + (This : in out Slider; + To : in Slider_Kind); + + end Extra; + + +private + + + type Slider is new Valuator with null record; + + overriding procedure Initialize + (This : in out Slider); + + overriding procedure Finalize + (This : in out Slider); + + procedure Extra_Init + (This : in out Slider; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Slider) + with Inline; + + + pragma Inline (Set_Bounds); + pragma Inline (Get_Box); + pragma Inline (Set_Box); + pragma Inline (Get_Slide_Size); + pragma Inline (Set_Slide_Size); + pragma Inline (Set_Scrollvalue); + + pragma Inline (Draw); + pragma Inline (Handle); + + pragma Inline (Get_Kind); + + +end FLTK.Widgets.Valuators.Sliders; + + diff --git a/spec/fltk-widgets-valuators-value_inputs.ads b/spec/fltk-widgets-valuators-value_inputs.ads new file mode 100644 index 0000000..ba1d66f --- /dev/null +++ b/spec/fltk-widgets-valuators-value_inputs.ads @@ -0,0 +1,191 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Inputs.Text; + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Value_Inputs is + + + type Value_Input is new Valuator with private; + + type Value_Input_Reference (Data : not null access Value_Input'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Input; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Input; + + end Forge; + + + + + -- Attributes -- + + function Text_Field + (This : in out Value_Input) + return FLTK.Widgets.Inputs.Text.Text_Input_Reference; + + + + + -- Cursors -- + + function Get_Cursor_Color + (This : in Value_Input) + return Color; + + procedure Set_Cursor_Color + (This : in out Value_Input; + Col : in Color); + + + + + -- Shortcut -- + + function Get_Shortcut + (This : in Value_Input) + return Key_Combo; + + procedure Set_Shortcut + (This : in out Value_Input; + Key : in Key_Combo); + + + + + -- Allow Outside Range -- + + function Is_Soft + (This : in Value_Input) + return Boolean; + + procedure Set_Soft + (This : in out Value_Input; + To : in Boolean); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Input) + return Color; + + procedure Set_Text_Color + (This : in out Value_Input; + Col : in Color); + + function Get_Text_Font + (This : in Value_Input) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Value_Input; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Value_Input) + return Font_Size; + + procedure Set_Text_Size + (This : in out Value_Input; + Size : in Font_Size); + + + + + -- Dimensions -- + + procedure Resize + (This : in out Value_Input; + X, Y, W, H : in Integer); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Input); + + function Handle + (This : in out Value_Input; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Value_Input is new Valuator with record + My_Input : aliased Inputs.Text.Text_Input; + end record; + + overriding procedure Initialize + (This : in out Value_Input); + + overriding procedure Finalize + (This : in out Value_Input); + + procedure Extra_Init + (This : in out Value_Input; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Value_Input) + with Inline; + + + pragma Inline (Text_Field); + + pragma Inline (Get_Cursor_Color); + pragma Inline (Set_Cursor_Color); + + pragma Inline (Get_Shortcut); + pragma Inline (Set_Shortcut); + + pragma Inline (Is_Soft); + pragma Inline (Set_Soft); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Resize); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Value_Inputs; + + diff --git a/spec/fltk-widgets-valuators-value_outputs.ads b/spec/fltk-widgets-valuators-value_outputs.ads new file mode 100644 index 0000000..09c1da5 --- /dev/null +++ b/spec/fltk-widgets-valuators-value_outputs.ads @@ -0,0 +1,132 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators.Value_Outputs is + + + type Value_Output is new Valuator with private; + + type Value_Output_Reference (Data : not null access Value_Output'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Value_Output; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Value_Output; + + end Forge; + + + + + -- Allow Outside Range -- + + function Is_Soft + (This : in Value_Output) + return Boolean; + + procedure Set_Soft + (This : in out Value_Output; + To : in Boolean); + + + + + -- Text Settings -- + + function Get_Text_Color + (This : in Value_Output) + return Color; + + procedure Set_Text_Color + (This : in out Value_Output; + Col : in Color); + + function Get_Text_Font + (This : in Value_Output) + return Font_Kind; + + procedure Set_Text_Font + (This : in out Value_Output; + Font : in Font_Kind); + + function Get_Text_Size + (This : in Value_Output) + return Font_Size; + + procedure Set_Text_Size + (This : in out Value_Output; + Size : in Font_Size); + + + + + -- Drawing, Events -- + + procedure Draw + (This : in out Value_Output); + + function Handle + (This : in out Value_Output; + Event : in Event_Kind) + return Event_Outcome; + + +private + + + type Value_Output is new Valuator with null record; + + overriding procedure Initialize + (This : in out Value_Output); + + overriding procedure Finalize + (This : in out Value_Output); + + procedure Extra_Init + (This : in out Value_Output; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Value_Output) + with Inline; + + + pragma Inline (Is_Soft); + pragma Inline (Set_Soft); + + pragma Inline (Get_Text_Color); + pragma Inline (Set_Text_Color); + pragma Inline (Get_Text_Font); + pragma Inline (Set_Text_Font); + pragma Inline (Get_Text_Size); + pragma Inline (Set_Text_Size); + + pragma Inline (Draw); + pragma Inline (Handle); + + +end FLTK.Widgets.Valuators.Value_Outputs; + + diff --git a/spec/fltk-widgets-valuators.ads b/spec/fltk-widgets-valuators.ads new file mode 100644 index 0000000..e8180d6 --- /dev/null +++ b/spec/fltk-widgets-valuators.ads @@ -0,0 +1,181 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +limited with + + FLTK.Widgets.Groups; + + +package FLTK.Widgets.Valuators is + + + type Valuator is new Widget with private; + + type Valuator_Reference (Data : not null access Valuator'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Valuator; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Valuator; + + end Forge; + + + + + -- Formatting -- + + -- You may override this to change the formatting of the Valuator + function Format + (This : in Valuator) + return String; + + + + + -- Calculation -- + + function Clamp + (This : in Valuator; + Input : in Long_Float) + return Long_Float; + + function Round + (This : in Valuator; + Input : in Long_Float) + return Long_Float; + + function Increment + (This : in Valuator; + Input : in Long_Float; + Step : in Integer) + return Long_Float; + + + + + -- Settings, Value -- + + function Get_Minimum + (This : in Valuator) + return Long_Float; + + procedure Set_Minimum + (This : in out Valuator; + To : in Long_Float); + + function Get_Maximum + (This : in Valuator) + return Long_Float; + + procedure Set_Maximum + (This : in out Valuator; + To : in Long_Float); + + function Get_Step + (This : in Valuator) + return Long_Float; + + procedure Set_Step_Top + (This : in out Valuator; + To : in Long_Float); + + procedure Set_Step_Bottom + (This : in out Valuator; + To : in Integer); + + procedure Set_Step + (This : in out Valuator; + Top : in Long_Float; + Bottom : in Integer); + + function Get_Value + (This : in Valuator) + return Long_Float; + + procedure Set_Value + (This : in out Valuator; + To : in Long_Float); + + procedure Set_Bounds + (This : in out Valuator; + Min, Max : in Long_Float); + + procedure Set_Precision + (This : in out Valuator; + To : in Integer); + + procedure Set_Range + (This : in out Valuator; + Min, Max : in Long_Float); + + + + + -- Drawing -- + + procedure Value_Damage + (This : in out Valuator); + + +private + + + type Valuator is new Widget with null record; + + overriding procedure Initialize + (This : in out Valuator); + + overriding procedure Finalize + (This : in out Valuator); + + procedure Extra_Init + (This : in out Valuator; + X, Y, W, H : in Integer; + Text : in String) + with Inline; + + procedure Extra_Final + (This : in out Valuator) + with Inline; + + + pragma Inline (Clamp); + pragma Inline (Round); + pragma Inline (Increment); + + pragma Inline (Get_Minimum); + pragma Inline (Set_Minimum); + pragma Inline (Get_Maximum); + pragma Inline (Set_Maximum); + pragma Inline (Get_Step); + pragma Inline (Set_Step_Top); + pragma Inline (Set_Step_Bottom); + pragma Inline (Set_Step); + pragma Inline (Get_Value); + pragma Inline (Set_Value); + pragma Inline (Set_Bounds); + pragma Inline (Set_Precision); + pragma Inline (Set_Range); + + pragma Inline (Value_Damage); + + +end FLTK.Widgets.Valuators; + + diff --git a/spec/fltk-widgets.ads b/spec/fltk-widgets.ads new file mode 100644 index 0000000..67c1625 --- /dev/null +++ b/spec/fltk-widgets.ads @@ -0,0 +1,665 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images; + +limited with + + FLTK.Widgets.Groups.Windows; + +private with + + System.Address_To_Access_Conversions, + Interfaces.C, + FLTK.Widget_Callback_Conversions; + + +package FLTK.Widgets is + + + type Widget is new Wrapper with private; + + type Widget_Reference (Data : not null access Widget'Class) is limited null record + with Implicit_Dereference => Data; + + type Widget_Callback is access procedure + (Item : in out Widget'Class); + + + + + package Forge is + + function Create + (X, Y, W, H : in Integer; + Text : in String := "") + return Widget; + + function Create + (Parent : in out FLTK.Widgets.Groups.Group'Class; + X, Y, W, H : in Integer; + Text : in String := "") + return Widget; + + end Forge; + + + + + -- Activity -- + + procedure Activate + (This : in out Widget); + + procedure Deactivate + (This : in out Widget); + + function Is_Active + (This : in Widget) + return Boolean; + + function Is_Tree_Active + (This : in Widget) + return Boolean; + + procedure Set_Active + (This : in out Widget); + + procedure Set_Active + (This : in out Widget; + To : in Boolean); + + procedure Clear_Active + (This : in out Widget); + + + + + -- Changed and Output -- + + function Has_Changed + (This : in Widget) + return Boolean; + + procedure Set_Changed + (This : in out Widget); + + procedure Set_Changed + (This : in out Widget; + To : in Boolean); + + procedure Clear_Changed + (This : in out Widget); + + function Is_Output_Only + (This : in Widget) + return Boolean; + + procedure Set_Output_Only + (This : in out Widget); + + procedure Set_Output_Only + (This : in out Widget; + To : in Boolean); + + procedure Clear_Output_Only + (This : in out Widget); + + + + + -- Visibility -- + + function Is_Visible + (This : in Widget) + return Boolean; + + function Is_Tree_Visible + (This : in Widget) + return Boolean; + + procedure Set_Visible + (This : in out Widget); + + procedure Set_Visible + (This : in out Widget; + To : in Boolean); + + procedure Clear_Visible + (This : in out Widget); + + procedure Show + (This : in out Widget); + + procedure Hide + (This : in out Widget); + + + + + -- Focus -- + + function Has_Visible_Focus + (This : in Widget) + return Boolean; + + procedure Set_Visible_Focus + (This : in out Widget); + + procedure Set_Visible_Focus + (This : in out Widget; + To : in Boolean); + + procedure Clear_Visible_Focus + (This : in out Widget); + + function Take_Focus + (This : in out Widget) + return Boolean; + + function Takes_Events + (This : in Widget) + return Boolean; + + + + + -- Colors -- + + function Get_Background_Color + (This : in Widget) + return Color; + + procedure Set_Background_Color + (This : in out Widget; + To : in Color); + + function Get_Selection_Color + (This : in Widget) + return Color; + + procedure Set_Selection_Color + (This : in out Widget; + To : in Color); + + procedure Set_Colors + (This : in out Widget; + Back, Sel : in Color); + + + + + -- Relatives -- + + function Parent + (This : in Widget) + return access FLTK.Widgets.Groups.Group'Class; + + function Contains + (This : in Widget; + Item : in Widget'Class) + return Boolean; + + function Inside + (This : in Widget; + Parent : in Widget'Class) + return Boolean; + + function Nearest_Window + (This : in Widget) + return access FLTK.Widgets.Groups.Windows.Window'Class; + + function Top_Window + (This : in Widget) + return access FLTK.Widgets.Groups.Windows.Window'Class; + + function Top_Window_Offset + (This : in Widget; + Offset_X, Offset_Y : out Integer) + return access FLTK.Widgets.Groups.Windows.Window'Class; + + + + + -- Alignment, Box, Tooltip -- + + function Get_Alignment + (This : in Widget) + return Alignment; + + procedure Set_Alignment + (This : in out Widget; + New_Align : in Alignment); + + function Get_Box + (This : in Widget) + return Box_Kind; + + procedure Set_Box + (This : in out Widget; + Box : in Box_Kind); + + function Get_Tooltip + (This : in Widget) + return String; + + procedure Set_Tooltip + (This : in out Widget; + Text : in String); + + + + + -- Labels -- + + function Get_Label + (This : in Widget) + return String; + + procedure Set_Label + (This : in out Widget; + Text : in String); + + procedure Set_Label + (This : in out Widget; + Kind : in Label_Kind; + Text : in String); + + function Get_Label_Color + (This : in Widget) + return Color; + + procedure Set_Label_Color + (This : in out Widget; + Value : in Color); + + function Get_Label_Font + (This : in Widget) + return Font_Kind; + + procedure Set_Label_Font + (This : in out Widget; + Font : in Font_Kind); + + function Get_Label_Size + (This : in Widget) + return Font_Size; + + procedure Set_Label_Size + (This : in out Widget; + Size : in Font_Size); + + function Get_Label_Kind + (This : in Widget) + return Label_Kind; + + procedure Set_Label_Kind + (This : in out Widget; + Label : in Label_Kind); + + procedure Measure_Label + (This : in Widget; + W, H : out Integer); + + + + + -- Callbacks -- + + function Get_Callback + (This : in Widget) + return Widget_Callback; + + procedure Set_Callback + (This : in out Widget; + Func : in Widget_Callback); + + procedure Do_Callback + (This : in out Widget); + + procedure Do_Callback + (This : in Widget; + Using : in out Widget); + + procedure Default_Callback + (This : in out Widget'Class); + + function Get_When + (This : in Widget) + return Callback_Flag; + + procedure Set_When + (This : in out Widget; + To : in Callback_Flag); + + + + + -- Dimensions -- + + function Get_X + (This : in Widget) + return Integer; + + function Get_Y + (This : in Widget) + return Integer; + + function Get_W + (This : in Widget) + return Integer; + + function Get_H + (This : in Widget) + return Integer; + + procedure Resize + (This : in out Widget; + W, H : in Integer); + + procedure Resize + (This : in out Widget; + X, Y, W, H : in Integer); + + procedure Reposition + (This : in out Widget; + X, Y : in Integer); + + + + + -- Images -- + + function Get_Image + (This : in Widget) + return access FLTK.Images.Image'Class; + + procedure Set_Image + (This : in out Widget; + Pic : in out FLTK.Images.Image'Class); + + function Get_Inactive_Image + (This : in Widget) + return access FLTK.Images.Image'Class; + + procedure Set_Inactive_Image + (This : in out Widget; + Pic : in out FLTK.Images.Image'Class); + + + + + -- Damage, Drawing, Events -- + + function Is_Damaged + (This : in Widget) + return Boolean; + + function Get_Damage + (This : in Widget) + return Damage_Mask; + + procedure Set_Damage + (This : in out Widget; + Mask : in Damage_Mask); + + procedure Set_Damage + (This : in out Widget; + Mask : in Damage_Mask; + X, Y, W, H : in Integer); + + procedure Clear_Damage + (This : in out Widget; + Mask : in Damage_Mask := Damage_None); + + procedure Draw + (This : in out Widget); + + procedure Draw_Label + (This : in out Widget); + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer); + + procedure Draw_Label + (This : in out Widget; + X, Y, W, H : in Integer; + Align : in Alignment); + + procedure Draw_Backdrop + (This : in out Widget); + + procedure Draw_Box + (This : in out Widget); + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + Hue : in Color); + + procedure Draw_Box + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer; + Hue : in Color); + + procedure Draw_Focus + (This : in out Widget); + + procedure Draw_Focus + (This : in out Widget; + Kind : in Box_Kind; + X, Y, W, H : in Integer); + + procedure Redraw + (This : in out Widget); + + procedure Redraw_Label + (This : in out Widget); + + function Handle + (This : in out Widget; + Event : in Event_Kind) + return Event_Outcome; + + + + + -- Miscellaneous -- + + -- Only relevant to MacOS + function Uses_Accents_Menu + (This : in Widget) + return Boolean; + + +private + + + type Widget is new Wrapper with + record + Callback : Widget_Callback; + Current_Image : access FLTK.Images.Image'Class; + Inactive_Image : access FLTK.Images.Image'Class; + Draw_Ptr : System.Address; + Handle_Ptr : System.Address; + end record; + + overriding procedure Initialize + (This : in out Widget); + + overriding procedure Finalize + (This : in out Widget); + + -- Widgets that might cause problems for this setup in the future: + -- Menus (gets various Menu_Items added to it) + -- Groups.Text_Displays (gets a Text_Buffer attached) + -- Groups.Text_Displays.Text_Editors (also gets a Text_Buffer attached) + -- If weird Init/Final errors start mysteriously occuring then check there first. + + -- Extra_Init functionality is also duplicated in FLTK.File_Choosers + -- for reasons of hierarchy visibility. Really, the File_Chooser should be in + -- the Widget hierarchy like Color_Chooser but for some reason it isn't. + + procedure Extra_Init + (This : in out Widget; + X, Y, W, H : in Integer; + Text : in String); + + procedure Extra_Final + (This : in out Widget); + + + -- the user data portion should always be a reference back to the Ada binding + procedure Callback_Hook + (W, U : in Storage.Integer_Address); + pragma Export (C, Callback_Hook, "widget_callback_hook"); + + procedure Draw_Hook + (U : in Storage.Integer_Address); + pragma Export (C, Draw_Hook, "widget_draw_hook"); + + function Handle_Hook + (U : in Storage.Integer_Address; + E : in Interfaces.C.int) + return Interfaces.C.int; + pragma Export (C, Handle_Hook, "widget_handle_hook"); + + + package Widget_Convert is new System.Address_To_Access_Conversions (Widget'Class); + package Callback_Convert renames FLTK.Widget_Callback_Conversions; + + + function fl_widget_get_user_data + (W : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_widget_get_user_data, "fl_widget_get_user_data"); + pragma Inline (fl_widget_get_user_data); + + procedure fl_widget_set_user_data + (W, D : in Storage.Integer_Address); + pragma Import (C, fl_widget_set_user_data, "fl_widget_set_user_data"); + pragma Inline (fl_widget_set_user_data); + + + procedure fl_widget_set_label + (W : in Storage.Integer_Address; + T : in Interfaces.C.char_array); + pragma Import (C, fl_widget_set_label, "fl_widget_set_label"); + pragma Inline (fl_widget_set_label); + + + function fl_widget_get_type + (W : in Storage.Integer_Address) + return Interfaces.C.unsigned_char; + pragma Import (C, fl_widget_get_type, "fl_widget_get_type"); + pragma Inline (fl_widget_get_type); + + procedure fl_widget_set_type + (W : in Storage.Integer_Address; + T : in Interfaces.C.unsigned_char); + pragma Import (C, fl_widget_set_type, "fl_widget_set_type"); + pragma Inline (fl_widget_set_type); + + + pragma Inline (Activate); + pragma Inline (Deactivate); + pragma Inline (Is_Active); + pragma Inline (Is_Tree_Active); + pragma Inline (Set_Active); + pragma Inline (Clear_Active); + + pragma Inline (Has_Changed); + pragma Inline (Set_Changed); + pragma Inline (Clear_Changed); + pragma Inline (Is_Output_Only); + pragma Inline (Set_Output_Only); + pragma Inline (Clear_Output_Only); + + pragma Inline (Is_Visible); + pragma Inline (Set_Visible); + pragma Inline (Clear_Visible); + pragma Inline (Show); + pragma Inline (Hide); + + pragma Inline (Has_Visible_Focus); + pragma Inline (Set_Visible_Focus); + pragma Inline (Clear_Visible_Focus); + pragma Inline (Take_Focus); + pragma Inline (Takes_Events); + + pragma Inline (Get_Background_Color); + pragma Inline (Set_Background_Color); + pragma Inline (Get_Selection_Color); + pragma Inline (Set_Selection_Color); + pragma Inline (Set_Colors); + + pragma Inline (Parent); + pragma Inline (Contains); + pragma Inline (Inside); + pragma Inline (Nearest_Window); + pragma Inline (Top_Window); + pragma Inline (Top_Window_Offset); + + pragma Inline (Get_Alignment); + pragma Inline (Set_Alignment); + pragma Inline (Get_Box); + pragma Inline (Set_Box); + pragma Inline (Get_Tooltip); + pragma Inline (Set_Tooltip); + + pragma Inline (Get_Label); + pragma Inline (Set_Label); + pragma Inline (Get_Label_Color); + pragma Inline (Set_Label_Color); + pragma Inline (Get_Label_Font); + pragma Inline (Set_Label_Font); + pragma Inline (Get_Label_Size); + pragma Inline (Set_Label_Size); + pragma Inline (Get_Label_Kind); + pragma Inline (Set_Label_Kind); + pragma Inline (Measure_Label); + + pragma Inline (Get_Callback); + pragma Inline (Set_Callback); + pragma Inline (Do_Callback); + pragma Inline (Default_Callback); + pragma Inline (Get_When); + pragma Inline (Set_When); + + pragma Inline (Get_X); + pragma Inline (Get_Y); + pragma Inline (Get_W); + pragma Inline (Get_H); + pragma Inline (Resize); + pragma Inline (Reposition); + + pragma Inline (Get_Image); + pragma Inline (Set_Image); + pragma Inline (Get_Inactive_Image); + pragma Inline (Set_Inactive_Image); + + pragma Inline (Is_Damaged); + pragma Inline (Get_Damage); + pragma Inline (Set_Damage); + pragma Inline (Draw); + pragma Inline (Draw_Label); + pragma Inline (Draw_Backdrop); + pragma Inline (Draw_Box); + pragma Inline (Draw_Focus); + pragma Inline (Redraw); + pragma Inline (Redraw_Label); + pragma Inline (Handle); + + pragma Inline (Uses_Accents_Menu); + + +end FLTK.Widgets; + + diff --git a/spec/fltk.ads b/spec/fltk.ads new file mode 100644 index 0000000..964af79 --- /dev/null +++ b/spec/fltk.ads @@ -0,0 +1,874 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Ada.Finalization, + System; + +private with + + Ada.Unchecked_Conversion, + Interfaces.C.Strings, + System.Storage_Elements; + + +package FLTK is + + + -- Ugly implementation detail, never use this. + -- This is necessary so things like Text_Buffers and + -- Widgets can talk to each other behind the binding. + type Wrapper is new Ada.Finalization.Limited_Controlled with private; + + function Is_Valid + (Object : in Wrapper) + return Boolean; + + -- If this is ever raised it means FLTK has returned a value or otherwise + -- acted in a way that the binding really did not expect. + Internal_FLTK_Error : exception; + + -- Text buffers for marshalling purposes will be this size. + Buffer_Size : constant Natural := 1024; + + -- For image data arrays. + type Size_Type is mod 2 ** System.Word_Size; + subtype Positive_Size is Size_Type range 1 .. Size_Type'Last; + + + + + -- Color -- + + -- Values scale from A/Black to X/White. + type Greyscale is new Character range 'A' .. 'X'; + + type Color is mod 2**32; + + type Color_Component is mod 256; + type Color_Component_Array is array (Positive_Size 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#; + RGB_Green_Color : constant Color := 16#00ff0000#; + RGB_Blue_Color : constant Color := 16#0000ff00#; + RGB_White_Color : constant Color := 16#ffffff00#; + + -- Standard colors used in widgets + Foreground_Color : constant Color := 0; + Background2_Color : constant Color := 7; + 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; + Dark2_Color : constant Color := 45; + Dark1_Color : constant Color := 47; + Background_Color : constant Color := 49; + Light1_Color : constant Color := 50; + Light2_Color : constant Color := 52; + Light3_Color : constant Color := 54; + + -- Color cube colors + Black_Color : constant Color := 56; + Red_Color : constant Color := 88; + Green_Color : constant Color := 63; + Yellow_Color : constant Color := 95; + Blue_Color : constant Color := 216; + Magenta_Color : constant Color := 248; + Cyan_Color : constant Color := 223; + Dark_Red_Color : constant Color := 72; + Dark_Green_Color : constant Color := 60; + Dark_Yellow_Color : constant Color := 76; + Dark_Blue_Color : constant Color := 136; + Dark_Magenta_Color : constant Color := 152; + Dark_Cyan_Color : constant Color := 140; + White_Color : constant Color := 255; + + + + + -- Alignment -- + + -- This should be a bitmask, except there are magic values... + type Alignment is private; + + function "+" (Left, Right : in Alignment) return Alignment; + function "-" (Left, Right : in Alignment) return Alignment; + + Align_Center : constant Alignment; + Align_Top : constant Alignment; + Align_Bottom : constant Alignment; + Align_Left : constant Alignment; + Align_Right : constant Alignment; + Align_Inside : constant Alignment; + Align_Text_Over_Image : constant Alignment; + Align_Image_Over_Text : constant Alignment; + Align_Clip : constant Alignment; + Align_Wrap : constant Alignment; + Align_Image_Next_To_Text : constant Alignment; + Align_Text_Next_To_Image : constant Alignment; + Align_Image_Backdrop : constant Alignment; + Align_Top_Left : constant Alignment; + Align_Top_Right : constant Alignment; + Align_Bottom_Left : constant Alignment; + Align_Bottom_Right : constant Alignment; + Align_Left_Top : constant Alignment; + Align_Right_Top : constant Alignment; + Align_Left_Bottom : constant Alignment; + Align_Right_Bottom : constant Alignment; + Align_Nowrap : constant Alignment; + Align_All_Position : constant Alignment; + Align_All_Image : constant Alignment; + + + + + -- Mouse Cursors -- + + type Mouse_Cursor_Kind is + (Default_Mouse, + Arrow_Mouse, + Crosshair_Mouse, + Wait_Mouse, + Insert_Mouse, + Hand_Mouse, + Help_Mouse, + Move_Mouse, + NS_Mouse, + WE_Mouse, + NWSE_Mouse, + NESW_Mouse, + N_Mouse, + NE_Mouse, + E_Mouse, + SE_Mouse, + S_Mouse, + SW_Mouse, + W_Mouse, + NW_Mouse, + None_Mouse) + with Default_Value => Default_Mouse; + + + + + -- Keyboard and Mouse Input -- + + type Keypress is private; + subtype Pressable_Key is Character range Character'Val (32) .. Character'Val (126); + + function Press (Key : in Pressable_Key) return Keypress; + + Enter_Key : constant Keypress; + Keypad_Enter_Key : constant Keypress; + Backspace_Key : constant Keypress; + Insert_Key : constant Keypress; + Delete_Key : constant Keypress; + Home_Key : constant Keypress; + End_Key : constant Keypress; + Page_Down_Key : constant Keypress; + Page_Up_Key : constant Keypress; + Down_Key : constant Keypress; + Left_Key : constant Keypress; + Right_Key : constant Keypress; + Up_Key : constant Keypress; + Escape_Key : constant Keypress; + Tab_Key : constant Keypress; + + + type Mouse_Button is + (No_Button, + Left_Button, + Middle_Button, + Right_Button, + Back_Button, + Forward_Button, + Any_Button); + + + type Key_Combo is private; + + function Press (Key : in Pressable_Key) return Key_Combo; + function Press (Key : in Keypress) return Key_Combo; + function Press (Key : in Mouse_Button) return Key_Combo; + + No_Key : constant Key_Combo; + + + type Modifier is private; + + function "+" (Left, Right : in Modifier) return Modifier; + function "+" (Left : in Modifier; Right : in Pressable_Key) return Key_Combo; + function "+" (Left : in Modifier; Right : in Keypress) return Key_Combo; + function "+" (Left : in Modifier; Right : in Mouse_Button) return Key_Combo; + function "+" (Left : in Modifier; Right : in Key_Combo) return Key_Combo; + + Mod_None : constant Modifier; + Mod_Shift : constant Modifier; + Mod_Caps_Lock : constant Modifier; + Mod_Ctrl : constant Modifier; + Mod_Alt : constant Modifier; + Mod_Num_Lock : constant Modifier; + Mod_Meta : constant Modifier; + Mod_Scroll_Lock : constant Modifier; + Mod_Command : constant Modifier; + + + + + -- Box Types -- + + type Box_Kind is + (No_Box, + Flat_Box, + Up_Box, + Down_Box, + Up_Frame, + Down_Frame, + Thin_Up_Box, + Thin_Down_Box, + Thin_Up_Frame, + Thin_Down_Frame, + Engraved_Box, + Embossed_Box, + Engraved_Frame, + Embossed_Frame, + Border_Box, + Shadow_Box, + Border_Frame, + Shadow_Frame, + Rounded_Box, + RShadow_Box, + Rounded_Frame, + RFlat_Box, + Round_Up_Box, + Round_Down_Box, + Diamond_Up_Box, + Diamond_Down_Box, + Oval_Box, + OShadow_Box, + Oval_Frame, + OFlat_Box, + Plastic_Up_Box, + Plastic_Down_Box, + Plastic_Up_Frame, + Plastic_Down_Frame, + Plastic_Thin_Up_Box, + Plastic_Thin_Down_Box, + Plastic_Round_Up_Box, + Plastic_Round_Down_Box, + Gtk_Up_Box, + Gtk_Down_Box, + Gtk_Up_Frame, + Gtk_Down_Frame, + Gtk_Thin_Up_Box, + Gtk_Thin_Down_Box, + Gtk_Thin_Up_Frame, + Gtk_Thin_Down_Frame, + Gtk_Round_Up_Box, + Gtk_Round_Down_Box, + Gleam_Up_Box, + Gleam_Down_Box, + Gleam_Up_Frame, + Gleam_Down_Frame, + Gleam_Thin_Up_Box, + Gleam_Thin_Down_Box, + Gleam_Round_Up_Box, + 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; + + + + + -- Fonts -- + + type Font_Kind is + (Helvetica, + Helvetica_Bold, + Helvetica_Italic, + Helvetica_Bold_Italic, + Courier, + Courier_Bold, + Courier_Italic, + Courier_Bold_Italic, + Times, + Times_Bold, + Times_Italic, + Times_Bold_Italic, + Symbol, + Monospace, + Monospace_Bold, + Zapf_Dingbats, + Free_Font); + + type Font_Size is new Natural; + Normal_Size : constant Font_Size := 14; + + type Font_Size_Array is array (Positive range <>) of Font_Size; + + + + + -- Label Types -- + + type Label_Kind is + (Normal_Label, + No_Label, + Shadow_Label, + Engraved_Label, + Embossed_Label, + Multi_Label, + Icon_Label, + Image_Label, + Free_Label); + + + + + -- Events -- + + type Event_Kind is + (No_Event, + Push, + Release, + Enter, + Leave, + Drag, + Focus, + Unfocus, + Keydown, + Keyup, + Close, + Move, + Shortcut, + Deactivate, + Activate, + Hide, + Show, + Paste, + Selection_Clear, + Mouse_Wheel, + DnD_Enter, + DnD_Drag, + DnD_Leave, + DnD_Release, + Screen_Config_Changed, + Fullscreen); + + type Event_Outcome is (Not_Handled, Handled); + + + + + -- Callback Flags -- + + type Callback_Flag is record + Changed : Boolean := False; + Interact : Boolean := False; + Release : Boolean := False; + Enter_Key : Boolean := False; + end record; + + function "+" (Left, Right : in Callback_Flag) return Callback_Flag; + function "-" (Left, Right : in Callback_Flag) return Callback_Flag; + + Call_Never : constant Callback_Flag; + When_Changed : constant Callback_Flag; + When_Interact : constant Callback_Flag; + When_Release : constant Callback_Flag; + When_Release_Always : constant Callback_Flag; + When_Enter_Key : constant Callback_Flag; + When_Enter_Key_Always : constant Callback_Flag; + + + + + -- Menu Flags -- + + -- It's easier to have this here rather than in Menu_Items for visibility reasons. + + type Menu_Flag is record + Inactive : Boolean := False; + Toggle : Boolean := False; + Value : Boolean := False; + Radio : Boolean := False; + Invisible : Boolean := False; + Submenu : Boolean := False; + Divider : Boolean := False; + end record; + + function "+" (Left, Right : in Menu_Flag) return Menu_Flag; + function "-" (Left, Right : in Menu_Flag) return Menu_Flag; + + Flag_Normal : constant Menu_Flag; + Flag_Inactive : constant Menu_Flag; + Flag_Toggle : constant Menu_Flag; + Flag_Value : constant Menu_Flag; + Flag_Radio : constant Menu_Flag; + Flag_Invisible : constant Menu_Flag; + Flag_Submenu : constant Menu_Flag; + Flag_Divider : constant Menu_Flag; + + + + + -- Damage Bits -- + + type Damage_Mask is record + Child : Boolean := False; + Expose : Boolean := False; + Scroll : Boolean := False; + Overlay : Boolean := False; + User_1 : Boolean := False; + User_2 : Boolean := False; + Full : Boolean := False; + end record; + + function "+" (Left, Right : in Damage_Mask) return Damage_Mask; + function "-" (Left, Right : in Damage_Mask) return Damage_Mask; + + Damage_None : constant Damage_Mask; + Damage_Child : constant Damage_Mask; + Damage_Expose : constant Damage_Mask; + Damage_Scroll : constant Damage_Mask; + Damage_Overlay : constant Damage_Mask; + Damage_User_1 : constant Damage_Mask; + Damage_User_2 : constant Damage_Mask; + Damage_Full : constant Damage_Mask; + + + + + -- Clipboard Attributes -- + + Clipboard_Image : constant String; + Clipboard_Plain_Text : constant String; + + + + + -- Versioning -- + + type Version_Number is new Natural; + + function ABI_Check + (ABI_Ver : in Version_Number) + return Boolean; + + function ABI_Version + return Version_Number; + + function API_Version + return Version_Number; + + function Version + return Version_Number; + + + + + -- Event Loop -- + + procedure Check; + + function Check + return Boolean; + + function Ready + return Boolean; + + function Wait + return Integer; + + function Wait + (Seconds : in Long_Float) + return Long_Float; + + function Run + return Integer; + + +private + + + package Storage renames System.Storage_Elements; + use type Interfaces.C.size_t, Storage.Integer_Address; + + + Null_Pointer : constant Storage.Integer_Address := Storage.To_Integer (System.Null_Address); + + + pragma Linker_Options ("-lfltk"); + pragma Linker_Options ("-lfltk_images"); + pragma Linker_Options ("-lfltk_gl"); + + + function c_pointer_size + return Interfaces.C.size_t; + pragma Import (C, c_pointer_size, "c_pointer_size"); + + -- If this fails then we are on an architecture that for whatever reason + -- has significant problems interfacing between C and Ada + pragma Assert + (c_pointer_size * Interfaces.C.CHAR_BIT = Storage.Integer_Address'Size, + "Size of C void pointers and size of Ada address values do not match"); + + + + + -- Note: This has to be Limited because otherwise the various init subprograms + -- wouldn't work, the widget callbacks wouldn't work, deallocation would be + -- a mess, really just all sorts of problems. + type Wrapper is new Ada.Finalization.Limited_Controlled with record + Void_Ptr : Storage.Integer_Address := Null_Pointer; + Needs_Dealloc : Boolean := True; + end record; + + + + + for Color_Component_Array'Component_Size use Interfaces.C.CHAR_BIT; + pragma Convention (C, Color_Component_Array); + + + + + -- Default value here is Align_Center + type Alignment is mod 2 ** 16 + with Default_Value => 0; + + for Alignment'Size use 16; + + pragma Import (C, Align_Center, "fl_align_center"); + pragma Import (C, Align_Top, "fl_align_top"); + pragma Import (C, Align_Bottom, "fl_align_bottom"); + pragma Import (C, Align_Left, "fl_align_left"); + pragma Import (C, Align_Right, "fl_align_right"); + pragma Import (C, Align_Inside, "fl_align_inside"); + pragma Import (C, Align_Text_Over_Image, "fl_align_text_over_image"); + pragma Import (C, Align_Image_Over_Text, "fl_align_image_over_text"); + pragma Import (C, Align_Clip, "fl_align_clip"); + pragma Import (C, Align_Wrap, "fl_align_wrap"); + pragma Import (C, Align_Image_Next_To_Text, "fl_align_image_next_to_text"); + pragma Import (C, Align_Text_Next_To_Image, "fl_align_text_next_to_image"); + pragma Import (C, Align_Image_Backdrop, "fl_align_image_backdrop"); + pragma Import (C, Align_Top_Left, "fl_align_top_left"); + pragma Import (C, Align_Top_Right, "fl_align_top_right"); + pragma Import (C, Align_Bottom_Left, "fl_align_bottom_left"); + pragma Import (C, Align_Bottom_Right, "fl_align_bottom_right"); + pragma Import (C, Align_Left_Top, "fl_align_left_top"); + pragma Import (C, Align_Right_Top, "fl_align_right_top"); + pragma Import (C, Align_Left_Bottom, "fl_align_left_bottom"); + pragma Import (C, Align_Right_Bottom, "fl_align_right_bottom"); + pragma Import (C, Align_Nowrap, "fl_align_nowrap"); + pragma Import (C, Align_All_Position, "fl_align_all_position"); + pragma Import (C, Align_All_Image, "fl_align_all_image"); + + + + + -- What delightful magic numbers FLTK cursors are! + -- (These correspond to the enum found in Enumerations.H) + Cursor_Values : array (Mouse_Cursor_Kind) of Interfaces.C.int := + (Default_Mouse => 0, + Arrow_Mouse => 35, + Crosshair_Mouse => 66, + Wait_Mouse => 76, + Insert_Mouse => 77, + Hand_Mouse => 31, + Help_Mouse => 47, + Move_Mouse => 27, + NS_Mouse => 78, + WE_Mouse => 79, + NWSE_Mouse => 80, + NESW_Mouse => 81, + N_Mouse => 70, + NE_Mouse => 69, + E_Mouse => 49, + SE_Mouse => 8, + S_Mouse => 9, + SW_Mouse => 7, + W_Mouse => 36, + NW_Mouse => 68, + None_Mouse => 255); + + + + + type Keypress is new Interfaces.Unsigned_16; + type Modifier is new Interfaces.Unsigned_16; + + type Key_Combo is record + Modcode : Modifier; + Keycode : Keypress; + Mousecode : Mouse_Button; + end record; + + function To_C + (Key : in Key_Combo) + return Interfaces.C.unsigned; + + function To_Ada + (Key : in Interfaces.C.unsigned) + return Key_Combo; + + function To_C + (Key : in Keypress) + return Interfaces.C.unsigned; + + function To_Ada + (Key : in Interfaces.C.unsigned) + return Keypress; + + function To_C + (Modi : in Modifier) + return Interfaces.C.unsigned; + + function To_Ada + (Modi : in Interfaces.C.unsigned) + return Modifier; + + function To_C + (Button : in Mouse_Button) + return Interfaces.C.unsigned; + + function To_Ada + (Button : in Interfaces.C.unsigned) + return Mouse_Button; + + -- these values designed to align with FLTK enumeration types + Mod_None : constant Modifier := 2#00000000#; + Mod_Shift : constant Modifier := 2#00000001#; + Mod_Caps_Lock : constant Modifier := 2#00000010#; + Mod_Ctrl : constant Modifier := 2#00000100#; + Mod_Alt : constant Modifier := 2#00001000#; + Mod_Num_Lock : constant Modifier := 2#00010000#; + -- Missing 2#00100000#; + Mod_Meta : constant Modifier := 2#01000000#; + Mod_Scroll_Lock : constant Modifier := 2#10000000#; + + -- If this is Apple then Mod_Meta, otherwise Mod_Ctrl + pragma Import (C, Mod_Command, "fl_mod_command"); + + No_Key : constant Key_Combo := (Modcode => Mod_None, Keycode => 0, Mousecode => No_Button); + + -- these values correspond to constants defined in FLTK Enumerations.H + Enter_Key : constant Keypress := 16#ff0d#; + Keypad_Enter_Key : constant Keypress := 16#ff8d#; + Backspace_Key : constant Keypress := 16#ff08#; + Insert_Key : constant Keypress := 16#ff63#; + Delete_Key : constant Keypress := 16#ffff#; + Home_Key : constant Keypress := 16#ff50#; + End_Key : constant Keypress := 16#ff57#; + Page_Down_Key : constant Keypress := 16#ff56#; + Page_Up_Key : constant Keypress := 16#ff55#; + Down_Key : constant Keypress := 16#ff54#; + Left_Key : constant Keypress := 16#ff51#; + Right_Key : constant Keypress := 16#ff53#; + Up_Key : constant Keypress := 16#ff52#; + Escape_Key : constant Keypress := 16#ff1b#; + Tab_Key : constant Keypress := 16#ff09#; + + + + + for Callback_Flag use record + Changed at 0 range 0 .. 0; + Interact at 0 range 1 .. 1; + Release at 0 range 2 .. 2; + Enter_Key at 0 range 3 .. 3; + end record; + + for Callback_Flag'Size use Interfaces.C.unsigned_char'Size; + + Call_Never : constant Callback_Flag := (others => False); + When_Changed : constant Callback_Flag := (Changed => True, others => False); + When_Interact : constant Callback_Flag := (Interact => True, others => False); + When_Release : constant Callback_Flag := (Release => True, others => False); + When_Enter_Key : constant Callback_Flag := (Enter_Key => True, others => False); + + When_Release_Always : constant Callback_Flag := + (Release => True, Interact => True, others => False); + When_Enter_Key_Always : constant Callback_Flag := + (Enter_Key => True, Interact => True, others => False); + + function Flag_To_UChar is new + Ada.Unchecked_Conversion (Callback_Flag, Interfaces.C.unsigned_char); + + function UChar_To_Flag is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Callback_Flag); + + + + + for Menu_Flag use record + Inactive at 0 range 0 .. 0; + Toggle at 0 range 1 .. 1; + Value at 0 range 2 .. 2; + Radio at 0 range 3 .. 3; + Invisible at 0 range 4 .. 4; + -- Submenu_Pointer unused + Submenu at 0 range 6 .. 6; + Divider at 0 range 7 .. 7; + end record; + + for Menu_Flag'Size use Interfaces.C.int'Size; + + Flag_Normal : constant Menu_Flag := (others => False); + Flag_Inactive : constant Menu_Flag := (Inactive => True, others => False); + Flag_Toggle : constant Menu_Flag := (Toggle => True, others => False); + Flag_Value : constant Menu_Flag := (Value => True, others => False); + Flag_Radio : constant Menu_Flag := (Radio => True, others => False); + Flag_Invisible : constant Menu_Flag := (Invisible => True, others => False); + -- Flag_Submenu_Pointer unused + Flag_Submenu : constant Menu_Flag := (Submenu => True, others => False); + Flag_Divider : constant Menu_Flag := (Divider => True, others => False); + + function MFlag_To_Cint is new + Ada.Unchecked_Conversion (Menu_Flag, Interfaces.C.int); + + function Cint_To_MFlag is new + Ada.Unchecked_Conversion (Interfaces.C.int, Menu_Flag); + + + + + for Damage_Mask use record + Child at 0 range 0 .. 0; + Expose at 0 range 1 .. 1; + Scroll at 0 range 2 .. 2; + Overlay at 0 range 3 .. 3; + User_1 at 0 range 4 .. 4; + User_2 at 0 range 5 .. 5; + -- bit 6 missing + Full at 0 range 7 .. 7; + end record; + + for Damage_Mask'Size use Interfaces.C.unsigned_char'Size; + + Damage_None : constant Damage_Mask := (others => False); + Damage_Child : constant Damage_Mask := (Child => True, others => False); + Damage_Expose : constant Damage_Mask := (Expose => True, others => False); + Damage_Scroll : constant Damage_Mask := (Scroll => True, others => False); + Damage_Overlay : constant Damage_Mask := (Overlay => True, others => False); + Damage_User_1 : constant Damage_Mask := (User_1 => True, others => False); + Damage_User_2 : constant Damage_Mask := (User_2 => True, others => False); + Damage_Full : constant Damage_Mask := (Full => True, others => False); + + function Mask_To_UChar is new + Ada.Unchecked_Conversion (Damage_Mask, Interfaces.C.unsigned_char); + + function UChar_To_Mask is new + Ada.Unchecked_Conversion (Interfaces.C.unsigned_char, Damage_Mask); + + + + + clip_image_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_image_char_ptr, "fl_clip_image_char_ptr"); + + clip_plain_text_char_ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, clip_plain_text_char_ptr, "fl_clip_plain_text_char_ptr"); + + Clipboard_Image : constant String := Interfaces.C.Strings.Value (clip_image_char_ptr); + Clipboard_Plain_Text : constant String := Interfaces.C.Strings.Value (clip_plain_text_char_ptr); + + + + + pragma Inline (RGB_Color); + pragma Inline (Color_Cube); + pragma Inline (Grey_Ramp); + pragma Inline (Darker); + pragma Inline (Lighter); + pragma Inline (Contrast); + pragma Inline (Inactive); + pragma Inline (Color_Average); + + pragma Inline (Filled); + pragma Inline (Frame); + pragma Inline (Down); + + pragma Inline (ABI_Check); + pragma Inline (ABI_Version); + pragma Inline (API_Version); + pragma Inline (Version); + + pragma Inline (Check); + pragma Inline (Ready); + pragma Inline (Wait); + pragma Inline (Run); + + +end FLTK; + + |