1. with Actions; 
  2.  
  3. private with Ada.Real_Time; 
  4. private with Allegro.Keyboard; 
  5.  
  6. pragma Warnings( Off, Actions ); 
  7. pragma Elaborate_All( Actions ); 
  8.  
  9. package Widgets.Input_Boxes is 
  10.  
  11.     -- Represents a widget action involving an Input_Box, such as a input event. 
  12.     type Input_Action is new Action with private; 
  13.     type A_Input_Action is access all Input_Action'Class; 
  14.  
  15.     Entered : constant Action_Id;             -- the enter key was pressed 
  16.  
  17.     -- This is the interface to implement in order to listen to input actions. 
  18.     -- When an input action occurs, the listener will be notified of the type of 
  19.     -- action performed and the input box that performed the action. 
  20.     type Input_Listener is limited interface and Action_Listener; 
  21.     type A_Input_Listener is access all Input_Listener'Class; 
  22.  
  23.     -- Handles the input action 'action'. 
  24.     procedure Handle_Action( this   : access Input_Listener; 
  25.                              action : A_Input_Action ) is abstract; 
  26.  
  27.     -- A simple procedure to handle an input action, used by Simple_Input_Listener. 
  28.     type A_Input_Handler is 
  29.         access procedure( action : A_Input_Action ); 
  30.  
  31.     ---------------------------------------------------------------------------- 
  32.  
  33.     -- An access to a string constraint function. A constraint function returns 
  34.     -- 'newstr' if it meets the constraint, otherwise 'curstr' will be returned. 
  35.     type A_Constrain_Func is 
  36.         access function( curstr, newstr : String ) return String; 
  37.  
  38.     ---------------------------------------------------------------------------- 
  39.  
  40.     -- An Input_Box widget allows a single line of text to be edited with the 
  41.     -- keyboard. The text of the input box can be larger than the width of the 
  42.     -- width; the portion of the text near the cursor will be displayed. 
  43.     type Input_Box is new Widget with private; 
  44.     type A_Input_Box is access all Input_Box'Class; 
  45.  
  46.     -- Creates a new Input_Box within 'view' with id 'id'. 
  47.     function Create_Input_Box( view : not null access Game_Views.Game_View'Class; 
  48.                                id   : String ) return A_Input_Box; 
  49.     pragma Precondition( id'Length > 0 ); 
  50.     pragma Postcondition( Create_Input_Box'Result /= null ); 
  51.  
  52.     -- Registers 'listener' as an Input_Action listener. 
  53.     procedure Add_Listener( this     : access Input_Box; 
  54.                             listener : not null A_Input_Listener ); 
  55.  
  56.     -- Registers 'handler' to be invoked when an Input_Action occurs. 
  57.     procedure Add_Listener( this    : access Input_Box; 
  58.                             handler : not null A_Input_Handler ); 
  59.  
  60.     -- Returns the input box's text. 
  61.     function Get_Text( this : access Input_Box ) return String; 
  62.  
  63.     -- Unregisters 'listener' as an Input_Action listener. 
  64.     procedure Remove_Listener( this     : access Input_Box; 
  65.                                listener : not null A_Input_Listener ); 
  66.  
  67.     -- Sets a constraint function to validate the input box's text. If 
  68.     -- 'constraint' is null, any text can be added. No text can be entered into 
  69.     -- the input box that is not validated by the constraint function. 
  70.     procedure Set_Constraint( this       : access Input_Box; 
  71.                               constraint : A_Constrain_Func ); 
  72.  
  73.     -- Sets the maximum length of the input box's text in characters. 
  74.     procedure Set_Max_Length( this : access Input_Box; maxlen : Positive ); 
  75.  
  76.     -- Sets the input box's text value. The value will remain unchanged if 
  77.     -- 'text' is not accepted by the current constraint function. 
  78.     procedure Set_Text( this : access Input_Box; text : String ); 
  79.  
  80. private 
  81.  
  82.     use Ada.Real_Time; 
  83.     use Allegro.Keyboard; 
  84.  
  85.     -- direction to move the cursor on a key press 
  86.     type Move_Dir is (Go_First, Go_Left, Go_Right, Go_Last); 
  87.  
  88.     -- an array of time values for each key scancode. this is used for repeating 
  89.     -- characters when a key is held. 
  90.     type Key_Delay_Array is array (1..KEY_MAX) of Time; 
  91.  
  92.     ---------------------------------------------------------------------------- 
  93.  
  94.     type Input_Action is new Action with null record; 
  95.  
  96.     Entered : constant Action_Id := To_Action_Id( "input.entered" ); 
  97.  
  98.     -- Deletes the Input_Action. 
  99.     procedure Delete( this : in out A_Input_Action ); 
  100.     pragma Postcondition( this = null ); 
  101.  
  102.     ---------------------------------------------------------------------------- 
  103.  
  104.     -- A Simple_Input_Listener is an adapter class that listens for Input_Action 
  105.     -- events and invokes a callback, A_Input_Handler. This allows callback 
  106.     -- procedures to handle input actions instead of requiring an object to do 
  107.     -- so. 
  108.     type Simple_Input_Listener is new Simple_Action_Listener and Input_Listener with 
  109.         record 
  110.             handler : A_Input_Handler := null; 
  111.         end record; 
  112.     type A_Simple_Input_Listener is access all Simple_Input_Listener'Class; 
  113.  
  114.     -- Creates a Simple_Input_Listener that invokes 'handler' when it receives 
  115.     -- an input action. 
  116.     function Create_Listener( handler : not null A_Input_Handler ) return A_Input_Listener; 
  117.     pragma Postcondition( Create_Listener'Result /= null ); 
  118.  
  119.     -- Invokes the simple input listener's Input_Handler procedure. 
  120.     procedure Handle_Action( this   : access Simple_Input_Listener; 
  121.                              action : A_Input_Action ); 
  122.  
  123.     ---------------------------------------------------------------------------- 
  124.  
  125.     type Input_Box is new Widget with 
  126.         record 
  127.             text      : Unbounded_String; 
  128.             cursor    : Natural := 0; 
  129.             firstchar : Natural := 0;   -- first character to draw. this is 0 
  130.                                         --   unless the text is too long to fit 
  131.                                         --   in the content area of the widget. 
  132.             lastchar  : Natural := 0;   -- last character to draw. this is the 
  133.                                         --   length of text unless the text is 
  134.                                         --   too long to fit in the content area 
  135.                                         --   of the widget. 
  136.             constrain : A_Constrain_Func := null; 
  137.             maxlen    : Positive := 1024; 
  138.             key_delay : Key_Delay_Array; 
  139.         end record; 
  140.  
  141.     -- Inserts 'char' into the input box's value to the right of the cursor 
  142.     -- position. If the updated text exceeds the max length or it does not 
  143.     -- validate with the input box's constraint function, the character will not 
  144.     -- be added. 
  145.     procedure Add_Character( this : not null access Input_Box'Class; 
  146.                              char : Character ); 
  147.  
  148.     -- Adjusts the range of the text that is visible in input box if it's too 
  149.     -- long to fit in the widget's screen space, keeping the cursor in sight. 
  150.     procedure Adjust_Visible_Text( this : not null access Input_Box'Class ); 
  151.  
  152.     procedure Construct( this : access Input_Box; 
  153.                          view : not null access Game_Views.Game_View'Class; 
  154.                          id   : String ); 
  155.     pragma Precondition( id'Length >  0 ); 
  156.  
  157.     -- Dispatches Action_Id 'id' to all registered Input_Action listeners. 
  158.     procedure Dispatch_Action( this : access Input_Box; id : Action_Id ); 
  159.  
  160.     -- Deletes the character to the left of the cursor, if there is one, and if 
  161.     -- the resulting text doesn't violate the constraint function. 
  162.     procedure Do_Backspace( this : not null access Input_Box'Class ); 
  163.  
  164.     -- Deletes the character to the right of the cursor, if there is one, and if 
  165.     -- the resulting text doesn't violate the constraint function. 
  166.     procedure Do_Delete( this : not null access Input_Box'Class ); 
  167.  
  168.     -- Enters the current text, firing the 'Entered' Input_Action. This is 
  169.     -- called when the Enter key is pressed. 
  170.     procedure Do_Enter( this : not null access Input_Box'Class ); 
  171.  
  172.     procedure Draw_Content( this : access Input_Box; dc : Drawing_Context ); 
  173.  
  174.     function Handle_Key_Held( this : access Input_Box; 
  175.                               evt  : not null A_Key_Event ) return Boolean; 
  176.  
  177.     function Handle_Key_Press( this : access Input_Box; 
  178.                                evt  : not null A_Key_Event ) return Boolean; 
  179.  
  180.     function Handle_Key_Release( this : access Input_Box; 
  181.                                  evt  : not null A_Key_Event ) return Boolean; 
  182.  
  183.     procedure Handle_Mouse_Press( this : access Input_Box; 
  184.                                   evt  : not null A_Mouse_Button_Event ); 
  185.  
  186.     -- Moves the cursor in the direction 'dir', if possible. The visible portion 
  187.     -- of the text will be adjusted to always keep the cursor in view. 
  188.     procedure Move_Cursor( this : not null access Input_Box'Class; dir : Move_Dir ); 
  189.  
  190.     -- Adjusts the visible text after packing the widget. 
  191.     procedure Pack( this : access Input_Box ); 
  192.  
  193. end Widgets.Input_Boxes;