La rubrique a besoin de vous [Sources]

[khayyam90]

Vous avez des codes sources ADA ?
Vous pensez que ces codes sources peuvent aider d'autres personnes ?
Vous souhaitez partager vos codes avec des internautes ?

Dans ce cas, participez à l'enrichissement des pages de codes sources de developpez.com et postez à la suite

Pour chaque proposition, merci d'expliquer en quelques mots ce que fait le code, s'il nécessite des bibliothèques ou des options particulières. Si le code est trop volumineux, envoyez-moi un MP avec l'archive zippée.

[khayyam90]

par Seb_de_lille
permet de faire fonctionner un pool de 10 connexions en utilisant les sockets avec GNAT

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
with GNAT.Sockets; use GNAT.Sockets;
with Text_Io; use Text_Io;

procedure Network is
   Liste : array(1..10) of Socket_Type;
   Bliste : array(1..10) of Boolean;
   Reads,Write : Socket_Set_Type;

   Selector : Selector_Type;
   Srv_Adr,Adr : Sock_Addr_Type;
   Srv_Socket : Socket_Type;
   Status : Selector_Status;
   package Intio is new Text_Io.Integer_Io(Integer);
   Ptr : Integer := 0;
   C : Character;
begin

   -- Initialisation de GNAT.Sockets
   Initialize;

   -- Creation de la socket serveur
   Srv_Adr.Addr := Any_Inet_Addr;
   Srv_Adr.Port := 3128;
   Create_Socket(Srv_Socket);
   Bind_Socket(Srv_Socket,Srv_Adr);
   Listen_Socket(Srv_Socket);

   -- Creation
   Create_Selector(Selector);
   Set(Write,Srv_Socket);

   for I in 1..10 loop
      Bliste(I) := False;
   end loop;

   loop
      --Creation  des sets
      Empty(Reads);
      Set(Reads,Srv_Socket);
      for I in 1..10 loop
         if Bliste(I) then
            Set(Reads,Liste(I));
         end if;
      end loop;

      Check_Selector(Selector,Reads,Write,Status);

      case Status is
         when Completed =>

            if Is_Set(Reads,Srv_Socket) then
               Ptr := Ptr + 1;
               Put_Line("Connexion : "&Integer'Image(Ptr));
               Accept_Socket(Srv_Socket,Liste(Ptr),Adr);
               Bliste(Ptr) := True;
            else
               for I in 1..10 loop
                  if Bliste(I) then
                     if Is_Set(Reads,Liste(I)) then
                        Character'Read(Stream(Liste(I)),C);
                        Put_line("socket "&Integer'Image(I)&Character'Image(C));
                     end if;
                  end if;
               end loop;
            end if;

         when Expired =>
            Put_Line("expired");

         when Aborted =>
            Put_Line("aborted");

      end case;

   end loop;

   -- Destruction du selector
   Close_Selector(Selector);
   -- Finalisation pour le package GNAT.Sockets
   Finalize;

exception
   when SOCKET_ERROR =>
      Put_Line("SOCKET_ERROR");
end Network;

[jovalise]

Envoyé par khayyam90

par Seb_de_lille
permet de faire fonctionner un pool de 10 connexions en utilisant les sockets avec GNAT

Moi j'aurais dis "en utilisant les selectors" me semble t'il, non ?

[jovalise]

Bonjour,
Un paquetage de génération de mot de passe ... amusant à faire en tout cas !

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119

----------------------------------------------------------------------
--                                                                  --
-- Petit paquetage générant un mot de passe                       --
-- Le type 'T_Passwd' est un sous type de 'String' de N caracteres. --
--                                                                  --
----------------------------------------------------------------------

with Ada.Numerics.Discrete_Random;

package body Passwd_Gen_Random is



   subtype Maj is Character range 'A'.. 'Z';
   subtype min is Character range 'a'.. 'z';
   subtype num is Character range '0'.. '9';


   subtype Methode is Integer range 1..3;


   subtype Index is Positive range 1..T_Passwd'Last;

   package Maj_Random is new Ada.Numerics.Discrete_Random(Maj);
   package min_Random is new Ada.Numerics.Discrete_Random(min);
   package Num_Random is new Ada.Numerics.Discrete_Random(num);
   package methode_Random is new Ada.Numerics.Discrete_Random(methode);
   package index_Random is new Ada.Numerics.Discrete_Random(index);

    Tab_Index : array(Index) of Index;


   Maj_Gen : Maj_Random.Generator;
   min_Gen : min_Random.Generator;
   num_Gen : num_Random.Generator;
   Methode_Gen : Methode_Random.Generator;
   index_Gen : index_Random.Generator;



   -------------------------------------------
   --     Generer_Passwd return T_Passwd    --
   -------------------------------------------
   --                                       --
   function Generer_Passwd return T_passwd is
      Passwd : T_passwd := "No passwd0";
      M : Methode;

      Tampon_Index : Index;
      Source_Index : Index;
      Destination_index : Index;

      Index_Passwd : Index;
   begin

      ----------------------------------------------------------------------
      -- D'abord, j'initialise le tableau d'index aleatoire               --
      --                                                                  --
      for I in 1..Tab_Index'Length loop

         Tab_Index(I) := I;

      end loop;

      --                                                                  --
      ----------------------------------------------------------------------

      ----------------------------------------------------------------------
      -- Puis, je prepare mon tableau de tirage aleatoire sans remise.    --
      --                                                                  --

      for I in 1..Index'last/2 loop
         index_Random.Reset(index_Gen);
         Source_Index := Index_Random.Random(Index_Gen);
         index_Random.Reset(index_Gen);
         Destination_Index := index_Random.random(index_Gen);
         Tampon_Index := Tab_Index(Destination_index);
         Tab_Index(Destination_Index) := Tab_Index(Source_Index);
         Tab_Index(Source_Index) := Tampon_Index;

      end loop;

      --                                                                  --
      ----------------------------------------------------------------------

      ----------------------------------------------------------------------
      -- Ensuite je remplis N fois, aleatoirement parmis 3 methodes,     --
      -- l'element de position aleatoire tire dans le tableau.            --

      Maj_random.reset(Maj_Gen);
      Min_random.reset(Min_Gen);
      Num_random.reset(Num_Gen);
      Methode_random.reset(Methode_Gen);
      for I in 1..T_Passwd'last loop
         Index_Passwd := Tab_Index(I);

         M := Methode_Random.Random(Methode_Gen);
         case M is
            when 1 =>
               Passwd(Index_passwd) := Maj_Random.Random(Maj_Gen);
            when 2 =>
               Passwd(Index_passwd) := min_Random.Random(min_Gen);
            when 3 =>
               Passwd(Index_passwd) := num_Random.Random(num_Gen);
         end case;
      end loop;

      return Passwd;

   end Generer_Passwd;

   --                                                                  --
   ----------------------------------------------------------------------



end Passwd_Gen_Random;

Merci à Seb_de_lille sans qui je ne serais pas parvenue à bout de mon serveur.

[PRomu@ld]

Pile générique (Last In First Out). La seule restriction, est que le type de données ne soit pas de type limited (ie on doit pouvoir utiliser :=)

stack.ads

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
-- Generic stack
-- author : Romuald Perrot.

generic

   -- Data must not be limited type
   type T_Data is private;

package Stack is

   type T_Stack is private;

   -- Init stack
   procedure Stack_Init( S : out T_Stack );

   -- Destroy stack (ie : free all elements)
   procedure Stack_Destroy( S : in out T_Stack );

   --Copie d'une pile dans une autre.
   procedure Stack_Copy( S : in out T_Stack ;
                         I : in T_Stack );

   -- Push element on stack
   procedure Stack_Push( S : in out T_Stack ; I : in T_Data );

   -- Get top stack element
   function Stack_Top( S : in T_Stack ) return T_Data ;

   -- Pop top stack and destroy it
   procedure Stack_Pop( S : in out T_Stack ; D : out T_Data );

   -- Tell if stack is empty
   function Stack_Empty( S : in T_Stack ) return Boolean;

   -- exception when popping or asking top of empty stack
   Stack_Underflow : exception;

   -- exception when no memory left
   Stack_Overflow : exception ;

private

   type T_Node;
   type T_Stack is access T_Node ;

   -- stack node type
   type T_Node is
      record
         next : T_Stack;
         Data : T_Data ;
      end record;

end Stack;

stack.adb

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
with Unchecked_Deallocation;

package body Stack is

   procedure Stack_Init( S : out T_Stack ) is
   begin
      -- Create empty stack
      S := null;
   end;

   procedure Stack_Destroy( S : in out T_Stack ) is
      procedure Free is new Unchecked_Deallocation( T_Node , T_Stack );

      Cur : T_Stack := S;
      Next : T_Stack;
   begin
      -- loop on every element, destroy it and go to the next
      loop
         exit when Cur = null;
         Next := Cur.Next ;
         Free( Cur );
         Cur := Next ;
      end loop;
   end;

   procedure Stack_Copy( S : in out T_Stack ;
                         I : in T_Stack ) is

      function Copy_Aux( S : in T_Stack ) return T_Stack is
         Res : T_Stack;
      begin
         if S = null then
            return null;
         else
            Res := new T_Node'( Next => Copy_Aux( S.Next ) ,
                                Data => S.Data );
            return Res ;
         end if;
      end;


   begin
      if S /= null then
         Stack_Destroy( S );
      end if;
      S := Copy_Aux( I );
   end;


   procedure Stack_Push( S : in out T_Stack ; I : in T_Data ) is
      Tmp : T_Stack ;
   begin

      if S = null then
         -- Special case when stack is empty
         S := new T_Node'( Next => null , Data => I );
      else
         -- General case
         Tmp := new T_Node'( Next => S , Data => I );
         S := Tmp ;
      end if;

      -- when no memory left
   exception
      when others =>
         raise Stack_Overflow ;
   end;

   function Stack_Top( S : in T_Stack ) return T_Data is
   begin

      if S = null then
         raise Stack_Underflow ;
      end if;

      -- Get top element of stack
      return S.Data ;
   end;

   procedure Stack_Pop( S : in out T_Stack ; D : out T_Data ) is
      procedure Free is new Unchecked_Deallocation( T_Node , T_Stack );
      Tmp : T_Stack;

   begin

      if S = null then
         raise Stack_Underflow ;
      end if;

      -- Get top element
      D := S.Data ;

      -- Get next node
      Tmp := S.Next ;

      -- free this node
      Free( S );

      -- set current node to the next one.
      S := Tmp;

   end;


   function Stack_Empty( S : in T_Stack ) return Boolean is
   begin
      return S = null;
   end ;

