1. private with Ada.Real_Time; 
  2. private with Allegro.Keyboard; 
  3.  
  4. package Widgets.Input_Boxes is 
  5.  
  6.     type Input_Action is new Action with private; 
  7.     type A_Input_Action is access all Input_Action'Class; 
  8.  
  9.     Entered : constant Action_Id; 
  10.  
  11.     -- This is the interface to implement in order to listen to input actions. 
  12.     -- When an input action occurs, the listener will be notified of the type of 
  13.     -- action performed and the input box that performed the action. 
  14.     type Input_Listener is limited interface and Action_Listener; 
  15.     type A_Input_Listener is access all Input_Listener'Class; 
  16.  
  17.     procedure Handle_Action( this   : access Input_Listener; 
  18.                              action : A_Input_Action ) is abstract; 
  19.  
  20.     type A_Input_Handler is 
  21.         access procedure( action : A_Input_Action ); 
  22.  
  23.     ---------------------------------------------------------------------------- 
  24.  
  25.     -- the returned string is constrained according to the function's logic 
  26.     -- curstr: the current value 
  27.     -- newstr: the new value to constrain 
  28.     type A_Constrain_Func is 
  29.         access function( curstr, newstr : String ) return String; 
  30.  
  31.     ---------------------------------------------------------------------------- 
  32.  
  33.     type Input_Box is new Widget with private; 
  34.     type A_Input_Box is access all Input_Box'Class; 
  35.  
  36.     function Create_Input_Box( view : not null access Game_Views.Game_View'Class; 
  37.                                id   : String ) return A_Input_Box; 
  38.     pragma Precondition( id'Length > 0 ); 
  39.     pragma Postcondition( Create_Input_Box'Result /= null ); 
  40.  
  41.     procedure Add_Listener( this     : access Input_Box; 
  42.                             listener : not null A_Input_Listener ); 
  43.  
  44.     procedure Add_Listener( this    : access Input_Box; 
  45.                             handler : not null A_Input_Handler ); 
  46.  
  47.     function Get_Text( this : access Input_Box ) return String; 
  48.  
  49.     procedure Remove_Listener( this     : access Input_Box; 
  50.                                listener : not null A_Input_Listener ); 
  51.  
  52.     procedure Set_Constraint( this       : access Input_Box; 
  53.                               constraint : A_Constrain_Func ); 
  54.  
  55.     procedure Set_Max_Length( this : access Input_Box; maxlen : Positive ); 
  56.  
  57.     procedure Set_Text( this : access Input_Box; text : String ); 
  58.  
  59. private 
  60.  
  61.     use Ada.Real_Time; 
  62.     use Allegro.Keyboard; 
  63.  
  64.     type Move_Dir is (Go_First, Go_Left, Go_Right, Go_Last); 
  65.  
  66.     type Key_Delay_Array is array (1..KEY_MAX) of Time; 
  67.  
  68.     type Direction_Type is (From_First, From_Last); 
  69.  
  70.     ---------------------------------------------------------------------------- 
  71.  
  72.     type Input_Action is new Action with null record; 
  73.  
  74.     Entered : constant Action_Id := To_Action_Id( "input.entered" ); 
  75.  
  76.     procedure Delete( this : in out A_Input_Action ); 
  77.     pragma Postcondition( this = null ); 
  78.  
  79.     ---------------------------------------------------------------------------- 
  80.  
  81.     type Simple_Input_Listener is new Simple_Action_Listener and Input_Listener with 
  82.         record 
  83.             handler : A_Input_Handler := null; 
  84.         end record; 
  85.     type A_Simple_Input_Listener is access all Simple_Input_Listener'Class; 
  86.  
  87.     function Create_Listener( handler : not null A_Input_Handler ) return A_Input_Listener; 
  88.     pragma Postcondition( Create_Listener'Result /= null ); 
  89.  
  90.     procedure Handle_Action( this   : access Simple_Input_Listener; 
  91.                              action : A_Input_Action ); 
  92.  
  93.     ---------------------------------------------------------------------------- 
  94.  
  95.     type Input_Box is new Widget with 
  96.         record 
  97.             text      : Unbounded_String; 
  98.             cursor    : Natural := 0; 
  99.             firstchar : Natural := 0;    -- first character to draw. this is 0 
  100.                                           -- unless the text is too long to fit 
  101.                                           -- in the content area of the widget. 
  102.             lastchar  : Natural := 0;    -- last character to draw. this is the 
  103.                                           -- length of text unless the text is 
  104.                                           -- too long to fit in the content area 
  105.                                           -- of the widget. 
  106.             constrain : A_Constrain_Func := null; 
  107.             maxlen    : Positive := 1024; 
  108.             key_delay : Key_Delay_Array; 
  109.         end record; 
  110.  
  111.     procedure Add_Character( this : not null access Input_Box'Class; 
  112.                              char : Character ); 
  113.  
  114.     procedure Adjust_Visible_Text( this : not null access Input_Box'Class ); 
  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.     procedure Dispatch_Action( this : access Input_Box; id : Action_Id ); 
  122.  
  123.     procedure Do_Backspace( this : not null access Input_Box'Class ); 
  124.  
  125.     procedure Do_Delete( this : not null access Input_Box'Class ); 
  126.  
  127.     procedure Do_Enter( this : not null access Input_Box'Class ); 
  128.  
  129.     procedure Draw_Content( this : access Input_Box; dc : Drawing_Context ); 
  130.  
  131.     function Handle_Key_Held( this : access Input_Box; 
  132.                               evt  : not null A_Key_Event ) return Boolean; 
  133.  
  134.     function Handle_Key_Press( this : access Input_Box; 
  135.                                evt  : not null A_Key_Event ) return Boolean; 
  136.  
  137.     function Handle_Key_Release( this : access Input_Box; 
  138.                                  evt  : not null A_Key_Event ) return Boolean; 
  139.  
  140.     procedure Handle_Mouse_Press( this : access Input_Box; 
  141.                                   evt  : not null A_Mouse_Button_Event ); 
  142.  
  143.     procedure Move_Cursor( this : not null access Input_Box'Class; dir : Move_Dir ); 
  144.  
  145.     procedure Pack( this : access Input_Box ); 
  146.  
  147. end Widgets.Input_Boxes;