← Back to branch summary

~ubuntu-branches/debian/sid/adabrowse/sid

« back to all changes in this revision

Viewing changes to gal-support-list_sort.adb

  • Committer: Bazaar Package Importer
  • Author(s): Ludovic Brenta
  • Date: 2004-02-14 13:22:40 UTC
  • Revision ID: james.westby@ubuntu.com-20040214132240-cqumhiq1677pkvzo
Tags: upstream-4.0.2
Import upstream version 4.0.2

Show diffs side-by-side

added added

removed removed

Lines of Context:
gal-support-list_sort.adb
 
1
-------------------------------------------------------------------------------
 
2
--
 
3
-- <STRONG>Copyright (c) 2001, 2002 by Thomas Wolf.</STRONG>
 
4
-- <BLOCKQUOTE>
 
5
--    AdaBrowse is free software; you can redistribute it and/or modify it
 
6
--    under the terms of the  GNU General Public License as published by the
 
7
--    Free Software  Foundation; either version 2, or (at your option) any
 
8
--    later version. AdaBrowse is distributed in the hope that it will be
 
9
--    useful, but <EM>without any warranty</EM>; without even the implied
 
10
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
 
11
--    See the GNU General Public License for  more details. You should have
 
12
--    received a copy of the GNU General Public License with this distribution,
 
13
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
 
14
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
15
--    USA.
 
16
-- </BLOCKQUOTE>
 
17
-- <BLOCKQUOTE>
 
18
--   As a special exception from the GPL, if other files instantiate generics
 
19
--   from this unit, or you link this unit with other files to produce an
 
20
--   executable, this unit does not by itself cause the resulting executable
 
21
--   to be covered by the GPL. This exception does not however invalidate any
 
22
--   other reasons why the executable file might be covered by the GPL.
 
23
-- </BLOCKQUOTE>
 
24
--
 
25
-- <DL><DT><STRONG>
 
26
-- Author:</STRONG><DD>
 
27
--   Thomas Wolf  (TW)
 
28
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
 
29
--
 
30
-- <DL><DT><STRONG>
 
31
-- Purpose:</STRONG><DD>
 
32
--   Generic list sorting operation with <CODE>O (n*log n)</CODE> worst-case
 
33
--   run-time complexity.
 
34
--
 
35
-- <DL><DT><STRONG>
 
36
-- Tasking semantics:</STRONG><DD>
 
37
--   N/A. Not abortion-safe.</DL>
 
38
--
 
39
-- <DL><DT><STRONG>
 
40
-- Storage semantics:</STRONG><DD>
 
41
--   No dynamic storage allocation. Uses <CODE>O (log n)</CODE> stack
 
42
--   space.</DL>
 
43
--
 
44
-- <!--
 
45
-- Revision History
 
46
--
 
47
--   27-NOV-2001   TW  Initial version.
 
48
--   15-JAN-2002   TW  Replaced natural merge sort by a direct method. (Both
 
49
--                     are O(n*log n), but the natural merge sort has a higher
 
50
--                     constant factor. In my performance tests, natural merge
 
51
--                     sort was about three times slower. And, BTW, sorting an
 
52
--                     array with GAL.Sorting.Sort_G was about 1.5 to 2 times
 
53
--                     faster than this list sort.)
 
54
-- -->
 
55
-------------------------------------------------------------------------------
 
56
 
 
57
pragma License (Modified_GPL);
 
58
 
 
59
--  To consider: shall I rewrite this in terms of a 'Position' type, like the
 
60
--  lexicographical comparisons?
 
61
 
 
62
--  generic
 
63
--     type Node (<>) is limited private;
 
64
--     type Node_Ptr is access all Node;
 
65
--     with function  "<" (L, R : in Node_Ptr) return Boolean;
 
66
--
 
67
--     with function  Next     (N       : in Node_Ptr) return Node_Ptr;
 
68
--     with procedure Set_Next (N, Next : in Node_Ptr);
 
69
--
 
70
--     with procedure Post_Process (List, Last : in out Node_Ptr);
 
71
procedure GAL.Support.List_Sort
 
72
  (List : in out Node_Ptr;
 
73
   Last :    out Node_Ptr)
 
74
is
 
75
 
 
76
   type Sequence is
 
77
      record
 
78
        First, Last : Node_Ptr;
 
79
      end record;
 