end Stack;

Un exemple de main :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
with Ada.Integer_Text_Io;
use Ada.Integer_Text_Io;

with Ada.Text_Io;
use Ada.Text_Io;

with Stack;

procedure Main is

   package Stack_Int is new Stack( Integer );
   use Stack_Int ;

   S : T_Stack ;

   tmp : Integer ;
begin

   Stack_Init( S );
   Stack_Push( S , 10 );
   Stack_Push( S , 20 );
   Stack_Push( S , 30 );
   Stack_Push( S , 40 );


   while not Stack_Empty( S ) loop

      Stack_Pop( S , Tmp );
      Put( Tmp );
      New_Line;

   end loop;

   Stack_Destroy( S );

end;

[PRomu@ld]

Une file générique (First In First Out). Même restriction que pour le post précédent.

queue.ads

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
-- Generic Queue
-- author : Romuald Perrot.

generic

   -- data must not be limited type
   type T_Data is private;

package Queue is

   type T_Queue is private;

   -- Init queue
   procedure Queue_Init( Q : in out T_Queue );

   -- Destroy queue (ie: free all elements)
   procedure Queue_Destroy( Q : in out T_Queue );

   -- Push element on queue.
   procedure Queue_Push( Q : in out T_Queue ; I : in T_Data );

   -- Pop first in element and delete it
   procedure Queue_Pop( Q : in out T_Queue ; I : out T_Data );

   -- Get first element
   function Queue_Front( Q : in T_Queue ) return T_Data ;

   -- Tell if queue is empty
   function Queue_Empty( Q : in T_Queue ) return Boolean;


   -- exception when popping or asking front of empty queue
   Queue_Overflow : exception ;

   -- exception when no memory left
   Queue_Underflow : exception ;

private

   type T_Node;
   type Ptr_Node is access T_Node;

   -- Queue is a simple linked list.
   type T_Node is
     record
        Data : T_Data ;
        Next : Ptr_Node ;
     end record;

   -- Queue only record first and last element
   type T_Queue is record
      Front : Ptr_Node ;
      Rear  : Ptr_Node ;
   end record;

end Queue;

queue.adb

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
with Unchecked_Deallocation;

