Вот, только там есть маленькие недорабоки:
uses CRT, Graph; type TPoint = record X, Y: integer; end; MAS = array[1..1000] of TPoint; var A: MAS; N, C: integer; T1: TPoint; Key: Char; procedure DRIVER; var Gd, Gm: integer; begin Gd:=Detect; InitGraph(Gd, Gm, ''); end; procedure POLE; begin moveto(51, 51); lineto(428, 51); lineto(428, 428); lineto(51, 428); lineto(51, 51); end; procedure PAINT(T: TPoint; N: integer); begin case N of 1: SetColor(White); 2: SetColor(Black); 3: SetColor(Red); end; Rectangle(T.X*15-15+52, T.Y*15-15+52, T.X*15+52, T.Y*15+52); end; procedure GAMEOVER(A: MAS; N: integer; var Key: char); var I: integer; begin if (A[N].X=0) or (A[N].X=26) or (A[N].Y=0) or (A[N].Y=26) then Key:='q'; for I:=1 to N-1 do if (A[N].X=A[I].X) and (A[N].Y=A[I].Y) then Key:='q'; end; procedure METKA(var T1: TPoint); begin T1.X:=Random(25)+1; T1.Y:=Random(25)+1; Paint(T1, 3); end; procedure SNAKE(A: MAS; N: integer; Key: char; var B: MAS); var T: TPoint; I, X, Y: integer; begin case Key of 'w': begin X:=0; Y:=-1; end; 'a': begin X:=-1; Y:=0; end; 's': begin X:=0; Y:=1; end; 'd': begin X:=1; Y:=0; end; end; T:=A[1]; for I:=1 to N-1 do A[I]:=A[I+1]; A[N].X:=A[N].X+X; A[N].Y:=A[N].Y+Y; PAINT(T, 2); for I:=1 to N do PAINT(A[I], 1); for I:=1 to N do B[I]:=A[I]; end; begin DRIVER; POLE; A[1].X:=1; A[1].Y:=1; A[2].X:=2; A[2].Y:=1; N:=2; C:=0; Key:='d'; repeat if C=30 then begin PAINT(T1, 2); METKA(T1); C:=0; end; inc©; if (T1.X=A[N].X) and (T1.Y=A[N].Y) then begin inc(N); C:=30; A[N]:=T1; end; if KeyPressed then Key:=readkey; Delay(9000); SNAKE(A, N, Key, A); GAMEOVER(A, N, Key); until Key='q'; OutTextXY(315, 238, 'GAME OVER'); OutTextXY(302, 250, 'press any key'); readkey; end.