Category : Pascal Source Code
Archive   : MRGSORT.ZIP
Filename : MRGDEMO.PAS
{$M 2048,0,655360}
PROGRAM mrgdemo(input, output); (* compiled on TP5.0 *)
(* Demonstrating the use of mergesort on linked lists *)
(* We are using a packed representation of the A..Z alphabet *)
(* This is based on Sedgewicks (Algorithms) descriptions. *)
(* You can easily get to 20 or 30000 items. This demo will *)
(* only create about 180 items with the heap limit at 6000. *)
(* Public Domain, by C.B. Falconer, 1:141/209.1@fidonet *)
(* {} at left margin marks non-std portability problems. *)
(* Any others should be resolvable by creating procs/types *)
(* On my 8mhz V20 XT system, executes as follows: *)
(* items creation time sorting time *)
(* ----- ------------- ------------ *)
(* 10 0.013 Sec. 0.010 Sec. *)
(* 100 0.117 Sec. 0.164 Sec. *)
(* 500 0.582 Sec. 1.050 Sec. *)
(* 2500 2.903 Sec. 6.407 Sec. *)
(* 12500 14.502 Sec. 38.028 Sec. *)
(* (FULL) 33874 38.028 Sec. 113.692 Sec. *)
(* which shows the n*log(n) behaviour of the algorithm. *)
{}USES (* all public domain *)
{} txtfiles, (* for fptr, skipblks, readwd *)
{} uclock, (* for clock, microsecond timing *)
{} errmsgs, (* for full runtime error display *)
{} mrgsort; (* for sort, greaterf, null *)
CONST
minchar = 'A';
maxchar = 'Z'; (* underlying continuous char set assumed *)
packing = 3; (* chars per packed word *)
pksize = 4;
alfalen = 12; (* (packing * pksize), ref. only *)
maxword = 65535;
TYPE
pkword = integer;
pkindex = 1..pksize;
alfaptr = ^alfa;
alfa = RECORD (* must agree with link in mrgsort *)
next : alfaptr; (* i.e. this MUST be first field *)
index : word;
s : ARRAY[pkindex] OF pkword;
END; (* alfa *)
VAR
root : alfaptr; (* of the monster list *)
chrmax : integer; (* handy size of char coding *)
maxcount : word; (* how big to make the list *)
begun,
ended : real; (* for routine timing only *)
{} relation : greaterf; (* TP can't pass procedures, only ptrs *)
(* 1---------------1 *)
PROCEDURE buildlist(root : alfaptr);
CONST
margin = 2048;
VAR
j,
pkmax : integer;
count : word;
BEGIN (* buildlist *)
pkmax := succ(chrmax) * succ(chrmax) * succ(chrmax);
count := 0;
WHILE (memavail > margin) AND (count < maxcount) DO BEGIN
new(root^.next); root := root^.next; root^.next := null;
count := succ(count); root^.index := count;
FOR j := 1 TO pksize DO root^.s[j] := random(pkmax); END;
ended := clock;
IF memavail <= margin THEN write('(FULL) ');
write(count : 1, ' items created');
END; (* buildlist *)
(* 1---------------1 *)
PROCEDURE dump(items : alfaptr);
VAR
n : word;
(* 2---------------2 *)
PROCEDURE dump12;
VAR
j : pkindex;
(* 3---------------3 *)
PROCEDURE dump3(w : pkword);
VAR
i : 1..packing;
ch : ARRAY[1..packing] OF char;
BEGIN (* dump3 *)
FOR i := 1 TO packing DO BEGIN
ch[i] := chr(w MOD succ(chrmax));
w := w DIV succ(chrmax); END;
FOR i := packing DOWNTO 1 DO
write(chr(ord(ch[i]) + ord(minchar)));
END; (* dump3 *)
(* 3---------------3 *)
BEGIN (* dump12 *)
write(n : 6, ' ', items^.index : 6, ' ');
FOR j := pksize DOWNTO 1 DO dump3(items^.s[j]);
END; (* dump12 *)
(* 2---------------2 *)
BEGIN (* dump *)
n := 0;
WHILE items <> null DO BEGIN
n := succ(n); dump12; items := items^.next;
IF n MOD 3 = 0 THEN writeln; END;
IF n MOD 3 <> 0 THEN writeln;
END; (* dump *)
(* 1---------------1 *)
FUNCTION gety(prompt : string) : boolean;
(* true if user enters 'y' or 'Y', else false *)
BEGIN (* gety *)
write(prompt); skipblks(input);
IF eoln THEN gety := false
ELSE gety := upcase(fptr(input)) = 'Y';
readln;
END; (* gety *)
(* 1---------------1 *)
{$f+} (* passed functions MUST be far *)
FUNCTION greater(thing, than : pointer) : boolean;
(* This is the time bind - make assy language. This *)
(* will later be passed in as a param to mrgsort *)
LABEL 9, 10;
VAR
k : pkindex;
(* These gyrations bypass type checking, and describe *)
(* the actual pointer type that mrgsort will call with *)
{} a : alfaptr ABSOLUTE thing;
{} b : alfaptr ABSOLUTE than;
{$r-,s-}
BEGIN (* greater *)
greater := true;
FOR k := pksize DOWNTO 1 DO (* Check most sig. first *)
IF a^.s[k] > b^.s[k] THEN GOTO 10
ELSE IF a^.s[k] < b^.s[k] THEN GOTO 9;
9: greater := false;
10: END; (* greater *)
{$r+,s+,f-} (* put the options back *)
(* 1---------------1 *)
BEGIN (* mrgdemo *)
{}relation := greater; (* init the procedural pointer *)
new(root); root^.next := null; (* using sentinels *)
chrmax := ord(maxchar) - ord(minchar); (* randomize; *)
REPEAT
write('How many items to create (5 min) ? ');
readwd(input, maxcount); readln;
UNTIL maxcount >= 5;
write('Building ... ');
begun := clock;
buildlist(root); (* just to create something to sort *)
ended := clock;
writeln(' in ', (ended - begun) * 3600 : 1 : 3, ' seconds');
IF gety('Dump list (y/N) ?') THEN dump(root^.next);
write('Sorting ... ');
begun := clock;
(* Here we do all the real work *)
root^.next := sort(root^.next, relation);
ended := clock;
writeln(' done in ', (ended - begun) * 3600 : 1 : 3, ' seconds');
IF gety('Dump list (y/N) ?') THEN dump(root^.next);
END. (* mrgdemo *)
®.
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/