package body Queue is

   procedure Queue_Init( Q : in out T_Queue ) is
   begin
      Q.Front := null;
      Q.Rear := null;
   end;


   procedure Queue_Push( Q : in out T_Queue ; I : in T_Data ) is
      Tmp : Ptr_Node ;
   begin
      Tmp := new T_Node'( I , null );

      if Q.Front = null then
         Q.Front := Tmp;
         Q.Rear := Tmp;
      else
         Q.Rear.Next := Tmp;
         Q.Rear := Tmp;
      end if;

   exception
      when others =>
         raise Queue_Overflow;

   end;

   procedure Queue_Pop( Q : in out T_Queue ; I : out T_Data ) is
      procedure Free is new Unchecked_Deallocation( T_Node , Ptr_Node );
      Tmp : Ptr_Node;
   begin
      if Q.Front = null then
         raise Queue_Underflow;
      elsif Q.Front = Q.Rear then
         I := Q.Front.Data ;
         Free( Q.Front );
         Q.Front := null;
         Q.Rear := null;
      else
         I := Q.Front.Data ;
         Tmp := Q.Front ;
         Q.Front := Q.Front.Next ;
         Free( Tmp );
      end if;
   end;

   function Queue_Front( Q : in T_Queue ) return T_Data is
   begin
      if Q.Front = null then
         raise Queue_Underflow;
      end if;
      return Q.Front.Data ;
   end;

   function Queue_Empty( Q : in T_Queue ) return Boolean is
   begin
      return Q.Front = null;
   end;

   procedure Queue_Destroy( Q : in out T_Queue ) is
      procedure Free is new Unchecked_Deallocation( T_Node , Ptr_Node );
      Tmp : Ptr_Node := Q.Front ;
   begin

      loop
         exit when Q.Front = null;

         Tmp := Q.Front ;
         Q.Front := Q.Front.Next;
         Free( Tmp );

      end loop;

      Q.Front := null ;
      Q.Rear := null;

   end;

end Queue;

un exemple de main :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
with Ada.Integer_Text_Io;
use Ada.Integer_Text_Io;

with Ada.Text_Io;
use Ada.Text_Io;

with Queue ;

procedure Main is

   package Queue_Int is new Queue( Integer );
   use Queue_Int ;

   Q : T_Queue ;
   tmp : Integer ;
begin

   Queue_Init( Q );
   Queue_Push( Q , 10 );
   Queue_Push( Q , 20 );
   Queue_Push( Q , 30 );
   Queue_Push( Q , 40 );

   while not Queue_Empty( Q ) loop
      Queue_Pop( Q , Tmp );
      Put( Tmp );
      New_Line ;
   end loop;

   Queue_Destroy( Q );

end;

[PRomu@ld]

Quelques exemples de tri sur les tableaux.

Au sommaire :

-> Tri par insertion
-> Tri par selection
-> Tri à bulle
-> Tri fusion
-> Tri rapide

Le tout sous forme générique. Il n'y a pas de commentaire mais le code ne pose pas de problème.

util_array.ads :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
-- package util_array
-- author Romuald Perrot
-- desc : five ways of array sorting 

generic

   type T_Data is private;
   with procedure Put( D : in T_Data ) is <>;
   with function Random return T_Data ;
   with function ">"(X,Y : in T_Data ) return Boolean is <> ;
   with function "<"(X,Y : in T_Data ) return Boolean is <> ;

package Util_Array is

   type T_Array is array( Integer range <> ) of T_Data ;

   procedure Put( A : in T_Array );

   procedure Build_Random_Array( A : out T_Array );

   procedure Insertion_Sort( X : in out T_Array );

   procedure Selection_Sort( X : in out T_Array );

   procedure Fusion_Sort( X : in out T_Array );

   procedure Bubble_Sort( X : in out T_Array );

   procedure Quick_Sort( X : in out T_Array );


end Util_Array;

util_array.adb :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
with Ada.Text_Io ;
use Ada.Text_Io ;

