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; 
  10.  
  11. private with Ada.Real_Time; 
  12. private with Allegro.Keyboard; 
  13.  
  14. pragma Warnings( Off, Actions ); 
  15. pragma Elaborate_All( Actions ); 
  16.  
  17. package Widgets.Input_Boxes is 
  18.  
  19.     -- Represents a widget action involving an Input_Box, such as a input event. 
  20.     type Input_Action is new Action with private; 
  21.     type A_Input_Action is access all Input_Action'Class; 
  22.  
  23.     Entered : constant Action_Id;             -- the enter key was pressed 
  24.  
  25.     -- This is the interface to implement in order to listen to input actions. 
  26.     -- When an input action occurs, the listener will be notified of the type of 
  27.     -- action performed and the input box that performed the action. 
  28.     type Input_Listener is limited interface and Action_Listener; 
  29.     type A_Input_Listener is access all Input_Listener'Class; 
  30.  
  31.     -- Handles the input action 'action'. 
  32.     procedure Handle_Action( this   : access Input_Listener; 
  33.                              action : A_Input_Action ) is abstract; 
  34.  
  35.     ---------------------------------------------------------------------------- 
  36.  
  37.     -- An access to a string constraint function. A constraint function returns 
  38.     -- 'newstr' if it meets the constraint, otherwise 'curstr' will be returned. 
  39.     type A_Constrain_Func is 
  40.         access function( curstr, newstr : String ) return String; 
  41.  
  42.     ---------------------------------------------------------------------------- 
  43.  
  44.     -- An Input_Box widget allows a single line of text to be edited with the 
  45.     -- keyboard. The text of the input box can be larger than the width of the 
  46.     -- width; the portion of the text near the cursor will be displayed. 
  47.     type Input_Box is new Widget with private; 
  48.     type A_Input_Box is access all Input_Box'Class; 
  49.  
  50.     -- Creates a new Input_Box within 'view' with id 'id'. 
  51.     function Create_Input_Box( view : not null access Game_Views.Game_View'Class; 
  52.                                id   : String ) return A_Input_Box; 
  53.     pragma Precondition( id'Length > 0 ); 
  54.     pragma Postcondition( Create_Input_Box'Result /= null ); 
  55.  
  56.     -- Registers 'listener' as an Input_Action listener. 
  57.     procedure Add_Listener( this     : access Input_Box; 
  58.                             listener : not null A_Input_Listener ); 
  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.     ---------------------------------------------------------------------------- 
  99.  
  100.     type Input_Box is new Widget with 
  101.         record 
  102.             text      : Unbounded_String; 
  103.             cursor    : Natural := 0; 
  104.             firstchar : Natural := 0;   -- first character to draw. this is 0 
  105.                                         --   unless the text is too long to fit 
  106.                                         --   in the content area of the widget. 
  107.             lastchar  : Natural := 0;   -- last character to draw. this is the 
  108.                                         --   length of text unless the text is 
  109.                                         --   too long to fit in the content area 
  110.                                         --   of the widget. 
  111.             constrain : A_Constrain_Func := null; 
  112.             maxlen    : Positive := 1024; 
  113.             key_delay : Key_Delay_Array; 
  114.         end record; 
  115.  
  116.     procedure Construct( this : access Input_Box; 
  117.                          view : not null access Game_Views.Game_View'Class; 
  118.                          id   : String ); 
  119.     pragma Precondition( id'Length >  0 ); 
  120.  
  121.     -- Inserts 'char' into the input box's value to the right of the cursor 
  122.     -- position. If the updated text exceeds the max length or it does not 
  123.     -- validate with the input box's constraint function, the character will not 
  124.     -- be added. 
  125.     procedure Add_Character( this : not null access Input_Box'Class; 
  126.                              char : Character ); 
  127.  
  128.     -- Adjusts the range of the text that is visible in input box if it's too 
  129.     -- long to fit in the widget's screen space, keeping the cursor in sight. 
  130.     procedure Adjust_Visible_Text( this : not null access Input_Box'Class ); 
  131.  
  132.     -- Dispatches Action_Id 'id' to all registered Input_Action listeners. 
  133.     procedure Dispatch_Action( this : access Input_Box; id : Action_Id ); 
  134.  
  135.     -- Deletes the character to the left of the cursor, if there is one, and if 
  136.     -- the resulting text doesn't violate the constraint function. 
  137.     procedure Do_Backspace( this : not null access Input_Box'Class ); 
  138.  
  139.     -- Deletes the character to the right of the cursor, if there is one, and if 
  140.     -- the resulting text doesn't violate the constraint function. 
  141.     procedure Do_Delete( this : not null access Input_Box'Class ); 
  142.  
  143.     -- Enters the current text, firing the 'Entered' Input_Action. This is 
  144.     -- called when the Enter key is pressed. 
  145.     procedure Do_Enter( this : not null access Input_Box'Class ); 
  146.  
  147.     procedure Draw_Content( this : access Input_Box; dc : Drawing_Context ); 
  148.  
  149.     function Handle_Key_Held( this : access Input_Box; 
  150.                               evt  : not null A_Key_Event ) return Boolean; 
  151.  
  152.     function Handle_Key_Press( this : access Input_Box; 
  153.                                evt  : not null A_Key_Event ) return Boolean; 
  154.  
  155.     function Handle_Key_Release( this : access Input_Box; 
  156.                                  evt  : not null A_Key_Event ) return Boolean; 
  157.  
  158.     procedure Handle_Mouse_Press( this : access Input_Box; 
  159.                                   evt  : not null A_Mouse_Button_Event ); 
  160.  
  161.     -- Moves the cursor in the direction 'dir', if possible. The visible portion 
  162.     -- of the text will be adjusted to always keep the cursor in view. 
  163.     procedure Move_Cursor( this : not null access Input_Box'Class; dir : Move_Dir ); 
  164.  
  165.     -- Adjusts the visible text after packing the widget. 
  166.     procedure Pack( this : access Input_Box ); 
  167.  
  168. end Widgets.Input_Boxes;