home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / turbopas / concr4.arc / CPDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1988-04-17  |  4KB  |  175 lines
  1. program cpdemo;
  2.  
  3. { Concurrent programming demonstration program }
  4.  
  5. {$R-}              { Range checking off }
  6. {$B-}              { Boolean short circuit }
  7. {$S-}              { Stack checking off }
  8. {$I+}              { I/O checking on }
  9. {$N-}              { No numeric coprocessor }
  10. {$D+}              { Debug information on }
  11. {$T+}              { Map on }
  12. {$M 32768,16384,16384}
  13.  
  14. Uses
  15.   Dos,
  16.   TPCrt,
  17.   CpExec;
  18.  
  19. procedure DisplayFile1;
  20. { Display the contents of a text file. }
  21.   const
  22.     filename = 'cpdemo.pas';
  23.   var
  24.     ch: char;
  25.     i: word;
  26.     s: string;
  27.     f: text;
  28.   begin
  29.     TaskWindow(1, 1, 40, 20, Cyan, White, LightGray, False,
  30.       ' Display ' + filename + ' ');
  31.     assign(f, filename);
  32.     repeat
  33.       for i := 1 to 5 do
  34.         begin
  35.           {$i-} reset(f); {$i+}
  36.           if ioresult = 0
  37.             then
  38.               begin
  39.                 while not eof(f) do
  40.                   begin
  41.                     readln(f, s);
  42.                     writeln(s);
  43.                     TaskSwitch
  44.                   end;
  45.                 close(f)
  46.               end
  47.             else writeln('Cannot find ', filename);
  48.         end;
  49.       ClaimInput;
  50.       write('Hit any key to continue ');
  51.       while not KeyPressed do
  52.         TaskSwitch;
  53.       ch := ReadKey;
  54.       ReleaseInput;
  55.       ClrScr;
  56.       delay(1000)
  57.     until False
  58.   end;
  59.  
  60. procedure DisplayFile2;
  61. { Display the contents of a text file. }
  62.   const
  63.     filename = 'cpexec.pas';
  64.   var
  65.     save: byte;
  66.     s: string;
  67.     f: text;
  68.   begin
  69.     TaskWindow(41, 1, 80, 10, Magenta, White, Cyan, False,
  70.       ' Display ' + filename + ' ');
  71.     assign(f, filename);
  72.     repeat
  73.       reset(f);
  74.       while not eof(f) do
  75.         begin
  76.           readln(f, s);
  77.           writeln(s);
  78.           TaskSwitch
  79.         end;
  80.       close(f);
  81.       save := TextAttr;
  82.       TextBackground(LightGray);
  83.       TextColor(Red + Blink);
  84.       writeln;
  85.       write('5 second delay - other tasks continue');
  86.       TextAttr := save;
  87.       delay(5000)
  88.     until False
  89.   end;
  90.  
  91. procedure SimpleArithmetic;
  92. { Do some simple arithmetic. }
  93.   var
  94.     i, j: word;
  95.   begin
  96.     TaskWindow(41, 11, 80, 20, Red, White, Yellow, False,
  97.       ' Some Simple Arithmetic ');
  98.     i := 1;
  99.     j := 1;
  100.     repeat
  101.       writeln(i, ' * ', j, ' = ', i * j:2);
  102.       Inc(i);
  103.       if odd(i)
  104.         then Inc(j);
  105.       TaskSwitch
  106.     until False
  107.   end;
  108.  
  109. procedure HarderMath;
  110. { Do some mathematics that's just a little harder. }
  111.   var
  112.     i: word;
  113.     x: real;
  114.   begin
  115.     TaskWindow(41, 11, 80, 20, Red, White, Yellow, False,
  116.       ' Just a Little Harder ');
  117.     x := 0.0;
  118.     repeat
  119.       writeln(i, ' * exp(', x:4:2, ') = ', i * exp(x):4:2);
  120.       Inc(i);
  121.       if odd(i)
  122.         then x := x + 0.1357;
  123.       TaskSwitch
  124.     until False
  125.   end;
  126.  
  127.   var
  128.     ch: char;
  129.     count: word;
  130.     DFtask1, DFtask2, SAtask, HMtask: word;
  131.     PtrDFtask1, PtrDFtask2, PtrSAtask, PtrHMtask: pointer;
  132.  
  133.   begin { main }
  134.     ClrScr;
  135.  
  136.     TaskInstall(@DisplayFile1, 1000, DFtask1, PtrDFtask1);
  137.     TaskInstall(@DisplayFile2, 1000, DFtask2, PtrDFtask2);
  138.     TaskInstall(@SimpleArithmetic, 1000, SAtask, PtrSAtask);
  139.  
  140.     TaskWindow(1, 21, 80, 25, Green, White, Yellow, True, ' Main Program ');
  141.     writeln('Hit any key to issue command ');
  142.     write('To stop program, enter "H"');
  143.     ch := ' ';
  144.     count := 0;
  145.     repeat
  146.       Inc(count);
  147.       if (count mod 200) = 0
  148.         then
  149.           begin
  150.             TaskRemove(HMtask, PtrHMtask, 1000);
  151.             TaskInstall(@SimpleArithmetic, 1000, SAtask, PtrSAtask)
  152.           end
  153.       else if (count mod 100) = 0
  154.         then
  155.           begin
  156.             TaskRemove(SAtask, PtrSAtask, 1000);
  157.             TaskInstall(@HarderMath, 1000, HMtask, PtrHMtask)
  158.           end;
  159.       ClaimInput;
  160.       if KeyPressed
  161.         then
  162.           begin
  163.             ch := ReadKey;
  164.             write(': ');
  165.             readln(ch);
  166.             ReleaseInput
  167.           end
  168.         else
  169.           begin
  170.             ReleaseInput;
  171.             TaskSwitch
  172.           end
  173.     until UpCase(ch) = 'H'
  174.   end.
  175.