1 files changed, 407 insertions, 0 deletions
diff --git a/body/fltk.adb b/body/fltk.adb
new file mode 100644
index 0000000..f302b47
--- /dev/null
+++ b/body/fltk.adb
@@ -0,0 +1,407 @@
+
+
+--  Programmed by Jedidiah Barber
+--  Released into the public domain
+
+
+with
+
+    Interfaces.C;
+
+use type
+
+    Interfaces.C.int,
+    Interfaces.C.unsigned_long;
+
+
+package body FLTK is
+
+
+    function fl_enum_rgb_color
+           (R, G, B : in Interfaces.C.unsigned_char)
+        return Interfaces.C.unsigned;
+    pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color");
+    pragma Inline (fl_enum_rgb_color);
+
+
+
+
+    function fl_abi_check
+           (V : in Interfaces.C.int)
+        return Interfaces.C.int;
+    pragma Import (C, fl_abi_check, "fl_abi_check");
+    pragma Inline (fl_abi_check);
+
+    function fl_abi_version
+        return Interfaces.C.int;
+    pragma Import (C, fl_abi_version, "fl_abi_version");
+    pragma Inline (fl_abi_version);
+
+    function fl_api_version
+        return Interfaces.C.int;
+    pragma Import (C, fl_api_version, "fl_api_version");
+    pragma Inline (fl_api_version);
+
+    function fl_version
+        return Interfaces.C.double;
+    pragma Import (C, fl_version, "fl_version");
+    pragma Inline (fl_version);
+
+
+
+
+    function fl_get_damage
+        return Interfaces.C.int;
+    pragma Import (C, fl_get_damage, "fl_get_damage");
+    pragma Inline (fl_get_damage);
+
+    procedure fl_set_damage
+           (V : in Interfaces.C.int);
+    pragma Import (C, fl_set_damage, "fl_set_damage");
+    pragma Inline (fl_set_damage);
+
+
+
+
+    function fl_check
+        return Interfaces.C.int;
+    pragma Import (C, fl_check, "fl_check");
+    pragma Inline (fl_check);
+
+    function fl_ready
+        return Interfaces.C.int;
+    pragma Import (C, fl_ready, "fl_ready");
+    pragma Inline (fl_ready);
+
+    function fl_wait
+        return Interfaces.C.int;
+    pragma Import (C, fl_wait, "fl_wait");
+    pragma Inline (fl_wait);
+
+    function fl_wait2
+           (S : in Interfaces.C.double)
+        return Interfaces.C.int;
+    pragma Import (C, fl_wait2, "fl_wait2");
+    pragma Inline (fl_wait2);
+
+    function fl_run
+        return Interfaces.C.int;
+    pragma Import (C, fl_run, "fl_run");
+    pragma Inline (fl_run);
+
+
+
+
+    function Is_Valid
+           (Object : in Wrapper)
+        return Boolean is
+    begin
+        return Object.Void_Ptr /= Null_Pointer;
+    end Is_Valid;
+
+
+    procedure Initialize
+           (This : in out Wrapper) is
+    begin
+        This.Void_Ptr := Null_Pointer;
+    end Initialize;
+
+
+
+
+    function RGB_Color
+           (R, G, B : in Color_Component)
+        return Color is
+    begin
+        return Color (fl_enum_rgb_color
+           (Interfaces.C.unsigned_char (R),
+            Interfaces.C.unsigned_char (G),
+            Interfaces.C.unsigned_char (B)));
+    end RGB_Color;
+
+
+
+
+    function Press
+           (Key : in Pressable_Key)
+        return Keypress is
+    begin
+        return Character'Pos (Key);
+    end Press;
+
+
+    function Press
+           (Key : Pressable_Key)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Mod_None;
+            This.Keycode := Character'Pos (Key);
+            This.Mousecode := No_Button;
+        end return;
+    end Press;
+
+
+    function Press
+           (Key : in Keypress)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Mod_None;
+            This.Keycode := Key;
+            This.Mousecode := No_Button;
+        end return;
+    end Press;
+
+
+    function Press
+           (Key : in Mouse_Button)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Mod_None;
+            This.Keycode := 0;
+            This.Mousecode := Key;
+        end return;
+    end Press;
+
+
+
+
+    function "+"
+           (Left, Right : in Modifier)
+        return Modifier is
+    begin
+        return Left or Right;
+    end "+";
+
+
+    function "+"
+           (Left  : in Modifier;
+            Right : in Pressable_Key)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Left;
+            This.Keycode := Character'Pos (Right);
+            This.Mousecode := No_Button;
+        end return;
+    end "+";
+
+
+    function "+"
+           (Left : in Modifier;
+            Right : in Keypress)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Left;
+            This.Keycode := Right;
+            This.Mousecode := No_Button;
+        end return;
+    end "+";
+
+
+    function "+"
+           (Left : in Modifier;
+            Right : in Mouse_Button)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Left;
+            This.Keycode := 0;
+            This.Mousecode := Right;
+        end return;
+    end "+";
+
+
+    function "+"
+           (Left  : in Modifier;
+            Right : in Key_Combo)
+        return Key_Combo is
+    begin
+        return This : Key_Combo do
+            This.Modcode := Left or Right.Modcode;
+            This.Keycode := Right.Keycode;
+            This.Mousecode := Right.Mousecode;
+        end return;
+    end "+";
+
+
+
+
+    function To_C
+           (Key : in Key_Combo)
+        return Interfaces.C.int is
+    begin
+        return To_C (Key.Modcode) + To_C (Key.Keycode) + To_C (Key.Mousecode);
+    end To_C;
+
+
+    function To_Ada
+           (Key : in Interfaces.C.int)
+        return Key_Combo is
+    begin
+        return Result : Key_Combo do
+            Result.Modcode := To_Ada (Key);
+            Result.Keycode := To_Ada (Key);
+            Result.Mousecode := To_Ada (Key);
+        end return;
+    end To_Ada;
+
+
+    function To_C
+           (Key : in Keypress)
+        return Interfaces.C.int is
+    begin
+        return Interfaces.C.int (Key);
+    end To_C;
+
+
+    function To_Ada
+           (Key : in Interfaces.C.int)
+        return Keypress is
+    begin
+        return Keypress (Key mod 65536);
+    end To_Ada;
+
+
+    function To_C
+           (Modi : in Modifier)
+        return Interfaces.C.int is
+    begin
+        return Interfaces.C.int (Modi) * 65536;
+    end To_C;
+
+
+    function To_Ada
+           (Modi : in Interfaces.C.int)
+        return Modifier is
+    begin
+        return Modifier ((Modi / 65536) mod 256);
+    end To_Ada;
+
+
+    function To_C
+           (Button : in Mouse_Button)
+        return Interfaces.C.int is
+    begin
+        case Button is
+            when Left_Button => return 1 * (256 ** 3);
+            when Middle_Button => return 2 * (256 ** 3);
+            when Right_Button => return 4 * (256 ** 3);
+            when others => return 0;
+        end case;
+    end To_C;
+
+
+    function To_Ada
+           (Button : in Interfaces.C.int)
+        return Mouse_Button is
+    begin
+        case (Button / (256 ** 3)) is
+            when 1 => return Left_Button;
+            when 2 => return Middle_Button;
+            when 4 => return Right_Button;
+            when others => return No_Button;
+        end case;
+    end To_Ada;
+
+
+
+
+    function "+"
+           (Left, Right : in Menu_Flag)
+        return Menu_Flag is
+    begin
+        return Left or Right;
+    end "+";
+
+
+
+
+    function ABI_Check
+           (ABI_Ver : in Version_Number)
+        return Boolean is
+    begin
+        return fl_abi_check (Interfaces.C.int (ABI_Ver)) /= 0;
+    end ABI_Check;
+
+
+    function ABI_Version
+        return Version_Number is
+    begin
+        return Version_Number (fl_abi_version);
+    end ABI_Version;
+
+
+    function API_Version
+        return Version_Number is
+    begin
+        return Version_Number (fl_api_version);
+    end API_Version;
+
+
+    function Version
+        return Version_Number is
+    begin
+        return Version_Number (fl_version);
+    end Version;
+
+
+
+
+    function Is_Damaged
+        return Boolean is
+    begin
+        return fl_get_damage /= 0;
+    end Is_Damaged;
+
+
+    procedure Set_Damaged
+           (To : in Boolean) is
+    begin
+        fl_set_damage (Boolean'Pos (To));
+    end Set_Damaged;
+
+
+
+
+    function Check
+        return Boolean is
+    begin
+        return fl_check /= 0;
+    end Check;
+
+
+    function Ready
+        return Boolean is
+    begin
+        return fl_ready /= 0;
+    end Ready;
+
+
+    function Wait
+        return Integer is
+    begin
+        return Integer (fl_wait);
+    end Wait;
+
+
+    function Wait
+           (Seconds : in Long_Float)
+        return Integer is
+    begin
+        return Integer (fl_wait2 (Interfaces.C.double (Seconds)));
+    end Wait;
+
+
+    function Run
+        return Integer is
+    begin
+        return Integer (fl_run);
+    end Run;
+
+
+end FLTK;
+