path: root/body/fltk.adb

--  Programmed by Jedidiah Barber
--  Released into the public domain


with

    Interfaces.C;

use type

    Interfaces.C.int,
    Interfaces.C.unsigned_char,
    Interfaces.C.unsigned_long;


package body FLTK is


    ------------------------
    --  Constants From C  --
    ------------------------

    fl_enum_num_red : constant Interfaces.C.int;
    pragma Import (C, fl_enum_num_red);

    fl_enum_num_green : constant Interfaces.C.int;
    pragma Import (C, fl_enum_num_green);

    fl_enum_num_blue : constant Interfaces.C.int;
    pragma Import (C, fl_enum_num_blue);

    fl_enum_num_gray : constant Interfaces.C.int;
    pragma Import (C, fl_enum_num_gray);




    ------------------------
    --  Functions From C  --
    ------------------------

    --  Enumerations.H  --

    --  Color  --

    function fl_enum_rgb_color2
           (L : in Interfaces.C.unsigned_char)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_rgb_color2, "fl_enum_rgb_color2");
    pragma Inline (fl_enum_rgb_color2);

    function fl_enum_rgb_color
           (R, G, B : in Interfaces.C.unsigned_char)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_rgb_color, "fl_enum_rgb_color");
    pragma Inline (fl_enum_rgb_color);

    function fl_enum_color_cube
           (R, G, B : in Interfaces.C.int)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_color_cube, "fl_enum_color_cube");
    pragma Inline (fl_enum_color_cube);

    function fl_enum_gray_ramp
           (L : in Interfaces.C.int)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_gray_ramp, "fl_enum_gray_ramp");
    pragma Inline (fl_enum_gray_ramp);

    function fl_enum_darker
           (T : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_darker, "fl_enum_darker");
    pragma Inline (fl_enum_darker);

    function fl_enum_lighter
           (T : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_lighter, "fl_enum_lighter");
    pragma Inline (fl_enum_lighter);

    function fl_enum_contrast
           (F, B : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_contrast, "fl_enum_contrast");
    pragma Inline (fl_enum_contrast);

    function fl_enum_inactive
           (T : in Interfaces.C.unsigned)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_inactive, "fl_enum_inactive");
    pragma Inline (fl_enum_inactive);

    function fl_enum_color_average
           (T1, T2 : in Interfaces.C.unsigned;
            W      : in Interfaces.C.C_float)
        return Interfaces.C.unsigned;
    pragma Import (C, fl_enum_color_average, "fl_enum_color_average");
    pragma Inline (fl_enum_color_average);




    --  Box Types  --

    function fl_enum_box
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_enum_box, "fl_enum_box");
    pragma Inline (fl_enum_box);

    function fl_enum_frame
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_enum_frame, "fl_enum_frame");
    pragma Inline (fl_enum_frame);

    function fl_enum_down
           (B : in Interfaces.C.int)
        return Interfaces.C.int;
    pragma Import (C, fl_enum_down, "fl_enum_down");
    pragma Inline (fl_enum_down);




    --  Fl.H  --

    --  Versioning  --

    function fl_abi_check
           (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);




    --  Drawing  --

    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);




    --  Event Loop  --

    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.double;
    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);




    -----------------------
    --  API Subprograms  --
    -----------------------

    --  Implementation Details  --

    function Is_Valid
           (Object : in Wrapper)
        return Boolean is
    begin
        return Object.Void_Ptr /= Null_Pointer;
    end Is_Valid;




    --  Color  --

    function RGB_Color
           (Light : in Greyscale)
        return Color is
    begin
        case Light is
        when 'A' .. 'W' => return Color (fl_enum_rgb_color2
            ((Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First)) * 11));
        when 'X' => return Color (fl_enum_rgb_color2 (255));
        end case;
    end RGB_Color;


    function RGB_Color
           (Light : in Color_Component)
        return Color is
    begin
        return Color (fl_enum_rgb_color2 (Interfaces.C.unsigned_char (Light)));
    end RGB_Color;


    function RGB_Color
           (R, G, B : in Color_Component)
        return Color is
    begin
        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 Color_Cube
           (R, G, B : in Color_Component)
        return Color is
    begin
        return Color (fl_enum_color_cube
           (Interfaces.C.int (Float'Rounding (Float (R) * Float (fl_enum_num_red   - 1) / 255.0)),
            Interfaces.C.int (Float'Rounding (Float (G) * Float (fl_enum_num_green - 1) / 255.0)),
            Interfaces.C.int (Float'Rounding (Float (B) * Float (fl_enum_num_blue  - 1) / 255.0))));
    end Color_Cube;


    function Grey_Ramp
           (Light : in Greyscale)
        return Color is
    begin
        return Color (fl_enum_gray_ramp (Greyscale'Pos (Light) - Greyscale'Pos (Greyscale'First)));
    end Grey_Ramp;


    function Grey_Ramp
           (Light : in Color_Component)
        return Color is
    begin
        return Color (fl_enum_gray_ramp (Interfaces.C.int
            (Float'Rounding (Float (Light) * Float (fl_enum_num_gray - 1) / 255.0))));
    end Grey_Ramp;


    function Darker
           (Tone : in Color)
        return Color is
    begin
        return Color (fl_enum_darker (Interfaces.C.unsigned (Tone)));
    end Darker;


    function Lighter
           (Tone : in Color)
        return Color is
    begin
        return Color (fl_enum_lighter (Interfaces.C.unsigned (Tone)));
    end Lighter;


    function Contrast
           (Fore, Back : in Color)
        return Color is
    begin
        return Color (fl_enum_contrast
           (Interfaces.C.unsigned (Fore),
            Interfaces.C.unsigned (Back)));
    end Contrast;


    function Inactive
           (Tone : in Color)
        return Color is
    begin
        return Color (fl_enum_inactive (Interfaces.C.unsigned (Tone)));
    end Inactive;


    function Color_Average
           (Tone1, Tone2 : in Color;
            Weight       : in Blend := 0.5)
        return Color is
    begin
        return Color (fl_enum_color_average
           (Interfaces.C.unsigned (Tone1),
            Interfaces.C.unsigned (Tone2),
            Interfaces.C.C_float (Weight)));
    end Color_Average;




    --  Alignment  --

    function "+"
           (Left, Right : in Alignment)
        return Alignment is
    begin
        return Left or Right;
    end "+";


    function "-"
           (Left, Right : in Alignment)
        return Alignment is
    begin
        return Left and (not Right);
    end "-";




    --  Keyboard and Mouse Input  --

    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;




    --  Box Types  --

    function Filled
           (Box : in Box_Kind)
        return Box_Kind
    is
        Result : Interfaces.C.int := fl_enum_box (Box_Kind'Pos (Box));
    begin
        return Box_Kind'Val (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "fl_box in Enumerations.H returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Filled;


    function Frame
           (Box : in Box_Kind)
        return Box_Kind
    is
        Result : Interfaces.C.int := fl_enum_frame (Box_Kind'Pos (Box));
    begin
        return Box_Kind'Val (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "fl_frame in Enumerations.H returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Frame;


    function Down
           (Box : in Box_Kind)
        return Box_Kind
    is
        Result : Interfaces.C.int := fl_enum_down (Box_Kind'Pos (Box));
    begin
        return Box_Kind'Val (Result);
    exception
    when Constraint_Error => raise Internal_FLTK_Error with
        "fl_down in Enumerations.H returned unexpected int value of " &
        Interfaces.C.int'Image (Result);
    end Down;




    --  Menu Flags  --

    function "+"
           (Left, Right : in Menu_Flag)
        return Menu_Flag is
    begin
        return Left or Right;
    end "+";




    --  Versioning  --

    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;




    --  Drawing  --

    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;




    --  Event Loop  --

    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 Long_Float is
    begin
        return Long_Float (fl_wait2 (Interfaces.C.double (Seconds)));
    end Wait;


    function Run
        return Integer is
    begin
        return Integer (fl_run);
    end Run;


end FLTK;