diff options
Diffstat (limited to 'body/fltk.adb')
| -rw-r--r-- | body/fltk.adb | 459 |
1 files changed, 405 insertions, 54 deletions
diff --git a/body/fltk.adb b/body/fltk.adb index d729364..49d9048 100644 --- a/body/fltk.adb +++ b/body/fltk.adb @@ -11,20 +11,149 @@ with use type Interfaces.C.int, - Interfaces.C.unsigned_long; + Interfaces.C.unsigned, + Interfaces.C.unsigned_char; package body FLTK is + ------------------------ + -- Constants From C -- + ------------------------ + + -- Color -- + + fl_enum_num_red : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_red, "fl_enum_num_red"); + + fl_enum_num_green : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_green, "fl_enum_num_green"); + + fl_enum_num_blue : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_blue, "fl_enum_num_blue"); + + fl_enum_num_gray : constant Interfaces.C.int; + pragma Import (C, fl_enum_num_gray, "fl_enum_num_gray"); + + + + + -- Keyboard and Mouse Input -- + + fl_enum_button1 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button1, "fl_enum_button1"); + + fl_enum_button2 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button2, "fl_enum_button2"); + + fl_enum_button3 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button3, "fl_enum_button3"); + + fl_enum_button4 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button4, "fl_enum_button4"); + + fl_enum_button5 : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_button5, "fl_enum_button5"); + + fl_enum_buttons : constant Interfaces.C.unsigned; + pragma Import (C, fl_enum_buttons, "fl_enum_buttons"); + + + + + ------------------------ + -- 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) @@ -50,18 +179,7 @@ package body FLTK is - 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; @@ -80,7 +198,7 @@ package body FLTK is function fl_wait2 (S : in Interfaces.C.double) - return Interfaces.C.int; + return Interfaces.C.double; pragma Import (C, fl_wait2, "fl_wait2"); pragma Inline (fl_wait2); @@ -92,6 +210,12 @@ package body FLTK is + ----------------------- + -- API Subprograms -- + ----------------------- + + -- Implementation Details -- + function Is_Valid (Object : in Wrapper) return Boolean is @@ -100,13 +224,28 @@ package body FLTK is end Is_Valid; - procedure Initialize - (This : in out Wrapper) is + + + -- Color -- + + function RGB_Color + (Light : in Greyscale) + return Color is begin - This.Void_Ptr := Null_Pointer; - end Initialize; + 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 @@ -120,7 +259,83 @@ package body FLTK is 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) @@ -134,12 +349,14 @@ package body FLTK is (Left, Right : in Alignment) return Alignment is begin - return Left and (not Right); + return Left and not Right; end "-"; + -- Keyboard and Mouse Input -- + function Press (Key : in Pressable_Key) return Keypress is @@ -250,14 +467,14 @@ package body FLTK is function To_C (Key : in Key_Combo) - return Interfaces.C.int is + return Interfaces.C.unsigned 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) + (Key : in Interfaces.C.unsigned) return Key_Combo is begin return Result : Key_Combo do @@ -270,14 +487,14 @@ package body FLTK is function To_C (Key : in Keypress) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Key); + return Interfaces.C.unsigned (Key); end To_C; function To_Ada - (Key : in Interfaces.C.int) + (Key : in Interfaces.C.unsigned) return Keypress is begin return Keypress (Key mod 65536); @@ -286,14 +503,14 @@ package body FLTK is function To_C (Modi : in Modifier) - return Interfaces.C.int is + return Interfaces.C.unsigned is begin - return Interfaces.C.int (Modi) * 65536; + return Interfaces.C.unsigned (Modi) * 65536; end To_C; function To_Ada - (Modi : in Interfaces.C.int) + (Modi : in Interfaces.C.unsigned) return Modifier is begin return Modifier ((Modi / 65536) mod 256); @@ -302,42 +519,181 @@ package body FLTK is function To_C (Button : in Mouse_Button) - return Interfaces.C.int is + return Interfaces.C.unsigned 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; + when No_Button => return 0; + when Left_Button => return fl_enum_button1; + when Middle_Button => return fl_enum_button2; + when Right_Button => return fl_enum_button3; + when Back_Button => return fl_enum_button4; + when Forward_Button => return fl_enum_button5; + when Any_Button => return fl_enum_buttons; end case; end To_C; function To_Ada - (Button : in Interfaces.C.int) + (Button : in Interfaces.C.unsigned) 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; + if Button = 0 then + return No_Button; + elsif Button = fl_enum_button1 then + return Left_Button; + elsif Button = fl_enum_button2 then + return Middle_Button; + elsif Button = fl_enum_button3 then + return Right_Button; + elsif Button = fl_enum_button4 then + return Back_Button; + elsif Button = fl_enum_button5 then + return Forward_Button; + elsif Button = fl_enum_buttons then + return Any_Button; + else + raise Constraint_Error; + end if; end To_Ada; + -- Box Types -- + + function Filled + (Box : in Box_Kind) + return Box_Kind + is + Result : constant 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 : constant 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 : constant 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; + + + + + -- Callback Flags -- + + type Callback_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function CFlag_To_Bits is new + Ada.Unchecked_Conversion (Callback_Flag, Callback_Bitmask); + + function Bits_To_CFlag is new + Ada.Unchecked_Conversion (Callback_Bitmask, Callback_Flag); + + + function "+" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) or CFlag_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Callback_Flag) + return Callback_Flag is + begin + return Bits_To_CFlag (CFlag_To_Bits (Left) and not CFlag_To_Bits (Right)); + end "-"; + + + + + -- Menu Flags -- + + type Menu_Bitmask is mod 2 ** Interfaces.C.int'Size; + + function MFlag_To_Bits is new + Ada.Unchecked_Conversion (Menu_Flag, Menu_Bitmask); + + function Bits_To_MFlag is new + Ada.Unchecked_Conversion (Menu_Bitmask, Menu_Flag); + + function "+" (Left, Right : in Menu_Flag) return Menu_Flag is begin - return Left or Right; + return Bits_To_MFlag (MFlag_To_Bits (Left) or MFlag_To_Bits (Right)); end "+"; + function "-" + (Left, Right : in Menu_Flag) + return Menu_Flag is + begin + return Bits_To_MFlag (MFlag_To_Bits (Left) and not MFlag_To_Bits (Right)); + end "-"; + + + + + -- Damage Bits -- + + type Damage_Bitmask is mod 2 ** Interfaces.C.unsigned_char'Size; + + function Damage_To_Bits is new + Ada.Unchecked_Conversion (Damage_Mask, Damage_Bitmask); + + function Bits_To_Damage is new + Ada.Unchecked_Conversion (Damage_Bitmask, Damage_Mask); + function "+" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) or Damage_To_Bits (Right)); + end "+"; + + + function "-" + (Left, Right : in Damage_Mask) + return Damage_Mask is + begin + return Bits_To_Damage (Damage_To_Bits (Left) and not Damage_To_Bits (Right)); + end "-"; + + + + + -- Versioning -- + function ABI_Check (ABI_Ver : in Version_Number) return Boolean is @@ -369,20 +725,14 @@ package body FLTK is - function Is_Damaged - return Boolean is - begin - return fl_get_damage /= 0; - end Is_Damaged; - + -- Event Loop -- - procedure Set_Damaged - (To : in Boolean) is + procedure Check + is + Ignore : Interfaces.C.int := fl_check; begin - fl_set_damage (Boolean'Pos (To)); - end Set_Damaged; - - + null; + end Check; function Check @@ -408,9 +758,9 @@ package body FLTK is function Wait (Seconds : in Long_Float) - return Integer is + return Long_Float is begin - return Integer (fl_wait2 (Interfaces.C.double (Seconds))); + return Long_Float (fl_wait2 (Interfaces.C.double (Seconds))); end Wait; @@ -423,3 +773,4 @@ package body FLTK is end FLTK; + |