Microsoft Programmer's Library 1.3/Microsoft_Programmers_Library.7z/MPL/pas/passmpl.txt

Text File | 2013-11-08 | 38.8 KB | 1,094 lines

 \SAMPCODE
 \SAMPCODE\PASCAL
 \SAMPCODE\PASCAL\DEMOEXEC.PAS

 {*      DEMOEXEC.PAS - demonstration progam for calling C library functions
  *
  *      Microsoft Pascal release 3.32 can call large model C functions.
  *      Please read PASEXEC.INC for more details on interlanguage calling.
  *
  *      To compile and link DEMOEXEC.PAS
  *
  *      pas1 demoexec;
  *      pas2
  *      link demoexec,,,cexec;          (must search CEXEC.LIB)
  *}

 program demoexec(input,output);

 {$include : 'pasexec.inc'}

 var
         i : integer;
         NULL : integer4;

 value
         NULL := 0;

 begin

 {*      invoke command.com with a command line
  *
  *              dir *.pas
  *}
         i := system(ads('dir *.pas'*chr(0)));
         writeln (output,'system return code = ',i);
         writeln (output,' ');

 {*      invoke a child process
  *
  *              exemod          (display usage line only)
  *}
         i := spawnlp(0,ads('exemod'*chr(0)),ads('exemod'*chr(0)),NULL);
         writeln (output,'spawnlp return code =',i);
         writeln (output,' ');

 {*      invoke an overlay process (chaining)
  *
  *              exemod demoexec.exe
  *}
         i := spawnlp(_p_overlay,ads('exemod'*chr(0)),ads('exemod'*chr(0)),
                      ads('demoexec.exe'*chr(0)),NULL);

 {*      we should never see this if spawnlp (overlay) is successful
  *}
         writeln (output,'spawnlp return code =',i);
         writeln (output,' ');

 end.

 \SAMPCODE\PASCAL\PRIMES.PAS

 { Prime number generator }
 { Generates all the primes between 0 and 10000 }
 program primes(output);

   var
     prime:      integer;
     rprime:     real4;
     i:          integer;
     sqrtp:      integer;
     notprime:   boolean;

   begin
     writeln('      2');
     writeln('      3');
     prime := 5;
     repeat
       rprime := prime;
       sqrtp := trunc(sqrt(rprime) + 1.0);
       i := 1;
       notprime := false;
       while (i < sqrtp) and (not notprime) do
         begin
           i := i + 2;
           notprime := (prime mod i = 0);
         end;
       if (not notprime) then writeln(prime:6);
       prime := prime + 2;
     until (prime > 10000);
   end.
 \SAMPCODE\PASCAL\SORT.PAS

 { Bubble Sort Demonstration Program }
 {       Microsoft Pascal 3.1        }

 { The main routine reads from the terminal an array  }
 { of ten real numbers and calls the procedure BUBBLE }
 { to sort them.                                      }

 program BubbleSort(input,output);

   const
     TABLEN = 10;                    { Length of reals table }

   type
     TABLE = array[1 .. TABLEN] of real4;
                                     { Table of reals type }
   var
     R:          TABLE;              { The table itself }
     i:          integer;            { Table index }

   procedure Bubble(var t: TABLE);   { The sorting routine }
     var
       i:        integer;            { Index variable }
       j:        integer;            { Index variable }
       temp:     real4;              { Exchange variable }
     begin
       for i := 1 to 9 do            { Outer loop }
         begin
           for j := i + 1 to 10 do   { Inner loop }
             begin
               if (t[i] > t[j]) then { Sort in ascending order }
                 begin
                   temp := t[i];     { Perform the }
                   t[i] := t[j];     { exchange of }
                   t[j] := temp;     { table elememts }
                 end;
             end;
         end;
     end;

   begin
     writeln(' Bubble Sort Demonstration Program.');
     for i := 1 to 10 do             { Loop to read in reals }
       begin
         writeln(' Please input real number no. ',i:2);
                                     { Prompt user }
         readln(R[i]);               { Read response }
       end;
     Bubble(R);                      { Sort the array }
     writeln;                        { Skip a line }
     writeln(' The sorted ordering from lowest to highest is:');
                                     { Print a header }
     for i := 1 to 10 do             { Loop to print array }
       begin
         write(R[i]);                { Write a number }
         if (i mod 5 = 0) then writeln;
                                     { Five numbers per line }
       end;
   end.
 \SAMPCODE\PASCAL\SORTDEMO.PAS

 (*                                 SORTDEMO
  * This program graphically demonstrates six common sorting algorithms.  It
  * prints 25 or 43 horizontal bars, all of different lengths and all in rando
  * order, then sorts the bars from smallest to longest.
  *
  * The program also uses sound statements to generate different pitches,
  * depending on the location of the bar being printed. Note that the sound
  * statements delay the speed of each sorting algorithm so you can follow
  * the progress of the sort. Therefore, the times shown are for comparison
  * only. They are not an accurate measure of sort speed.
  *
  * If you use these sorting routines in your own programs, you may notice
  * a difference in their relative speeds (for example, the exchange
  * sort may be faster than the shell sort) depending on the number of
  * elements to be sorted and how "scrambled" they are to begin with.
  *)

 PROGRAM SortDemo;

 CONST
     INCL_SUB           = 1;        (* Include KBD, VIO, and MOU definitions *
     INCL_DOSDATETIME   = 1;        (* DOS date/time definitions *)
     INCL_DOSPROCESS    = 1;        (* Some DOS process definitions *)
     INCL_NOCOM         = 1;        (* Don't include default sections of DOS *

 (*
  * Define the data type used to hold the information for each colored bar:
  *)
 TYPE
     SortType = RECORD
                 Length: BYTE;   (* Bar length (the element compared
                                  * in the different sorts)             *)
                 ColorVal: BYTE; (* Bar color                           *)
                END;

     CELLINFO = RECORD
             Char: BYTE;
             Attr: BYTE;
            END;

 (* Declare global constants:
  *)
 CONST
     BLOCK = 223;
     ESC = CHR(27);
     FIRSTMENU = 1;
     LEFTCOLUMN = 48;
     NLINES = 18;
     NULL = 0;
     SPACE = 32;
     WIDTH = 80 - LEFTCOLUMN;
     WHITE = 15;

 (* Declare global variables, and allocate storage space for them.  SortArray
  * and SortBackup are both arrays of the data type SortType defined above:
  *)
 VAR
     sTime,wTime: _DATETIME;
     KeyInfo: _KBDKEYINFO;
     wMode: _VIOMODEINFO;
     SortArray, SortBackup: ARRAY[1..43] OF SortType;
     Menu: ARRAY[1..NLINES] OF LSTRING(30);
     Sound: BOOLEAN;
     curSelect, MaxBars, MaxColors: INTEGER;
     oTime, nTime, Pause, RandSeed: INTEGER4;
     ret: WORD;

 (* Data statements for the different options printed in the sort menu:
  *)

 VALUE
     Menu[1] := '     PASCAL Sorting Demo';
     Menu[2] := ' ';
     Menu[3] := 'Insertion';
     Menu[4] := 'Bubble';
     Menu[5] := 'Heap';
     Menu[6] := 'Exchange';
     Menu[7] := 'Shell';
     Menu[8] := 'Quick';
     Menu[9] := ' ';
     Menu[10] := 'Toggle Sound: ';
     Menu[11] := ' ';
     Menu[12] := 'Pause Factor: ';
     Menu[13] := '<   (Slower)';
     Menu[14] := '>   (Faster)';
     Menu[15] := ' ';
     Menu[16] := 'Type first character of';
     Menu[17] := 'choice ( I B H E S Q T < > )';
     Menu[18] := 'or ESC key to end program: ';
     wMode.cb := SIZEOF(wMode);

 FUNCTION GETMQQ (Wants:WORD):ADSMEM; EXTERN;
 FUNCTION RandInt (Lower,Upper:INTEGER):INTEGER; FORWARD;
 PROCEDURE BoxInit; FORWARD;
 PROCEDURE BubbleSort; FORWARD;
 PROCEDURE DrawFrame (Top,Left,Width,Height:INTEGER); FORWARD;
 PROCEDURE ElapsedTime (CurrentRow:INTEGER); FORWARD;
 PROCEDURE ExchangeSort; FORWARD;
 PROCEDURE HeapSort; FORWARD;
 PROCEDURE Initialize; FORWARD;
 PROCEDURE InsertionSort; FORWARD;
 PROCEDURE PercolateDown (MaxLevel:INTEGER); FORWARD;
 PROCEDURE PercolateUp (MaxLevel:INTEGER); FORWARD;
 PROCEDURE PrintOneBar (Row:INTEGER); FORWARD;
 PROCEDURE QuickSort (Low,High:INTEGER); FORWARD;
 PROCEDURE Reinitialize; FORWARD;
 PROCEDURE ShellSort; FORWARD;
 FUNCTION Screen (ACTION:BYTE):BOOLEAN; FORWARD;
 PROCEDURE SortMenu; FORWARD;
 PROCEDURE SwapBars (Row1,Row2:INTEGER); FORWARD;
 PROCEDURE cls; FORWARD;
 PROCEDURE swaps (VAR one, two:SortType); FORWARD;

 (* =============================== BoxInit ==================================
  *    Calls the DrawFrame procedure to draw the frame around the sort menu,
  *    then prints the different options stored in the Menu array.
  * ==========================================================================
  *)
 PROCEDURE BoxInit;
 VAR
     Color: BYTE;
     i: INTEGER;
     Factor: LSTRING(3);

 BEGIN
     Color := WHITE;
     DrawFrame(1, LEFTCOLUMN - 3, WIDTH + 3, 22);

     FOR i := 1 TO NLINES DO
         ret := VioWrtCharStrAtt(ads Menu[i,1], Menu[i].len,
                                FIRSTMENU + i, LEFTCOLUMN, Color, 0);

    (* Print the current value for Sound:
     *)
     IF (Sound) THEN
         ret := VioWrtCharStrAtt(ads 'ON ',3, 11, LEFTCOLUMN + 14, Color, 0)
     ELSE
         ret := VioWrtCharStrAtt(ads 'OFF',3, 11, LEFTCOLUMN + 14, Color, 0);

     EVAL(ENCODE(Factor,Pause DIV 30:3));
     ret := VioWrtCharStrAtt(ads Factor[1], 3, 13, LEFTCOLUMN + 14, Color, 0);

    (* Erase the speed option if the length of the Pause is at a limit
     *)
     IF (Pause = 900) THEN
         ret := VioWrtCharStrAtt(ads '            ',12,14,LEFTCOLUMN,Color,0)
     ELSE IF (Pause = 0) THEN
         ret := VioWrtCharStrAtt(ads '            ',12,15,LEFTCOLUMN,Color,0);

 END;

 (* ============================== BubbleSort ================================
  *    The BubbleSort algorithm cycles through SortArray, comparing adjacent
  *    elements and swapping pairs that are out of order.  It continues to
  *    do this until no pairs are swapped.
  * ==========================================================================
  *)
 PROCEDURE BubbleSort;
 VAR
     Row, Switch, Limit: INTEGER;

 BEGIN
     Limit := MaxBars;
     REPEAT
         Switch := 0;
         FOR Row := 1 TO Limit - 1 DO BEGIN

            (* Two adjacent elements are out of order, so swap their values
             * and redraw those two bars: *)
             IF (SortArray[Row].Length > SortArray[Row + 1].Length) THEN BEGIN
                 swaps (SortArray[Row], SortArray[Row + 1]);
                 SwapBars (Row, Row + 1);
                 Switch := Row;
             END;
         END;

     (* Sort on next pass only to where the last switch was made: *)
     Limit := Switch;
     UNTIL Switch = 0;
 END;

 (* ============================== DrawFrame =================================
  *   Draws a rectangular frame using the high-order ASCII characters ╔ (201)
  *   ╗ (187) , ╚ (200) , ╝ (188) , ║ (186) , and ═ (205). The parameters
  *   TopSide, BottomSide, LeftSide, and RightSide are the row and column
  *   arguments for the upper-left and lower-right corners of the frame.
  * ==========================================================================
  *)
 PROCEDURE DrawFrame {(Top, Left, Width, Height)};
 CONST
     ULEFT = 201;
     URIGHT = 187;
     LLEFT = 200;
     LRIGHT = 188;
     VERTICAL = 186;
     HORIZONTAL = 205;
     SPACE = ' ';

 VAR
     Attr: BYTE;
     CellAttr, i, bottom, right: INTEGER;
     TempStr: STRING(80);

 BEGIN
       Attr := WHITE;
       CellAttr := Attr * 256;
       bottom := Top+Height-1;
       right := Left+Width-1;

       ret := VioWrtNCell(ads (CellAttr OR ULEFT),1,Top,Left,0);
       ret := VioWrtNCell(ads (CellAttr OR HORIZONTAL),Width-2,Top,Left+1,0);
       ret := VioWrtNCell(ads (CellAttr OR URIGHT),1,Top,right,0);

       FILLSC(ads Tempstr,Width,CHR(SPACE));
       Tempstr[1] := CHR(VERTICAL);
       Tempstr[Width] := CHR(VERTICAL);
       FOR i := 1 TO Height-2 DO
           ret := VioWrtCharStrAtt(ads Tempstr,Width,i+Top,Left,Attr,0);

       ret := VioWrtNCell(ads (CellAttr OR LLEFT),1,bottom,Left,0);
       ret := VioWrtNCell(ads (CellAttr OR HORIZONTAL),Width-2,bottom,Left+1,0
       ret := VioWrtNCell(ads (CellAttr OR LRIGHT),1,bottom,right,0);
 END;

 (* ============================= ElapsedTime ================================
  *    Prints seconds elapsed since the given sorting routine started.
  *    Note that this time includes both the time it takes to redraw the
  *    bars plus the pause while the SOUND statement plays a note, and
  *    thus is not an accurate indication of sorting speed.
  * ==========================================================================
  *)
 PROCEDURE ElapsedTime {(CurrentRow)};
 VAR
     Color: BYTE;
     Timing: LSTRING(80);

 BEGIN
     Color := WHITE;

     ret := DosGetDateTime(ads wTime);

     nTime := (wTime.hours * 360000) +
             (wTime.minutes * 6000) +
             (wTime.seconds * 100) +
              wTime.hundredths;

     EVAL(ENCODE(Timing,(nTime - oTime) / 100:7:2));

     (* Print the number of seconds elapsed *)
     ret := VioWrtCharStrAtt(ads Timing[1], 7, curSelect + FIRSTMENU + 3,
         LEFTCOLUMN + 15, Color, 0);

     IF (Sound) THEN
         ret := DosBeep(60 * CurrentRow, 32);    (* Play a note. *)
     ret := DosSleep(Pause);                     (* Pause. *)

 END;

 (* ============================= ExchangeSort ===============================
  *   The ExchangeSort compares each element in SortArray - starting with
  *   the first element - with every following element.  If any of the
  *   following elements is smaller than the current element, it is exchanged
  *   with the current element and the process is repeated for the next
  *   element in SortArray.
  * ==========================================================================
  *)
 PROCEDURE ExchangeSort;
 VAR
     Row, SmallestRow, j: INTEGER;

 BEGIN
     FOR Row := 1 TO MaxBars - 1 DO BEGIN
         SmallestRow := Row;
         FOR j := Row + 1 TO MaxBars DO BEGIN
             IF (SortArray[j].Length < SortArray[SmallestRow].Length) THEN BEG
                 SmallestRow := j;
                 ElapsedTime(j);
             END;
         END;
        (* Found a row shorter than the current row, so swap those
         * two array elements: *)
         IF (SmallestRow > Row) THEN BEGIN
             swaps (SortArray[Row], SortArray[SmallestRow]);
             SwapBars (Row, SmallestRow);
         END;
     END;

 END;

 (* =============================== HeapSort =================================
  *  The HeapSort procedure works by calling two other procedures - PercolateU
  *  and PercolateDown.  PercolateUp turns SortArray into a "heap," which has
  *  the properties outlined in the diagram below:
  *
  *                               SortArray(1)
  *                               /          \
  *                    SortArray(2)           SortArray(3)
  *                   /          \            /          \
  *         SortArray(4)   SortArray(5)   SortArray(6)  SortArray(7)
  *          /      \       /       \       /      \      /      \
  *        ...      ...   ...       ...   ...      ...  ...      ...
  *
  *
  *  where each "parent node" is greater than each of its "child nodes"; for
  *  example, SortArray(1) is greater than SortArray(2) or SortArray(3),
  *  SortArray(3) is greater than SortArray(6) or SortArray(7), and so forth.
  *
  *  Therefore, once the first FOR...NEXT loop in HeapSort is finished, the
  *  largest element is in SortArray(1).
  *
  *  The second FOR...NEXT loop in HeapSort swaps the element in SortArray(1)
  *  with the element in MaxRow, rebuilds the heap (with PercolateDown) for
  *  MaxRow - 1, then swaps the element in SortArray(1) with the element in
  *  MaxRow - 1, rebuilds the heap for MaxRow - 2, and continues in this way
  *  until the array is sorted.
  * ==========================================================================
  *)
 PROCEDURE HeapSort;
 VAR
     i: INTEGER;

 BEGIN
     FOR i := 2 TO MaxBars DO
         PercolateUp (i);

     FOR i := MaxBars DOWNTO 2 DO BEGIN
         swaps (SortArray[1], SortArray[i]);
         SwapBars (1, i);
         PercolateDown (i - 1);
     END;
 END;

 (* ============================== Initialize ================================
  *    Initializes the SortBackup array.  It also calls the BoxInit procedure.
  * ==========================================================================
  *)
 PROCEDURE Initialize;
 VAR
     iTime: _DATETIME;
     i, MaxIndex, Index, BarLength: INTEGER;
     TempArray: ARRAY [1..43] OF INTEGER;

 BEGIN
     FOR i := 1 TO MaxBars DO
         TempArray[i] := i;

    (* If monochrome or color burst disabled, use one color *)
     IF (((wMode.fbType AND VGMT_OTHER) <> 0) AND
         ((wMode.fbType AND VGMT_DISABLEBURST) = 0))
         MaxColors := 15;
     ELSE
         MaxColors := 1;

    (* Seed the random-number generator. *)
     ret := DosGetDateTime(ads iTime);
     RandSeed := (iTime.hours * 3600) +
                 (iTime.minutes * 60) +
                  iTime.seconds;
     RandSeed := TRUNC4(RandSeed / 86400.0 * 259199.0);

     MaxIndex := MaxBars;
     FOR i := 1 TO MaxBars DO BEGIN

        (* Find a random element in TempArray between 1 and MaxIndex,
         * then assign the value in that element to BarLength: *)
         Index := RandInt(1,MaxIndex);
         BarLength := TempArray[Index];

        (* Overwrite the value in TempArray[Index] with the value in
         * TempArray[MaxIndex] so the value in TempArray[Index] is
         * chosen only once: *)
         TempArray[Index] := TempArray[MaxIndex];

        (* Decrease the value of MaxIndex so that TempArray[MaxIndex] can't
         * be chosen on the next pass through the loop: *)
         MaxIndex := MaxIndex - 1;

         SortBackup[i].Length := BarLength;

         IF (MaxColors = 1) THEN
             SortBackup[i].ColorVal := 7;
         ELSE
             SortBackup[i].ColorVal := (BarLength MOD MaxColors) + 1;
     END;

     cls;
     Reinitialize;      (* Assign values in SortBackup to SortArray and draw *
                          (* unsorted bars on the screen. *)
     Sound := TRUE;
     Pause := 30;           (* Initialize Pause. *)
     BoxInit;           (* Draw frame for the sort menu and print options. *)

 END;

 (* ============================= InsertionSort ==============================
  *   The InsertionSort procedure compares the length of each successive
  *   element in SortArray with the lengths of all the preceding elements.
  *   When the procedure finds the appropriate place for the new element, it
  *   inserts the element in its new place, and moves all the other elements
  *   down one place.
  * ==========================================================================
  *)
 PROCEDURE InsertionSort;
 VAR
     j, Row, TempLength: INTEGER;
     TempVal: SortType;

 BEGIN
     FOR Row := 2 TO MaxBars DO BEGIN
         TempVal := SortArray[Row];
         TempLength := TempVal.Length;
         FOR j := Row DOWNTO 2 DO BEGIN

            (* As long as the length of the j-1st element is greater than the
             * length of the original element in SortArray(Row), keep shifting
             * the array elements down: *)
             IF (SortArray[j - 1].Length > TempLength) THEN BEGIN
                 SortArray[j] := SortArray[j - 1];
                 PrintOneBar(j);             (* Print the new bar. *)
                 ElapsedTime(j);             (* Print the elapsed time. *)

              (* Otherwise, exit: *)
              END
              ELSE
                 break;
         END;

         (* Insert the original value of SortArray(Row) in SortArray(j): *)
         SortArray[j] := TempVal;
         PrintOneBar(j);
         ElapsedTime(j);
     END;
 END;

 (* ============================ PercolateDown ===============================
  *   The PercolateDown procedure restores the elements of SortArray from 1 to
  *   MaxLevel to a "heap" (see the diagram with the HeapSort procedure).
  * ==========================================================================
  *)
 PROCEDURE PercolateDown {(MaxLevel)};
 VAR
     i, Child: INTEGER;

 BEGIN
     i := 1;
    (* Move the value in SortArray(1) down the heap until it has reached
     * its proper node (that is, until it is less than its parent node
     * or until it has reached MaxLevel, the bottom of the current heap): *)
     WHILE TRUE DO BEGIN
         Child := 2 * i;            (* Get the subscript for the child node. *

         (* Reached the bottom of the heap, so exit this procedure: *)
         IF (Child > MaxLevel) THEN
             break;

         (* If there are two child nodes, find out which one is bigger: *)
         IF (Child + 1 <= MaxLevel) THEN
             IF (SortArray[Child + 1].Length > SortArray[Child].Length) THEN
                 Child := Child+1;

        (* Move the value down if it is still not bigger than either one of
         * its children: *)
         IF (SortArray[i].Length < SortArray[Child].Length) THEN BEGIN
             swaps (SortArray[i], SortArray[Child]);
             SwapBars (i, Child);
             i := Child;

        (* Otherwise, SortArray has been restored to a heap from 1 to
         * MaxLevel, so exit: *)
         END
         ELSE
             break;
     END;
 END;

 (* ============================== PercolateUp ===============================
  *   The PercolateUp procedure converts the elements from 1 to MaxLevel in
  *   SortArray into a "heap" (see the diagram with the HeapSort procedure).
  * ==========================================================================
  *)
 PROCEDURE PercolateUp {(MaxLevel)};
 VAR
     i, Parent: INTEGER;

 BEGIN
     i := MaxLevel;
    (* Move the value in SortArray(MaxLevel) up the heap until it has
     * reached its proper node (that is, until it is greater than either
     * of its child nodes, or until it has reached 1, the top of the heap): *)
     WHILE (i <> 1) DO BEGIN
         Parent := i DIV 2;           (* Get the subscript for the parent node

        (* The value at the current node is still bigger than the value at
         * its parent node, so swap these two array elements: *)
         IF (SortArray[i].Length > SortArray[Parent].Length) THEN BEGIN
             swaps (SortArray[Parent], SortArray[i]);
             SwapBars (Parent, i);
             i := Parent;

        (* Otherwise, the element has reached its proper place in the heap,
         * so exit this procedure: *)
         END
         ELSE
             break;
     END;
 END;

 (* ============================== PrintOneBar ===============================
  *  Prints SortArray(Row).BarString at the row indicated by the Row
  *  parameter, using the color in SortArray(Row).ColorVal.
  * ==========================================================================
  *)
 PROCEDURE PrintOneBar {(Row)};
 VAR
     Cell: CELLINFO;
     NumSpaces: INTEGER;

 BEGIN
     Cell.Attr := SortArray[Row].ColorVal;
     Cell.Char := BLOCK;
     ret := VioWrtNCell(ads Cell,SortArray[Row].Length,Row,1,0);
     NumSpaces := MaxBars - SortArray[Row].Length;
     IF NumSpaces > 0 THEN
         Cell.Char := SPACE;
         ret := VioWrtNCell(ads Cell,NumSpaces,Row,SortArray[Row].Length+1,0);
 END;

 (* ============================== QuickSort =================================
  *   QuickSort works by picking a random "pivot" element in SortArray, then
  *   moving every element that is bigger to one side of the pivot, and every
  *   element that is smaller to the other side.  QuickSort is then called
  *   recursively with the two subdivisions created by the pivot.  Once the
  *   number of elements in a subdivision reaches two, the recursive calls end
  *   and the array is sorted.
  * ==========================================================================
  *)
 PROCEDURE QuickSort {(Low, High)};
 VAR
     i, j, RandIndex, Partition: INTEGER;

 BEGIN
     IF (Low < High) THEN BEGIN

        (* Only two elements in this subdivision; swap them if they are out of
         * order, then end recursive calls: *)
         IF ((High - Low) = 1) THEN BEGIN
             IF (SortArray[Low].Length > SortArray[High].Length) THEN BEGIN
                 swaps (SortArray[Low], SortArray[High]);
                 SwapBars (Low, High);
             END;
         END
         ELSE BEGIN
             Partition := SortArray[High].Length;
             i := Low;
             j := High;
             WHILE i < j DO BEGIN

                 (* Move in from both sides towards the pivot element: *)
                 WHILE ((i < j) AND (SortArray[i].Length <= Partition)) DO
                     i := i + 1;

                 WHILE ((j > i) AND (SortArray[j].Length >= Partition)) DO
                     j := j - 1;

                (* If we haven't reached the pivot element, it means that two
                 * elements on either side are out of order, so swap them: *)
                 IF (i < j) THEN BEGIN
                     swaps (SortArray[i], SortArray[j]);
                     SwapBars (i, j);
                 END;
             END;

            (* Move the pivot element back to its proper place in the array: *
             swaps (SortArray[i], SortArray[High]);
             SwapBars (i, High);

            (* Recursively call the QuickSort procedure (pass the smaller
             * subdivision first to use less stack space): *)
             IF ((i - Low) < (High - i)) THEN BEGIN
                 QuickSort (Low, i - 1);
                 QuickSort (i + 1, High);
             END
             ELSE BEGIN
                 QuickSort (i + 1, High);
                 QuickSort (Low, i - 1);
             END;
         END;
     END;
 END;

 (* =============================== RandInt ==================================
  *   Returns a random integer greater than or equal to the Lower parameter
  *   and less than or equal to the Upper parameter.
  * ==========================================================================
  *)
 FUNCTION RandInt {(Lower, Upper)};
 BEGIN
     RandSeed := (RandSeed*7141+54773) MOD 259200;
     RandInt := ORD(Lower + ((Upper - Lower + 1) * RandSeed) DIV 259200);
 END;

 (* ============================== Reinitialize ==============================
  *   Restores the array SortArray to its original unsorted state, then
  *   prints the unsorted color bars.
  * ==========================================================================
  *)
 PROCEDURE Reinitialize;
 VAR
     Row: INTEGER;
 BEGIN
     FOR Row := 1 TO MaxBars DO BEGIN
         SortArray[Row] := SortBackup[Row];
         PrintOneBar(Row);
     END;

     ret := DosGetDateTime(ads sTime);
     oTime := (sTime.hours * 360000) +
             (sTime.minutes * 6000) +
             (sTime.seconds * 100) +
              sTime.hundredths;
 END;

 FUNCTION Screen {(ACTION)};
 VAR [STATIC]
     Mode: _VIOMODEINFO;
     CellStr: ADSMEM;
     Row,Col,Length: WORD;
 BEGIN
     if(ACTION=1) THEN BEGIN
         Mode.cb := sizeof(Mode);
         ret := VioGetMode(ads Mode,0);
         Length := 2*Mode.row*Mode.col;
         CellStr := GETMQQ(Length);
         if(CellStr.r = NULL) THEN BEGIN Screen := FALSE;return;END;
         ret := VioReadCellStr(CellStr,Length,0,0,0);
         ret := VioGetCurPos(Row,Col,0);
     END
     ELSE BEGIN
         ret := VioSetMode(ads Mode,0);
         if(CellStr.r = NULL) THEN BEGIN Screen := FALSE;return;END;
         ret := VioWrtCellStr(CellStr,Length,0,0,0);
         ret := VioSetCurPos(Row,Col,0);
     END;
     Screen := TRUE;
 END;

 (* =============================== ShellSort ================================
  *  The ShellSort procedure is similar to the BubbleSort procedure.  However,
  *  ShellSort begins by comparing elements that are far apart (separated by
  *  the value of the Offset variable, which is initially half the distance
  *  between the first and last element), then comparing elements that are
  *  closer together (when Offset is one, the last iteration of this procedure
  *  is merely a bubble sort).
  * ==========================================================================
  *)
 PROCEDURE ShellSort;
 VAR
     Offset, Switch, Limit, Row: INTEGER;

 BEGIN
     (* Set comparison offset to half the number of records in SortArray: *)
     Offset := MaxBars DIV 2;

     WHILE (Offset>0) DO BEGIN     (* Loop until offset gets to zero. *)
         Limit := MaxBars - Offset;
         REPEAT
             Switch := 0;        (* Assume no switches at this offset. *)

          (* Compare elements and switch ones out of order: *)
             FOR Row := 1 TO Limit DO
                 IF (SortArray[Row].Length > SortArray[Row + Offset].Length) T
                     swaps (SortArray[Row], SortArray[Row + Offset]);
                     SwapBars (Row, Row + Offset);
                     Switch := Row;
                 END;

             (* Sort on next pass only to where last switch was made: *)
             Limit := Switch - Offset;
         UNTIL Switch = 0;

        (* No switches at last offset, try one half as big: *)
         Offset := Offset DIV 2;
     END;
 END;

 (* =============================== SortMenu =================================
  *   The SortMenu procedure first calls the Reinitialize procedure to make
  *   sure the SortArray is in its unsorted form, then prompts the user to
  *   make one of the following choices:
  *
  *               * One of the sorting algorithms
  *               * Toggle sound on or off
  *               * Increase or decrease speed
  *               * End the program
  * ==========================================================================
  *)
 PROCEDURE SortMenu;
 BEGIN
     WHILE TRUE DO BEGIN

         ret := VioSetCurPos(FIRSTMENU + NLINES, LEFTCOLUMN + Menu[NLINES].len

         ret := KbdCharIn(ads KeyInfo, 0, 0);
         IF (CHR(KeyInfo.chChar) >= 'a') AND (CHR(KeyInfo.chChar) <= 'z') THEN
             KeyInfo.chChar := KeyInfo.chChar - 32;

         (* Branch to the appropriate procedure depending on the key typed: *)
         CASE CHR(KeyInfo.chChar) OF

             'I': BEGIN
                     curSelect := 0;
                     Reinitialize;
                     InsertionSort;
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             'B': BEGIN
                     curSelect := 1;
                     Reinitialize;
                     BubbleSort;
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             'H': BEGIN
                     curSelect := 2;
                     Reinitialize;
                     HeapSort;
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             'E': BEGIN
                     curSelect := 3;
                     Reinitialize;
                     ExchangeSort;
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             'S': BEGIN
                     curSelect := 4;
                     Reinitialize;
                     ShellSort;
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             'Q': BEGIN
                     curSelect := 5;
                     Reinitialize;
                     QuickSort (1, MaxBars);
                     ElapsedTime(0);     (* Print final time. *)
                  END;

             '>': BEGIN
                    (* Decrease pause length to speed up sorting time,
                     * then redraw the menu to clear any timing results
                     * (since they won't compare with future results): *)
                     IF (Pause <> 0) THEN
                         Pause := Pause - 30;
                     BoxInit;
                  END;

             '<': BEGIN
                    (* Increase pause length to slow down sorting time,
                     * then redraw the menu to clear any timing results
                     * (since they won't compare with future results): *)
                     IF (Pause <> 900) THEN
                         Pause := Pause + 30;
                     BoxInit;
                  END;

             'T': BEGIN
                     Sound := NOT Sound;
                     BoxInit;
                  END;

             ESC: return; (* User pressed ESC, so exit and return to main: *)

             OTHERWISE

         END;
     END;
 END;

 (* =============================== SwapBars =================================
  *   Calls PrintOneBar twice to switch the two bars in Row1 and Row2,
  *   then calls the ElapsedTime procedure.
  * ==========================================================================
  *)
 PROCEDURE SwapBars {(Row1, Row2)};
 BEGIN
     PrintOneBar (Row1);
     PrintOneBar (Row2);
     ElapsedTime (Row1);
 END;

 PROCEDURE cls;
 BEGIN
     ret := VioScrollDn (0, 0, -1, -1, -1, ads 1824, 0);
 END;

 PROCEDURE swaps {(one, two)};
 VAR
     temp: SortType;

 BEGIN
     temp := one;
     one := two;
     two := temp;

 END;

 (* Main program *)
 BEGIN
     if(NOT Screen(1)) THEN cls;
     ret := VioGetMode(ads wMode,0);
     IF (wMode.row <> 43) THEN BEGIN     (* Use 43-line mode if available *)
         wMode.row := 43;
         wmode.hres := 640;              (* Try EGA *)
         wmode.vres := 350;
         IF (VioSetMode(ads wMode,0) <> 0) THEN BEGIN
             wmode.hres := 720;          (* Try VGA *)
             wmode.vres := 400;
             IF (VioSetMode(ads wMode,0) <> 0) THEN BEGIN
                 ret = VioGetMode(ads wMode,0)
                 wMode.row := 25;        (* Use 25 lines *)
                 ret = VioSetMode(ads wMode,0)
             END
         END;
     END;
     MaxBars := ORD(wMode.row);
     Initialize;          (* Initialize data values. *)
     SortMenu;            (* Print sort menu. *)
     if(NOT Screen(0)) THEN cls;
 END.

 \SAMPCODE\PASCAL\PASEXEC.INC

 {   PASEXEC.INC - interface file for C library routines

     This include file along with the CEXEC.LIB library has been included
     with your Pascal 3.32 to show you how easy it is to call routines
     written in our new C 4.00 release.  The CEXEC.LIB contains several
     routines from the C library which we think you will find useful in
     extending the power of your Pascal programs.

     The memory model that Pascal uses is basically medium model (16-bit
     data pointers) with some extensions for large model addressing
     (32-bit data pointers).  The CEXEC.LIB routines are from the large
     model C library.  This means that you should be careful interfacing
     to these routines.  You should use ADS or VARS instead of ADR or VAR
     so that 32-bit addressed get constructed.

     The Microsoft FORTRAN 3.3x, PASCAL 3.32, and C 4.00 releases
     have been designed so that libraries or subprograms can be written
     in any one of these languages and used in any other.

     Try compiling and running the demonstration program DEMOEXEC.PAS
     to see some actual examples.
 }

 {   C function

             int system(string)
                     char *string;

     The system() function passes the given C string (00hex terminated)
     to the DOS command interpreter (COMMAND.COM), which interprets and
     executes the string as an MS-DOS command.  This allows MS-DOS commands
     (i.e., DIR or DEL), batch files, and programs to be executed.

     Example usage in Pascal

     i := system(ads('dir *.for'*chr(0)));

     The interface to system is given below.  The [c] attribute is given
     after the function return type.  The [varying] attribute says the
     function has an undetermined number of parameters; in this case, 1.
 }

     function system : integer [c,varying]; extern;

 {   C function

     int spawnlp(mode,path,arg0,arg1,...,argn)
             int mode;               /* spawn mode */
             char *path;             /* pathname of program to execute */
             char *arg0;             /* should be the same as path */
             char *arg1,...,*argn;   /* command line arguments */
                                     /* argn must be NULL */

     The spawnlp creates and executes a new child process.  There must be
     enough memory to load and execute the child process.  The mode
     argument determines which form of spawnlp is executed as follows:

         Value       Action

           0         Suspend parent program and execute the child program.
                     When the child program terminates, the parent program
                     resumes execution.  The return value from spawnlp is -1
                     if an error has occured or if the child process has
                     run, the return value is the child processes return
                     code.

         _p_overlay  Overlay parent program with the child program.  The
                     child program is now the running process and the
                     parent process is terminated.  spawnlp only returns
                     a value if there has been a recoverable error.  Some
                     errors can not be recovered from and execution will
                     terminate by safely returning to DOS.  This might
                     happen if there is not enough memory to run the new
                     process.

     The path argument specifies the file to be executed as the child
     process.  The path can specify a full path name (from the root
     directory \), a partial path name (from the current working directory),
     or just a file name.  If the path argument does not have a filename
     extension or end with a period (.), the spawnlp call first appends
     the extension ".COM" and searches for the file; if unsuccessful, the
     extension ".EXE" is tried.  The spawnlp routine will also search for
     the file in any of the directories specified in the PATH environment
     variable (using the same procedure as above).

     Example usage in Pascal

     var     NULL : integer4;
     value   NULL := 0;
     ...
     i := spawnlp(0, ads('exemod'*chr(0)), ads('exemod'*chr(0)),
                  ads('demoexec.exe'*chr(0)), NULL);

     The C spawnlp function is expecting the addresses of the strings
     (not the actual characters), so we use the ADS() function to pass
     the address of the strings.  The last parameter to the spawnlp
     routine must be a C NULL pointer which is a 32-bit integer 0, so
     we use an INTEGER4 variable NULL set to 0 as the last parameter.
 }

     var _p_overlay [c,extern] :integer;
     function spawnlp : integer [c,varying]; extern;