Split public API and private implementation files into different directories

1 files changed, 659 insertions, 0 deletions

diff --git a/body/fltk-asks.adb b/body/fltk-asks.adb
new file mode 100644
index 0000000..bd09fac
--- /dev/null
+++ b/body/fltk-asks.adb
@@ -0,0 +1,659 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Ada.Assertions,
+    Interfaces.C.Strings;
+
+use type
+
+    Interfaces.C.int,
+    Interfaces.C.Strings.chars_ptr;
+
+
+package body FLTK.Asks is
+
+
+    package Chk renames Ada.Assertions;
+
+
+
+
+    ------------------------
+    --  Functions From C  --
+    ------------------------
+
+    function fl_ask_get_cancel
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_get_cancel, "fl_ask_get_cancel");
+    pragma Inline (fl_ask_get_cancel);
+
+    procedure fl_ask_set_cancel
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_set_cancel, "fl_ask_set_cancel");
+    pragma Inline (fl_ask_set_cancel);
+
+    function fl_ask_get_close
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_get_close, "fl_ask_get_close");
+    pragma Inline (fl_ask_get_close);
+
+    procedure fl_ask_set_close
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_set_close, "fl_ask_set_close");
+    pragma Inline (fl_ask_set_close);
+
+    function fl_ask_get_no
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_get_no, "fl_ask_get_no");
+    pragma Inline (fl_ask_get_no);
+
+    procedure fl_ask_set_no
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_set_no, "fl_ask_set_no");
+    pragma Inline (fl_ask_set_no);
+
+    function fl_ask_get_ok
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_get_ok, "fl_ask_get_ok");
+    pragma Inline (fl_ask_get_ok);
+
+    procedure fl_ask_set_ok
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_set_ok, "fl_ask_set_ok");
+    pragma Inline (fl_ask_set_ok);
+
+    function fl_ask_get_yes
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_get_yes, "fl_ask_get_yes");
+    pragma Inline (fl_ask_get_yes);
+
+    procedure fl_ask_set_yes
+           (V : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_set_yes, "fl_ask_set_yes");
+    pragma Inline (fl_ask_set_yes);
+
+
+
+
+    procedure fl_ask_alert
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_ask_alert, "fl_ask_alert");
+    pragma Inline (fl_ask_alert);
+
+    procedure fl_ask_beep
+           (B : in Interfaces.C.int);
+    pragma Import (C, fl_ask_beep, "fl_ask_beep");
+    pragma Inline (fl_ask_beep);
+
+    function fl_ask_choice
+           (M, A : in Interfaces.C.char_array;
+            B, C : in Interfaces.C.Strings.chars_ptr)
+        return Interfaces.C.int;
+    pragma Import (C, fl_ask_choice, "fl_ask_choice");
+    pragma Inline (fl_ask_choice);
+
+    function fl_ask_choice_n
+           (M, A : in Interfaces.C.char_array;
+            B, C : in Interfaces.C.Strings.chars_ptr)
+        return Interfaces.C.int;
+    pragma Import (C, fl_ask_choice_n, "fl_ask_choice_n");
+    pragma Inline (fl_ask_choice_n);
+
+    function fl_ask_input
+           (M, D : in Interfaces.C.char_array)
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_input, "fl_ask_input");
+    pragma Inline (fl_ask_input);
+
+    procedure fl_ask_message
+           (M : in Interfaces.C.char_array);
+    pragma Import (C, fl_ask_message, "fl_ask_message");
+    pragma Inline (fl_ask_message);
+
+    function fl_ask_password
+           (M, D : in Interfaces.C.char_array)
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_password, "fl_ask_password");
+    pragma Inline (fl_ask_password);
+
+
+
+
+    function fl_ask_color_chooser
+           (N       : in     Interfaces.C.char_array;
+            R, G, B : in out Interfaces.C.double;
+            M       : in     Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_ask_color_chooser, "fl_ask_color_chooser");
+    pragma Inline (fl_ask_color_chooser);
+
+    function fl_ask_color_chooser2
+           (N       : in     Interfaces.C.char_array;
+            R, G, B : in out Interfaces.C.unsigned_char;
+            M       : in     Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_ask_color_chooser2, "fl_ask_color_chooser2");
+    pragma Inline (fl_ask_color_chooser2);
+
+    function fl_ask_dir_chooser
+           (M, D : in Interfaces.C.char_array;
+            R    : in Interfaces.C.int)
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_dir_chooser, "fl_ask_dir_chooser");
+    pragma Inline (fl_ask_dir_chooser);
+
+    function fl_ask_file_chooser
+           (M, P, D : in Interfaces.C.char_array;
+            R       : in Interfaces.C.int)
+        return Interfaces.C.Strings.chars_ptr;
+    pragma Import (C, fl_ask_file_chooser, "fl_ask_file_chooser");
+    pragma Inline (fl_ask_file_chooser);
+
+    procedure fl_ask_file_chooser_callback
+           (CB : in Storage.Integer_Address);
+    pragma Import (C, fl_ask_file_chooser_callback, "fl_ask_file_chooser_callback");
+    pragma Inline (fl_ask_file_chooser_callback);
+
+    procedure fl_ask_file_chooser_ok_label
+           (L : in Interfaces.C.Strings.chars_ptr);
+    pragma Import (C, fl_ask_file_chooser_ok_label, "fl_ask_file_chooser_ok_label");
+    pragma Inline (fl_ask_file_chooser_ok_label);
+
+
+
+
+    function fl_ask_get_message_hotspot
+        return Interfaces.C.int;
+    pragma Import (C, fl_ask_get_message_hotspot, "fl_ask_get_message_hotspot");
+    pragma Inline (fl_ask_get_message_hotspot);
+
+    procedure fl_ask_set_message_hotspot
+           (V : in Interfaces.C.int);
+    pragma Import (C, fl_ask_set_message_hotspot, "fl_ask_set_message_hotspot");
+    pragma Inline (fl_ask_set_message_hotspot);
+
+    procedure fl_ask_message_font
+           (F, S : in Interfaces.C.int);
+    pragma Import (C, fl_ask_message_font, "fl_ask_message_font");
+    pragma Inline (fl_ask_message_font);
+
+    function fl_ask_message_icon
+        return Storage.Integer_Address;
+    pragma Import (C, fl_ask_message_icon, "fl_ask_message_icon");
+    pragma Inline (fl_ask_message_icon);
+
+    procedure fl_ask_message_title
+           (T : in Interfaces.C.char_array);
+    pragma Import (C, fl_ask_message_title, "fl_ask_message_title");
+    pragma Inline (fl_ask_message_title);
+
+    procedure fl_ask_message_title_default
+           (T : in Interfaces.C.char_array);
+    pragma Import (C, fl_ask_message_title_default, "fl_ask_message_title_default");
+    pragma Inline (fl_ask_message_title_default);
+
+
+
+
+    ---------------------
+    --  Callback Hook  --
+    ---------------------
+
+    procedure File_Chooser_Callback_Hook
+           (C_Str : in Interfaces.C.Strings.chars_ptr);
+
+    pragma Convention (C, File_Chooser_Callback_Hook);
+
+    procedure File_Chooser_Callback_Hook
+           (C_Str : in Interfaces.C.Strings.chars_ptr) is
+    begin
+        if Chooser_Func /= null then
+            Chooser_Func (Interfaces.C.Strings.Value (C_Str));
+        end if;
+    end File_Chooser_Callback_Hook;
+
+
+
+
+    ---------------
+    --  Cleanup  --
+    ---------------
+
+    procedure Finalize
+           (This : in out Dialog_String_Final_Controller)
+    is
+        use Interfaces.C.Strings;
+    begin
+        Free (Cancel_Str);
+        Free (Close_Str);
+        Free (No_Str);
+        Free (OK_Str);
+        Free (Yes_Str);
+        Free (Chooser_OK_Str);
+    end Finalize;
+
+
+
+
+    ------------------
+    --  Attributes  --
+    ------------------
+
+    function Get_Cancel_String
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_ask_get_cancel);
+    end Get_Cancel_String;
+
+
+    procedure Set_Cancel_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (Cancel_Str);
+        Cancel_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_set_cancel (Cancel_Str);
+    end Set_Cancel_String;
+
+
+    function Get_Close_String
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_ask_get_close);
+    end Get_Close_String;
+
+
+    procedure Set_Close_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (Close_Str);
+        Close_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_set_close (Close_Str);
+    end Set_Close_String;
+
+
+    function Get_No_String
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_ask_get_no);
+    end Get_No_String;
+
+
+    procedure Set_No_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (No_Str);
+        No_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_set_no (No_Str);
+    end Set_No_String;
+
+
+    function Get_OK_String
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_ask_get_ok);
+    end Get_OK_String;
+
+
+    procedure Set_OK_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (OK_Str);
+        OK_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_set_ok (OK_Str);
+    end Set_OK_String;
+
+
+    function Get_Yes_String
+        return String is
+    begin
+        return Interfaces.C.Strings.Value (fl_ask_get_yes);
+    end Get_Yes_String;
+
+
+    procedure Set_Yes_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (Yes_Str);
+        Yes_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_set_yes (Yes_Str);
+    end Set_Yes_String;
+
+
+
+
+    ----------------------
+    --  Common Dialogs  --
+    ----------------------
+
+    procedure Alert
+           (Message : String) is
+    begin
+        fl_ask_alert (Interfaces.C.To_C (Message));
+    end Alert;
+
+
+    procedure Beep
+           (Kind : in Beep_Kind := Default_Beep) is
+    begin
+        fl_ask_beep (Beep_Kind'Pos (Kind));
+    end Beep;
+
+
+    function Choice
+           (Message, Button1 : in String)
+        return Choice_Result
+    is
+        Result : Interfaces.C.int := fl_ask_choice
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.Null_Ptr,
+            Interfaces.C.Strings.Null_Ptr);
+    begin
+        return Choice_Result'Val (Result);
+    end Choice;
+
+
+    function Choice
+           (Message, Button1, Button2 : in String)
+        return Choice_Result
+    is
+        Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2);
+        Result : Interfaces.C.int := fl_ask_choice
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access),
+            Interfaces.C.Strings.Null_Ptr);
+    begin
+        return Choice_Result'Val (Result);
+    end Choice;
+
+
+    function Choice
+           (Message, Button1, Button2, Button3 : in String)
+        return Choice_Result
+    is
+        Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2);
+        Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3);
+        Result : Interfaces.C.int := fl_ask_choice
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access),
+            Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access));
+    begin
+        return Choice_Result'Val (Result);
+    end Choice;
+
+
+    function Extended_Choice
+           (Message, Button1 : in String)
+        return Extended_Choice_Result
+    is
+        Result : Interfaces.C.int := fl_ask_choice_n
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.Null_Ptr,
+            Interfaces.C.Strings.Null_Ptr);
+    begin
+        pragma Assert (Result in -3 .. 2);
+        return Extended_Choice_Result'Val (Result mod 6);
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
+    end Extended_Choice;
+
+
+    function Extended_Choice
+           (Message, Button1, Button2 : in String)
+        return Extended_Choice_Result
+    is
+        Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2);
+        Result : Interfaces.C.int := fl_ask_choice_n
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access),
+            Interfaces.C.Strings.Null_Ptr);
+    begin
+        pragma Assert (Result in -3 .. 2);
+        return Extended_Choice_Result'Val (Result mod 6);
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
+    end Extended_Choice;
+
+
+    function Extended_Choice
+           (Message, Button1, Button2, Button3 : in String)
+        return Extended_Choice_Result
+    is
+        Str2 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button2);
+        Str3 : aliased Interfaces.C.char_array := Interfaces.C.To_C (Button3);
+        Result : Interfaces.C.int := fl_ask_choice_n
+           (Interfaces.C.To_C (Message),
+            Interfaces.C.To_C (Button1),
+            Interfaces.C.Strings.To_Chars_Ptr (Str2'Unchecked_Access),
+            Interfaces.C.Strings.To_Chars_Ptr (Str3'Unchecked_Access));
+    begin
+        pragma Assert (Result in -3 .. 2);
+        return Extended_Choice_Result'Val (Result mod 6);
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
+    end Extended_Choice;
+
+
+    function Text_Input
+           (Message : in String;
+            Default : in String := "")
+        return String
+    is
+        Result : Interfaces.C.Strings.chars_ptr := fl_ask_input
+               (Interfaces.C.To_C (Message),
+                Interfaces.C.To_C (Default));
+    begin
+        --  Result does not need dealloc
+        if Result = Interfaces.C.Strings.Null_Ptr then
+            return "";
+        else
+            return Interfaces.C.Strings.Value (Result);
+        end if;
+    end Text_Input;
+
+
+    procedure Message_Box
+           (Message : in String) is
+    begin
+        fl_ask_message (Interfaces.C.To_C (Message));
+    end Message_Box;
+
+
+    function Password
+           (Message : in String;
+            Default : in String := "")
+        return String
+    is
+        Result : Interfaces.C.Strings.chars_ptr := fl_ask_password
+               (Interfaces.C.To_C (Message),
+                Interfaces.C.To_C (Default));
+    begin
+        --  Result does not need dealloc
+        if Result = Interfaces.C.Strings.Null_Ptr then
+            return "";
+        else
+            return Interfaces.C.Strings.Value (Result);
+        end if;
+    end Password;
+
+
+
+
+    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
+    is
+        C_R : Interfaces.C.double := Interfaces.C.double (R);
+        C_G : Interfaces.C.double := Interfaces.C.double (G);
+        C_B : Interfaces.C.double := Interfaces.C.double (B);
+        M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode);
+        Result : Interfaces.C.int := fl_ask_color_chooser
+            (Interfaces.C.To_C (Title), C_R, C_G, C_B, M);
+    begin
+        if Result = 1 then
+            R := RGB_Float (C_R);
+            G := RGB_Float (C_G);
+            B := RGB_Float (C_B);
+            return Confirm;
+        else
+            pragma Assert (Result = 0);
+            return Cancel;
+        end if;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
+    end Color_Chooser;
+
+
+    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
+    is
+        C_R : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (R);
+        C_G : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (G);
+        C_B : Interfaces.C.unsigned_char := Interfaces.C.unsigned_char (B);
+        M : Interfaces.C.int := FLTK.Widgets.Groups.Color_Choosers.Color_Mode'Pos (Mode);
+        Result : Interfaces.C.int := fl_ask_color_chooser2
+               (Interfaces.C.To_C (Title), C_R, C_G, C_B, M);
+    begin
+        if Result = 1 then
+            R := RGB_Int (C_R);
+            G := RGB_Int (C_G);
+            B := RGB_Int (C_B);
+            return Confirm;
+        else
+            pragma Assert (Result = 0);
+            return Cancel;
+        end if;
+    exception
+    when Chk.Assertion_Error => raise Internal_FLTK_Error;
+    end Color_Chooser;
+
+
+    function Dir_Chooser
+           (Message, Default : in String;
+            Relative         : in Boolean := False)
+        return String
+    is
+        Result : Interfaces.C.Strings.chars_ptr := fl_ask_dir_chooser
+               (Interfaces.C.To_C (Message),
+                Interfaces.C.To_C (Default),
+                Boolean'Pos (Relative));
+    begin
+        --  Result does not need dealloc
+        if Result = Interfaces.C.Strings.Null_Ptr then
+            return "";
+        else
+            return Interfaces.C.Strings.Value (Result);
+        end if;
+    end Dir_Chooser;
+
+
+    function File_Chooser
+           (Message, Filter_Pattern, Default : in String;
+            Relative                         : in Boolean := False)
+        return String
+    is
+        Result : Interfaces.C.Strings.chars_ptr := fl_ask_file_chooser
+               (Interfaces.C.To_C (Message),
+                Interfaces.C.To_C (Filter_Pattern),
+                Interfaces.C.To_C (Default),
+                Boolean'Pos (Relative));
+    begin
+        --  Result does not need dealloc
+        if Result = Interfaces.C.Strings.Null_Ptr then
+            return "";
+        else
+            return Interfaces.C.Strings.Value (Result);
+        end if;
+    end File_Chooser;
+
+
+    procedure Set_File_Chooser_Callback
+           (Func : in File_Chooser_Callback) is
+    begin
+        Chooser_Func := Func;
+    end Set_File_Chooser_Callback;
+
+
+    procedure Set_File_Chooser_OK_String
+           (Value : in String) is
+    begin
+        Interfaces.C.Strings.Free (Chooser_OK_Str);
+        Chooser_OK_Str := Interfaces.C.Strings.New_String (Value);
+        fl_ask_file_chooser_ok_label (Chooser_OK_Str);
+    end Set_File_Chooser_OK_String;
+
+
+
+
+    function Get_Message_Hotspot
+        return Boolean is
+    begin
+        return fl_ask_get_message_hotspot /= 0;
+    end Get_Message_Hotspot;
+
+
+    procedure Set_Message_Hotspot
+           (To : in Boolean) is
+    begin
+        fl_ask_set_message_hotspot (Boolean'Pos (To));
+    end Set_Message_Hotspot;
+
+
+    procedure Set_Message_Font
+           (Font : in Font_Kind;
+            Size : in Font_Size) is
+    begin
+        fl_ask_message_font (Font_Kind'Pos (Font), Interfaces.C.int (Size));
+    end Set_Message_Font;
+
+
+    function Get_Message_Icon
+        return FLTK.Widgets.Boxes.Box_Reference is
+    begin
+        return (Data => Icon_Box'Access);
+    end Get_Message_Icon;
+
+
+    procedure Set_Message_Title
+           (To : in String) is
+    begin
+        fl_ask_message_title (Interfaces.C.To_C (To));
+    end Set_Message_Title;
+
+
+    procedure Set_Message_Title_Default
+           (To : in String) is
+    begin
+        fl_ask_message_title_default (Interfaces.C.To_C (To));
+    end Set_Message_Title_Default;
+
+
+
+
+begin
+
+
+    Wrapper (Icon_Box).Void_Ptr := fl_ask_message_icon;
+    Wrapper (Icon_Box).Needs_Dealloc := False;
+
+    fl_ask_file_chooser_callback (Storage.To_Integer (File_Chooser_Callback_Hook'Address));
+
+
+end FLTK.Asks;
+