1. with Actions; 
  2.  
  3. pragma Warnings( Off, Actions ); 
  4. pragma Elaborate_All( Actions ); 
  5.  
  6. package Widgets.Buttons is 
  7.  
  8.     -- Represents a widget action involving a Button, like a press or release. 
  9.     type Button_Action is new Action with private; 
  10.     type A_Button_Action is access all Button_Action'Class; 
  11.  
  12.     Press   : constant Action_Id;    -- button is pressed down 
  13.     Held    : constant Action_Id;    -- button is held down for the repeat delay 
  14.     Release : constant Action_Id;    -- button is released 
  15.     Click   : constant Action_Id;    -- button is pressed and released quickly 
  16.  
  17.     ---------------------------------------------------------------------------- 
  18.  
  19.     -- This is the interface to implement in order to listen to button actions. 
  20.     -- When a button action occurs, the listener will be notified of the type of 
  21.     -- action performed and the button that performed the action. 
  22.     type Button_Listener is limited interface and Action_Listener; 
  23.     type A_Button_Listener is access all Button_Listener'Class; 
  24.  
  25.     -- Handles the button action 'action'. 
  26.     procedure Handle_Action( this   : access Button_Listener; 
  27.                              action : A_Button_Action ) is abstract; 
  28.  
  29.     -- A simple procedure to handle a button action, used by Simple_Button_Listener. 
  30.     type A_Button_Handler is 
  31.         access procedure( action : A_Button_Action ); 
  32.  
  33.     ---------------------------------------------------------------------------- 
  34.  
  35.     -- A Button is a simple control widget with two states: on and off. A button 
  36.     -- notifies listeners of each event, so that a listener can know when a 
  37.     -- button is pressed by the user, release, held down for a period of time, 
  38.     -- or clicked. 
  39.     -- 
  40.     -- This abstract class is intended to be extended by a subclass that 
  41.     -- implements a specific behavior, like toggling, or a button that goes back 
  42.     -- to Off as soon as the mouse is released. 
  43.     type Button is abstract new Widget with private; 
  44.     type A_Button is access all Button'Class; 
  45.  
  46.     -- Registers 'listener' as an Button_Action listener. 
  47.     procedure Add_Listener( this     : access Button; 
  48.                             listener : not null A_Button_Listener ); 
  49.  
  50.     -- Registers 'handler' to be invoked when a Button_Action occurs. 'handler' 
  51.     -- can be added multiple times and can't be removed. 
  52.     procedure Add_Listener( this    : access Button; 
  53.                             handler : not null A_Button_Handler ); 
  54.  
  55.     -- If contasting text is enabled, the text of the button will be displayed 
  56.     -- as either white or black, whichever contrasts most with the button's 
  57.     -- foreground color. 
  58.     procedure Contrast_Text( this : not null access Button'Class; enabled : Boolean ); 
  59.  
  60.     -- Returns the state of the button: True if it's on and False if it's off. 
  61.     function Get_State( this : not null access Button'Class ) return Boolean; 
  62.  
  63.     -- Returns the button's text. 
  64.     function Get_Text( this : not null access Button'Class ) return String; 
  65.  
  66.     -- Unregisters 'listener' as an Button_Action listener. 
  67.     procedure Remove_Listener( this     : access Button; 
  68.                                listener : not null A_Button_Listener ); 
  69.  
  70.     -- Sets the horizontal alignment for the button's icon and text. 
  71.     procedure Set_Align( this : not null access Button'Class; align : Align_Type ); 
  72.  
  73.     -- Sets the color to be used for a specific purpose. Setting the Foreground 
  74.     -- color to Transparent will cause the button to become transparent. 
  75.     procedure Set_Color( this    : access Button; 
  76.                          purpose : Color_Purpose; 
  77.                          color   : Color_Type ); 
  78.  
  79.     -- Sets the button's icon by filename. 
  80.     procedure Set_Icon( this : access Button; icon : String ); 
  81.  
  82.     -- Sets the shade applied to the button's foreground color when it is 
  83.     -- disabled. Use 1.0 for no shading, < 1.0 to darken and > 1.0 to lighten. 
  84.     procedure Set_Shade_Disabled( this : not null access Button'Class; shade : Float ); 
  85.  
  86.     -- Sets the shade applied to the button's foreground color when its state 
  87.     -- is On / Pressed down. Use 1.0 for no shading, < 1.0 to darken and > 1.0 
  88.     -- to lighten. 
  89.     procedure Set_Shade_On(this : not null access Button'Class; shade : Float ); 
  90.  
  91.     -- Sets the shade applied to the button's foreground color when the mouse 
  92.     -- hovers over it. Use 1.0 for no shading, < 1.0 to darken and > 1.0 to 
  93.     -- lighten. 
  94.     procedure Set_Shade_Hover( this : not null access Button'Class; shade : Float ); 
  95.  
  96.     -- Sets the state of the button. If the state changes, a Press or Release 
  97.     -- action will occur as appopriate. 
  98.     procedure Set_State( this : access Button; on : Boolean ); 
  99.  
  100.     -- Sets the button's text. 
  101.     procedure Set_Text( this : access Button; text : String ); 
  102.  
  103.     -- Toggles the state of the button to the opposite of the current state. A 
  104.     -- Press or Release action will occur as appopriate. 
  105.     procedure Toggle_State( this : access Button ); 
  106.  
  107. private 
  108.  
  109.     SPACING : constant Integer := 2; 
  110.  
  111.     ---------------------------------------------------------------------------- 
  112.  
  113.     type Button_Action is new Action with null record; 
  114.  
  115.     Press   : constant Action_Id := To_Action_Id( "button.press" ); 
  116.     Held    : constant Action_Id := To_Action_Id( "button.held" ); 
  117.     Release : constant Action_Id := To_Action_Id( "button.release" ); 
  118.     Click   : constant Action_Id := To_Action_Id( "button.click" ); 
  119.  
  120.     -- Deletes the Button_Action. 
  121.     procedure Delete( this : in out A_Button_Action ); 
  122.     pragma Postcondition( this = null ); 
  123.  
  124.     ---------------------------------------------------------------------------- 
  125.  
  126.     -- A Simple_Button_Listener is an adapter class that listens for 
  127.     -- Button_Action events and invokes a callback, A_Button_Handler. This 
  128.     -- allows callback procedures to handle input actions instead of requiring 
  129.     -- an object to do so. 
  130.     type Simple_Button_Listener is new Simple_Action_Listener and Button_Listener with 
  131.         record 
  132.             handler : A_Button_Handler := null; 
  133.         end record; 
  134.     type A_Simple_Button_Listener is access all Simple_Button_Listener'Class; 
  135.  
  136.     -- Creates a Simple_Button_Listener that invokes 'handler' when it receives 
  137.     -- a button action. 
  138.     function Create_Listener( handler : not null A_Button_Handler ) return A_Button_Listener; 
  139.     pragma Postcondition( Create_Listener'Result /= null ); 
  140.  
  141.     procedure Construct( this    : access Simple_Button_Listener; 
  142.                          handler : not null A_Button_Handler ); 
  143.  
  144.     -- Invokes the simple button listener's Button_Handler procedure. 
  145.     procedure Handle_Action( this   : access Simple_Button_Listener; 
  146.                              action : A_Button_Action ); 
  147.  
  148.     ---------------------------------------------------------------------------- 
  149.  
  150.     type Button is abstract new Widget with 
  151.         record 
  152.             text          : Unbounded_String; 
  153.             icon          : Integer := 0; 
  154.             on            : Boolean := False; 
  155.             align         : Align_Type := Align_Center; 
  156.             contrastText  : Boolean := False; 
  157.             shadeDisabled : Float := 0.9; 
  158.             shadeHover    : Float := 1.1; 
  159.             shadeOn       : Float := 0.85; 
  160.         end record; 
  161.  
  162.     procedure Construct( this : access Button; 
  163.                          view : not null access Game_Views.Game_View'Class; 
  164.                          id   : String; 
  165.                          text : String; 
  166.                          icon : String ); 
  167.     pragma Precondition( id'Length > 0 ); 
  168.  
  169.     -- Dispatches Action_Id 'id' to all registered Button_Action listeners. 
  170.     procedure Dispatch_Action( this : access Button; id : Action_Id ); 
  171.  
  172.     -- Draws the button. 
  173.     procedure Draw_Content( this : access Button; dc : Drawing_Context ); 
  174.  
  175.     -- Returns the minimum height of the button, based on its icon and text. 
  176.     function Get_Min_Height( this : access Button ) return Natural; 
  177.  
  178.     -- Returns the minimum width of the button, based on its icon and text. 
  179.     function Get_Min_Width( this : access Button ) return Natural; 
  180.  
  181.     -- Returns a string representation of the widget for debugging purposes. 
  182.     function To_String( this : access Button ) return String; 
  183.  
  184. end Widgets.Buttons;