package body util_array is

   procedure Put( A : in T_Array ) is
   begin
      for I in A'Range loop
         Put( A(I) );
         Put( ' ' );
      end loop;
   end;

   procedure Build_Random_Array( A : out T_Array ) is
   begin
      for I in A'Range loop
         A(I) := Random ;
      end loop;
   end;

   procedure Insertion_Sort( X : in out T_Array ) is
      I   : Integer ;
      Key : T_Data ;
   begin
      for J in (X'First + 1)..X'Last loop
         Key := X(J);
         I := J - 1 ;

         while I > (X'First - 1 ) and then X(I) > Key loop
            X(I+1) := X(I);
            I := I - 1 ;
         end loop;

         X(I+1) := Key ;
      end loop;
   end;


   procedure Fusion_Sort( X : in out T_Array ) is

      procedure Fusion( Res : in out T_Array ;
                        X1 : in T_Array ;
                        X2 : in T_Array ) is
         I : Integer := X1'First ;
         J : Integer := X2'First ;
         K : Integer := Res'First ;
      begin

         loop
            exit when I > X1'Last ;
            exit when J > X2'Last ;

            if X1(I) > X2(J) then
               Res(K) := X2(J);
               j := J + 1 ;
               K := K + 1 ;
            else
               Res(K) := X1(I) ;
               I := I + 1 ;
               K := K + 1 ;
            end if ;

         end loop;

         loop
            exit when I > X1'Last ;
            Res(K) := X1(I);
            I := I + 1 ;
            K := K + 1 ;
         end loop;

         loop
            exit when J > X2'Last ;
            Res(K) := X2(J) ;
            J := J + 1 ;
            K := K + 1 ;
         end loop;

      end Fusion ;

   begin

      if X'Length < 2 then
         return;
      else
         declare
            K : constant Integer := (X'Last + X'First) / 2 ;
            X1 : T_Array( X'First..K ) := X( X'First..K );
            X2 : T_Array( (K+1)..X'Last ) := X( (K+1)..X'Last );
         begin
            Fusion_Sort( X1 );
            Fusion_Sort( X2 );
            Fusion( X , X1 , X2 );
         end;
      end if;

   end;

   procedure Bubble_Sort( X : in out T_Array ) is
   begin

      for I in X'First..X'Last loop
         for J in reverse (I+1)..X'Last loop
            if X(J) < X(J-1) then
               declare
                  Tmp : constant T_Data := X(J) ;
               begin
                  X(J) := X(J-1) ;
                  X(J-1) := Tmp ;
               end;
            end if;
         end loop;
      end loop;
   end;

   procedure Selection_Sort( X : in out T_Array ) is
      Min_Id : Integer ;
      Tmp : T_Data ;
   begin

      for I in X'First..(X'Last-1) loop
         Min_Id := I ;
         for J in (I + 1)..X'Last loop
            if X(J) < X(Min_Id) then
               Min_Id := J ;
            end if;
         end loop;

         Tmp       := X(I) ;
         X(I)      := X(Min_Id);
         X(Min_Id) := Tmp ;
      end loop;
   end;

   procedure Quick_Sort( X : in out T_Array ) is


      procedure Partition( X : in out T_Array ;
                           P : in Integer ;
                           R : in Integer ;
                           Res : out Integer ) is
         Piv : constant T_Data := X(R) ;
         Tmp : T_Data ;
      begin
         Res := P - 1 ;

         for J in P..(R-1) loop
            if X(J) < Piv then
               Res := Res + 1 ;
               Tmp := X(J) ;
               X(J) := X(Res);
               X(Res) := Tmp ;
            end if;
         end loop;

         Res := Res + 1 ;
         Tmp := X(Res) ;
         X(Res) := X(R);
         X(R) := Tmp ;

      end;

      Piv : Integer ;
   begin
      if X'Length > 1 then
         Partition( X , X'First , X'Last , Piv );
         Quick_Sort( X(X'First..Piv-1) );
         Quick_Sort( X(Piv + 1..X'Last) );
      end if;
   end;


end Util_Array;

un exemple de main :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
with Ada.Text_Io , Ada.Float_Text_Io ;
use Ada.Text_Io , Ada.Float_Text_Io ;

with Util_Array ;

with Ada.Numerics.Float_Random ;
use Ada.Numerics.Float_Random ;

procedure Main is

   procedure Affiche_Float( X : in Float ) is
   begin
      Put( X , 0 , 5 , 0 );
   end ;

   G : Generator;

   function Generateur return Float is
   begin
      return Random( G );
   end;

   package Util_Float_Array is new Util_Array( Float , Affiche_Float , Generateur );
   use Util_Float_Array ;

   X : T_Array( 1..100 );


begin

   Build_Random_Array( X );
   Put( "before : ");
   Put( X );
   New_Line ;
   Quick_Sort( X );
   Put( "after sort : " );
   Put( X );

end Main;

[azalsup]

C'est un exemple de parser XML : Je ne parse pas un fichier XML à l'aide d'un parser récupéré ... je réinvente la roue caré quoi

J'avait codé ce parser (DOM comme je l'immagine dans ma tete) pour m'entrainer à parser des fichiers text en ADA.

C'est un tres bon exemple pour débutant qui souhaite apprendre à lire et récupérer du contenu à partir d'un fichier text.

Accesoirement si vous voulez savoir comment se parsent les fichiers .xml c'est plus rapide de lire mon code que de se farcire l'API DOM ou SAX par exemple XD


http://azalsup.free.fr/Sources/ADA/XML_Parser.zip


Si vous quelqu'un a besoin d'un exemple de code en particulier ou d'un package qui machin truc bidule je pourais peut etre aider à enrichir la séction tutoriels ADA.


Bonne chance à tous

[PRomu@ld]

Tu n'étais pas obligé de mettre l'exécutable (les sources suffisent). A l'occasion j'y jetterai un oeil, il y a sûrement des choses à récupérer.

[azalsup]

effectivement, mais bon j'avais juste zipé mon répertoire sans trop penser à faire le ménage avant.

D'ailler les binaires sont compilés sous cygwin.

[PRomu@ld]

Il vaut mieux mettre uniquement les sources, tout le monde n'est pas sous windows (moi le premier )

[PRomu@ld]

Une implémentation possible de file à priorité sous forme de tas binomial. Les priorités minimales et maximales sont générés.

pqueue.ads

Code ada :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
-- package pqueue
-- author Romuald Perrot
-- desc : priority queue using binomial heap

generic

   type T_Data is private ;
   type T_Priority is private ;
   with function "<"( X1 , X2 : in T_Priority ) return Boolean ;

package Pqueue is

   type T_Priority_Queue is limited private ;
   type T_Priority_Mode is( Min_Priority , Max_Priority );

   procedure Init( Q : out T_Priority_Queue ; Mode : in T_Priority_Mode );
   procedure Destroy( Q : in out T_Priority_Queue );
   procedure Copy( Q : out T_Priority_Queue ; Src : in T_Priority_Queue );
   procedure Add( Q : in out T_Priority_Queue ; X : in T_Data ; K : in T_Priority );
   procedure Extract( Q : in out T_Priority_Queue ; X : out T_Data ; K : out T_Priority );
   procedure Top( Q : in out T_Priority_Queue ; X : out T_Data ; K : out T_Priority );
   function Empty( Q : in T_Priority_Queue ) return Boolean ;

   Priority_Queue_Underflow : exception ;

private

   type T_Priority_Queue_Node ;
   type T_Priority_Queue_Node_Ptr is access T_Priority_Queue_Node ;

   type T_Priority_Queue_Node is
      record
         Prio : T_Priority ;
         Data : T_Data ;
         Degree  : Natural ;
         Father  : T_Priority_Queue_Node_Ptr ;
         Brother : T_Priority_Queue_Node_Ptr ;
         Child   : T_Priority_Queue_Node_Ptr ;
      end record ;

   type T_Priority_Queue is
      record
         First : T_Priority_Queue_Node_Ptr ;
         Mode  : T_Priority_Mode ;
      end record ;

   procedure Fusion_List( Res : out T_Priority_Queue_Node_Ptr ;
                          Q1 : in out T_Priority_Queue_Node_Ptr ;
                          Q2 : in out T_Priority_Queue_Node_Ptr );

   procedure Fusion_Min( Res : out T_Priority_Queue_Node_Ptr ;
                         Q1  : in out T_Priority_Queue_Node_Ptr ;
                         Q2  : in out T_Priority_Queue_Node_Ptr );

   procedure Fusion_Max( Res : out T_Priority_Queue_Node_Ptr ;
                         Q1  : in out T_Priority_Queue_Node_Ptr ;
                         Q2  : in out T_Priority_Queue_Node_Ptr );



end Pqueue ;

pqueue.adb

Code ada :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
with Unchecked_Deallocation ;

package body Pqueue is

   procedure Init( Q : out T_Priority_Queue ;
                   Mode : in T_Priority_Mode ) is
   begin
      Q.First := null ;
      Q.Mode := Mode ;
   end;

   procedure Destroy( Q : in out T_Priority_Queue ) is
      procedure Free is new Unchecked_Deallocation( T_Priority_Queue_Node , T_Priority_Queue_Node_Ptr );

      procedure Destroy( Q : in out T_Priority_Queue_Node_Ptr ) is
      begin
         if Q /= null then
            Destroy( Q.Brother );
            Destroy( Q.Child );
            Free( Q );
            Q := null ;
         end if;
      end ;

   begin
      Destroy( Q.First );
   end;

   procedure Copy( Q : out T_Priority_Queue ; Src : in T_Priority_Queue ) is
      procedure Copy( Node : out T_Priority_Queue_Node_ptr ;
                      Src : in T_Priority_Queue_Node_Ptr ;
                      Father : in T_Priority_Queue_Node_Ptr ) is
      begin
         if Src = null then
            Node := null ;
         else
            Node := new T_Priority_Queue_Node'( Prio => Src.Prio ,
                                                Data => Src.Data ,
                                                Degree => Src.Degree ,
                                                Father => Father ,
                                                Brother => null ,
                                                Child => null );
            Copy( Node.Brother , Src.Brother , Father );
            Copy( Node.Child , Src.Child , Node ) ;
         end if;
      end;
   begin
      Copy( Q.First , Src.First , null );
      Q.Mode := Src.Mode ;
   end;

   procedure Add( Q : in out T_Priority_Queue ; X : in T_Data ; K : in T_Priority ) is
      Node : T_Priority_Queue_Node_Ptr := null ;
      Tmp  : T_Priority_Queue_Node_Ptr := null ;
   begin

      Node := new T_Priority_Queue_Node'( Data => X ,
                                          Prio => K ,
                                          Degree => 0 ,
                                          Brother => null ,
                                          Child => null ,
                                          Father => null );
      if Q.Mode = Min_Priority then
         Fusion_Min( Tmp , Q.First , Node );
      else
         Fusion_Max( Tmp , Q.First , Node );
      end if;

      Q.First := Tmp ;

   end;

   procedure Extract( Q : in out T_Priority_Queue ; X : out T_Data ; K : out T_Priority ) is
      procedure Free is new Unchecked_Deallocation( T_Priority_Queue_Node , T_Priority_Queue_Node_Ptr );

      procedure Invert( New_Head  : out T_Priority_Queue_Node_Ptr ;
                        List      : in out T_Priority_Queue_Node_Ptr ;
                        Brother   : in T_Priority_Queue_Node_Ptr ) is
      begin
         if List = null then
            New_Head := null ;
         elsif List.Brother = null then
            New_Head := List ;
            List.Brother := Brother ;
            List.Father := null ;
         else
            Invert( New_Head , List.Brother , List );
            List.Brother := Brother ;
            List.Father := null ;
         end if;
      end;

      Cur : T_Priority_Queue_Node_Ptr := Q.First ;
      Good : T_Priority_Queue_Node_Ptr := Q.First ;
      Before : T_Priority_Queue_Node_Ptr := null ;
      Before_Good : T_Priority_Queue_Node_Ptr := null ;
      Tmp    : T_Priority_Queue_Node_Ptr ;
      Tmp2   : T_Priority_Queue_Node_Ptr ;
   begin
      -- Recupere le mini
      if Cur = null then
         raise Priority_Queue_Underflow ;
      else
         K := Cur.Prio ;
         Before := Cur ;
         Cur := Cur.Brother ;

         if Q.Mode = Min_Priority then
            loop
               exit when Cur = null ;
               if Cur.Prio < K then
                  K := Cur.Prio ;
                  Good := Cur ;
                  Before_Good := Before ;
               end if;
               Before := Cur ;
               Cur := Cur.Brother ;
            end loop;
         else
            loop
               exit when Cur = null ;
               if K < Cur.Prio then
                  K := Cur.Prio ;
                  Good := Cur ;
                  Before_Good := Before ;
               end if ;
               Before := Cur ;
               Cur := Cur.Brother ;
            end loop;
         end if;
         X := Good.Data ;
      end if;

      -- supprime good de la liste des racines
      if Before_Good = null then
         -- suppression en tete
         Q.First := Good.Brother ;
      else
         Before_Good.Brother := Good.Brother ;
      end if;

      -- inverse la liste des fils de good
      Invert( Tmp , Good.Child , null );

      if Q.Mode = Min_Priority then
         Fusion_Min( Tmp2 , Q.First , Tmp );
      else
         Fusion_Max( Tmp2 , Q.First , Tmp );
      end if;
      Q.First := Tmp2 ;

      Free( Good );

   end;


   procedure Top( Q : in out T_Priority_Queue ; X : out T_Data ; K : out T_Priority ) is
      Cur : T_Priority_Queue_Node_Ptr := Q.First ;
      Good : T_Priority_Queue_Node_Ptr := Q.First ;
   begin
      if Cur = null then
         raise Priority_Queue_Underflow ;
      else
         K := Cur.Prio ;
         Cur := Cur.Brother ;

         if Q.Mode = Min_Priority then
            loop
               exit when Cur = null ;
               if Cur.Prio < K then
                  K := Cur.Prio ;
                  Good := Cur ;
               end if;
               Cur := Cur.Brother ;
            end loop;
         else
            loop
               exit when Cur = null ;
               if K < Cur.Prio then
                  K := Cur.Prio ;
                  Good := Cur ;
               end if ;
               Cur := Cur.Brother ;
            end loop;
         end if;

         X := Good.Data ;

      end if;
   end;

   function Empty( Q : in T_Priority_Queue ) return Boolean is
   begin
      return Q.First = null ;
   end;

   procedure Fusion_List( Res : out T_Priority_Queue_Node_Ptr ;
                          Q1 : in out T_Priority_Queue_Node_Ptr ;
                          Q2 : in out T_Priority_Queue_Node_Ptr ) is
      Cur_Q1  : T_Priority_Queue_Node_Ptr := Q1 ;
      Cur_Q2  : T_Priority_Queue_Node_Ptr := Q2 ;
      Cur_Res : T_Priority_Queue_Node_Ptr := null ;
      Old     : T_Priority_Queue_Node_Ptr := null ;
   begin

      -- gere le premier echelon
      if Cur_Q1 /= null and then Cur_Q2 /= null then
         if Cur_Q1.Degree < Cur_Q2.Degree then
            Res := Cur_Q1 ;
            Cur_Res := Cur_Q1 ;
            Cur_Q1 := Cur_Q1.Brother ;
         else
            Res := Cur_Q2 ;
            Cur_Res := Cur_Q2 ;
            Cur_Q2 := Cur_Q2.Brother ;
         end if;
      elsif Cur_Q1 = null and then Cur_Q2 /= null then
         Res := Cur_Q2 ;
         Cur_Res := Cur_Q2 ;
         Cur_Q2 := Cur_Q2.Brother ;
      elsif Cur_Q2 = null and then Cur_Q1 /= null then
         Res := Cur_Q1 ;
         Cur_Res := Cur_Q1 ;
         Cur_Q1 := Cur_Q1.Brother ;
      else -- les deux vides
         Res := null ;
         return ;
      end if;

      -- Les deux listes non vides
      loop
         exit when Cur_Q1 = null ;
         exit when Cur_Q2 = null ;

         if Cur_Q1.Degree < Cur_Q2.Degree then
            Cur_Res.Brother := Cur_Q1 ;
            Cur_Q1          := Cur_Q1.Brother ;
            Cur_Res         := Cur_Res.Brother ;
         else
            Cur_Res.Brother := Cur_Q2 ;
            Cur_Q2          := Cur_Q2.Brother ;
            Cur_Res         := Cur_Res.Brother ;
         end if;
      end loop;

      if Cur_Q2 = null Then
         Cur_Res.Brother := Cur_Q1 ;
      else
         Cur_Res.Brother := Cur_Q2 ;
      end if;
   end;

   procedure Fusion_Min( Res : out T_Priority_Queue_Node_Ptr ;
                         Q1  : in out T_Priority_Queue_Node_Ptr ;
                         Q2  : in out T_Priority_Queue_Node_Ptr ) is
      -- link node under new_father
      procedure Link( Node : in out T_Priority_Queue_Node_Ptr  ;
                      New_Father : in out T_Priority_Queue_Node_Ptr ) is
      begin
         Node.Father := New_Father ;
         Node.Brother := New_Father.Child ;
         New_Father.Child := Node ;
         New_Father.Degree := New_Father.Degree + 1 ;
      end;

      Prev , Cur , Next : T_Priority_Queue_Node_Ptr ;

   begin
      Fusion_List( Res , Q1 , Q2 );

      if Res = null then
         return ;
      end if;

      Prev := null ;
      Cur  := Res ;
      Next := Cur.Brother ;

      loop
         exit when Next = null ;

         if Cur.Degree /= Next.Degree then
            -- Cas 1 : degree differents, on passe
            Prev := Cur ;
            Cur := Next ;
            Next := Cur.Brother ;
         elsif Next.Brother /= null and then
           Cur.Degree = Next.Degree and then
           Next.Degree = Next.Brother.Degree then
            -- Cas 2 : trois racines de mm degre
            Prev := Cur ;
            Cur := Next ;
            Next := Cur.Brother ;
         else
            -- Cas 3 : deux racines de mm degre
            if Cur.Prio < Next.Prio then
               -- On accroche next dessous cur
               Cur.Brother := Next.Brother ;
               Link( Next , Cur );
            else
               -- On accroche cur dessous next
               if Prev = null then
                  Res := Next ;
               else
                  Prev.Brother := Next ;
               end if;
               Link( Cur , Next );
               Cur := Next ;
            end if;
            Next := Cur.Brother ;
         end if;
      end loop;
   end ;

   procedure Fusion_Max( Res : out T_Priority_Queue_Node_Ptr ;
                         Q1  : in out T_Priority_Queue_Node_Ptr ;
                         Q2  : in out T_Priority_Queue_Node_Ptr ) is

      -- link node under new_father
      procedure Link( Node : in out T_Priority_Queue_Node_Ptr  ;
                      New_Father : in out T_Priority_Queue_Node_Ptr ) is
      begin
         Node.Father := New_Father ;
         Node.Brother := New_Father.Child ;
         New_Father.Child := Node ;
         New_Father.Degree := New_Father.Degree + 1 ;
      end;

      Prev , Cur , Next : T_Priority_Queue_Node_Ptr ;

   begin
      Fusion_List( Res , Q1 , Q2 );

      if Res = null then
         return ;
      end if;

      Prev := null ;
      Cur  := Res ;
      Next := Cur.Brother ;

      loop
         exit when Next = null ;

         if Cur.Degree /= Next.Degree then
            -- Cas 1 : degree differents, on passe
            Prev := Cur ;
            Cur := Next ;
            Next := Cur.Brother ;
         elsif Next.Brother /= null and then
           Cur.Degree = Next.Degree and then
           Next.Degree = Next.Brother.Degree then
            -- Cas 2 : trois racines de mm degre
            Prev := Cur ;
            Cur := Next ;
            Next := Cur.Brother ;
         else
            -- Cas 3 : deux racines de mm degre
            if Next.Prio < Cur.Prio then
               -- On accroche next dessous cur
               Cur.Brother := Next.Brother ;
               Link( Next , Cur );
            else
               -- On accroche cur dessous next
               if Prev = null then
                  Res := Next ;
               else
                  Prev.Brother := Next ;
               end if;
               Link( Cur , Next );
               Cur := Next ;
            end if;
            Next := Cur.Brother ;
         end if;
      end loop;
   end ;
end Pqueue ;

[PRomu@ld]

Un paquet relativement similaire à mon précedent post sur la gestion des tableaux :

array_algorithm.ads

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
generic

   type T_Data is (<>) ;

package Array_Algorithm is

   type Array_Of_Data is array( Integer range <> ) of T_Data ;

   -- Rempli le tableau avec la valeur X
   procedure Fill( T : out Array_Of_Data ; X : in T_Data ) ;

   -- Rempli le tableau aleatoirement avec des valeurs
   -- dans l'intervalle [min;max]
   procedure Random_Fill( T: out Array_Of_Data ;
                          Min : in T_Data ;
                          Max : in T_Data );

   -- Rempli le tableau aleatoirement avec des valeurs
   -- dans l'intevalle [min;max]
   -- de facon a ce que le tableau soit trie
   procedure Increasing_Random_Fill( T : out Array_Of_Data ;
                                     Min : in T_Data ;
                                     Max : in T_Data );

   -- Effectue une recherche sequentielle (ie : O( n ) )
   -- renvoie la position dans le tableau si l'element est trouve
   -- Integer'last si non trouve
   function Sequential_Search( T : in Array_Of_Data ; X : in T_Data ) return Integer ;

   -- Effectue une recherche dichotomique (ie : O( n ln n ) )
   -- renvoie la position dans le tableau si l'element est trouve
   -- Integer'last si non trouve
   function Dichotomic_Search( T : in Array_Of_Data ; X : in T_Data ) return Integer ;

   -- Indique si le tableau est trie
   function Is_Sorted( X : in Array_Of_Data ) return Boolean ;

   -- Tri par selection
   procedure Selection_Sort( X : in out Array_Of_Data );

   -- Tri par insertion
   procedure Insertion_Sort( X : in out Array_Of_Data );

   -- Tri a bulle
   procedure Bubble_Sort( X : in out Array_Of_Data );

   -- Tri fusion
   procedure Merge_Sort( X : in out Array_Of_Data );

   -- Tri rapide
   procedure Quick_Sort( X : in out Array_Of_Data );

   -- Affichage d'un tableau
   procedure Put( X : in Array_Of_Data );

end Array_Algorithm ;

array_algorithm.adb

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
with Ada.Text_Io;
use Ada.Text_Io;

with Ada.Numerics.Discrete_Random ;

package body Array_Algorithm is

   -- Rempli le tableau a une valeur bien precise
   procedure Fill( T : out Array_Of_Data ; X : in T_Data ) is
   begin
      for I in T'Range loop
         T(I) := X ;
      end loop;
   end;


   -- Rempli le tableau aleatoirement
   procedure Random_Fill( T: out Array_Of_Data ;
                          Min : in T_Data ;
                          Max : in T_Data ) is

      subtype Range_Data is T_Data range Min..Max ;
      package Random_Data is new Ada.Numerics.Discrete_Random( Range_Data ) ;
      use Random_Data ;
      G : Generator ;
   begin
      Reset( G );
      for I in T'Range loop
         T(I) := Random( G );
      end loop;
   end;


   -- Rempli le tableau aleatoirement tout en etant trie
   procedure Increasing_Random_Fill( T : out Array_Of_Data ;
                                     Min : in T_Data ;
                                     Max : in T_Data ) is

      function Random( Rmin , Rmax : in T_Data ) return T_Data is
         subtype Range_Data is T_Data range Rmin..Rmax ;
         package Random_Data is new Ada.Numerics.Discrete_Random( Range_Data ) ;
         use Random_Data ;
         G : Generator ;
      begin
         Reset( G );
         return Random( G ) ;
      end;

      Last : T_Data := Random( Min , Max );
   begin
      for I in T'Range loop
         T(I) := Random( Last , Max );
         Last := T(I) ;
      end loop ;
   end;


   -- Recherche sequentielle
   function Sequential_Search( T : in Array_Of_Data ; X : in T_Data ) return Integer is
   begin
      for I in T'Range loop
         if x = T(I) then
            return I ;
         end if;
      end loop;
      return Integer'Last ;
   end;


   -- Recherche dichotomique
   function Dichotomic_Search( T : in Array_Of_Data ; X : in T_Data ) return Integer is
      Left : Integer := T'First ;
      Right : Integer := T'Last ;
      Cur : Integer ;
   begin
      loop
         exit when Left > Right ;
         Cur := (Left + Right) / 2 ;

         if T(Cur) = X then
            return Cur ;
         elsif X > T(Cur) then
            Left := Cur + 1 ;
         else
            Right := Cur - 1 ;
         end if;
      end loop;

      return Integer'Last ;
   end;


   -- Indique si le tableau est trie
   function Is_Sorted( X : in Array_Of_Data ) return Boolean is
   begin
      for I in X'First..X'Last-1 loop
         if X(I) > X(I+1) then
            return False ;
         end if;
      end loop;

      return False ;
   end ;


   -- Tri par selection
   procedure Selection_Sort( X : in out Array_Of_Data ) is

      procedure Swap( X : in out Array_Of_Data ;
                      I : in Integer ;
                      J : in Integer ) is
         Tmp : constant T_Data := X(I) ;
      begin
         X(I) := X(J) ;
         X(J) := Tmp ;
      end;

      Pos : Integer ;
   begin
      for I in X'First..X'Last-1 loop

         Pos := I ;

         for K in I+1..X'Last loop
            if X(Pos) > X(K) then
               Pos := K ;
            end if;
         end loop;

         Swap( X , Pos , I );

      end loop;
   end;


   -- tri par insertion
   procedure Insertion_Sort( X : in out Array_Of_Data ) is

      procedure Put_Element( T : in out Array_Of_Data ;
                             Elt : in T_Data ;
                             Id_End : in Integer ) is
         I : Integer := Id_End ;
      begin
         loop
            exit when I < T'First ;
            exit when T(I) <= Elt ;
            T(I+1) := T(I) ;
            I := I - 1 ;
         end loop;
         X(I+1) := Elt ;
      end;

   begin
      for I in X'First+1..X'Last loop
         Put_Element( X , X(I) , I-1 );
      end loop;
   end;

   -- Tri a bulle
   procedure Bubble_Sort( X : in out Array_Of_Data ) is

      procedure Swap( X : in out Array_Of_Data ;
                      I : in Integer ;
                      J : in Integer ) is
         Tmp : constant T_Data := X(I) ;
      begin
         X(I) := X(J) ;
         X(J) := Tmp ;
      end;

   begin
      for I in reverse X'Range loop
         for J in X'First+1..I loop
            if X(J-1) > X(J) then
               Swap( X , J - 1 , J );
            end if;
         end loop;
      end loop;
   end;


   -- Tri fusion
   procedure Merge_Sort( X : in out Array_Of_Data ) is

      -- Fussionne les deux tableaux :
      -- T( first..middle ) et T( middle+1..last )
      procedure Merge( T : in out Array_Of_Data ;
                       Middle : in Integer ) is
         T1 : constant Array_Of_Data := T( T'First..Middle );
         T2 : constant Array_Of_Data := T( Middle+1 .. T'Last );

         Id : Integer := T'First ;
         Id1 : Integer := T1'First ;
         Id2 : Integer := T2'First ;
      begin

         loop
            exit when Id1 > T1'Last ;
            exit when Id2 > T2'Last ;

            if T1( Id1 ) < T2( Id2 ) then
               T( Id ) := T1( Id1 );
               Id := Id + 1 ;
               Id1 := Id1 + 1 ;
            else
               T( Id ) := T2( Id2 ) ;
               Id := Id+1 ;
               Id2 := Id2 + 1 ;
            end if ;

         end loop;

         loop
            exit when Id1 > T1'Last ;
            T( Id ) := T1( Id1 ) ;
            Id := Id + 1 ;
            Id1 := Id1 + 1 ;
         end loop;

         loop
            exit when Id2 > T2'Last ;
            T( Id ) := T2( Id2 );
            Id := Id + 1 ;
            Id2 := Id2 + 1 ;
         end loop;

      end;

      Middle : constant Integer := ( X'First + X'Last) / 2 ;
   begin

      if X'First < X'Last then
         Merge_Sort( X( X'First..Middle) );
         Merge_Sort( X( Middle+1..X'Last ) );
         Merge( X , Middle );
      end if;
   end;


   -- Tri rapide
   procedure Quick_Sort( X : in out Array_Of_Data ) is

      procedure Swap( X : in out Array_Of_Data ;
                      I : in Integer ;
                      J : in Integer ) is
         Tmp : constant T_Data := X(I) ;
      begin
         X(I) := X(J) ;
         X(J) := Tmp ;
      end;

      -- Partitionne avec comme pivot le premier element
      procedure Partition( T : in out Array_Of_Data ;
                           From : in Integer ;
                           To : in Integer ;
                           Middle : out Integer ) is
         Left_Id : Integer := From ;
         Right_Id : Integer := To ;
         Pivot : constant T_Data := T( From ) ;
      begin
         loop

            loop
               exit when T( Right_Id ) <= Pivot ;
               Right_Id := Right_Id - 1 ;
            end loop;

            loop
               exit when T(Left_Id) >= Pivot ;
               Left_Id := Left_Id + 1 ;
            end loop;

            if Left_Id < Right_Id then
               Swap( T , Left_Id , Right_Id );
               Left_Id := Left_Id + 1 ;
               Right_Id := Right_Id - 1 ;
            else
               Middle := Right_Id ;
               return ;
            end if;

         end loop;
      end;

      procedure Quick_Sort( T : in out Array_Of_Data ;
                            From : in Integer ;
                            To : in Integer ) is
         Middle : Integer ;
      begin
         if From >= To then
            return;
         else
            Partition( T , From , To , Middle );
            Quick_Sort( T , From , Middle );
            Quick_Sort( T , Middle + 1 , To );
         end if;
      end;

   begin
      Quick_Sort( X , X'First , X'Last );
   end;

   -- Affichage d'un tableau
   procedure Put( X : in Array_Of_Data ) is
   begin
      for I in X'Range loop
         Put( T_Data'Image( X(I) ) );
         Put( " " );
      end loop;
   end;

end Array_Algorithm ;

Un exemple de main :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
with Ada.Text_Io , Ada.Integer_Text_Io ;
use Ada.Text_Io , Ada.Integer_Text_Io ;

with Array_Algorithm ;

Procedure Main is

   package Int_Algo is new Array_Algorithm( T_Data => Integer );
   use Int_Algo ;

   T1 : Array_Of_Data( 1..10 );
   T2 : Array_Of_Data( 1..10 );
   T3 : Array_Of_Data( 1..10 );
   T4 : Array_Of_Data( 1..10 );
   T5 : Array_Of_Data( 1..10 );

   Pos : Integer ;
begin

   Random_Fill( T1 , 1 , 100 );
   Put( T1 );
   New_Line ;
   T2 := T1 ;
   T3 := T1 ;
   T4 := T1 ;
   T5 := T1 ;
   Selection_Sort( T1 );
   Put( T1 );
   New_Line ;
   Insertion_Sort( T2 );
   Put( T2 );
   New_Line ;
   Bubble_Sort( T3 );
   Put( T3 );
   New_Line ;
   Quick_Sort( T4 );
   Put( T4 );
   New_Line ;
   Merge_Sort( T5 ) ;
   Put( T5 ) ;
   New_Line ;

   for I in 1..100 loop
      Pos := Dichotomic_Search( T1 , I ) ;
      if Pos /= Integer'Last then
         Put( I );
         Put( " -> " );
         Put( Pos ) ;
         New_Line ;
      end if ;

   end loop;


end Main;

[Seb_de_lille]

Le code source suivant permet de créer un démon linux en Ada. Il nécessite la lib Florist pour fonctionner.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
with posix.Process_Primitives;use posix.Process_Primitives;
with posix.Process_Identification; use posix.Process_Identification;
with POSIX.Unsafe_Process_Primitives;use Posix.Unsafe_Process_Primitives;
with Posix.Permissions;use POSIX.Permissions;
with POSIX;use POSIX;
with Interfaces.C_Streams;use Interfaces.C_Streams;
with Text_Io;use Text_Io;
with Ada.Directories;use Ada.Directories;

procedure Demon is
    Pid : Posix.Process_Identification.Process_ID;
    Pgid : Process_Group_ID;
    F : Files;	
    Str : constant String := "/dev/null" & Ascii.Nul;
    Mode_Read : constant String := "r";
    Mode_Write : constant String := "w";

    procedure Start_Daemon is
    begin
        loop
            delay 10.0;
            Put_Line("coucou");
        end loop;

    end Start_Daemon;

begin
      Pid := Fork;

      if Integer'Value(Image(Pid)) = 0 then

          -- Equivalent d'un umask(0222)
          Set_Allowed_Process_Permissions(Group_Permission_Set);

          -- Equivalent d'un setsid()
          Create_Session(Pgid);
          if Integer'Value(Image(Pgid))< 0 then
              return;
          end if;

          -- On se place à la racine pour éviter les montages réseaux obsoletes
          Set_Directory("/");

          -- Redirection sur /dev/null pour éviter les traces dans la console
          F := Freopen(Str'Address,Mode_Read'Address,Stdin);
          F := Freopen(Str'Address,Mode_Write'Address,Stdout);
          F := Freopen(Str'Address,Mode_Write'Address,Stderr);

          -- Exécution du demon proprement dit
          Start_Daemon;
      elsif Integer'Value(Image(Pid)) < 0 then
          Put_Line("Impossible de démarrer le démon");
      else
          Put_Line(Image(Pid));
      end if;

end Demon;

Le corps du démon proprement dit devra utiliser la procedure Start_Daemon.