Se pone fin de línea del sistema.
[z.facultad/75.40/1er-cuat/orden.git] / test / msdemo.pas
1 program SortDemo ( Input, Output );
2 uses
3    Crt;
4
5 const
6    Max = 16;
7
8 type
9    ArrayType = array [ 1 .. Max ] of Integer;
10
11 var
12    A : ArrayType;
13
14    procedure DisplayArray ( var A : ArrayType );
15    var
16       I : Integer;
17    begin
18       ClrScr;
19       GotoXY( 1, 5 );
20       Write( '(' );
21       for I := 1 to Max do
22       begin
23          Write( A[ I ] : 3 );
24          if I <> Max then
25             Write( ',' )
26          else
27             Write( ')' )
28       end
29    end;
30
31    procedure FillArray( var A : ArrayType );
32    var
33       I : Integer;
34    begin
35       Randomize;
36       for I := 1 to Max do
37          A[ I ] := Random( 100 )
38    end;
39
40    procedure WriteLT ( Position : Integer;
41                        Level    : Integer );
42    begin
43       GoToXY( 4 * Position - 2, Level );
44       TextColor( White );
45       Write( ' >' );
46       TextColor( LightGray );
47    end;
48
49    procedure WriteBlank ( Position : Integer;
50                           Level    : Integer );
51    begin
52       GoToXY( 4 * Position - 2, Level );
53       TextColor( Black );
54       Write( '   ' );
55       TextColor( LightGray );
56    end;
57
58    procedure WriteColor ( I     : Integer;
59                           Value : Integer;
60                           Color : Integer;
61                           Row   : Integer );
62    var
63       X : Integer;
64    begin
65       X := 4 * I - 2;
66       GoToXY( X, Row );
67       TextColor( Color );
68       Write( Value : 3 );
69       TextColor( LightGray )
70    end;
71
72    procedure WriteNormal ( I     : Integer;
73                            Value : Integer );
74    var
75       X : Integer;
76    begin
77       X := 4 * I - 2;
78       TextColor( LightGray );
79       GoToXY( X, 5 );
80       Write( Value : 3 )
81    end;
82
83
84    procedure MergeSort ( var A : ArrayType );
85    {V}  var
86    {V}     Level : Integer;
87    {V}     I : Integer;
88
89       procedure Transfer( var F, T    : ArrayType;
90                               FromFirst,
91                               FromLast,
92                               ToFirst : Integer );
93       var
94          I : Integer;
95       begin
96          for I := FromFirst to FromLast do
97             T[ ToFirst + ( I - FromFirst ) ] := F[ I ];
98       end;  {Transfer}
99
100       procedure Merge ( var A    : ArrayType;
101                             First,
102                             Last : Integer );
103       var
104          MidPoint,
105          Left,
106          Right,
107          Count  : Integer;
108          Temp : ArrayType;
109
110       {V}   I : Integer;
111       {V}   Ch : Char;
112
113       begin
114          Count := First;
115          MidPoint := ( First + Last ) div 2;
116          Left := First;
117          Right := Midpoint + 1;
118
119          {V}  for I := First to Midpoint do
120          {V}     WriteColor( I, A[ I ], LightRed, 5 );
121          {V}  for I := Right to Last do
122          {V}     WriteColor( I, A[ I ], LightBlue, 5 );
123          {V}  Ch := ReadKey;
124
125          {V}  for I := First to Last do
126          {V}     WriteBlank( I, 5 );
127          {V}  for I := First to Midpoint do
128          {V}     WriteColor( I, A[ I ], LightRed, 10 );
129          {V}  for I := Right to Last do
130          {V}    WriteColor( I, A[ I ], LightBlue, 11 );
131          {V}  Ch := ReadKey;
132
133          while ( Left <= Midpoint ) and ( Right <= Last ) do
134          begin
135             if A[ Left ] < A[ Right ] then
136             begin
137                Temp[ Count ] := A[ Left ];
138
139                {V}  WriteColor( Count, A[ Left ], LightRed, 5 );
140                {V}  WriteBlank( Left, 10 );
141                {V}  Ch := ReadKey;
142
143                Inc( Left );
144             end
145             else
146             begin
147                Temp[ Count ] := A[ Right ];
148
149                {V}  WriteColor( Count, A[ Right ], LightBlue, 5 );
150                {V}  WriteBlank( Right, 11 );
151                {V}  Ch := ReadKey;
152
153                Inc( Right );
154             end;
155             Inc( Count )
156          end;
157
158          if ( Left <= MidPoint ) then
159          {V}  begin
160             Transfer( A, Temp, Left, Midpoint, Count );
161             {V}  for I := Left to Midpoint do
162             {V}  begin
163             {V}     WriteColor( Count, A[ I ], LightRed, 5 );
164             {V}     WriteBlank( I, 10 );
165             {V}     Inc( Count );
166             {V}     Ch := ReadKey;
167             {V}  end;
168          {V} end
169
170          else
171          {V}  begin
172             Transfer( A, Temp, Right, Last, Count );
173             {V}  for I := Right to Last do
174             {V}  begin
175             {V}     WriteColor( Count, A[ I ], LightBlue, 5 );
176             {V}     WriteBlank( I, 11 );
177             {V}     Inc( Count );
178             {V}     Ch := ReadKey;
179             {V}  end;
180          {V}   end;
181
182          Transfer( Temp, A, First, Last, First );
183
184
185       end;  {Merge}
186
187       procedure MSort ( var A     : ArrayType;
188                             First,
189                             Last  : Integer );
190       var
191          MidPoint : Integer;
192       {V}   I : Integer;
193       {V}   Ch : Char;
194       begin
195          if First < Last then
196          begin
197             MidPoint := ( First + Last ) div 2;
198             MSort( A, First, MidPoint );
199
200             {V}  for I := First to MidPoint do
201             {V}     WriteLT( I, Level );
202             {V}  Inc( Level );
203
204             MSort( A, MidPoint + 1, Last );
205
206             {V}  for I := MidPoint + 1 to Last do
207             {V}     WriteLT( I, Level );
208             {V}  Inc( Level );
209
210             Merge( A, First, Last );
211
212             {V}  for I := MidPoint + 1 to Last do
213             {V}  begin
214             {V}     WriteBlank( I, Level );
215             {V}     WriteBlank( I, Level - 1 );
216             {V}     WriteLT( I, Level - 2 );
217             {V}  end;
218             {V}  Dec( Level, 2 );
219
220             {V}  for I := First to Last do
221             {V}     WriteNormal( I, A[ I ] );
222             {V}  Ch := ReadKey
223          end
224       end;  {MSort}
225
226    begin
227       {V}  Level := 6;
228
229       MSort( A, 1, Max );
230
231       {V}  for I := 1 to Max do
232       {V}     WriteLT( I, Level );
233    end;  {MergeSort}
234
235 begin
236    FillArray( A );
237    DisplayArray( A );
238    MergeSort( A );
239 end.
240