1. with Actions; 
  2.  
  3. private with Ada.Containers.Doubly_Linked_Lists; 
  4.  
  5. pragma Warnings( Off, Actions ); 
  6. pragma Elaborate_All( Actions ); 
  7.  
  8. package Widgets.Buttons.Groups is 
  9.  
  10.     -- Represents a widget action involving a Button_Group. 
  11.     type Button_Group_Action is new Action with private; 
  12.     type A_Button_Group_Action is access all Button_Group_Action'Class; 
  13.  
  14.     Group_Cleared : constant Action_Id;    -- all buttons are off in the group 
  15.     Group_Set     : constant Action_Id;    -- one button in the group is on 
  16.  
  17.     -- A procedure to handle a button group action. 
  18.     type A_Button_Group_Listener is 
  19.         access procedure( action : A_Button_Group_Action ); 
  20.  
  21.     ---------------------------------------------------------------------------- 
  22.  
  23.     -- A Button_Group is a logical control object that allows buttons to be 
  24.     -- linked. A button group is used to create a radio-button-like behavior 
  25.     -- with two or more toggleable buttons. Button_Group is not actually a 
  26.     -- widget and an instance must be explicitly owned by another object, like 
  27.     -- the Game_View, to prevent leaks. The Button_Group object doesn't maintain 
  28.     -- ownership of any of the buttons added to its membership. 
  29.     type Button_Group is new Object and Button_Listener with private; 
  30.     type A_Button_Group is access all Button_Group'Class; 
  31.  
  32.     -- Creates a new, empty button group. 
  33.     function Create_Button_Group return A_Button_Group; 
  34.     pragma Postcondition( Create_Button_Group'Result /= null ); 
  35.  
  36.     -- Adds a button to the group's membership. 
  37.     procedure Add( this : access Button_Group; button : not null A_Button ); 
  38.  
  39.     -- Adds a button group listener to be notified of actions. Listeners can be 
  40.     -- added multiple times. 
  41.     procedure Add_Listener( this     : access Button_Group; 
  42.                             listener : not null A_Button_Group_Listener ); 
  43.  
  44.     -- Removes all buttons from the group's membership. 
  45.     procedure Clear( this : access Button_Group ); 
  46.  
  47.     -- Removes a button group listener from the listener list. If 'listener' 
  48.     -- isn't already listening then nothing happens. 
  49.     procedure Remove_Listener( this     : access Button_Group; 
  50.                                listener : not null A_Button_Group_Listener ); 
  51.  
  52.     -- Changes whether or not the active button in the group is allowed to be 
  53.     -- unselected. If 'keep' is set True then the active button on a tool group, 
  54.     -- once pressed, can't be unpressed. 
  55.     procedure Set_Keep_Selected( this : access Button_Group; keep : Boolean ); 
  56.  
  57.     -- Unpresses the active button in the group, if there is one. This will have 
  58.     -- no effect if the 'keep selected' option has been set unless 'force' is 
  59.     -- set True. 
  60.     procedure Unset( this  : access Button_Group; 
  61.                      force : Boolean := False ); 
  62.  
  63.     -- Deletes the Button_Group. 
  64.     procedure Delete( this : in out A_Button_Group ); 
  65.     pragma Postcondition( this = null ); 
  66.  
  67. private 
  68.  
  69.     -- Provides a list of Button_Group_Listeners. 
  70.     package Action_Listeners is new Ada.Containers.Doubly_Linked_Lists( A_Button_Group_Listener, "=" ); 
  71.     use Action_Listeners; 
  72.  
  73.     -- Provides a list of Buttons. 
  74.     package Button_Collection is new Ada.Containers.Doubly_Linked_Lists( A_Button, "=" ); 
  75.     use Button_Collection; 
  76.  
  77.     ---------------------------------------------------------------------------- 
  78.  
  79.     type Button_Group_Action is new Action with null record; 
  80.  
  81.     Group_Cleared : constant Action_Id := To_Action_Id( "button_group.cleared" ); 
  82.     Group_Set     : constant Action_Id := To_Action_Id( "button_group.set" ); 
  83.  
  84.     -- Deletes the Button_Group_Action. 
  85.     procedure Delete( this : in out A_Button_Group_Action ); 
  86.     pragma Postcondition( this = null ); 
  87.  
  88.     ---------------------------------------------------------------------------- 
  89.  
  90.     type Button_Group is new Object and Button_Listener with 
  91.         record 
  92.             buttons       : Button_Collection.List; 
  93.             pressed       : A_Button := null; 
  94.             keep_selected : Boolean := True;  -- force a button to remain selected 
  95.             listeners     : Action_Listeners.List; 
  96.         end record; 
  97.  
  98.     procedure Delete( this : in out Button_Group ); 
  99.  
  100.     -- Dispatches Action_Id 'id' to all registered Button_Group_Action listeners. 
  101.     procedure Dispatch_Action( this   : access Button_Group; 
  102.                                id     : Action_Id; 
  103.                                source : not null A_Widget ); 
  104.  
  105.     -- Handles actions of buttons within the button group's membership. A 
  106.     -- Button_Group_Action will occur as necessary. 
  107.     procedure Handle_Action( this   : access Button_Group; 
  108.                              action : A_Button_Action ); 
  109.  
  110.     -- Returns a string representation of a button group for debugging purposes. 
  111.     function To_String( this : access Button_Group ) return String; 
  112.  
  113. end Widgets.Buttons.Groups;