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;                           use Actions; 
  10. with Allegro.Bitmaps;                   use Allegro.Bitmaps; 
  11. with Allegro.Color;                     use Allegro.Color; 
  12. with Events.Input;                      use Events.Input; 
  13. with Keyboard;                          use Keyboard; 
  14. with Objects;                           use Objects; 
  15. with Processes;                         use Processes; 
  16. with Themes;                            use Themes; 
  17. with Values;                            use Values; 
  18. with Values.Associations;               use Values.Associations; 
  19.  
  20. limited with Game_Views; 
  21.  
  22. private with Ada.Containers.Doubly_Linked_Lists; 
  23. private with Ada.Containers.Indefinite_Hashed_Maps; 
  24. private with Ada.Strings.Hash_Case_Insensitive; 
  25. private with Ada.Strings.Equal_Case_Insensitive; 
  26. private with Ada.Strings.Unbounded; 
  27.  
  28. limited private with Widgets.Containers.Windows; 
  29.  
  30. pragma Elaborate_All( Actions ); 
  31.  
  32. package Widgets is 
  33.  
  34.     -- Represents a widget action involving a keyboard key, such as a key press 
  35.     -- or release. 
  36.     type Key_Action is new Action with private; 
  37.     type A_Key_Action is access all Key_Action'Class; 
  38.  
  39.     Key_Press   : constant Action_Id;   -- key pressed down 
  40.     Key_Release : constant Action_Id;   -- key released 
  41.     Key_Typed   : constant Action_Id;   -- key typed (press and held with repeat) 
  42.  
  43.     -- Returns the scancode of the key involved in the action. 
  44.     function Get_Key( this : not null access Key_Action'Class ) return Integer; 
  45.  
  46.     -- Returns the state of all modifier keys at the time of the action. 
  47.     function Get_Modifiers( this : not null access Key_Action'Class ) return Modifiers_Array; 
  48.  
  49.     ---------------------------------------------------------------------------- 
  50.  
  51.     -- This is the interface to implement in order to listen to key actions. 
  52.     -- When a key action occurs, the listener will be notified of the type of 
  53.     -- action performed and the widget that received the key action. 
  54.     type Key_Listener is limited interface and Action_Listener; 
  55.     type A_Key_Listener is access all Key_Listener'Class; 
  56.  
  57.     -- Handles the key action 'action'. If 'handled' returns True, the action 
  58.     -- will not be propagated to the next registered listener. 
  59.     procedure Handle_Action( this    : access Key_Listener; 
  60.                              action  : A_Key_Action; 
  61.                              handled : out Boolean ) is abstract; 
  62.  
  63.     ---------------------------------------------------------------------------- 
  64.  
  65.     -- Represents a widget resize or move action. 
  66.     type Resize_Action is new Action with private; 
  67.     type A_Resize_Action is access all Resize_Action'Class; 
  68.  
  69.     Widget_Resized : constant Action_Id;    -- resized/moved 
  70.  
  71.     -- This is the interface to implement in order to listen to resize actions. 
  72.     -- When a resize action occurs, the listener will be notified of the source 
  73.     -- widget's content size changed. 
  74.     type Resize_Listener is limited interface and Action_Listener; 
  75.     type A_Resize_Listener is access all Resize_Listener'Class; 
  76.  
  77.     -- Handles the resize action 'action'. 
  78.     procedure Handle_Action( this   : access Resize_Listener; 
  79.                              action : A_Resize_Action ) is abstract; 
  80.  
  81.     ---------------------------------------------------------------------------- 
  82.  
  83.     -- Represents a change in the widget's visability state, either directly or 
  84.     -- indirectly via a change in an ancestor's visability. 
  85.     type Visibility_Action is new Action with private; 
  86.     type A_Visibility_Action is access all Visibility_Action'Class; 
  87.  
  88.     Change_Visibility : constant Action_Id;    -- visibility changed 
  89.  
  90.     -- Returns True if the source widget is now visible. 
  91.     function Is_Visible( this : not null access Visibility_Action'Class ) return Boolean; 
  92.  
  93.     ---------------------------------------------------------------------------- 
  94.  
  95.     -- Implement this interface to receive notifications when a widget's 
  96.     -- visibility changes. 
  97.     type Visibility_Listener is limited interface and Action_Listener; 
  98.     type A_Visibility_Listener is access all Visibility_Listener'Class; 
  99.  
  100.     -- Handles the visibility action 'action'. 
  101.     procedure Handle_Action( this   : access Visibility_Listener; 
  102.                              action : A_Visibility_Action ) is abstract; 
  103.  
  104.     ---------------------------------------------------------------------------- 
  105.  
  106.     -- Implement the Animated interface to automatically run a widget as a 
  107.     -- process when it's visible. Animated extends Process, so the implementor 
  108.     -- must have a Tick procedure that will be automatically called. The widget 
  109.     -- subclass does not need to attach itself to a Process_Manager; that is 
  110.     -- handled automatically. 
  111.     type Animated is limited interface and Process; 
  112.  
  113.     ---------------------------------------------------------------------------- 
  114.  
  115.     -- A Widget is the most basic component of the GUI. A widget represents a 
  116.     -- control element, display element, or container in the interface. Widgets 
  117.     -- are organized as a tree, ultimately rooted at a Window widget, with each 
  118.     -- widget having one parent. Widgets are part of an event-based interface 
  119.     -- model, where Action_Listeners listen for and handle Actions that are 
  120.     -- generated by widgets when a change occurs or input is received. 
  121.     type Widget is abstract new Limited_Object with private; 
  122.     type A_Widget is access all Widget'Class; 
  123.  
  124.     -- Adds an object as a listener for key actions, such as press, release 
  125.     -- and held actions. 
  126.     procedure Add_Listener( this     : not null access Widget'Class; 
  127.                             listener : not null A_Key_Listener ); 
  128.  
  129.     -- Adds an object as a listener for resize actions. Resize listeners are 
  130.     -- notified when the widget's content size changes. 
  131.     procedure Add_Listener( this     : not null access Widget'Class; 
  132.                             listener : not null A_Resize_Listener ); 
  133.  
  134.     -- Adds an object as a listener for visibility actions. Visibility listeners 
  135.     -- are notified when the widget becomes visible or hidden. 
  136.     procedure Add_Listener( this     : not null access Widget'Class; 
  137.                             listener : not null A_Visibility_Listener ); 
  138.  
  139.     -- Draws the widget and its children. 
  140.     procedure Draw( this : access Widget ); 
  141.  
  142.     -- Returns a copy of the value of the specified attribute. If the attribute 
  143.     -- does exist then a Null_Value will be returned. 
  144.     function Get_Attribute( this : not null access Widget'Class; 
  145.                             name : String ) return Value_Ptr; 
  146.     pragma Precondition( name'Length > 0 ); 
  147.     pragma Postcondition( Get_Attribute'Result /= Values.Nul ); 
  148.  
  149.     -- Returns the widget's drawn border type 
  150.     function Get_Border( this : not null access Widget'Class ) return Border_Type; 
  151.  
  152.     -- Returns the color used by the widget for a specific purpose. Not all 
  153.     -- color purposes apply to every widget. 
  154.     function Get_Color( this    : access Widget; 
  155.                         purpose : Color_Purpose ) return Allegro_Color; 
  156.  
  157.     -- Returns the name of the widget's font. 
  158.     function Get_Font_Name( this : not null access Widget'Class ) return String; 
  159.  
  160.     -- Returns the point size of the widget's font. 
  161.     function Get_Font_Size( this : not null access Widget'Class ) return Positive; 
  162.  
  163.     -- Returns the screen height of the widget (height of the viewport) 
  164.     function Get_Height( this : not null access Widget'Class ) return Integer; 
  165.  
  166.     -- Returns the unique id of the widget 
  167.     function Get_Id( this : not null access Widget'Class ) return String; 
  168.     pragma Postcondition( Get_Id'Result'Length > 0 ); 
  169.  
  170.     -- Returns the view controlling this widget. 
  171.     function Get_View( this : access Widget ) return access Game_Views.Game_View'Class; 
  172.  
  173.     -- Returns the screen width of the widget (width of the viewport). 
  174.     function Get_Width( this : not null access Widget'Class ) return Natural; 
  175.  
  176.     -- Returns the zoom factor of the widget. Numbers greater than one mean the 
  177.     -- view of the widget is zoomed in. 
  178.     function Get_Zoom( this : not null access Widget'Class ) return Float; 
  179.  
  180.     -- Returns true if the widget is current enabled. 
  181.     function Is_Enabled( this : not null access Widget'Class ) return Boolean; 
  182.  
  183.     -- Returns True if the widget is showing on the screen; that is, it is 
  184.     -- visible and its parent is also visible and showing. 
  185.     function Is_Showing( this : access Widget ) return Boolean; 
  186.  
  187.     -- Returns True if the widget should be visible when its parent is visible. 
  188.     function Is_Visible( this : not null access Widget'Class ) return Boolean; 
  189.  
  190.     -- Moves the widget within its parent's content region. 
  191.     procedure Move( this : not null access Widget'Class; xdist, ydist : Integer ); 
  192.  
  193.     -- Moves the widget to an absolute location with its parent's content 
  194.     -- region. The top left of the widget is positioned at x, y. 
  195.     procedure Move_To( this  : not null access Widget'Class; x, y : Integer ); 
  196.  
  197.     -- Unregisters 'listener' as a key action listener. 
  198.     procedure Remove_Listener( this     : not null access Widget'Class; 
  199.                                listener : not null A_Key_Listener ); 
  200.  
  201.     -- Unregisters 'listener' as a resize action listener. 
  202.     procedure Remove_Listener( this     : not null access Widget'Class; 
  203.                                listener : not null A_Resize_Listener ); 
  204.  
  205.     -- Unregisters 'listener' as a visibility action listener. 
  206.     procedure Remove_Listener( this     : not null access Widget'Class; 
  207.                                listener : not null A_Visibility_Listener ); 
  208.  
  209.     -- Requests focus for the widget from the widget's window. If the widget is 
  210.     -- not rooted with a window, the request will be ignored. If the widget does 
  211.     -- not accept focus, the next possible candidate will be receive focus. See 
  212.     -- Window.Give_Focus() for details. 
  213.     procedure Request_Focus( this : not null access Widget'Class ); 
  214.  
  215.     -- Scrolls the widget's viewport, if possible, by the given x, y distances. 
  216.     -- The positive scroll direction is down and to the right. 
  217.     procedure Scroll( this : not null access Widget'Class; x, y : Integer ); 
  218.  
  219.     -- Scrolls the widget's viewport by moving the top left corner to the given 
  220.     -- location. 
  221.     procedure Scroll_To( this : not null access Widget'Class; x, y : Integer ); 
  222.  
  223.     -- Sets an attribute on the widget (by copy). Attributes are used for 
  224.     -- encapsulating minor additional data without extending a widget class. 
  225.     procedure Set_Attribute( this  : not null access Widget'Class; 
  226.                              name  : String; 
  227.                              val   : Value_Ptr'Class ); 
  228.     pragma Precondition( name'Length > 0 ); 
  229.     pragma Precondition( Value_Ptr(val) /= Values.Nul ); 
  230.  
  231.     -- Sets the border for the widget, if it uses one. 
  232.     procedure Set_Border( this : access Widget; border : Border_Type ); 
  233.  
  234.     -- Sets the color used by the widget for a specific purpose. Not all color 
  235.     -- purposes apply to every widget. 
  236.     procedure Set_Color( this    : access Widget; 
  237.                          purpose : Color_Purpose; 
  238.                          color   : Allegro_Color ); 
  239.  
  240.     -- Sets whether the widget is enabled or not. If not enabled, the widget 
  241.     -- will ignore all user interaction. If a widget is disabled, all of its 
  242.     -- children are also implicitly disabled. 
  243.     procedure Set_Enabled( this : not null access Widget'Class; enabled : Boolean ); 
  244.  
  245.     -- Sets whether the widget can accept focus. 
  246.     procedure Set_Focusable( this      : not null access Widget'Class; 
  247.                              focusable : Boolean ); 
  248.  
  249.     -- Sets the widget's focused state. This does not focus the widget. It 
  250.     -- should be called only by a Window widget. 
  251.     procedure Set_Focused( this : not null access Widget'Class; focused : Boolean ); 
  252.  
  253.     -- Sets the widget's font name and/or size. 
  254.     procedure Set_Font( this : not null access Widget'Class; 
  255.                         name : String := ""; 
  256.                         size : Natural := 0 ); 
  257.  
  258.     -- Sets the widget's layout as centered within the parent's content area, 
  259.     -- given the viewport size. If 'width' or 'height' is 0, the widget's 
  260.     -- minimum width or height will be used. 
  261.     procedure Set_Layout_Center( this   : not null access Widget'Class; 
  262.                                  width, 
  263.                                  height : Natural := 0 ); 
  264.  
  265.     -- Sets the widget's layout as centered horizontally and spaced from the top 
  266.     -- and bottom of the parent's content area like layout LTRB. 
  267.     procedure Set_Layout_CenterH( this   : not null access Widget'Class; 
  268.                                   width  : Natural; 
  269.                                   top, 
  270.                                   bottom : Integer ); 
  271.  
  272.     -- Sets the widget's layout as centered horizontally and positioned 
  273.     -- absolutely in the vertical dimension. y1 and y2 are both distances from 
  274.     -- the top of the parent's content region. Negative values will position 
  275.     -- the widget off the top edge of the parent's content. 
  276.     procedure Set_Layout_CenterHY( this   : not null access Widget'Class; 
  277.                                    width  : Natural; 
  278.                                    y1, y2 : Integer ); 
  279.  
  280.     -- Sets the widget's layout based on the distance of the viewport's edges 
  281.     -- from the edges of the parent's content area. 
  282.     procedure Set_Layout_LTRB( this   : not null access Widget'Class; 
  283.                                left, 
  284.                                top, 
  285.                                right, 
  286.                                bottom : Integer ); 
  287.  
  288.     -- Sets the widget's layout based on a size and distance from the top left 
  289.     -- edges of the parent's content area. If top or left is negative then the 
  290.     -- top left corner of the widget will be positioned relative to the bottom 
  291.     -- or right edge of the content area. If width or height is 0 then the 
  292.     -- widget's minimum width or height will be used instead. 
  293.     procedure Set_Layout_LTWH( this   : not null access Widget'Class; 
  294.                                left, 
  295.                                top    : Integer; 
  296.                                width, 
  297.                                height : Natural ); 
  298.  
  299.     -- Sets the widget's layout based on a size and absolute distance from the 
  300.     -- top left corner of the parent's content area. This layout is nearly 
  301.     -- identical to LTWH except negative values for 'x' and 'y' are kept 
  302.     -- relative to the upper left. If width or height is 0 then the 
  303.     -- widget's minimum width or height will be used instead. 
  304.     procedure Set_Layout_XYWH( this   : not null access Widget'Class; 
  305.                                x, y   : Integer; 
  306.                                width, 
  307.                                height : Natural ); 
  308.  
  309.     -- Sets the minimum height value to override the computed minimum height 
  310.     -- for the widget. If height is set to zero, the computed value is returned 
  311.     -- by Get_Min_Height. 
  312.     procedure Set_Min_Height( this   : not null access Widget'Class; 
  313.                               height : Natural ); 
  314.  
  315.     -- Sets the minimum width value to override the computed minimum width 
  316.     -- for the widget. If width is set to zero, the computed value is returned 
  317.     -- by Get_Min_Width. 
  318.     procedure Set_Min_Width( this  : not null access Widget'Class; 
  319.                              width : Natural ); 
  320.  
  321.     -- Sets the next widget to receive focus when tab is pressed on this widget. 
  322.     procedure Set_Next( this : not null access Widget'Class; id : String ); 
  323.  
  324.     -- Sets the next widget to receive focus when shift + tab is pressed on this 
  325.     -- widget. 
  326.     procedure Set_Prev( this : not null access Widget'Class; id : String ); 
  327.  
  328.     -- Set to true if the widget is partly transparent so that it will be drawn 
  329.     -- over the background. 
  330.     procedure Set_Transparent( this        : not null access Widget'Class; 
  331.                                transparent : Boolean ); 
  332.  
  333.     -- Sets whether the widget is visible. 
  334.     procedure Set_Visible( this : not null access Widget'Class; visible : Boolean ); 
  335.  
  336.     -- Sets the zoom factor. Values > 1 make the contents larger and values < 1 
  337.     -- make the contents smaller. This does not affect the screen size of the 
  338.     -- widget; Increasing the zoom decreases the visible content area. 
  339.     procedure Set_Zoom( this : access Widget; zoom : Float ); 
  340.  
  341.     -- Deletes the Widget and all children. 
  342.     procedure Delete( this : in out A_Widget ); 
  343.     pragma Postcondition( this = null ); 
  344.  
  345. private 
  346.  
  347.     use Ada.Strings.Unbounded; 
  348.  
  349.     -- A layout is a decorator that determines a child widget's size and 
  350.     -- position within its parent container. 
  351.     type Layout is abstract new Object with null record; 
  352.     type A_Layout is access all Layout'Class; 
  353.  
  354.     -- Raises Constraint_Error because this is an abstract procedure that should 
  355.     -- not be directly called. This procedure isn't officially declared abstract 
  356.     -- so that the Layout class can remain in the private section. 
  357.     procedure Apply( this : access Layout; widget : not null A_Widget ); 
  358.  
  359.     ---------------------------------------------------------------------------- 
  360.  
  361.     -- provides a list of Action_Listeners 
  362.     package Action_Listeners is new Ada.Containers.Doubly_Linked_Lists( A_Action_Listener, "=" ); 
  363.  
  364.     -- maps Action_Id strings to lists of Action_Listeners; case insensitive 
  365.     package Listener_Maps is new 
  366.         Ada.Containers.Indefinite_Hashed_Maps( String, Action_Listeners.List, 
  367.                                                Ada.Strings.Hash_Case_Insensitive, 
  368.                                                Ada.Strings.Equal_Case_Insensitive, 
  369.                                                Action_Listeners."=" ); 
  370.  
  371.     ---------------------------------------------------------------------------- 
  372.  
  373.     Key_Press   : constant Action_Id := To_Action_Id( "key.press" ); 
  374.     Key_Typed   : constant Action_Id := To_Action_Id( "key.typed" ); 
  375.     Key_Release : constant Action_Id := To_Action_Id( "key.release" ); 
  376.  
  377.     type Key_Action is new Action with 
  378.         record 
  379.             key       : Integer; 
  380.             modifiers : Modifiers_Array; 
  381.         end record; 
  382.  
  383.     procedure Construct( this      : access Key_Action; 
  384.                          id        : Action_Id; 
  385.                          source    : not null A_Widget; 
  386.                          key       : Integer; 
  387.                          modifiers : Modifiers_Array ); 
  388.  
  389.     ---------------------------------------------------------------------------- 
  390.  
  391.     Widget_Resized : constant Action_Id := To_Action_Id( "widget.resized" ); 
  392.  
  393.     type Resize_Action is new Action with null record; 
  394.  
  395.     ---------------------------------------------------------------------------- 
  396.  
  397.     Change_Visibility : constant Action_Id := To_Action_Id( "visibility.changed" ); 
  398.  
  399.     type Visibility_Action is new Action with 
  400.         record 
  401.             visible : Boolean; 
  402.         end record; 
  403.  
  404.     procedure Construct( this    : access Visibility_Action; 
  405.                          id      : Action_Id; 
  406.                          source  : not null A_Widget; 
  407.                          visible : Boolean ); 
  408.  
  409.     ---------------------------------------------------------------------------- 
  410.  
  411.     -- Enumeration for specifying the corner of a widget 
  412.     type Widget_Corner_Type is (Widget_Top_Left,    Widget_Top_Right, 
  413.                                 Widget_Bottom_Left, Widget_Bottom_Right); 
  414.  
  415.     ---------------------------------------------------------------------------- 
  416.  
  417.     -- A dummy class-wide access type to use for the 'view' field, that really 
  418.     -- points to a Game_View object. This is a workaround for a 6.4 compiler 
  419.     -- issue, where the compiler crashes if 'view' is an anonymous access type 
  420.     -- to Game_View'Class. Fix this in the future. 
  421.     type Game_View2 is tagged null record; 
  422.     type A_Game_View2 is access all Game_View2'Class; 
  423.     pragma No_Strict_Aliasing( A_Game_View2 ); 
  424.  
  425.     type Widget is abstract new Limited_Object with 
  426.         record 
  427.             view        : A_Game_View2;         -- widget's game view 
  428.             id          : Unbounded_String;     -- unique id of the instance 
  429.             registered  : Boolean := False;     -- successfully added to registry 
  430.             parent      : A_Widget := null;     -- parent/containing widget 
  431.             buffer      : A_Allegro_Bitmap := null;  -- (view width x view height) 
  432.             x1, y1,                             -- offset of viewport from top 
  433.             x2, y2,                             --   left of parent's content area 
  434.             vx1, vy1,                           -- offset of viewport from top 
  435.             vx2, vy2    : Integer := 0;         --   left of own content area 
  436.             clampView   : Boolean := True;      -- keep the viewport within the content 
  437.             cwidth,                             -- width of the content area 
  438.             cheight     : Natural := 0;         -- height of the content area 
  439.             minWidth,                           -- overrides minimum width if > 0 
  440.             minHeight   : Natural := 0;         -- overrides minimum height if > 0 
  441.             zoom        : Float := 1.0;         -- >1 is bigger 
  442.                                                 -- zoom = (x2-x1)/(vx2-vx1) or 
  443.                                                 --        (y2-y1)/(vy2-vy1) 
  444.             zoomable    : Boolean := True;      -- widget can be zoomed in/out 
  445.             layout      : A_Layout := null; 
  446.             visible     : Boolean := False;     -- widget is visible 
  447.             enabled     : Boolean := True;      -- user interaction allowed 
  448.             hover       : Boolean := False;     -- mouse is over widget 
  449.             pressed     : Boolean := False;     -- mouse LB is pressed on widget 
  450.             acceptFocus : Boolean := True;      -- widget accepts focus 
  451.             focused     : Boolean := False;     -- widget is focused 
  452.             colors      : Colors_Array; 
  453.             border      : Border_Type := Border_None; 
  454.             transparent : Boolean := False;     -- widget is partly transparent 
  455.             attrs       : Assoc_Ptr;            -- additional attributes 
  456.             listeners   : Listener_Maps.Map;    -- listeners registered to 
  457.                                                 --   receive widget actions 
  458.             nextId,                             -- widget to focus on Tab key 
  459.             prevId      : Unbounded_String;     -- widget to focus on Shift+Tab 
  460.  
  461.             fontName    : Unbounded_String := To_Unbounded_String( DEFAULT_FONT_NAME ); 
  462.             fontSize    : Positive := DEFAULT_FONT_SIZE; 
  463.         end record; 
  464.  
  465.     -- Raises DUPLICATE_ID exception if 'id' has already been registered with 
  466.     -- the widget's view. Widget id strings must be unique per view. 
  467.     procedure Construct( this : access Widget; 
  468.                          view : not null access Game_Views.Game_View'Class; 
  469.                          id   : String ); 
  470.     pragma Precondition( id'Length > 0 ); 
  471.  
  472.     procedure Delete( this : in out Widget ); 
  473.  
  474.     -- Activates a popup menu. Corner specifies which corner of the popup to 
  475.     -- place at the given coordinates. Arguments x, y are in widget content 
  476.     -- coordinates. Width and height specify the size of the popup widget. 
  477.     -- Passing zero in either dimension will size the popup to its own reported 
  478.     -- reported minimum. Note that the popup will be a child of the window; thus 
  479.     -- without scaling, the size of the popup will be treated as window content 
  480.     -- coordinates which may be different than this widget. The scale argument 
  481.     -- determines whether or not the given popup size will be scaled from this 
  482.     -- widget's content coordinates to the window's content coordinates. 
  483.     -- 
  484.     -- Example situations for specifying/omitting sizes are as follows: 
  485.     -- Select-enum choices popup : Specify width, omit height, scale 
  486.     -- Pulldown menu             : Omit width and height, no scaling (menubars don't zoom) 
  487.     -- Contextual popup menu     : Omit width and height, no scaling 
  488.     procedure Activate_Popup( this   : access Widget; 
  489.                               popup  : not null A_Widget; 
  490.                               corner : Widget_Corner_Type; 
  491.                               x, y   : Integer; 
  492.                               width  : Natural := 0; 
  493.                               height : Natural := 0; 
  494.                               scale  : Boolean := False ); 
  495.  
  496.     -- Registers an action listener. Argument 'listenerType' is the string name 
  497.     -- of the exact listener interface to register the listener as, for example 
  498.     -- "Button_Listener" to register the action listener for button actions. 
  499.     procedure Add_Listener( this         : not null access Widget'Class; 
  500.                             listenerType : String; 
  501.                             listener     : not null A_Action_Listener ); 
  502.     pragma Precondition( listenerType'Length > 0 ); 
  503.  
  504.     -- Brings this widget and its ancestors of the front. 
  505.     procedure Bring_To_Front( this : access Widget ); 
  506.  
  507.     -- Deactivates the popup menu by popping popups from the window until the 
  508.     -- given popup has been deactivated. If the given popup menu isn't active, 
  509.     -- nothing will happen. 
  510.     procedure Deactivate_Popup( this : not null access Widget'Class; popup : not null A_Widget ); 
  511.  
  512.     -- Dispatches a key action to the widget's listeners. Returns True if the 
  513.     -- key action was handled by a listener. 
  514.     function Dispatch_Key_Action( this      : not null access Widget'Class; 
  515.                                   id        : Action_Id; 
  516.                                   key       : Integer; 
  517.                                   modifiers : Modifiers_Array ) return Boolean; 
  518.  
  519.     -- Dispatches a resize action to the widget's listeners to notify them that 
  520.     -- a resize occurred. 
  521.     procedure Dispatch_Resize_Action( this : not null access Widget'Class ); 
  522.  
  523.     -- Dispatches a visibility action to the widget's listeners. 
  524.     procedure Dispatch_Visibility_Action( this    : not null access Widget'Class; 
  525.                                           visible : Boolean ); 
  526.  
  527.     -- Draws the widget content within the viewport. This procedure must be 
  528.     -- overridden. 
  529.     procedure Draw_Content( this : access Widget ) is null; 
  530.  
  531.     -- Returns the widget containing the given screen coordinates (coordinates 
  532.     -- relative to the widget's viewport), and the widget coordinates that x,y 
  533.     -- map to within the found widget's content area. 
  534.     procedure Find_Widget_At( this   : access Widget; 
  535.                               x, y   : Integer; 
  536.                               wx, wy : out Integer; 
  537.                               found  : out A_Widget ); 
  538.  
  539.      -- Attempts to focus the previous widget, or if it's disabled, its 
  540.      -- previous. Returns True if a previous widget was focused. 
  541.     function Focus_Prev( this : not null access Widget'Class ) return Boolean; 
  542.  
  543.      -- Attempts to focus the next widget, or if it's disabled- its next. 
  544.      -- Returns True if a next widget was focused. 
  545.     function Focus_Next( this : not null access Widget'Class ) return Boolean; 
  546.  
  547.     -- Returns the height of the widget's content. 
  548.     function Get_Content_Height( this : not null access Widget'Class ) return Natural; 
  549.  
  550.     -- Returns the width of the widget's content. 
  551.     function Get_Content_Width( this : not null access Widget'Class ) return Natural; 
  552.  
  553.     -- Returns the minimum allowable height for this widget based on its 
  554.     -- content. 
  555.     function Get_Min_Height( this : access Widget ) return Natural; 
  556.  
  557.     -- Returns the minimum allowable width for this widget based on its content. 
  558.     function Get_Min_Width( this : access Widget ) return Natural; 
  559.  
  560.     -- Returns the To_String representation of the widget as a process name. 
  561.     -- This is used to provide default behavior in the event that a Widget class 
  562.     -- implements Animated (and by extension, Process). 
  563.     function Get_Process_Name( this : access Widget ) return String; 
  564.  
  565.     -- Returns the widget's visible drawing area in widget coordinates. 
  566.     procedure Get_Viewport( this   : not null access Widget'Class; 
  567.                             x1, y1, 
  568.                             x2, y2 : out Integer ); 
  569.  
  570.     -- Returns the window containing this widget. If the widget does not have a 
  571.     -- window yet then null will be returned. 
  572.     function Get_Window( this : access Widget 
  573.                        ) return access Widgets.Containers.Windows.Window'Class; 
  574.  
  575.     -- Handles dispatching a Key_Press event and passing it up the hierarachy. 
  576.     procedure Handle_Key_Press( this    : not null access Widget'Class; 
  577.                                 evt     : not null A_Key_Event; 
  578.                                 handled : in out Boolean ); 
  579.  
  580.     -- Handles dispatching a Key_Release event and passing it up the hierarachy. 
  581.     procedure Handle_Key_Release( this    : not null access Widget'Class; 
  582.                                   evt     : not null A_Key_Event; 
  583.                                   handled : in out Boolean ); 
  584.  
  585.     -- Handles dispatching a Key_Typed event and passing it up the hierarachy. 
  586.     procedure Handle_Key_Typed( this    : not null access Widget'Class; 
  587.                                 evt     : not null A_Key_Typed_Event; 
  588.                                 handled : in out Boolean ); 
  589.  
  590.     -- This is called to allow the widget to handle a mouse scroll wheel event. 
  591.     -- The widget can handle the event with On_Mouse_Scroll(). If the event is 
  592.     -- not handled, this function will then pass the event to the parent. See 
  593.     -- On_Mouse_Scroll(). 
  594.     procedure Handle_Mouse_Scroll( this    : not null access Widget'Class; 
  595.                                    evt     : not null A_Mouse_Scroll_Event; 
  596.                                    handled : in out Boolean ); 
  597.  
  598.     -- This is called when Pack changes the size of the widget's viewport. 
  599.     procedure Handle_Resize( this : not null access Widget'Class ); 
  600.  
  601.     -- This is called when the widget becomes rooted or unrooted to a Window. 
  602.     -- "Rooted" means the widget has the Window as an ancestor. The rooted 
  603.     -- notification traverses down the tree until a leaf is reached. Widgets 
  604.     -- will be notified of their rooted state from the leaves of the tree 
  605.     -- upward. Override On_Rooted() to handle this message. 
  606.     procedure Handle_Rooted( this : access Widget; rooted : Boolean ); 
  607.  
  608.     -- This is called when the widget becomes shown or unshown on the screen. 
  609.     -- For a widget to be shown, it must be rooted and visible, and all its 
  610.     -- ancestors must also be visible. If it becomes unrooted, or not visible, 
  611.     -- or one of its ancestors becomes not visible, the widget will become 
  612.     -- unshown. Essentially this procedure is called every time the result of 
  613.     -- the Is_Showing function changes. Widgets will be notified of their 
  614.     -- showing state from the leaves of the tree upward. 
  615.     -- 
  616.     -- This procedure notifies its ancestors that a descendent became shown or 
  617.     -- unshown, calls On_Shown to allow a subclass to handle the notification, 
  618.     -- and then dispatches a visibility action to all its visibility listeners. 
  619.     procedure Handle_Shown( this : access Widget; shown : Boolean ); 
  620.  
  621.     -- Checks if the widget is a descendent of the given widget. 
  622.     function Is_Descendant_Of( this     : not null access Widget'Class; 
  623.                                ancestor : A_Widget ) return Boolean; 
  624.  
  625.     -- Returns True if the widget accepts input focus. 
  626.     function Is_Focusable( this : not null access Widget'Class ) return Boolean; 
  627.  
  628.     -- Returns True if this widget is rooted within a Window. If it, or one of 
  629.     -- its ancestors, does not have a parent, then False will be returned. 
  630.     function Is_Rooted( this : access Widget ) return Boolean; 
  631.  
  632.     -- Iterate through the list of action listeners registered for a specific 
  633.     -- action type. 
  634.     procedure Iterate_Listeners( this         : not null access Widget'Class; 
  635.                                  listenerType : String; 
  636.                                  examine      : not null access procedure( listener : A_Action_Listener ) ); 
  637.     pragma Precondition( listenerType'Length > 0 ); 
  638.  
  639.     -- Override ths procedure to handle lost focus events. 
  640.     procedure On_Blur( this : access Widget ) is null; 
  641.  
  642.     -- Override this procedure to handle mouse click events. 
  643.     procedure On_Click( this : access Widget; 
  644.                         evt  : not null A_Mouse_Button_Event ) is null; 
  645.  
  646.     -- Override this function to handle a notification of when the descendent of 
  647.     -- the widget is shown or hidden on the screen. 
  648.     procedure On_Descendant_Shown( this       : access Widget; 
  649.                                    descendant : not null A_Widget; 
  650.                                    shown      : Boolean ) is null; 
  651.  
  652.     -- This is called when the widget is directly disabled from an enabled 
  653.     -- state. Override this function to implement behavior when 
  654.     -- Set_Enabled( False ) is called on this widget. Note that this is not 
  655.     -- called when the enabled state of an ancestor changes. 
  656.     procedure On_Disabled( this : access Widget ) is null; 
  657.  
  658.     -- This is called when the widget is directly enabled from a disabled state. 
  659.     -- Override this function to implement behavior when Set_Enabled( True ) is 
  660.     -- called on this widget. Note that this is not called when the enabled 
  661.     -- state of an ancestor changes. 
  662.     procedure On_Enabled( this : access Widget ) is null; 
  663.  
  664.     -- Override this procedure to handle mouse enter events. The default 
  665.     -- behavior toggles the 'hover' flag for the widget. This should be called 
  666.     -- at the start of the overriding procedure. 
  667.     procedure On_Enter( this : access Widget ); 
  668.  
  669.     -- Override this procedure to handle mouse exit events. The default 
  670.     -- behavior toggles the 'hover' flag for the widget. This should be called 
  671.     -- at the start of the overriding procedure. 
  672.     procedure On_Exit( this : access Widget ); 
  673.  
  674.     -- Override this procedure to handle received focus events. 
  675.     procedure On_Focus( this : access Widget ) is null; 
  676.  
  677.     -- Override this function to handle key press events. Set 'handled' to 
  678.     -- True if the key event is handled. 
  679.     procedure On_Key_Press( this    : access Widget; 
  680.                             evt     : not null A_Key_Event; 
  681.                             handled : in out Boolean ) is null; 
  682.  
  683.     -- Override this function to handle key release events. Set 'handled' to 
  684.     -- True if the key event is handled. 
  685.     procedure On_Key_Release( this    : access Widget; 
  686.                               evt     : not null A_Key_Event; 
  687.                               handled : in out Boolean ) is null; 
  688.  
  689.     -- Override this function to handle key typed events. Set 'handled' to True 
  690.     -- if the key event is handled. 
  691.     procedure On_Key_Typed( this    : access Widget; 
  692.                             evt     : not null A_Key_Typed_Event; 
  693.                             handled : in out Boolean ) is null; 
  694.  
  695.     -- Override this function to handle mouse held events. 
  696.     procedure On_Mouse_Held( this : access Widget; 
  697.                              evt  : not null A_Mouse_Button_Event ) is null; 
  698.  
  699.     -- Override this function to handle mouse move events. 
  700.     procedure On_Mouse_Move( this : access Widget; 
  701.                              evt  : not null A_Mouse_Event ) is null; 
  702.  
  703.     -- Override this procedure to handle mouse press events. The default 
  704.     -- behavior updates the 'pressed' flag. This should be called at the start 
  705.     -- of the overriding procedure. 
  706.     procedure On_Mouse_Press( this : access Widget; 
  707.                               evt  : not null A_Mouse_Button_Event ); 
  708.  
  709.     -- Override this procedure to handle mouse click events. The default 
  710.     -- behavior updates the 'pressed' flag. This should be called at the start 
  711.     -- of the overriding procedure. 
  712.     procedure On_Mouse_Release( this : access Widget; 
  713.                                 evt  : not null A_Mouse_Button_Event ); 
  714.  
  715.     -- Override this function to handle mouse scroll wheel events. 'x' and 'y' 
  716.     -- are the coordinates of the mouse during the scroll, in widget content 
  717.     -- coordinates. 'amount' is the amount the wheel was scrolled - down is 
  718.     -- positive, up is negative. Return 'handled' as True if the event was 
  719.     -- handled. If the event is not handled, the widget's parent will be given 
  720.     -- an opportunity to handle the event. 
  721.     procedure On_Mouse_Scroll( this    : access Widget; 
  722.                                x, y    : Integer; 
  723.                                amount  : Integer; 
  724.                                handled : in out Boolean ) is null; 
  725.  
  726.     -- Override this method to handle the situation where the widget's viewport 
  727.     -- size changes. 
  728.     procedure On_Resize( this : access Widget ) is null; 
  729.  
  730.     -- Override this function to handle the situation where the widget becomes 
  731.     -- rooted to or unrooted from a Window. 
  732.     procedure On_Rooted( this : access Widget; rooted : Boolean ) is null; 
  733.  
  734.     -- Override this function to handle the notification that the widget became 
  735.     -- shown or unshown on the screen. 
  736.     procedure On_Shown( this : access Widget; shown : Boolean ) is null; 
  737.  
  738.     -- Packs the widget into its parent container, calculating its size and 
  739.     -- applying its Layout. This is called after the widget's parent changes 
  740.     -- (either the parent itself, or just the parent's layout), and when 
  741.     -- its own layout changes. 
  742.     procedure Pack( this : access Widget ); 
  743.  
  744.     -- Adds an action listener to the front of the listener list for the given 
  745.     -- type of listener. The listener will be the first to be notified of an 
  746.     -- action (until another listener of the same type is prepended). 
  747.     procedure Prepend_Listener( this         : not null access Widget'Class; 
  748.                                 listenerType : String; 
  749.                                 listener     : not null A_Action_Listener ); 
  750.     pragma Precondition( listenerType'Length > 0 ); 
  751.  
  752.     -- Unregisters an action listener for receiving actions of the given type. 
  753.     procedure Remove_Listener( this         : not null access Widget'Class; 
  754.                                listenerType : String; 
  755.                                listener     : not null A_Action_Listener ); 
  756.     pragma Precondition( listenerType'Length > 0 ); 
  757.  
  758.     -- Replaces the widget's current layout, if any, and repacks the parent 
  759.     -- widget, if this widget has one. 
  760.     procedure Set_Layout( this   : not null access Widget'Class; 
  761.                           layout : in out A_Layout ); 
  762.     pragma Postcondition( layout = null ); 
  763.  
  764.     -- Sets a widget as the parent of this. 
  765.     procedure Set_Parent( this : access Widget; parent : A_Widget ); 
  766.  
  767.     -- Returns a string representation of the widget. 
  768.     function To_String( this : access Widget ) return String; 
  769.  
  770.     -- Translates screen coordinates into the widget's content coodinates. 
  771.     procedure Translate_To_Content( this   : access Widget; 
  772.                                     sx, sy : Integer; 
  773.                                     cx, cy : out Integer ); 
  774.  
  775.     -- Translates the widget's content coordinates into window coordinates. 
  776.     procedure Translate_To_Window( this   : access Widget; 
  777.                                    cx, cy : Integer; 
  778.                                    wx, wy : out Integer ); 
  779.  
  780.     -- Compares widgets 'l' and 'r' by id; returns True if 'l' is less than 'r'. 
  781.     function Lt( l, r : A_Widget ) return Boolean; 
  782.  
  783. end Widgets;