Power-Programmierung/CD1.mdf/pascal/library/dos/multtsk/tasker4/neat.pas

Pascal/Delphi Source File | 1988-01-07 | 5.2 KB | 234 lines

PROGRAM Tasking_Demo;
{$R- ,$S- ,$N-}
{
  Author  : Michael Warot;
  Date    : November 1987
  Purpose : Demonstrate the TASKER unit
}
Uses Crt,Drivers,Graph,Tasker;

Type
  Str  = String[255];

Var
  Dx1,Dy1,
  Dx2,Dy2,
  X1,X2,Y1,Y2  : Integer;
  C            : Char;
  Clr,CC       : Byte;
  Gd,Gm        : Integer;
  MaxColor     : Word;
  MaxX,MaxY,
  MinX,MinY    : Integer;

Procedure Exit;
Begin
  CloseGraph;
  Halt(0);
End; { Exit }

Procedure DoClip2(Var  a,da    : Integer;
                       Min,Max : Integer);
Begin
  a := a + (da div 256);
  If (a <= Min) or (a >= Max) then
  begin
    da := -da;
    a := a + (da div 256);
  end;
End;

Procedure DoClip(Var  a,da    : Integer;
                      Min,Max : Integer);
Begin
  a := a + da;
  If (a <= Min) or (a >= Max) then
  begin
    da := -da;
    a := a + da;
  end;
End;

Procedure Task_N(MinX,MaxX,MinY,MaxY,Time,Speed : Integer);
Var
  cx1,cy1,
  cx2,cy2,
  X1,X2,Y1,Y2  : Integer;
  C            : Char;
  Clr,CC       : Byte;
  i            : integer;

Begin
  cx1 := dx1; cx2 := dx2;
  cy1 := dy1; cy2 := dy2;

  X1 := MinX; Y1 := MinY;  CC := 0;
  X2 := MinX; Y2 := MinY;  Clr:= 1;
  Repeat
    SetColor(Clr);
    Line(          X1,          Y1,          X2,          Y2);
    Line(MaxX+MinX-X1,          Y1,MaxX+MinX-X2,          Y2);
    Line(          X1,MaxY+MinY-Y1,          X2,MaxY+MinY-Y2);
    Line(MaxX+MinX-X1,MaxY+MinY-Y1,MaxX+MinX-X2,MaxY+MinY-Y2);

    DoClip(x1,cx1,MinX,MaxX);
    DoClip(x2,cx2,MinX,MaxX);
    DoClip(y1,cy1,Miny,Maxy);
    DoClip(y1,cy2,Miny,Maxy);

    CC := CC + 1;
    If CC > Time then
    Begin
      cc := 0;
      Clr := Succ(Clr) mod Succ(MaxColor);
    end;
    For i := 1 to speed do
      Yield;
  Until KeyPressed;
  C := ReadKey;
 Exit;
End; { Task_N }

Procedure Ball(MinX,MaxX,MinY,MaxY,Speed : Integer);
{
  Bouncing ball.....
}
Type
  Ball_Record = Record
                  x,dx,ox  : Integer;
                  y,dy,oy  : Integer;
                  color       : byte;
                end;

Var
  C : Char;
  i : integer;
  balls      : array[1..10] of ball_record;

Begin
  for i := 1 to 10 do
  with balls[i] do
    Begin
      X  := MinX+Random(MaxX-MinX); Y  := MinY+Random(MaxY-MinY);
      DX := random(320)+16;         dy := random(320)+16;
      OX := X;                      oy := y;
      color := random(MaxColor)+ 1;
    end;
  Repeat
    for i := 1 to 10 do
    with balls[i] do
    begin
      DoClip2(x,dx,MinX,MaxX);
      DoClip2(y,dy,MinY,MaxY);
      PutPixel(ox,oy,0);
      PutPixel( x, y,Color);
      ox := x;
      oy := y;
      if dy > 0 then
        dy := dy + 150
      else
        dy := dy + 160;
      if ( (y >= MaxY-3) and (abs(dy) < 1000) ) then
      Begin
        X  := MinX+1;                 Y  := MinY+1;
        dx := 100+random(1000);       dy := 100+random(100);
      end;
    end;
    For i := 1 to speed do
      yield;
  until False;
End; { Ball }

Procedure GoodYear(Speed : Integer);
Var
  Data : String[255];
  i    : integer;
Begin
  Data := '               Blue Star Systems   MS-DOS specialists, '+
          ' Software, Data recovery, and many other services available.   ';
  Repeat
    GotoXY(6,2);
    For i := 1 to 15 do
      Write(Data[i]);
    Data := Data + Data[1];
    Delete(Data,1,1);
    For i := 1 to speed do
      Yield;
  Until False;
End; { GoodYear }

Procedure GoodYear2(Speed : Integer);
Var
  Data : String[255];
  i    : integer;
Begin
  Data := '    This demo program was written for Turbo Pascal 4.0 '+
          ' and is available with source from'+
          ' Blue Star Systems.  7751 Chestnut Ave, Hammond, IN 46324';
  Repeat
    GotoXY(8,25);
    For i := 1 to 20 do
      Write(Data[i]);
    Data := Data + Data[1];
    Delete(Data,1,1);
    For i := 1 to speed do
      Yield;
  Until False;
End; { GoodYear2 }

procedure Abort(Msg : string);
begin
  Writeln(Msg, ': ', GraphErrorMsg(GraphResult));
  Halt(1);
end;

Begin
  { Register all the drivers }
  if RegisterBGIdriver(@CGADriverProc) < 0 then
    Abort('CGA');
  if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
    Abort('EGA/VGA');
  if RegisterBGIdriver(@HercDriverProc) < 0 then
    Abort('Herc');
  if RegisterBGIdriver(@ATTDriverProc) < 0 then
    Abort('AT&T');
  if RegisterBGIdriver(@PC3270DriverProc) < 0 then
    Abort('PC 3270');

  Gd := Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then
    Halt(1);

  Case Gd of
    CGA : SetGraphMode(CGAC0);
  End; { Case Graphic Driver }
  DirectVideo := False;

  Init_Tasking;

  MaxColor := GetMaxColor;
  MaxX := GetMaxX - 10;   MinX := 10;
  MaxY := GetMaxY - 10;   MinY := 10;

  DX1 := 1;
  DY1 := 2;
  DX2 := 3;
  DY2 := -2;

  Fork; IF child_process THEN Task_N(210,310, 10,110,   50,15);

  Fork; IF child_process THEN Task_N(250,300,120,150,   60,12);

  Fork; IF child_process THEN Task_N(250,300,155,195,   20,13);

  Fork; IF child_process THEN Ball(10, 40,50,199,10);

  Fork; IF child_process THEN GoodYear(40);
  Fork; IF child_process THEN GoodYear2(60);

  Task_N(50,199,30,179, 100, 3);

END.