Program ScreenSaver; {}
{$G+}
Uses Graph;
const
  Nx = 40;
  Ny = 30;
  NCells = (Nx-15)*(Ny-10);
  dX = 640 div Nx;
  dY = 480 div Ny;
  Xm = Nx div 2;
  Ym = Ny div 2;
  MoveRight     = 0;{000}
  MoveLeft      = 1;{001}
  MoveUp        = 4;{100}
  MoveDown      = 5;{101}
  MoveUpRight   = 2;{010}
  MoveUpLeft    = 3;{011}
  MoveDownLeft  = 6;{110}
  MoveDownRight = 7;{111}
var
   D, R, e : Integer;
   Hor, Ver : Longint;
   i, j : Integer;
   Direction : LongInt;
   CellField : array [0..Nx+1, 0..Ny+1] of Boolean;
   CellColor : array [0..Nx+1, 0..Ny+1] of Byte;
   Seed : Word;
{------------------}
Function ReadKey : Char;Assembler;
asm
   mov ah, 10h
   int $16
end;
{----------------}
Procedure ResetTimer;Assembler;
asm
    mov      cx, 0
    mov      dx, 1
    mov      ah, $86
    int      $15
    jnc       @1
    mov ah, 83h
    mov al, 1
    int 15h
@1:
end;
{------------------}
Procedure Delay(V, W : Word);Assembler;
asm
  @1:
    mov      cx, Word Ptr V
    mov      dx, Word Ptr W
    mov      ah, $86
    int      $15
{    jc       @1}
end;
{------------------------}
Function MyRand1 : Word; Assembler;
asm
  jmp @4
@3:
  mov ax, word ptr seed
  mov cx, 8
@1:
  mov bx, ax
  and bx, 002Dh
  xor bh, bl
  clc
  jpe @2
  stc
@2:
  rcr ax, 1
  loop @1
  mov word ptr seed, ax
  mov ah, 0
  ret
@4:
  call @3
  push ax
  call @3
  pop dx
  mov ah, al
  mov al, dl
end;
Function KeyPressed : Boolean;Assembler;
asm
 mov ah, $0B
 int $21
end;
{------------------------}
Procedure DrawCell(X, Y : Integer);
begin
  SetFillStyle(1, CellColor[X, Y]);
  Bar((X-1)*dX+1, (Y-1)*dY+1, X*dX-1, Y*dY-1);
end;
{------------------------}
Procedure DeleteCell(X, Y : Integer);
begin
  SetFillStyle(1, Black);
  Bar((X-1)*dX+1, (Y-1)*dY+1, X*dX-1, Y*dY-1);
end;
{------------------------}
Function MoveCell(XX, YY, Xt, Yt : Integer):Boolean;
begin
  if CellField [XX, YY] and not CellField [Xt, Yt] then
   if not (CellField [XX+1  , YY+1] and CellField [XX+1, YY] and CellField [XX, YY+1] and
   CellField [XX+1, YY-1] and CellField [XX-1, YY+1] and CellField [XX-1, YY-1] and CellField [XX-1, YY] and
   CellField [XX, YY-1] ) then
    if (CellField[Xt+1, Yt+1] and CellField[Xt+1, Yt] and CellField[Xt, Yt+1] and
    CellField[Xt-1, Yt-1] and CellField[Xt-1, Yt+1] and CellField[Xt+1, Yt-1] and
    CellField[Xt-1, Yt] and CellField[Xt, Yt-1]) then
   begin
     CellField[XX, YY] := False;
     CellField[Xt, Yt] := True;
     CellColor[Xt, Yt] := CellColor[XX, YY];
     CellColor[XX, YY] := Black;
     DeleteCell(XX, YY);
     DrawCell(Xt, Yt);
     MoveCell:=True;
   end
  else MoveCell:=False;
end;
{------------------------}
Procedure InitCells;
var
  N : Integer;
  X, Y, X0, Y0 : Integer;
begin
  FillChar(CellField, SizeOf(CellField), False);
  FillChar(CellColor, SizeOf(CellColor), 0);
  N := 0;
  X0 := Random(12) - 5 + Nx div 2;
  Y0 := Random(12) - 5 + Ny div 2;
  CellColor [X0, Y0]:=Random(15)+1;
  DrawCell(X0, Y0);
  While N < NCells do
  begin
    X := Random(11)-5;
    Y := Random(11)-5;
    X := X div 5;
    Y := Y div 5;
    X0 := X0+X;
    Y0 := Y0+Y;
    if X0<1 then X0 := 1;
    if X0>Nx then X0:= Nx;
    if Y0<1 then Y0 := 1;
    if Y0>Ny then Y0:= Ny;
    if CellField[X0, Y0]=False then
    begin
      CellField[X0, Y0]:=True;
      CellColor[X0, Y0]:=Random(15)+1;
      DrawCell(X0, Y0);
      inc(N);
{      Delay(0, 5000);}
    end;
  end; {While N ', Hor, ' Ver-> ', Ver);
      end;
     MoveDown:
      begin
        dec(Ver);
        WriteLn('Вниз': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveLeft:
      begin
        inc(Hor);
        WriteLn('Влево': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveRight:
      begin
        dec(Hor);
        WriteLn('Вправо': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveUpLeft:
      begin
        inc(Ver);
        inc(Hor);
        WriteLn('Вверх-влево': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveUpRight:
      begin
        inc(Ver);
        dec(Hor);
        WriteLn('Вверх-вправо': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveDownLeft:
      begin
        dec(Ver);
        inc(Hor);
        WriteLn('Вниз-влево': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
     MoveDownRight:
      begin
        dec(Ver);
        dec(Hor);
        WriteLn('Вниз-вправо': 20, ' Hor-> ', Hor, ' Ver-> ', Ver);
      end;
   end;
   Delay(0, 1000);
  end;
end;
{------------------------}
Procedure RandomCells;
var
  X, Y, X0, Y0 : Integer;
begin
  ReadKey;
  While not KeyPressed do
  begin
   X := Random(Nx*Ny) div Ny + 1;
   Y := Random(Ny*Nx) div Nx + 1;
   Repeat
    X0 := Nx-(Random(X*Ny) div Ny - X div 2 + Nx div 2);
    Y0 := Ny-(Random(Y*Nx) div Nx - Y div 2 + Ny div 2);
    if KeyPressed then Exit;
   Until MoveCell(X, Y, X0, Y0);
{   Delay(0, 5000);}
  end;
end;
{------------------------}
begin
  D := Detect;
  InitGraph(D, R, '');
  e := GraphResult;
  if e <> grOk then
   begin
     WriteLn('Ошибка инициализации графического режима!(ошибка ', e,')');
     WriteLn(GraphErrorMsg(e));
     Halt($FA00+e);
   end;
  asm
    mov ax, 3h
    int 10h
  end;
  ResetTimer;
  Randomize;
  Seed := Lo(RandSeed);
  InitCells;
  RandomCells;
  ReadKey;
  for i := 1 to Nx do
    for j := 1 to Ny do
      if CellField[i, j] then inc(e);
  WriteLn(e);
  ReadKey;
  CloseGraph;
  RunCells;
end.

Назад