with Actions; use Actions;
with Allegro.Bitmaps; use Allegro.Bitmaps;
with Allegro.Truecolor; use Allegro.Truecolor;
with Drawing_Contexts; use Drawing_Contexts;
with Events.Input; use Events.Input;
with Keyboard; use Keyboard;
with Objects; use Objects;
with Themes; use Themes;
limited with Game_Views;
private with Ada.Containers.Doubly_Linked_Lists;
private with Ada.Containers.Indefinite_Hashed_Maps;
private with Ada.Strings.Hash_Case_Insensitive;
private with Ada.Strings.Equal_Case_Insensitive;
private with Ada.Strings.Unbounded;
private with Associations;
private with Values;
limited private with Widgets.Containers.Windows;
package Widgets is
type Widget is abstract new Object with private;
type A_Widget is access all Widget'Class;
----------------------------------------------------------------------------
type Key_Action is new Action with private;
type A_Key_Action is access all Key_Action'Class;
Key_Press : constant Action_Id;
Key_Held : constant Action_Id;
Key_Release : constant Action_Id;
function Get_Key( this : access Key_Action ) return Integer;
function Get_Modifiers( this : access Key_Action ) return Modifiers_Array;
-- This is the interface to implement in order to listen to key actions.
-- When a key action occurs, the listener will be notified of the type of
-- action performed and the widget that received the key action.
type Key_Listener is limited interface and Action_Listener;
type A_Key_Listener is access all Key_Listener'Class;
procedure Handle_Action( this : access Key_Listener;
action : A_Key_Action;
handled : out Boolean ) is abstract;
type A_Key_Handler is
access procedure( action : A_Key_Action;
handled : out Boolean );
----------------------------------------------------------------------------
type Visibility_Action is new Action with private;
type A_Visibility_Action is access all Visibility_Action'Class;
Change_Visibility : constant Action_Id;
function Is_Visible( this : access Visibility_Action ) return Boolean;
-- Implement this interface to receive notifications when the widget's
-- visibility changes.
type Visibility_Listener is limited interface and Action_Listener;
type A_Visibility_Listener is access all Visibility_Listener'Class;
procedure Handle_Action( this : access Visibility_Listener;
action : A_Visibility_Action ) is abstract;
----------------------------------------------------------------------------
-- Adds an object as a listener for key actions, such as press, release
-- and held actions.
procedure Add_Listener( this : not null access Widget'Class;
listener : not null A_Key_Listener );
-- Adds the handler procedure as a simple listener. The listener can't be
-- removed and can be added multiple times.
procedure Add_Listener( this : not null access Widget'Class;
key : Integer;
modifiers : Modifiers_Pattern;
handler : not null A_Key_Handler );
-- Adds the handler procedure as a simple listener. The listener can't be
-- removed and can be added multiple times. The key modifiers will match any
-- combination so this procedure is equivalent to calling Add_Listener with
-- modifiers => MODIFIERS_ANY.
procedure Add_Listener( this : not null access Widget'Class;
key : Integer;
handler : not null A_Key_Handler );
-- Adds an object as a listener for visibility actions. Visibility listeners
-- are notified when the widget becomes visibility or hidden.
procedure Add_Listener( this : not null access Widget'Class;
listener : not null A_Visibility_Listener );
-- Draws the widget and children to bmp, redrawing contents if necessary
procedure Draw( this : access Widget; bmp : not null A_Bitmap; x, y : Integer );
-- Draws the widget content within the viewport. This should not be called
-- directly.
procedure Draw_Content( this : access Widget; dc : Drawing_Context ) is abstract;
-- Returns the value of the specified attribute as an integer. If the
-- attribute is not an integer, it will be converted. If the attribute does
-- not exist or can not be converted then VALUE_NOT_FOUND or
-- INVALID_CONVERSION will be raised, respectively.
function Get_Attribute( this : not null access Widget'Class;
name : String ) return Integer;
pragma Precondition( name'Length > 0 );
-- Returns the value of the specified attribute as a string. If the
-- attribute is not an string, it will be converted. If the attribute does
-- not exist or can not be converted then VALUE_NOT_FOUND or
-- INVALID_CONVERSION will be raised, respectively.
function Get_Attribute( this : not null access Widget'Class;
name : String ) return String;
pragma Precondition( name'Length > 0 );
-- Returns the widget's drawn border type
function Get_Border( this : not null access Widget'Class ) return Border_Type;
-- Returns the color used by the widget for a specific purpose. Not all
-- color purposes apply to every widget.
function Get_Color( this : access Widget; purpose : Color_Purpose ) return Color_Type;
-- Returns the name of the widget's font.
function Get_Font_Name( this : not null access Widget'Class ) return String;
-- Returns the point size of the widget's font.
function Get_Font_Size( this : not null access Widget'Class ) return Positive;
-- Returns the screen height of the widget (height of the viewport)
function Get_Height( this : not null access Widget'Class ) return Integer;
-- Returns the unique id of the widget
function Get_Id( this : not null access Widget'Class ) return String;
pragma Postcondition( Get_Id'Result'Length > 0 );
-- Returns the view controlling this widget. The window widget contains a
-- reference to the view and all other widgets must ask for it.
function Get_View( this : access Widget ) return access Game_Views.Game_View'Class;
-- Returns the screen width of the widget (width of the viewport).
function Get_Width( this : not null access Widget'Class ) return Natural;
-- Returns the zoom factor of the widget. Numbers greater than one mean the
-- view of the widget is zoomed in.
function Get_Zoom( this : not null access Widget'Class ) return Float;
-- Returns true if the widget is current enabled.
function Is_Enabled( this : not null access Widget'Class ) return Boolean;
-- Returns true if the widget is currently visible.
function Is_Visible( this : not null access Widget'Class ) return Boolean;
-- Moves the widget within its parent's content region.
procedure Move( this : not null access Widget'Class; xdist, ydist : Integer );
-- Moves the widget to an absolute location with its parent's content
-- region. the top left of the widget is positioned at x, y.
procedure Move_To( this : not null access Widget'Class; x, y : Integer );
procedure Remove_Listener( this : not null access Widget'Class;
listener : not null A_Key_Listener );
procedure Remove_Listener( this : not null access Widget'Class;
listener : not null A_Visibility_Listener );
-- Forces the widget to redraw itself on the next frame.
procedure Redraw( this : not null access Widget'Class );
-- Scrolls the widget's viewport, if possible, by the given x, y distances.
-- The positive scroll direction is down and to the right.
procedure Scroll( this : not null access Widget'Class; x, y : Integer );
-- Scrolls the widget's viewport by moving the top left corner to the given
-- location.
procedure Scroll_To( this : not null access Widget'Class; x, y : Integer );
-- Sets an integer attribute on the widget. Attributes are used for
-- encapsulating minor additional data without extending a widget class.
procedure Set_Attribute( this : not null access Widget'Class;
name : String;
val : Integer );
pragma Precondition( name'Length > 0 );
-- Sets a string attribute on the widget. Attributes are used for
-- encapsulating minor additional data without extending a widget class.
procedure Set_Attribute( this : not null access Widget'Class;
name : String;
val : String );
pragma Precondition( name'Length > 0 );
-- Sets the border for the widget, if it uses one.
procedure Set_Border( this : not null access Widget'Class;
border : Border_Type );
-- Sets the color used by the widget for a specific purpose. Not all color
-- purposes apply to every widget.
procedure Set_Color( this : access Widget;
purpose : Color_Purpose;
color : Color_Type );
-- Sets whether the widget is enabled or not. If not enabled, the widget
-- will ignore all user interaction. If a widget is disabled, all of its
-- children are also implicitly disabled.
procedure Set_Enabled( this : access Widget; enabled : Boolean );
-- Sets whether the widget can accept focus.
procedure Set_Focusable( this : not null access Widget'Class;
focusable : Boolean );
-- Sets the widget's focused state. This does not focus the widget. It
-- should be called only by a Window widget.
procedure Set_Focused( this : access Widget; focused : Boolean );
-- Sets the widget's font name and/or size.
procedure Set_Font( this : not null access Widget'Class;
name : String := "";
size : Natural := 0 );
-- Sets the widget's layout as centered within the parent's content area,
-- given the viewport size.
procedure Set_Layout_Center( this : not null access Widget'Class;
width,
height : Natural );
-- Sets the widget's layout as centered horizontally and spaced from the top
-- and bottom of the parent's content area like layout LTRB.
procedure Set_Layout_CenterH( this : not null access Widget'Class;
width : Natural;
top,
bottom : Integer );
-- Sets the widget's layout as centered horizontally and positioned
-- absolutely in the vertical dimension. y1 and y2 are both distances from
-- the top of the parent's content region. Negative values will position
-- the widget off the top edge of the parent's content.
procedure Set_Layout_CenterHY( this : not null access Widget'Class;
width : Natural;
y1, y2 : Integer );
-- Sets the widget's layout based on the distance of the viewport's edges
-- from the edges of the parent's content area.
procedure Set_Layout_LTRB( this : not null access Widget'Class;
left,
top,
right,
bottom : Integer );
-- Sets the widget's layout based on a size and distance from the top left
-- edges of the parent's content area. If top or left is negative then the
-- top left corner of the widget will be positioned relative to the bottom
-- or right edge of the content area. If width or height is 0 then the
-- widget's minimum width or height will be used instead.
procedure Set_Layout_LTWH( this : not null access Widget'Class;
left,
top : Integer;
width,
height : Natural );
-- Sets the widget's layout based on a size and absolute distance from the
-- top left corner of the parent's content area. This layout is nearly
-- identical to LTWH except negative values for 'x' and 'y' are kept
-- relative to the upper left. If width or height is 0 then the
-- widget's minimum width or height will be used instead.
procedure Set_Layout_XYWH( this : not null access Widget'Class;
x, y : Integer;
width,
height : Natural );
-- Sets the minimum height value to override the computed minimum height
-- for the widget. If height is set to zero, the computed value is returned
-- by Get_Min_Height.
procedure Set_Min_Height( this : not null access Widget'Class;
height : Natural );
-- Sets the minimum width value to override the computed minimum width
-- for the widget. If width is set to zero, the computed value is returned
-- by Get_Min_Width.
procedure Set_Min_Width( this : not null access Widget'Class;
width : Natural );
-- Sets the next widget to receive focus when tab is pressed on this widget.
procedure Set_Next( this : not null access Widget'Class; id : String );
-- Sets the next widget to receive focus when shift + tab is pressed on this
-- widget.
procedure Set_Prev( this : not null access Widget'Class; id : String );
-- Set to true if the widget is partly transparent so that it will be drawn
-- over the background.
procedure Set_Transparent( this : not null access Widget'Class;
transparent : Boolean );
-- Sets whether the widget is visible.
procedure Set_Visible( this : access Widget; visible : Boolean );
-- Sets the zoom factor. Values > 1 make the contents larger and values < 1
-- make the contents smaller. This does not affect the screen size of the
-- widget; Increasing the zoom decreases the visible content area.
procedure Set_Zoom( this : access Widget; zoom : Float );
-- Enable/disable font smoothing if the widget draws text. This is only a
-- hint; it can be used to disable font smoothing, but font smoothing can
-- only work if the conditions support it (type of font, transparency, etc.)
-- Smooth fonts are enabled by default.
procedure Smooth_Text( this : not null access Widget'Class; enabled : Boolean );
private
use Ada.Strings.Unbounded;
use Associations;
use Values;
----------------------------------------------------------------------------
type Simple_Action_Listener is abstract new Object with null record;
----------------------------------------------------------------------------
type Layout is abstract new Object with null record;
type A_Layout is access all Layout'Class;
-- Raises Constraint_Error because this is an abstract procedure that should
-- not be directly called. This procedure isn't officially declared abstract
-- so the Layout type can remain in the private section.
procedure Apply( this : access Layout; widget : not null A_Widget );
----------------------------------------------------------------------------
package Action_Listeners is new Ada.Containers.Doubly_Linked_Lists( A_Action_Listener, "=" );
use Action_Listeners;
package Listener_Maps is new
Ada.Containers.Indefinite_Hashed_Maps( String, Action_Listeners.List,
Ada.Strings.Hash_Case_Insensitive,
Ada.Strings.Equal_Case_Insensitive,
Action_Listeners."=" );
use Listener_Maps;
----------------------------------------------------------------------------
Key_Press : constant Action_Id := To_Action_Id( "key.press" );
Key_Held : constant Action_Id := To_Action_Id( "key.held" );
Key_Release : constant Action_Id := To_Action_Id( "key.release" );
Key_Click : constant Action_Id := To_Action_Id( "key.click" );
type Key_Action is new Action with
record
key : Integer;
modifiers : Modifiers_Array;
end record;
procedure Construct( this : access Key_Action;
id : Action_Id;
source : not null A_Widget;
key : Integer;
modifiers : Modifiers_Array );
procedure Delete( this : in out A_Key_Action );
pragma Postcondition( this = null );
----------------------------------------------------------------------------
type Simple_Key_Listener is new Simple_Action_Listener and Key_Listener with
record
key : Integer;
modifiers : Modifiers_Pattern;
handler : A_Key_Handler := null;
end record;
type A_Simple_Key_Listener is access all Simple_Key_Listener'Class;
function Create_Listener( key : Integer;
modifiers : Modifiers_Pattern;
handler : not null A_Key_Handler
) return A_Key_Listener;
pragma Postcondition( Create_Listener'Result /= null );
procedure Handle_Action( this : access Simple_Key_Listener;
action : A_Key_Action;
handled : out Boolean );
----------------------------------------------------------------------------
Change_Visibility : constant Action_Id := To_Action_Id( "visibility.changed" );
type Visibility_Action is new Action with
record
visible : Boolean;
end record;
procedure Construct( this : access Visibility_Action;
id : Action_Id;
source : not null A_Widget;
visible : Boolean );
procedure Delete( this : in out A_Visibility_Action );
pragma Postcondition( this = null );
----------------------------------------------------------------------------
-- Enumeration for specifying the corner of a widget.
type Widget_Corner_Type is (Widget_Top_Left, Widget_Top_Right,
Widget_Bottom_Left, Widget_Bottom_Right);
----------------------------------------------------------------------------
type Game_View2 is tagged null record;
type A_Game_View2 is access all Game_View2'Class;
pragma No_Strict_Aliasing( A_Game_View2 );
type Widget is abstract new Object with
record
view : A_Game_View2; -- widget's game view
id : Unbounded_String; -- unique id of the instance
registered : Boolean := False; -- successfully added to registry
parent : A_Widget := null; -- parent/containing widget
bmp, -- the widget's display bitmap (width x height)
drawbmp : A_Bitmap := null; -- the bitmap for drawing (view width x view height)
dirty : Boolean := True; -- flag for redrawing contents
x1, y1, -- offset of viewport from top
x2, y2, -- left of parent's content area
vx1, vy1, -- offset of viewport from top
vx2, vy2 : Integer := 0; -- left of own content area
cwidth, -- width of the content area
cheight : Natural := 0; -- height of the content area
minWidth, -- overrides minimum width if > 0
minHeight : Natural := 0; -- overrides minimum height if > 0
zoom : Float := 1.0; -- >1 is bigger
-- zoom = (x2-x1)/(vx2-vx1) or
-- (y2-y1)/(vy2-vy1)
zoomable : Boolean := True; -- widget can be zoomed in/out
layout : A_Layout := null;
visible : Boolean := False; -- widget is visible
enabled : Boolean := True; -- user interaction allowed
hover : Boolean := False; -- mouse is over widget
pressed : Boolean := False; -- mouse LB is pressed on widget
acceptFocus : Boolean := True; -- widget accepts focus
focused : Boolean := False; -- widget is focused
colors : Colors_Array := Colors_Array'(others => 0);
border : Border_Type := Border_None;
transparent : Boolean := False; -- widget is partly transparent
attrs : A_Association := null; -- map of additional attributes
listeners : Listener_Maps.Map; -- listeners registered to
-- receive widget actions
nextId, -- widget to focus on Tab key
prevId : Unbounded_String; -- widget to focus on Shift+Tab
fontName : Unbounded_String := To_Unbounded_String( DEFAULT_FONT_NAME );
fontSize : Positive := DEFAULT_FONT_SIZE;
fontSmooth : Boolean := True; -- smooth fonts (hint)
end record;
-- Returns true if the widget accepts input focus.
function Accepts_Focus( this : not null access Widget'Class ) return Boolean;
-- Activates a popup menu. Corner specifies which corner of the popup to
-- place at the given coordinates. Arguments x, y are in widget content
-- coordinates. Width and height specify the size of the popup widget.
-- Passing zero in either dimension will size the popup to its own reported
-- reported minimum. Note that the popup will be a child of the window; thus
-- without scaling, the size of the popup will be treated as window content
-- coordinates which may be different than this widget. The scale argument
-- determines whether or not the given popup size will be scaled from this
-- widget's content coordinates to the window's content coordinates.
--
-- Example situations for specifying/omitting sizes are as follows:
-- Select-enum choices popup : Specify width, omit height, scale
-- Pulldown menu : Omit width and height, no scaling (menubars don't zoom)
-- Contextual popup menu : Omit width and height, no scaling
procedure Activate_Popup( this : access Widget;
popup : not null A_Widget;
corner : Widget_Corner_Type;
x, y : Integer;
width : Natural := 0;
height : Natural := 0;
scale : Boolean := False );
-- Registers an action listener. Argument 'listenerType' is the string name
-- of the exact listener interface to register the listener as, for exmaple
-- "Button_Listener" to register the action listener for button actions.
procedure Add_Listener( this : not null access Widget'Class;
listenerType : String;
listener : not null A_Action_Listener );
pragma Precondition( listenerType'Length > 0 );
-- Raises COPY_NOT_ALLOWED.
procedure Adjust( this : access Widget );
-- Brings this widget and its ancestors of the front.
procedure Bring_To_Front( this : access Widget );
-- Raises DUPLICATE_ID exception if 'id' has already been registered with
-- the widget's view. Widget id strings must be unique per view.
procedure Construct( this : access Widget;
view : not null access Game_Views.Game_View'Class;
id : String );
pragma Precondition( id'Length > 0 );
-- Deactivates the a popup menu by popping popups from the window until the
-- given popup has been deactivated. If the given popup menu isn't active,
-- nothing will happen.
procedure Deactivate_Popup( this : access Widget; popup : not null A_Widget );
procedure Delete( this : in out Widget );
-- Dispatches a visibility action to the widget's listeners.
procedure Dispatch_Visibility_Action( this : not null access Widget'Class;
visible : Boolean );
-- Dispatches a key action to the widget's listeners. Returns True if the
-- key action was handled by a listener.
function Dispatch_Key_Action( this : not null access Widget'Class;
id : Action_Id;
key : Integer;
modifiers : Modifiers_Array ) return Boolean;
-- Returns the widget containing the given screen coordinates (coordinates
-- relative to the widget's viewport), and the widget coordinates that x,y
-- map to within the found widget's content area.
procedure Find_Widget( this : access Widget;
x, y : Integer;
wx, wy : out Integer;
found : out A_Widget );
-- Returns the height of the widget's content.
function Get_Content_Height( this : not null access Widget'Class ) return Natural;
-- Returns the width of the widget's content.
function Get_Content_Width( this : not null access Widget'Class ) return Natural;
-- Returns the minimum allowable height for this widget based on its
-- content.
function Get_Min_Height( this : access Widget ) return Natural;
-- Returns the minimum allowable width for this widget based on its content.
function Get_Min_Width( this : access Widget ) return Natural;
-- Returns the widget's visible drawing area in widget coordinates.
procedure Get_Viewport( this : not null access Widget'Class;
x1, y1,
x2, y2 : out Integer );
-- Returns the window containing this widget. If the widget does not have a
-- window yet then null will be returned.
function Get_Window( this : access Widget
) return access Widgets.Containers.Windows.Window'Class;
-- Override this procedure to handle mouse click events.
procedure Handle_Click( this : access Widget;
evt : not null A_Mouse_Button_Event );
-- Override ths procedure to handle lost focus events.
procedure Handle_Blur( this : access Widget );
-- This is called on a visible widget when it, or an ancestor, becomes
-- hidden, in order to notify this widget's visibility listeners and those
-- of its visible children, if any.
procedure Handle_Ancestor_Hidden( this : access Widget );
-- This is called on a hidden widget when it, or an ancestor, becomes
-- visible, in order to notify this widget's visibility listeners and those
-- of its visible children, if any.
procedure Handle_Ancestor_Unhidden( this : access Widget );
-- This is called when a previously visible widget becomes hidden. This
-- should be handled by the root widget (window) appropriately.
procedure Handle_Descendant_Hidden( this : access Widget;
descendant : not null A_Widget );
-- Override this procedure to handle mouse enter events.
procedure Handle_Enter( this : access Widget );
-- Override this procedure to handle mouse exit events.
procedure Handle_Exit( this : access Widget );
-- Override this procedure to handle received focus events.
procedure Handle_Focus( this : access Widget );
-- Override this function to handle key held events.
function Handle_Key_Held( this : access Widget;
evt : not null A_Key_Event ) return Boolean;
-- Override this function to handle key press events.
function Handle_Key_Press( this : access Widget;
evt : not null A_Key_Event ) return Boolean;
-- Override this function to handle key release events.
function Handle_Key_Release( this : access Widget;
evt : not null A_Key_Event ) return Boolean;
-- Override this function to handle mouse held events.
procedure Handle_Mouse_Held( this : access Widget;
evt : not null A_Mouse_Button_Event );
-- Override this function to handle mouse move events.
procedure Handle_Mouse_Move( this : access Widget;
evt : not null A_Mouse_Event );
-- Override this procedure to handle mouse press events.
procedure Handle_Mouse_Press( this : access Widget;
evt : not null A_Mouse_Button_Event );
-- Override this procedure to handle mouse click events.
procedure Handle_Mouse_Release( this : access Widget;
evt : not null A_Mouse_Button_Event );
-- Override this procedure to handle mouse scrollwheel events.
function Handle_Mouse_Scroll( this : access Widget;
evt : not null A_Mouse_Scroll_Event ) return Boolean;
-- This is called when Pack changes the size of the widget's viewport.
procedure Handle_Resize( this : access Widget );
-- This is called when a previously hidden widget becomes visible. This
-- should be handled by the root widget (window) appropriately.
procedure Handle_Descendant_Unhidden( this : access Widget;
descendant : not null A_Widget );
-- Checks if the widget is a descendent of the given widget.
function Is_Descendant_Of( this : not null access Widget'Class;
ancestor : A_Widget ) return Boolean;
-- Iterate through the list of action listeners registered for a specific
-- action type.
procedure Iterate_Listeners( this : not null access Widget'Class;
listenerType : String;
examine : not null access procedure( listener : A_Action_Listener ) );
pragma Precondition( listenerType'Length > 0 );
procedure Pack( this : access Widget );
-- Adds an action listener to the front of the listener list for the given
-- type of listener. The listener will be the first to be notified of an
-- action (until another listener of the same type is prepended).
procedure Prepend_Listener( this : not null access Widget'Class;
listenerType : String;
listener : not null A_Action_Listener );
pragma Precondition( listenerType'Length > 0 );
-- Unregisters an action listener for receiving actions of the given type.
procedure Remove_Listener( this : not null access Widget'Class;
listenerType : String;
listener : not null A_Action_Listener );
pragma Precondition( listenerType'Length > 0 );
-- Sets a generic attribute on the widget. Attributes are used for
-- encapsulating minor additional data without extending a widget class.
-- 'val' is consumed.
procedure Set_Attribute( this : not null access Widget'Class;
name : String;
val : in out A_Value );
pragma Precondition( name'Length > 0 );
pragma Postcondition( val = null );
-- Marks the widget as dirty, causing it to refresh its contents on the next
-- redraw.
procedure Set_Dirty( this : access Widget );
procedure Set_Layout( this : not null access Widget'Class;
layout : in out A_Layout );
pragma Postcondition( layout = null );
-- Sets a widget as the parent of this.
procedure Set_Parent( this : access Widget; parent : A_Widget );
-- Returns a string representation of the widget.
function To_String( this : access Widget ) return String;
-- Translates screen coordinates into the widget's content coodinates.
procedure Translate_To_Content( this : access Widget;
sx, sy : Integer;
cx, cy : out Integer );
-- Translates the widget's content coordinates into window coordinates.
procedure Translate_To_Window( this : access Widget;
cx, cy : Integer;
wx, wy : out Integer );
-- Deletes the Widget.
procedure Delete( this : in out A_Widget );
pragma Postcondition( this = null );
function Lt( l, r : A_Widget ) return Boolean;
end Widgets;