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 Drawing;                           use Drawing; 
  10. with Events;                            use Events; 
  11. with Events.Listeners;                  use Events.Listeners; 
  12. with Widgets.Menubars;                  use Widgets.Menubars; 
  13.  
  14. private with Allegro.Keyboard; 
  15. private with Mouse; 
  16.  
  17. package Widgets.Containers.Windows is 
  18.  
  19.     -- A Window is the root of the widget tree within the application window. 
  20.     -- 
  21.     -- All interface input events are delivered to the Window and then 
  22.     -- dispatched by the Window to its descendent widgets. Widget events are 
  23.     -- handled in a bottom-up approach, being delivered to the focused widget 
  24.     -- first and then dispatching up the tree, toward the Window, until the 
  25.     -- event is captured and handled. 
  26.     -- 
  27.     -- Input focus, or just "focus", is tracked by the Window. Exactly one 
  28.     -- widget in the Window tree will have focus at all times. If no other 
  29.     -- widget is focused, the Window will be focused by default. The focused 
  30.     -- widget will receive all keyboard events. 
  31.     type Window is new Container and Event_Listener with private; 
  32.     type A_Window is access all Window'Class; 
  33.  
  34.     -- Creates a new Window within 'view'. 'width' and 'height' are the size of 
  35.     -- the widget. The window will automatically be upscaled to a higher 
  36.     -- resolution if the bitmap it draws onto is a multiple or more of the 
  37.     -- window size. 'filter' determines the upscaling filter algorithm to use. 
  38.     function Create_Window( view   : access Game_Views.Game_View'Class; 
  39.                             id     : String; 
  40.                             width, 
  41.                             height : Natural; 
  42.                             filter : Filter_Type := Filter_Nearest 
  43.                           ) return A_Window; 
  44.     pragma Precondition( id'Length > 0 ); 
  45.     pragma Postcondition( Create_Window'Result /= null ); 
  46.  
  47.     -- Adds a child widget to the Window. 'child' will be consumed if 'consume' 
  48.     -- is set to True. In either case, however, the Container will own 'child' 
  49.     -- after this is called, and will delete it if it's still a child at the 
  50.     -- time of deletion. 
  51.     procedure Add_Widget( this    : access Window; 
  52.                           child   : in out A_Widget; 
  53.                           consume : Boolean := True ); 
  54.     pragma Precondition( child /= null ); 
  55.     pragma Postcondition( consume xor child /= null ); 
  56.  
  57.     -- Draws the whole Window, all its children, and then the popup widget stack 
  58.     -- in back-to-front order. The modal widget, if set, will be the front-most 
  59.     -- child. The popup widgets, if any are active, will still be drawn in front 
  60.     -- of the modal widget tree and menu bar. This procedure is used by the 
  61.     -- renderer to draw the whole OS window. 
  62.     procedure Draw( this : access Window ); 
  63.  
  64.     -- Returns the color of the outer border that surrounds the window. See 
  65.     -- Set_Border_Color(). 
  66.     function Get_Outer_Border( this : not null access Window'Class ) return Allegro_Color; 
  67.  
  68.     -- Returns the scaling factor used when drawing the Window to the screen. A 
  69.     -- return value of 1 means it is drawn at actual size. 
  70.     function Get_Scale( this : not null access Window'Class ) return Positive; 
  71.  
  72.     -- Requests input focus be given to 'target'. If 'target' doesn't accept 
  73.     -- focus, then focus will be given to its "next focus" widget (what happens 
  74.     -- when you press the Tab key). If no "next focus" widget exists or accepts 
  75.     -- focus, then focus will be given to the widget's nearest ancestor that 
  76.     -- accepts it. Changing the input focus will prevent any potential key held 
  77.     -- and key release events from being sent to the old focused widget that 
  78.     -- received the key press. 
  79.     procedure Give_Focus( this : access Window; target : not null A_Widget ); 
  80.  
  81.     -- Returns True if the Window is showing on the screen. It is showing if it 
  82.     -- is visible and has been added to the Game_View. 
  83.     function Is_Showing( this : access Window ) return Boolean; 
  84.  
  85.     -- Pops the top-most widget off the popup stack. If there are no active 
  86.     -- popup widgets, nothing will happen. 
  87.     procedure Pop_Popup( this : access Window ); 
  88.  
  89.     -- Pops all widgets from the popups stack until the given popup widget has 
  90.     -- been popped. If the widget isn't an active popup menu, nothing will 
  91.     -- happen. 
  92.     procedure Pop_Popup( this : access Window; popup : not null A_Widget ); 
  93.  
  94.     -- Pushes a popup widget onto the top of the popup stack, making it visible. 
  95.     -- Popups are the highest in the Z-order, so they will be displayed in front 
  96.     -- of any modal widget, most recent on top. The widget will temporarily 
  97.     -- become a child of the window while its on the popup stack. 
  98.     procedure Push_Popup( this : access Window; popup : not null A_Widget ); 
  99.  
  100.     -- Removes the widget from the window. 
  101.     procedure Remove_Widget( this : access Window; child : not null A_Widget ); 
  102.  
  103.     -- Sets the pixel scaling filter for the entire window. If the window is 
  104.     -- scaled to a larger resolution on the screen, everything in the window 
  105.     -- will be scaled up to that resolution with this filter. 
  106.     procedure Set_Filter( this   : not null access Window'Class; 
  107.                           filter : Filter_Type ); 
  108.  
  109.     -- Sets the Window's menu bar widget. The menu bar is optional and there can 
  110.     -- be only one per Window. 'menu' will be consumed. If a menu bar has 
  111.     -- already been set, the old one will be deleted. 
  112.     procedure Set_Menubar( this : access Window; menu : in out A_Menubar ); 
  113.     pragma Postcondition( menu = null ); 
  114.  
  115.     -- Sets the modal widget drawn on top of all others in the Window. This 
  116.     -- widget and its descendents will receive all input events or prevent them 
  117.     -- from being sent to any others, while it is visible. Set 'modal' to null 
  118.     -- to clear the modal widget. 'modal' will be set visible when it's set and 
  119.     -- invisible when another modal widget is set or it's unset. The modal 
  120.     -- modal widget tree will be drawn in front of all other Window children and 
  121.     -- behind any active popup widgets. 
  122.     procedure Set_Modal( this : access Window; modal : A_Widget ); 
  123.  
  124.     -- Sets the offset of the top left corner of the window from the top left 
  125.     -- corner of the screen. 
  126.     procedure Set_Offset( this : access Window; x, y : Integer ); 
  127.  
  128.     -- Sets the color of the outer border that surrounds the window, if the 
  129.     -- window widget doesn't fill the entire display. For applications that use 
  130.     -- a fixed window size that scales to fill the display, the display 
  131.     -- resolutions in between exact multiples of the window size will show this 
  132.     -- border color between the edges of the window widget and the display. 
  133.     procedure Set_Outer_Border( this  : not null access Window'Class; 
  134.                                 color : Allegro_Color ); 
  135.  
  136.     -- Sets the title at the top of the application window. 
  137.     procedure Set_Title( this : not null access Window'Class; title : String ); 
  138.  
  139.     -- Deletes the Window. 
  140.     procedure Delete( this : in out A_Window ); 
  141.     pragma Postcondition( this = null ); 
  142.  
  143. private 
  144.  
  145.     use Allegro.Keyboard; 
  146.     use Mouse; 
  147.  
  148.     -- an array of widgets by mouse button; used for tracking mouse button 
  149.     -- history relative to widgets. 
  150.     type Mouse_Widget_Array is array (Mouse_Button) of A_Widget; 
  151.  
  152.     -- an array of widgets by key scancode. used for tracking key history 
  153.     -- relative to widgets. 
  154.     type Key_Widget_Array is array (1..ALLEGRO_KEY_MAX-1) of A_Widget; 
  155.  
  156.     ---------------------------------------------------------------------------- 
  157.  
  158.     type Window is new Container and Event_Listener with 
  159.         record 
  160.             scale          : Positive := 1; 
  161.             filter         : Filter_Type := Filter_Nearest; 
  162.             scaleBmp       : A_Allegro_Bitmap := null; 
  163.  
  164.             menu           : A_Menubar := null; 
  165.  
  166.             mouseOver      : A_Widget := null; 
  167.             mousePressedOn : Mouse_Widget_Array; 
  168.             mouseClickedOn : Mouse_Widget_Array; 
  169.             keyPressSentTo : Key_Widget_Array := Key_Widget_Array'(others=>null); 
  170.  
  171.             focus          : A_Widget := null; 
  172.             modal          : A_Widget := null;     -- widget with modality in window 
  173.             popups         : Widget_Lists.List;    -- stack of active popup widgets 
  174.  
  175.             outerBorder    : Allegro_Color; 
  176.         end record; 
  177.  
  178.     procedure Construct( this   : access Window; 
  179.                          view   : access Game_Views.Game_View'Class; 
  180.                          id     : String; 
  181.                          width, 
  182.                          height : Natural; 
  183.                          filter : Filter_Type ); 
  184.     pragma Precondition( id'Length > 0 ); 
  185.  
  186.     procedure Delete( this : in out Window ); 
  187.  
  188.     -- find a widget at the given screen coordinates (sx, sy) and return the 
  189.     -- corresponding widget content coordinates if a widget is found (wx, wy). 
  190.     procedure Find_Widget_At( this   : access Window; 
  191.                               sx, sy : Integer; 
  192.                               wx, wy : out Integer; 
  193.                               found  : out A_Widget ); 
  194.  
  195.     -- Recursively returns the widget's parent Window at the root of its 
  196.     -- ancestors. The Window widget is always its own window: returns 'this'. 
  197.     function Get_Window( this : access Window ) return access Window'Class; 
  198.  
  199.     -- Handles all input events that the Window is registered to receive. 
  200.     procedure Handle_Event( this : access Window; 
  201.                             evt  : in out A_Event; 
  202.                             resp : out Response_Type ); 
  203.     pragma Precondition( evt /= null ); 
  204.  
  205.     -- Returns True by definition. The Window is the root of every widget 
  206.     -- hierarchy. 
  207.     function Is_Rooted( this : access Window ) return Boolean; 
  208.  
  209.     -- Handles when 'descendent' is shown or hidden on the screen. If 
  210.     -- 'descendent' is hidden and it was focused, then focus must be transferred 
  211.     -- to a visible, focusable ancestor. 
  212.     procedure On_Descendant_Shown( this       : access Window; 
  213.                                    descendant : not null A_Widget; 
  214.                                    shown      : Boolean ); 
  215.  
  216.     -- Closes any open popups if Escape is pressed. 
  217.     procedure On_Key_Press( this    : access Window; 
  218.                             evt     : not null A_Key_Event; 
  219.                             handled : in out Boolean ); 
  220.  
  221.     -- Packs the window, all its children, and its menu bar. 
  222.     procedure Pack( this : access Window ); 
  223.  
  224.     -- Translates screen coordinates 'sx','sy' into Window content coordinates, 
  225.     -- 'cx','cy'. 
  226.     procedure Translate_To_Content( this   : access Window; 
  227.                                     sx, sy : Integer; 
  228.                                     cx, cy : out Integer ); 
  229.  
  230.     -- Translates this widget's content coordinates into its Window's content 
  231.     -- coordinates. Because this is the Window widget, no translation actually 
  232.     -- occurs. (This is for a recursive function.) Note that 'wx','wy' here are 
  233.     -- not in the same coordinate space as the screen coordinates, 'sx','sy', 
  234.     -- that are passed to Translate_To_Content. 
  235.     procedure Translate_To_Window( this   : access Window; 
  236.                                    cx, cy : Integer; 
  237.                                    wx, wy : out Integer ); 
  238.  
  239. end Widgets.Containers.Windows;