Змейка(Snake)

Program MSnake;
  Uses Crt, Graph;
  Type
    TElem = ^TStek;
    TStek = record
      X : integer;      { координаты по X }
      Y : integer;      { координаты по Y }
      Num : Word;       { номер элемента }
      Next : TElem;     { следующий элемент змейки }
      Prev : TElem;     { предыдущий элемент змейки }
    End;
 
    TDir = 1..4;        { 4 вида направления движения }
    TSnake = object
      First : TElem;    { первый элемент змейки }
      Last : TElem;     { последний элемент змйки }
      Direction : TDir; { направление змейки }
      Length : Word;    { длина змейки }
      Color : Word;     { цвет змеи }
      Esize : Word;     { размер эдиничного элемента }
      Asize : Word;     { размер яблока }
      pSn : pointer;    { для хранения в дим. памяти }
      pA : pointer;     { для хранения изоб. яблока в памяти }
      aX,aY : word;     { координаты яблока }
      AMaxX : word;     { максимум по горинзотали }
      AMAxY : word;     { максимум по вертикале }
 
      constructor Create(sDirection : TDir;
                         sLength : Word;
                         sX, sY : Word;
                         sColor : Word);
      { процедура создания змеи }
      destructor Destroy;
      { процедура уничтожения змеи }
 
      {procedure Release;}
      { процедура, выводящая всю змею на массив (чтобы знать, }
      { где расположена змея, вдруг будем вставлять алгоритм  }
      { поиска пути или еще, что-то) }
 
      function  CorrectCoord: boolean;
      { ф-ция для проверки корректности кординат яблока }
 
      procedure DrawApple;
      { процедура рисует яблоко на поле }
 
      procedure NewApple;
      { процедура создает новое яблоко}
 
      function EatApple : boolean;
      { ф-ция для проверки не сьела ли яблоко змея }
 
      function Snack : boolean;
      { ф-ция проверяет не укулила ли она себя }
 
      procedure Draw;
      { процедура прорисовки всей змейки }
 
      procedure DrawElement(Elem : TElem);
      { процедура отрисовывает определенный элемент змеи }
 
      procedure Clear;
      { процедура стирает змею }
 
      procedure ClearElement(Elem : TElem);
      { процедура стирает определенный элемент змеи }
 
      procedure Move(newX,newY : integer);
      { двигает все элементы змейки на место предыдущего, }
      { а первыый на новый координаты можно с помощью этой процедуры }
      { двинуть змейку вообще в какое-нибудь случайное место, }
      { а все элементы потом "телепортируются" туда }
      procedure Add;
      { добавляет к змейке элемент (последний) }
      procedure Remove;
      { уничтожает элемент змейки (последний) }
 
      {function GetByNumber(Num : Word) : TElem;}
      { находить элемент по номеру }
{      function GetByCoord(X,Y : Word) : TElem;   }
      { находит элемент по координатам}
 
      { Вдруг понадобится найти элемент с определенным номером }
      { или расположением }
 
      procedure SetDirection(sDirection : TDir);
      { устанавливает направление змейки }
    End;
 
  constructor TSnake.Create(sDirection : TDir;
                            sLength : Word;
                            sX,sY : Word;
                            sColor : Word);
    Var
      i : integer;
      Beg,Tek,Tek2 : TElem;
    Begin
      If sDirection = 3 Then Direction := 1
      Else Direction := sDirection;
      Length := sLength;
      Color := sColor;
 
      First := nil;
      Last := nil;
 
      { делаем проверку на правильное введение координат }
      { проверяем, что не вышле за пределы экрана }
      If (sX < 1) or (sX > AMaxX) or (sY < 1) or (sY > AMaxY) or ((sX+sLength)>AMaxX)
        Then Begin
          OutTextXY(0,0,'Error Creating Snake');
          Exit;
        End;
 
      If sLength = 0 Then
        Begin
          OutTextXY(0,0,'Error Creating Snake');
          Exit;
        End;
      New(Beg);    { создаем первый элемент змейки }
 
      Beg^.X := sX + sLength*14;{ координата X - координаты конца + длина }
      Beg^.Y := sY;             { по Y все координаты одинаковый }
      Beg^.Num := 1;            { номер естественно первый }
      Beg^.Next := nil;         { следующего элемента пока нет }
      Beg^.Prev := nil;         { предыдущего тоже }
 
      first := beg;             { запомнили первый элемент змейки }
                                { с этого момента в змейке есть первый элемент}
 
      Tek := beg;               { текущий элемент - первый }
      If (sLength - 1) < 1 Then { если длина 1, тогда ВСЕ }
        exit;
 
      For i := 1 to (sLength-1) do
        Begin
          New(Tek2);            { создаем новый элемент }
 
          Tek2^.X := Tek^.X - 14;{ располагаем новый элемент левее }
          Tek2^.Y := Tek^.Y;    { по оси Y все находятся одинаково }
          Tek2^.Next := nil;    { следующий элемент должен быть тот, }
                                { который мы до этого создали }
          Tek2^.Prev := nil;    { предыдущего пока не существует }
 
          Tek2^.Num := Tek^.Num + 1; { прибавляем номер }
 
          Tek^.Next := Tek2;    { предыдущий ставим существование следующего }
          Tek := Tek2;          { текущий - вновь созданный }
          Last := Tek2;         { последний созданный элемент - это и есть последний}
        End;
 
      { рисуем единичный элемент и сохраняем его в памяти }
      SetFillStyle(WideDotFill,15);
      PieSlice(sX,sY,0,360,10);
      Esize := ImageSize(sX-10,sY-10,sX+10,sY+10);
      GetMem(pSn,Esize);
      GetImage(sX-10,sY-10,sX+10,sY+10,pSn^);
      PutImage(sX-10,sY-10,pSn^,XorPut);
 
      { яблоко }
      Repeat
        aX := {random(AMaxX-10)+10}50;
        aY := {random(AMaxY-10)+10}50;
      Until CorrectCoord;
 
      SetFillStyle(SolidFill,10);
      PieSlice(aX,aY,0,360,3);
      Asize := ImageSize(aX-3,aY-3,aX+3,aY+3);
      GetMem(pA,Asize);
      GetImage(aX-3,aY-3,aX+3,aY+3,pA^);
    End;
 
  destructor TSnake.Destroy;
    Var
      Tek,Tek2 : TElem;
    Begin
      Tek := First;
      If Tek = nil Then Exit;   { вдруг змеи нет }
 
      While Tek^.Next <> nil do
        Begin
          Tek2 := Tek^.Next;
          Dispose(Tek2);        { уничтожаем }
          Tek := Tek2;
        End;
      FreeMem(pSn,Esize);        { освобождаем память }
      FreeMem(pA,Asize);
    End;
 
  function TSnake.CorrectCoord: boolean;
    Var Tek : TElem;
    Begin
      Tek := First;
      If Tek=nil then Exit;
 
      While Tek^.Next<>nil do
        Begin
          If (Tek^.X = aX) and (Tek^.Y = aY) Then
            Begin
              CorrectCoord := false;
              Exit;
            End;
          Tek := Tek^.Next;
        End;
 
      CorrectCoord := true;
    End;
 
  procedure TSnake.DrawApple;
     Begin
       PutImage(aX-3,aY-3,pA^,XorPut);
     End;
 
  procedure TSnake.NewApple;
    Begin
      Repeat
        aX := random(AMaxX-10)+10;
        aY := random(AMaxY-10)+10;
      Until CorrectCoord;
    End;
 
  function TSnake.EatApple : boolean;
    Begin
      If (First^.X in [aX-8..aX+8]) and (First^.Y in [aY-8..aY+8]) Then
        Begin
          EatApple := true;
          Exit;
        End;
 
      EatApple := false;
    End;
 
  function TSnake.Snack : boolean;
    Var
      x,y : word;
      Tek : TElem;
    Begin
      x := First^.X; y := First^.Y;
 
      Tek := First^.Next;
      While Tek <> nil do
        Begin
          If (x = Tek^.X) and (y = Tek^.Y) Then
            Begin
              Snack := true;
              exit;
            End;
          Tek := Tek^.Next;
        End;
 
      Snack := false;
    End;
 
  procedure TSnake.DrawElement(Elem:TElem);
    Begin
      PutImage(Elem^.X-10,Elem^.Y-10,pSn^,NormalPut);
    End;
 
  procedure TSnake.Draw;
    Var Tek:TElem;
    Begin
      Tek:=First;
      If Tek=nil Then Exit;
      DrawElement(Tek);
      While Tek^.Next<>nil do
        Begin
          Tek:= Tek^.Next;
          DrawElement(Tek);
        End;
    End;
 
  procedure TSnake.ClearElement(Elem:TElem);
    Begin
      PutImage(Elem^.X-10,Elem^.Y-10,pSn^,XorPut);
    End;
 
  procedure TSnake.Clear;
    Var Tek:TElem;
    Begin
      Tek:=First;
      If Tek=nil Then Exit;
      ClearElement(Tek);
      While Tek^.Next<>nil do
        Begin
          Tek:= Tek^.Next;
          ClearElement(Tek);
        End;
    End;
 
  procedure TSnake.Move(newX,NewY:integer);
    Var Tek,TEk2 : TElem;
    Begin
      If First=nil Then Exit;
      tek := First;
 
      If newX>AMaxX Then newX:=1;
      If newX<1 Then newX:=AMaxX;
      If newY>AMaxY Then newY:=1;
      If newY<1 Then newY:=AMaxY;
 
      While Tek^.Prev <> nil do
        Begin
          Tek2 := Tek^.Next;
          Tek^.X := Tek2^.X;
          Tek^.Y := Tek2^.Y;
          Tek := tek2;
        End;
 
      First^.X := newX;
      First^.Y := NewY;
 
      {ClearDevice;}
      If EatApple Then
        Begin
          Add;
          NewApple; DrawApple;
        End;
    End;
 
  procedure TSnake.SetDirection(sDirection:TDir);
    Begin
      If (sDirection=1) and (Direction=3) Then exit;
      If (sDirection=3) and (Direction=1) Then exit;
      If (sDirection=2) and (Direction=4) Then exit;
      If (sDirection=4) and (Direction=2) Then exit;
 
      Direction := sDirection;
    End;
 
  procedure TSnake.Add;
    Var Tek : TElem;
    Begin
      new(Tek);
      Tek^.X := 0;              { координаты можно ставить любые, }
      Tek^.Y := 0;              { все равно при движении все восстановится как надо }
      Tek^.Next := nil;
      Tek^.Prev := Last;
      Tek^.Num := Last^.Num+1;
      Last^.Next := tek;
 
      Inc(length);
 
      Last := Tek;
 
    End;
 
  procedure TSnake.Remove;
    Var Tek : TElem;
    Begin
      If Last=First Then Exit;
 
      Tek := Last;
      Last := Tek^.Prev;
      Last^.Next := nil;
      Dispose(Tek);
 
      Inc(length,-1);
    End;
 
  Var
   ch : char;
   Snake : TSnake;
 
 
  procedure GraphInterface;
    Var
      Driver, Mode, Error : integer;
    Begin
      Driver := Detect;
      InitGraph(Driver,Mode,'BGI\');
      Error := GraphResult;
      If Error <> GrOk Then
        Begin
          Writeln(GraphErrorMsg(Error));
          Readkey;
          Halt(Error);
        End;
    End;
 
BEGIN
  ClrScr;
    GraphInterface;
    Snake.AMaxX := GetMaxX; Snake.AMaxY := GetMaxY;
    Snake.Create(1,5,15,15,0);
    Snake.Draw;
    Repeat
      If not Keypressed Then
        Begin
          Snake.Clear;
          Case Snake.Direction of
            1 : Snake.Move(Snake.First^.X+14,Snake.First^.Y);
            2 : Snake.Move(Snake.First^.X,Snake.First^.Y+14);
            3 : Snake.Move(Snake.First^.X-14,Snake.First^.Y);
            4 : Snake.Move(Snake.First^.X,Snake.First^.Y-14);
          End;
          Snake.Draw;
        End
      Else
        Begin
          ch := Readkey;
          If ch=#0 Then ch := Readkey;
          Case ch of
            #72 : Snake.SetDirection(4);  { вверх }
            #77 : Snake.SetDirection(1);  { вправо }
            #75 : Snake.SetDirection(3);  { влево }
            #80 : Snake.SetDirection(2);  { вниз}
            #32 : Snake.Remove;
            #13 : Snake.Add;
            #27 : Exit;
          End;
        End;
      Delay(500);
    until false;
    Snake.destroy;
  Readkey;
END.