80
 
 
81
   type Sequences is array (Boolean) of Sequence;
 
82
 
 
83
   procedure Split
 
84
     (Original : in out Sequence;
 
85
      Work     : in out Sequences);
 
86
   pragma Inline (Split);
 
87
 
 
88
   procedure Split
 
89
     (Original : in out Sequence;
 
90
      Work     : in out Sequences)
 
91
   is
 
92
      P    : Node_Ptr := Original.First;
 
93
      Q, R : Node_Ptr;
 
94
      On   : Boolean := False;
 
95
   begin
 
96
      while P /= null loop
 
97
         R := P;
 
98
         loop
 
99
            Q := Next (R);
 
100
            exit when Q = null or else Q < R;
 
101
            R := Q;
 
102
         end loop;
 
103
         --  Append P .. R to Work (On).
 
104
         if Work (On).First = null then
 
105
            Work (On).First := P;
 
106
         else
 
107
            Set_Next (Work (On).Last, P);
 
108
         end if;
 
109
         Work (On).Last := R;
 
110
         P  := Q;
 
111
         On := not On;
 
112
      end loop;
 
113
      Original.First := null; Original.Last := null;
 
114
      if Work (False).First /= null then
 
115
         Set_Next (Work (False).Last, null);
 
116
      end if;
 
117
      if Work (True).First /= null then
 
118
         Set_Next (Work (True).Last, null);
 
119
      end if;
 
120
   end Split;
 
121
 
 
122
   procedure Merge
 
123
     (Work    : in out Sequences;
 
124
      Result  : in out Sequence);
 
125
   pragma Inline (Merge);
 
126
 
 
127
   procedure Merge
 
128
     (Work   : in out Sequences;
 
129
      Result : in out Sequence)
 
130
   is
 
131
      P, Q : Node_Ptr;
 
132
   begin
 
133
      while Work (False).First /= null and then Work (True).First /= null loop
 
134
         if Work (True).First < Work (False).First then
 
135
            P := Work (True).First;
 
136
            Work (True).First := Next (P);
 
137
         else
 
138
            P := Work (False).First;
 
139
            Work (False).First := Next (P);
 
140
         end if;
 
141
         if Result.First = null then
 
142
            Result.First := P;
 
143
         else
 
144
            Set_Next (Result.Last, P);
 
145
         end if;
 
146
         Result.Last := P;
 
147
      end loop;
 
148
      P := null;
 
149
      if Work (False).First /= null then
 
150
         P := Work (False).First;
 
151
         Q := Work (False).Last;
 
152
         Work (False).First := null;
 
153
      elsif Work (True).First /= null then
 
154
         P := Work (True).First;
 
155
         Q := Work (True).Last;
 
156
         Work (True).First := null;
 
157
      end if;
 
158
      if P /= null then
 
159
         if Result.First = null then
 
160
            Result.First := P;
 
161
         else
 
162
            Set_Next (Result.Last, P);
 
163
         end if;
 
164
         Result.Last := Q;
 
165
      end if;
 
166
      Set_Next (Result.Last, null);
 
167
   end Merge;
 
168
 
 
169
   procedure Sort
 
170
     (List : in out Node_Ptr;
 
171
      Last :    out Node_Ptr);
 
172
   pragma Inline (Sort);
 
173
 
 
174
   procedure Sort
 
175
     (List : in out Node_Ptr;
 
176
      Last :    out Node_Ptr)
 
177
   is
 
178
      Result : Sequence := (List, null);
 
179
      Work   : Sequences;
 
180
   begin
 
181
      Last := List;
 
182
      if List = null or else Next (List) = null then
 
183
         --  Zero or one element in the list: no need to sort.
 
184
         return;
 
185
      end if;
 
186
      --  We have at least two elements.
 
187
      Split (Result, Work);
 
188
      if Work (True).First /= null then
 
189
         Sort (Work (False).First, Work (False).Last);
 
190
         Sort (Work (True).First, Work (True).Last);
 
191
         Merge (Work, Result);
 
192
      else
 
193
         Result := Work (False);
 
194
      end if;
 
195
      List := Result.First;
 
196
      Last := Result.Last;
 
197
   end Sort;
 
198
 
 
199
begin
 
200
   Sort (List, Last);
 
201
   Post_Process (List, Last);
 
202
end GAL.Support.List_Sort;
 
203
 
 
204