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 | with Ada.Containers.Doubly_Linked_Lists;
-- with Ada.Text_IO; use Ada.Text_IO;
package body Partial_Order_Sorting.Array_Sort is
package Index_Lists is
new Ada.Containers.Doubly_Linked_Lists (Element_Type => Index_Type);
type Node_Descriptor is
record
N_Parents : Natural;
Children : Index_Lists.List;
end record;
type Precedence_Graph is array (Index_Type range <>) of Node_Descriptor;
function Make_Graph (From : Container_Type) return Precedence_Graph
is
Result : Precedence_Graph (From'Range) :=
(others => Node_Descriptor'(N_Parents => 0,
Children => Index_Lists.Empty_List));
procedure Make_Edge (Parent, Child : Index_Type) is
begin
Result (Parent).Children.Append (Child);
Result (Child).N_Parents := Result (Child).N_Parents + 1;
end Make_Edge;
begin
for I in From'First .. From'Last - 1 loop
for J in I + 1 .. From'Last loop
if From (I) < From (J) then
Make_Edge (Parent => J, Child => I);
elsif From (J) < From (I) then
Make_Edge (Parent => I, Child => J);
end if;
end loop;
end loop;
return Result;
end Make_Graph;
function Heads_Of (Graph : Precedence_Graph) return Index_Lists.List
is
Result : Index_Lists.List;
begin
for I in Graph'Range loop
if Graph (I).N_Parents = 0 then
Result.Append (I);
end if;
end loop;
return Result;
end Heads_Of;
function Sort (Item : Container_Type) return Container_Type
is
Graph : Precedence_Graph := Make_Graph (Item);
Heads : Index_Lists.List := Heads_Of (Graph);
Result : Container_Type (Item'Range);
Cursor : Index_Type := Result'First;
------------
-- Append --
------------
procedure Append (Item : Element_Type) is
begin
Result (Cursor) := Item;
Cursor := Cursor + 1;
end Append;
begin
while not Heads.Is_Empty loop
declare
Current_Head : constant Index_Type := Heads.First_Element;
begin
Heads.Delete_First;
Append (Item (Current_Head));
for Child of Graph (Current_Head).Children loop
Graph (Child).N_Parents := Graph (Child).N_Parents - 1;
if Graph (Child).N_Parents = 0 then
pragma Assert (Cursor <= Result'Last);
Heads.Append (Child);
end if;
end loop;
end;
end loop;
-- for X of Result loop
-- Put_Line (Image (X));
-- end loop;
--
-- for I in Result'Range loop
-- for J in Result'Range loop
-- Put_Line (I'Image
-- & J'Image
-- & Image(Result (I))
-- & Image(Result (J))
-- & Boolean'Image (Result (I) < Result (J))
-- & " "
-- & Boolean'Image(if Result (I) < Result (J) then I < J));
-- end loop;
-- end loop;
pragma Assert (Cursor = Result'Last + 1);
return Result;
end Sort;
procedure Sort (Item : in out Container_Type)
is
begin
Item := Sort (Item);
end Sort;
end Partial_Order_Sorting.Array_Sort;
|