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