1. -- 
  2. -- Uwe R. Zimmer, Australia, 2013 
  3. -- 
  4.  
  5. -- Simple example for an atomic action. 
  6. -- 
  7. -- Three flight control surfaces are to be moved in synchrony 
  8. -- and under real-time constraints. 
  9. -- 
  10. -- In case of an overall failure, all surfaces move automatically to their 
  11. -- failsafe positions. 
  12. -- 
  13.  
  14. with Ada.Real_Time;               use Ada.Real_Time; 
  15. with Ada.Text_IO;                 use Ada.Text_IO; 
  16. with Ada.Float_Text_IO;           use Ada.Float_Text_IO; 
  17. with Exceptions;                  use Exceptions; 
  18. with Generic_Atomic_Action; 
  19. with Generic_Atomic_Action_Types; 
  20.  
  21. procedure Atomic_Action is 
  22.  
  23.    type Flight_Surfaces is (Elevator, Rudder, Ailerons); 
  24.  
  25.    package Atomic_Action_Types is new Generic_Atomic_Action_Types (Flight_Surfaces); 
  26.    use Atomic_Action_Types; 
  27.  
  28.    subtype Degrees    is Float   range -180.0 .. +180.0; 
  29.    subtype Deflection is Degrees range  -45.0 ..  +45.0; 
  30.  
  31.    type Deflection_Set is array (Flight_Surfaces) of Deflection; 
  32.  
  33.    protected Target_Deflections is 
  34.  
  35.       procedure Write (Set : Deflection_Set); 
  36.       function Read_Surface (Surface : Flight_Surfaces) return Deflection; 
  37.  
  38.    private 
  39.       Current_Set : Deflection_Set; 
  40.    end Target_Deflections; 
  41.  
  42.    protected body Target_Deflections is 
  43.  
  44.       procedure Write (Set : Deflection_Set) is 
  45.  
  46.       begin 
  47.          Current_Set := Set; 
  48.       end Write; 
  49.  
  50.       function Read_Surface (Surface : Flight_Surfaces) return Deflection is 
  51.          (Current_Set (Surface)); 
  52.  
  53.    end Target_Deflections; 
  54.  
  55.    ------------------------ 
  56.    --  Actions Parts 
  57.    ------------------------ 
  58.  
  59.    procedure Elevator_Action is 
  60.  
  61.       Target : constant Deflection :=  Target_Deflections.Read_Surface (Elevator); 
  62.  
  63.    begin 
  64.       Put ("Elevator starts moving to: "); 
  65.       Put (Item => Target, Fore => 1, Aft  => 2, Exp  => 0); 
  66.       Put (" degrees"); New_Line; 
  67. --        raise Constraint_Error; 
  68.       delay 1.0; 
  69. --        delay 3.0; 
  70. --        raise Constraint_Error; 
  71.       Put_Line ("Elevator arrived"); 
  72.    end Elevator_Action; 
  73.  
  74.    procedure Rudder_Action is 
  75.  
  76.       Target : constant Deflection :=  Target_Deflections.Read_Surface (Rudder); 
  77.  
  78.    begin 
  79.       Put ("Rudder starts moving to: "); 
  80.       Put (Item => Target, Fore => 1, Aft  => 2, Exp  => 0); 
  81.       Put (" degrees"); New_Line; 
  82. --        raise Constraint_Error; 
  83.       delay 2.0; 
  84. --        delay 4.0; 
  85. --        raise Constraint_Error; 
  86.       Put_Line ("Rudder arrived"); 
  87.    end Rudder_Action; 
  88.  
  89.    procedure Ailerons_Action is 
  90.  
  91.       Target : constant Deflection :=  Target_Deflections.Read_Surface (Ailerons); 
  92.  
  93.    begin 
  94.       Put ("Ailerons starts moving to: "); 
  95.       Put (Item => Target, Fore => 1, Aft  => 2, Exp  => 0); 
  96.       Put (" degrees"); New_Line; 
  97. --        raise Constraint_Error; 
  98.       delay 3.0; 
  99. --        delay 5.0; 
  100. --        raise Constraint_Error; 
  101.       Put_Line ("Ailerons arrived"); 
  102.    end Ailerons_Action; 
  103.  
  104.    ------------------------ 
  105.    --  Cleanup Parts 
  106.    ------------------------ 
  107.  
  108.    procedure Elevator_Failsafe is 
  109.  
  110.    begin 
  111.       Put_Line ("Elevator moving to failsafe positions"); 
  112.    end Elevator_Failsafe; 
  113.  
  114.    procedure Rudder_Failsafe is 
  115.  
  116.    begin 
  117.       Put_Line ("Rudder moving to failsafe positions"); 
  118.    end Rudder_Failsafe; 
  119.  
  120.    procedure Ailerons_Failsafe is 
  121.  
  122.    begin 
  123.       Put_Line ("Ailerons moving to failsafe positions"); 
  124.    end Ailerons_Failsafe; 
  125.  
  126.    -------------------------------------------------------- 
  127.    --  Building whole atomic action 
  128.    -- 
  129.    -- Experiment with these settings 
  130.    -- to see what happens under different circumstances. 
  131.    -- 
  132.    -------------------------------------------------------- 
  133.  
  134.    Actions : constant Action_Parts := 
  135.      (Elevator => 
  136.         (Action  => Elevator_Action'Access, 
  137.          Cleanup => Elevator_Failsafe'Access, 
  138.          Scope   => (Start_Delay_Min => Milliseconds (11), 
  139.                      Start_Delay_Max => Milliseconds (20), 
  140.                      Max_Elapse      => Milliseconds (2000), 
  141.                      Deadline        => Time_Last) 
  142.            ), 
  143.       Rudder => 
  144.         (Action  => Rudder_Action'Access, 
  145.          Cleanup => Rudder_Failsafe'Access, 
  146.          Scope   => (Start_Delay_Min => Milliseconds (13), 
  147.                      Start_Delay_Max => Milliseconds (20), 
  148.                      Max_Elapse      => Milliseconds (3000), 
  149.                      Deadline        => Time_Last) 
  150.         ), 
  151.       Ailerons => 
  152.         (Action  => Ailerons_Action'Access, 
  153.          Cleanup => Ailerons_Failsafe'Access, 
  154.          Scope   => (Start_Delay_Min => Milliseconds (12), 
  155.                      Start_Delay_Max => Milliseconds (20), 
  156.                      Max_Elapse      => Milliseconds (4000), 
  157.                      Deadline        => Time_Last) 
  158.         )); 
  159.  
  160.    package Atomic_Action_Package is new Generic_Atomic_Action (Atomic_Action_Types, Actions); 
  161.    use Atomic_Action_Package; 
  162.  
  163. begin 
  164.    Target_Deflections.Write (Set => (Elevator => 2.0, Rudder => -1.2, Ailerons => 0.3)); 
  165.  
  166.    Atomic_Action_Package.Perform; 
  167.  
  168.    Put_Line ("The surfaces moved in time and without error."); 
  169. exception 
  170.    when Exception_Id : others => Show_Exception (Exception_Id); 
  171. end Atomic_Action;