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