Рейтинг@Mail.ru
Menu
Скачать картинки на телефон бесплатно.
Заставки для телефона, аватарки.
(Вырезать из фотографии)

Роза `Гренд Могул` Яхта `Алиса` Лесное озеро Музей `Пирогово` Белочка
Выберите рубрику (тему)

Тема: Курсовая работа – игра ‘Тетрис’, Tetris


1. Постановка задачи
2. Метод решения задачи
3. Описание алгоритма
4. Описание программы
  4.1. Описание главных структур и переменных программы
  4.2. Описание главных процедур и функций
5. Описание интерфейса
6. Результат работы
7. Листинг программы

1. Постановка задачи

  Разработать алгоритм программы, которая выполняет перемещение фигур по экрану сверху вниз, координацию их местонахождения в соответствии с действиями играющего.
  Фигуры состоят из квадратов одинакового размера, набор фигур - конечный, последовательность выпадения фигур - случайная.
  Игрок должен вкладывать фигуры на дно стакана по возможности с большей плотностью (количество незаполненных квадратов должно быть минимальным). При этом ряд, полностью заполненный квадратами, должен автоматически исчезать со стакану. Квадраты не должны накладываться один на один.
  Игрок может остановить и продолжить игру. Уровень определяет количество квадратов и скорость в начале игры.

2. Метод решения задачи

  Программа написана на языке Паскаль. Используются такие стандартные модули: graph (обработки кодов нажатых клавиш), graph (для работы в графическом видеорежиме), и windos (используется таймер).
  Использованное объектно - ориентированное программирование. Основные объекты - это фигура и стакан.
  Выполняется обработка событий от таймера, нажатых клавиш, выбранных пунктов меню.

3. Описание алгоритма

Курсовая работа – игра ‘Тетрис’, Tetris.
Описание алгоритма.
Постановка задачи:
Разработать алгоритм программы, которая выполняет перемещение фигур по экрану сверху вниз, координацию их местонахождения в соответствии с действиями играющего.
Фигуры состоят из квадратов одинакового размера, набор фигур - конечный, последовательность выпадения фигур - случайная.
Игрок должен вкладывать фигуры на дно стакана по возможности с большей плотностью (количество незаполненных квадратов должно быть минимальным). При этом ряд, полностью заполненный квадратами, должен автоматически исчезать со стакану. Квадраты не должны накладываться один на один.
Игрок может остановить и продолжить игру. Уровень определяет количество квадратов и скорость в начале игры.

4. Описание программы

  4.1. Описание главных структур и переменных программы

Типизированные константы:

Количество клеточек в стакане:
  max : byte =20;
  max : byte =30;
Размер одной клеточки:
  size : byte =12;
Уровень сложности - определяет начальную скорость движения и
    заполнение стакана:
  level : byte =1;
Промежуток времени между перемещениями фигуры вниз:
  speed:real=0.4

Объекты:

Фигура:

  TBlock=object
    mx,my,x,y:byte; Координаты фигуры и количество квадратов по
        высоте и ширине

    matr:TmatrixBlock; Елемнт матрицы равняется единице , если
        есть квадрат .

    t:byte; Тип фигуры
    pos:1..4; Положение фигуры
    p,p2:pointer; указатель на рисунок квадрата и на состояние
        экрана до того, как была нарисована фигура

    s,s2:word;
    procedure initmatrix; предоставление начального значения
        матрице

    constructor init;
    constructor init2(t1,pos1:byte); инициализация с
        предоставлением полям t, pos соответствующих значений.

    procedure rotate;virtual; поворот фигуры
    procedure draw;virtual; вырисовывание фигуры
    procedure clear;virtual; стирает фигуру
    destructor done;
  end;

Стакан:
  Tfield=object
    x 1, y 1: integer ; координаты поля
    matr:TMatrixField; если соответствующая каморка заполнена,
        содержит единицу

    constructor init(level:byte); Предоставление начальных
        значений в зависимости от уровня level

    procedure draw; Вырисовывание стакана
    procedure clear ; Исчезновение стакану из экрана
    function full:boolean; Возвращает true если стакан полный
    function fline (n:byte):boolean; Возвращает true если
        строка n полный

    procedure dline (n:byte); Уничтожает n- й строку
    private
    x2,y2:integer; ширина и высота
  end;

Рамка:
  tramka=object
    x,y,width,heigth:integer; координаты , ширина и высота
    lighted:boolean; Если true , то рамка подсвечена
    col1,col2,col3:integer; Цвета фона, активной и
        неактивной рамки

    private
    p:pointer; указатель на состояние экрана до того, как было
        выведено окно

    s:word; соответствующий размер памяти
    public
    constructor init( x1, y1, xx , yy :word);
    procedure mkactive; Установка окна на рамку
    procedure light; Подсветка рамки
    procedure unlight; Рамка неактивного цвета
    procedure draw; Вырисовывание рамки
    procedure clear; Возвращает экран к предыдущему состоянию
    destructor done;
  end;

Вертикальное меню:
  tsubmenu=object(tramka)
    punkts:menutype; массив из названий пунктов меню
    n:byte; количество пунктов
    col4:integer; Цвет пункта меню
    constructor init(const pnk:menutype;n1:byte;x1,y1:word);
    procedure draw;
    function result:byte; Выполняет пермещение между пунктами и
        возвращает номер избранного пункта

    private h:integer; Высота одного пункта
  end;

Горизонтальное меню:
  tmainmenu=object(tsubmenu)
    constructor init(const pnk:menutype;n1:byte);
    procedure draw;
    function result:byte;
    procedure getkoords(i:byte;var x,y:word);
  end;

  4.2. Описание главных процедур и функций

Модуль tetobj:
  procedure kv ( var p : pointer ; VAR s : word ) - возвращает указатель на рисунок квадрата и соответствующий размер памяти

Модуль Int:
  procedure drawmenu ( var res : longint ); Выполняет вывод на экран и обработку меню
  procedure entername(score:longint;var name:string); Ввод имени игрока
  procedure best; Вывод таблицы лучших результатов
  procedure clearbest; Очистка таблицы результатов

Модуль Game:
  procedure startgame(var bl:tblock;var f:tfield;var score:integer); Основная процедура, которая выполняет движение фигуры по полю, вызывает меню и обрабатывает результаты
  function fall ( const bl : tblock ; const f : tfield ): boolean ; Возвращает значение True , если фигура упала на дно стакана
  function left(const bl:tblock; const f:tfield):boolean;
  function right(const bl:tblock; const:tfield):boolean;
  function CanBeRotated(const block:tblock;const field:tfield): boolean; Эти функции возвращает значение true если возможно выполнить, соответственно, движение фигуры влево, вправо, или ее поворот.
  procedure NextFigure(var t1,p1:integer); Выводит следующую фигуру, возвращает ее тип и положение
  procedure OutScore(score : integer); Выводит счет на экран

5. Описание интерфейса

  После запуска программы на экране появляются игровое поле с фигурой, информация о следующем блоке и счет. Игра в начале находится в стане паузы. Вверху экрана - меню.
  Главное меню содержит такие пункты:
    • Игра ( Game)
    • Лучшие результаты (Best Results)
    • Налаживание (Options)
  Выбрать необходимый пункт можно с помощью клавиш-стрелок и клавиши 'enter'. При этом редактируется соответствующее подменю.
  Меню 'Игра' разрешает начать новую игру, продолжить начатую, или выйти из игры.
  Меню 'Лучшие рeзультати' - просмотреть таблицу лучших результатов или очистить ее.
  С помощью меню 'Налаживание', можно изменить размер экрана, или выбрать уровень, из которого начинать игру. На первом уровне в начале игры стакан пустой. На следующих уровнях наиболее низкие горизонтальные ряды игрового поля заполнены.
  Если в любой момент во время игры нажать клавишу Esc, то вызовется меню. Игру будет приостановлено. С помощью пункта Continue ее можно будет продолжить.

6. Результат работы

Курсовая работа – игра ‘Тетрис’, Tetris.
Результат работы (1)

Курсовая работа – игра ‘Тетрис’, Tetris.
Результат работы (2)

Курсовая работа – игра ‘Тетрис’, Tetris.
Результат работы (3)

7. Листинг программы

program main;
{ http://nataliya.kiev.ua }
uses tetobj,game,crt,graph,ramki,int;
    var bl:tblock;f:tfield;
        score:integer;
        s:string;
    procedure myinitgraph;
var gd,gm:integer;

begin
gd:=detect;
initgraph(gd,gm,'c:/bp/bgi');
if graphresult<>0 then
   begin writeln('Graphic Error');readkey;halt end;
end;
begin
release(heaporg);
randomize;
myinitgraph;
repeat startgame(bl,f,score) until 1=2;
entername(score,s);
CLOSEGRAPH;
end.
 
unit TetObj;
{ http://nataliya.kiev.ua }
interface
uses crt,graph;
const maxX:byte=20;
      maxY:byte=30;
      size:byte=12;
      level:byte=1;
      speed:real=0.4;
type TMatrixField=array[0..31,1..45]of 0..1;
     TMatrixBlock=array[1..4,1..4]of 0..1;
     TBlock=object
            mx,my,x,y:byte;
            matr:TmatrixBlock;
            t:byte;
            pos:1..4;
            p,p2:pointer;
            s,s2:word;
            procedure initmatrix;
            constructor init;
            constructor init2(t1,pos1:byte);
            procedure rotate;virtual;
            procedure draw;virtual;
            procedure clear;virtual;
            destructor done;
            end;
     Tfield=object
            x1,y1:integer;
            matr:TMatrixField;
            constructor init(level:byte);
            procedure draw;
            procedure clear;
            function full:boolean;
            function fline (n:byte):boolean;
            procedure dline (n:byte);
            private
             x2,y2:integer;
            end;
implementation

constructor tfield.init;
 var i,j:byte;
 begin
  for i:=1 to maxX do
      for j:=1 to maxY do
          matr[i,j]:=0;
  for i:=0 to maxX+1 do
      matr[i,maxY+1]:=1;
  for j:=1 to maxY do begin
      matr[0,j]:=1;
      matr[maxX+1,j]:=1;
      end;
  randomize;
  for i:=1 to level-1 do
      for j:=1 to MaxX div 2 do
      matr[random(maxX-2)+1,maxY-i+1]:=1;
  x1:=20;y1:=40;
  x2:=size*maxX;
  y2:=size*maxY;
  setviewport(x1,y1,x1+x2,y1+y2,true);
 end;
procedure tblock.initmatrix;
 var i,j:byte;
 begin
 for i:=1 to 4 do
     for j:=1 to 4 do
         matr[i,j]:=0;
 case t of
      1:case pos of
             1,3: begin
                  mx:=4;
                  my:=1;
                  for j:=1 to mx do matr[j,1]:=1;
                  end;
             2,4: begin
                  mx:=1;
                  my:=4;
                  for j:=1 to my do
                      matr[1,j]:=1;
                  end;
             end;
      2: case pos of
             1,3: begin
                  mx:=3;
                  my:=2;
                  matr[1,1]:=1;
                  matr[2,1]:=1;
                  matr[2,2]:=1;
                  matr[3,2]:=1;
                  end;
             2,4: begin
                  mx:=2;
                  my:=3;
                  matr[1,2]:=1;
                  matr[1,3]:=1;
                  matr[2,1]:=1;
                  matr[2,2]:=1;
                  end;
             end;
      3: case pos of
             1: begin
                mx:=3;
                my:=2;
                matr[2,1]:=1;
                matr[1,2]:=1;
                matr[2,2]:=1;
                matr[3,2]:=1;
                end;
             2: begin
                mx:=2;
                my:=3;
                matr[1,1]:=1;
                matr[1,2]:=1;
                matr[1,3]:=1;
                matr[2,2]:=1;
                end;
             3: begin
                mx:=3;
                my:=2;
                matr[2,2]:=1;
                matr[1,1]:=1;
                matr[2,1]:=1;
                matr[3,1]:=1;
                end;
             4: begin
                mx:=2;
                my:=3;
                matr[2,1]:=1;
                matr[2,2]:=1;
                matr[2,3]:=1;
                matr[1,2]:=1;
                end;
             end;
      4: case pos of
             1,3: begin
                  mx:=3;
                  my:=2;
                  matr[2,1]:=1;
                  matr[3,1]:=1;
                  matr[1,2]:=1;
                  matr[2,2]:=1;
                  end;
             2,4: begin
                  mx:=2;
                  my:=3;
                  matr[1,1]:=1;
                  matr[1,2]:=1;
                  matr[2,2]:=1;
                  matr[2,3]:=1;
                  end;
             end;
      5: begin
         mx:=2;
         my:=2;
         for i:=1 to 2 do
             for j:=1 to 2 do
                 matr[i,j]:=1;
         end;
      6: case pos of
         1: begin
            mx:=2;
            my:=3;
            matr[2,1]:=1;
            matr[2,2]:=1;
            matr[2,3]:=1;
            matr[1,3]:=1;
            end;
         2: begin
            mx:=3;
            my:=2;
            matr[1,1]:=1;
            matr[2,1]:=1;
            matr[3,1]:=1;
            matr[3,2]:=1;
            end;
         3: begin
            mx:=2;
            my:=3;
            matr[1,1]:=1;
            matr[1,2]:=1;
            matr[1,3]:=1;
            matr[2,1]:=1;
            end;
         4: begin
            mx:=3;
            my:=2;
            matr[1,1]:=1;
            matr[1,2]:=1;
            matr[2,2]:=1;
            matr[3,2]:=1;
            end;
         end;
       7: case pos of
         1: begin
            mx:=2;
            my:=3;
            matr[1,1]:=1;
            matr[1,2]:=1;
            matr[1,3]:=1;
            matr[2,3]:=1;
            end;
         2: begin
            mx:=3;
            my:=2;
            matr[1,2]:=1;
            matr[2,2]:=1;
            matr[3,2]:=1;
            matr[3,1]:=1;
            end;
         3: begin
            mx:=2;
            my:=3;
            matr[2,1]:=1;
            matr[2,2]:=1;
            matr[2,3]:=1;
            matr[1,1]:=1;
            end;
         4: begin
            mx:=3;
            my:=2;
            matr[1,2]:=1;
            matr[1,1]:=1;
            matr[2,1]:=1;
            matr[3,1]:=1;
            end;
         end;
      end;
 end;


 procedure kv ( var p: pointer;VAR s:word );
var p2:pointer;
    S2:WORD;
begin
s:=imagesize(0,0,size,size);
getmem(p2,s);
getimage(0,0,size,size,p2^);
setfillstyle(1,4);
setcolor(12);
bar(0,0,size,size);
rectangle(2,2,size-1,size-2);
getmem(p,s);
getimage(0,0,size,size,p^);
putimage(0,0,p2^,normalput);
freemem(p2,s);
p2:=nil;
end;

constructor tblock.init;
   var x1,y1,x2,y2,i,j:integer;
 begin
 randomize;
 t:=random(100)mod 7 +1;
 pos:=random(3)+1;
 initmatrix;
 x:=(maxX-mx) div 2;
 y:=2;
 kv(p,s);
 p2:=nil;
   end;
constructor tblock.init2;
begin
 t:=t1;
 pos:=pos1;
 initmatrix;
 x:=(maxX-mx) div 2;
 y:=2;
 kv(p,s);
 p2:=nil;
 end;

procedure tblock.draw;
 var i,j:byte;
 begin
 s2:=imagesize(0,0,mx*size,my*size);
 getmem(p2,s2);
 getimage((x-1)*size,(y-1)*size,(x-1+mx)*size,
                   (y-1+my)*size,p2^);
 for i:=1 to mx do
     for j:=1 to my do
         if matr[i,j]<>0 then putimage((x+i-2)*size,
(y+j-2)*size,p^,normalput);
 end;
procedure tblock.clear;
 var x1,x2,y1,y2:integer;
 begin
 putimage((x-1)*size,(y-1)*size,p2^,normalput);
 freemem(p2,s2);
 p2:=nil;
 end;
procedure tblock.rotate;
 begin
 if pos<4 then inc(pos)else pos:=1;
 x:=x+((mx+1) div 2);
 y:=y+((my+1) div 2);
 x:=x-((mx+1) div 2);
 y:=y-((my+1) div 2);
 initmatrix;
 end;

procedure tfield.draw;
var i,j:byte;
    p:pointer;
    s,r,a,b:word;
    col:word;
    ar:array [1..5,1..4]of word;
 begin
 setfillstyle(1,blue);
 bar(0,0,x2,y2);
  setcolor(3);
 for i:=1 to maxX-1 do
     line(size*i,0,size*i,y2);
 for i:=1 to maxY-1 do
     line(0,size*i,x2,size*i);

 ar[1,1]:=75*maxX*size div 100+4;
 ar[1,2]:=35*maxY*size div 150-4;
 ar[1,3]:=12;
 ar[1,4]:=MaxX*size div 6;

 ar[2,1]:=7*maxX*size div 10+3;
 ar[2,2]:=75*maxY*size div 150-2;
 ar[2,3]:=14;
 ar[2,4]:=MaxX*size div 8;

 ar[3,1]:=3*maxX*size div 10-6;
 ar[3,2]:=1*maxY*size div 10-4;
 ar[3,3]:=13;
 ar[3,4]:=MaxX*size div 10;

 for i:=1 to 3 do begin
  setcolor(ar[i,3]);
  a:=ar[i,1];b:=ar[i,2];
  r:=ar[i,4];
  {1}line(a,b,a+(r*3 div 10) ,b-(r*95)div 100);
  line(a-(r*3 div 10) ,b-(r*95)div 100,a,b);
  line(a+(r*3 div 10),b-(r*95)div 100,a-(r*3 div 10),
     b-(r*95)div 100);
  {2}line(a,b,a+(r*3 div 10) ,b+(r*95)div 100);
  line(a-(r*3 div 10) ,b+(r*95)div 100,a,b);
  line(a-(r*3 div 10),b+(r*95)div 100,a+(r*3 div 10),
     b+(r*95)div 100);
  {3}line(a,b,a-(r*95)div 100,b+(r*3 div 10));
  line(a-(r*95)div 100,b-(r*3 div 10),a,b);
  line(a-(r*95)div 100,b-(r*3 div 10),a-(r*95)div 100,
     b+(r*3 div 10));
  {4}line(a,b,a+(r*95)div 100,b+(r*3 div 10));
  line(a+(r*95)div 100,b-(r*3 div 10),a,b);
  line(a+(r*95)div 100,b-(r*3 div 10),a+(r*95)div 100,
     b+(r*3 div 10));
  {5}line(a+(45*r)div 100,b-(88*r)div 100,a,b);
  line(a+(88*r)div 100,b-(45*r)div 100,a,b);
  line(a+(45*r)div 100,b-(88*r)div 100,a+(88*r)div 100,
     b-(45*r)div 100);
  {6}line(a-(45*r)div 100,b-(88*r)div 100,a,b);
  line(a-(88*r)div 100,b-(45*r)div 100,a,b);
  line(a-(45*r)div 100,b-(88*r)div 100,a-(88*r)div 100,
     b-(45*r)div 100);
  {7}line(a-(45*r)div 100,b+(88*r)div 100,a,b);
  line(a-(88*r)div 100,b+(45*r)div 100,a,b);
  line(a-(45*r)div 100,b+(88*r)div 100,a-(88*r)div 100,
     b+(45*r)div 100);
  {8}line(a+(45*r)div 100,b+(88*r)div 100,a,b);
  line(a+(88*r)div 100,b+(45*r)div 100,a,b);
  line(a+(45*r)div 100,b+(88*r)div 100,a+(88*r)div 100,
     b+(45*r)div 100);
   end;
 kv( p,s );
 for i:=1 to maxX do
     for j:=1 to maxY do
         if matr [i,j] = 1 then putimage( (i-1)*size,
(j-1)*size,p^,normalput );
 freemem( p,s );
 p:=nil;
end;
procedure tfield.clear;
begin
 setviewport(x1,y1,x1+x2,y1+y2,true);
 setfillstyle(1,0);
 bar(0,0,x2,y2)
end;
function tfield.full;
 var i:byte;
 begin
   full:=false;
   for i:=1 to maxX do
       if matr[i,2]<>0 then full:=true ;
 end;
function tfield.fline;
 var i:byte;
     t:boolean;
 begin
   t:=true;
   for i:=1 to maxX do
       if matr[i,n]=0 then t:=false;
   fline:=t;
 end;
procedure tfield.dline;
 var i,j:byte;
     pr:^pointer;
     sz:word;
 begin
   for j:=n downto 2 do
       for i:=1 to maxX do
           matr[i,j]:=matr[i,j-1]
 end;
destructor tblock.done;
 begin
 if p<>nil then freemem (p,s);
 if p2<>nil then freemem (p2,s2 );
 p:=nil;
 p2:=nil;
 end;
begin
end.
 
unit ramki;
{ http://nataliya.kiev.ua }
interface
uses graph,crt;
type menutype=array[1..10]of string[15];

     tramka=object
     x,y,width,heigth:integer;
     lighted:boolean;
     col1,col2,col3:integer;
     private
      p:pointer;
      s:word;
     public
      constructor init( x1, y1, xx , yy :word);
      procedure mkactive;
      procedure light;
      procedure unlight;
      procedure draw;
      procedure clear;
      destructor done;
     end;

     tsubmenu=object(tramka)
      punkts:menutype;
      n:byte;
      col4:integer;
      constructor init(const pnk:menutype;n1:byte;x1,y1:word);
      procedure draw;
      function result:byte;
      private h:integer;
      end;

     tmainmenu=object(tsubmenu)
      constructor init(const pnk:menutype;n1:byte);
      procedure draw;
      function result:byte;
      procedure getkoords(i:byte;var xI,yI:word);
      end;

 implementation

constructor tramka.init;
 begin
 x:=x1;
 y:=y1;
 width:=xx;
 heigth:=yy;
 lighted:=false;
 col1:=2;
 col2:=4;
 col3:=14;
 end;

procedure tramka.mkactive;
 begin
 setviewport( x,y,x+width, y+heigth ,true);
 end;

procedure tramka.light;
 begin
 if not lighted then begin
 mkactive;
 setcolor(red);
 setlinestyle(0,$11,1);
 rectangle(1,1,width-1,heigth-1) ;
 lighted:=true;
 end;
 end;

procedure tramka.unlight;
 begin
 if lighted then begin
 mkactive;
 setcolor(14);
 setlinestyle(0,$11,1);
 rectangle(1,1,width-1,heigth-1) ;
 lighted:=false;
 end;
 end;

procedure tramka.draw;
 begin
 mkactive;
 s:=imagesize( 0,0,width ,heigth );
 getmem( p,s);
 getimage( 0,0,width,heigth,p^ );
 setfillstyle(1,green);
 bar( 0,0,width,heigth );
 light;
 end;

destructor tramka.done;
begin
if p<>nil then freemem(p,s);
p:=nil;
end;

procedure tramka.clear;
 begin
 mkactive;
 unlight;
 putimage(0,0,p^,normalput);
 if p<>nil then freemem(p,s);
 p:=nil;
 end;

constructor tsubmenu.init;
var i:byte;
begin
 n:=n1;
 h:=15;
 tramka.init(x1,y1,80,n*h+4);
 for i:=1 to n do punkts[i]:=pnk[i];
 col4:=14;
end;

procedure tsubmenu.draw;
var i:byte;
begin
 tramka.draw;
 setfillstyle(1,col4);
 for i:=1 to n do begin
     bar(3,(i-1)*h+3,width-3,(i)*h);
     setcolor(col4);
     rectangle(3,(i-1)*h+3,width-3,(i)*h) ;
     setcolor(0);
     outtextXY( 4, (i-1)*h+h div 2 , punkts[i])
     end;
 setcolor( red ); outtextXY( 4, h div 2 , punkts[1]);
 rectangle(3,3,width-3,h);

end;

function tsubmenu.result;
var c:char; var i:byte;
begin
 c:='q';
 draw;
 i:=1;
 repeat
  c:=readkey;
  case c of
   #72: begin
        setcolor( 0 );
        outtextXY( 4,(i-1)*h+h div 2,punkts[i] );
        setcolor(col4);
        rectangle(3,(i-1)*h+3,width-3,(i)*h) ;
        if i=1 then i:=n
           else i:=i-1;
        setcolor ( red );
        outtextXY( 4,(i-1)*h+h div 2,punkts[i] );
        rectangle(3,(i-1)*h+3,width-3,(i)*h) ;
        end;
   #80: begin
        setcolor( 0 );
        outtextXY( 4,(i-1)*h+h div 2,punkts[i] );
        setcolor(col4);
        rectangle(3,(i-1)*h+3,width-3,(i)*h) ;
        if i=n then i:=1
           else i:=i+1;
        setcolor ( red );
        outtextXY( 4,(i-1)*h+h div 2,punkts[i] );
        rectangle(3,(i-1)*h+3,width-3,(i)*h) ;
        end;
   end;
  until (c=#13) or (c=#27) ;
 if (c=#13) then result:=i
    ELSE result:=0;
 while keypressed do readkey;
end;

constructor tmainmenu.init;
var i:byte;
begin
 n:=n1;
 heigth:=20;
 width:=getmaxX-4;
 h:=width div n;
 tramka.init(2,2,width,heigth);
 for i:=1 to n do punkts[i]:=pnk[i] ;
 col4:=14;
end;

procedure tmainmenu.draw;
var i:byte;
begin
 tramka.draw;
 setfillstyle(1,col4);
 setlinestyle(0,$aa,1);
 for i:=1 to n do begin
     bar((i-1)*h+3,3,i*h-1,heigth-3);
     setcolor(col4);
     rectangle((i-1)*h+3,3,i*h-1,heigth-3) ;
     setcolor(black);
     outtextXY( (i-1)*h+5, heigth div 2, punkts[i])
     end;
 setcolor( red ); outtextXY( 5, heigth div 2 , punkts[1]);
 rectangle(3,3,h-1,heigth-3);
end;

function tmainmenu.result;
var c:char; var i:byte;
begin
 c:='q';
 draw;
 i:=1;
 repeat
  c:=readkey;
  case c of
   #75: begin
        setcolor( 0 );
        outtextXY( (i-1)*h+5, heigth div 2 , punkts[i]);
        setcolor(col4);
        rectangle((i-1)*h+3,3,i*h-1,heigth-3) ;
        if i=1 then i:=n
           else i:=i-1;
        setcolor ( red );
        outtextXY( (i-1)*h+5, heigth div 2 , punkts[i]);
        rectangle((i-1)*h+3,3,i*h-1,heigth-3) ;
        end;
   #77: begin
        setcolor( 0 );
        outtextXY( (i-1)*h+5, heigth div 2 , punkts[i]);
        setcolor(col4);
        rectangle((i-1)*h+3,3,i*h-1,heigth-3) ;
        if i=n then i:=1
           else i:=i+1;
        setcolor ( red );
        outtextXY( (i-1)*h+5, heigth div 2 , punkts[i] );
            rectangle((i-1)*h+3,3,i*h-1,heigth-3) ;
        end;
   end;
  until (c=#13);
 if c=#13 then result:=i
    ELSE result:=n+1;
end;
procedure tmainmenu.getkoords;
begin
yI:=heigth+2;
xI:=x+(i-1)*h;
end;
begin
end.
 
unit int;
{ http://nataliya.kiev.ua }
interface
uses ramki,graph,crt,tetobj;
procedure drawmenu(var res:longint);
procedure entername(score:longint;var name:string);
procedure best;
procedure clearbest;
implementation
procedure drawmenu;
var xI,yI:word;
    i,j,k:byte;
    C,d:CHAR;
    block:tblock;
    field:tfield;
    x1,y1,x2,y2:integer;
    smenu,op:tsubmenu;
    mmenu:tmainmenu;
const men:menutype=('Game','Best Results','Options',
            '','','','','','','');
         smen1:menutype=('Start','Continue','Exit',
'','','','','','','');
         smen3:menutype=('Size','Level',
'','','','','','','','');
         smen2:menutype=('Results','Clear',
'','','','','','','','');
         speed:menutype=('Level1','Level2','Level3',
'Level4','Level5','','','','','');
         sz:menutype=('Small','Normal','Large',
'','','','','','','');
begin
mmenu.init(men,3);
i:=mmenu.result;
mmenu.unlight;
mmenu.getkoords(i,xI,yI);
case i of
     1:begin
       smenu.init(smen1,3,xI,yI);
       j:=smenu.result;
       smenu.clear;
       if j=1 then res:=1;
       if j=2 then res:=2;
       if j=3 then res:=-3;
       smenu.done;
       end;
     2:begin
       smenu.init(smen2,2,xi,yi);
       j:=smenu.result;
       smenu.clear;
       if j=1 then res:=-1;
       if j=2 then res:=-2;
       smenu.done;
       end;
     3:begin
       smenu.init(smen3,2,xI,yI);
       j:=smenu.result;
       smenu.unlight;
       if j=1 then begin
          op.init(sz,3,smenu.x + smenu.width,smenu.y+3);
          k:=op.result;
          op.clear;
          op.done;
          if k=1 then res:=3;
          if k=2 then res:=4;
          if k=3 then res:=5;
          end;
       if j=2 then begin
          op.init(speed,5,smenu.x + smenu.width,smenu.y+3);
          k:=op.result;
          op.clear;
          op.done;
          if (k>=1)and(k<=5)then res:=5+k;
          end;
       smenu.clear;
       smenu.done;
       end;
     end;
end;
procedure entername;
type t=record
     name:string;
     score:longint;
     end;
     tf=file of t;
var a,b:tf;
    c,d,t1:t;
    ram:tramka;
    i:byte;
    bool:boolean;
begin
 bool:=false;
 assign(a,'file.txt');
 reset(a);
 assign(b,'temp.txt');
 rewrite(b); t1.score:=score;
 i:=0;
 while (not eof(a))and(i<=12) do
  begin
  i:=i+1;
  read(a,c);
  write(b,c);

  end;
 close(a); close(b); rewrite(a); reset(b);
 c.score:=1000000;
 read(b,d);
 write(a,c);
 while not eof(b) do
 begin
 c:=d;
 read(b,d);
 if (d.score=score)
 then begin
     ram.init((GetMaxX-300)div 2,(GetMaxY-200)div 2,300,200);
     ram.draw;
     SetTextJustify(1,1);
     OutTextXY(ram.width div 2, 30, 'Enter your nane:');
     SetTextJustify(0,2);
     setfillstyle(1,10);
     bar((ram.width-150)div 2,115,(ram.width+150)div 2,135);
     GotoXY(33,17);
     textcolor(red);
     textbackground(1);
     readln(name);
     t1.name:=name;
     write(a,t1);
     ram.clear;
     ram.done;
     bool:=true;
     end;
 write(a,d);
 end;
 close(a);
 close(b);
 if bool then best;
 end;
procedure best;
 type t=record
     name:string;
     score:longint;
     end;
     tf=file of t;
var a:tf;
    i:byte;
    x:t;
    ram:tramka;
    st:string;
begin
 ram.init((GetmaxX-400)div 2,(GetMaxY-300)div 2,400,300);
 ram.draw;
 assign(a,'file.txt');
 reset(a);
 read(a,x);
 for i:=1 to 10 do if not eof(a) then
 begin
 GoToXY(100,100);
 read(a,x);
 str(x.score,st);
 outTextXY(20,50+i*15,x.name); OutTextXY(200,50+i*15,st);
 end;
 while keypressed do readkey;readkey;
 ram.clear;
 ram.done;
end;
procedure clearbest;
 type t=record
     name:string;
     score:longint;
     end;
     tf=file of t;
var f:tf;
    tt:t;
    i:byte;
begin
assign(f,'file.txt');
rewrite(f);
tt.score:=100000;
write(f,tt);
for i:=1 to 50 do begin
tt.name:='noname';
tt.score:=5;
write(f,tt);
end;
close(f);
end;
begin
end.

unit game;
{ http://nataliya.kiev.ua }
interface
uses graph,crt,windos,tetobj,ramki,int;
procedure startgame(var bl:tblock;var f:tfield;
   var score:integer);
function time:real;

implementation
var ramka,r:tramka;
    ng:boolean;
CONST cont:boolean=false;
      ch:char=#27;
function time;
 var h,m,s,ms : word;
 begin
     Gettime(h,m,s,ms);
     time:=3600*h+60*m+s+ms/100;
end;

function fall(const bl:tblock; const f:tfield):boolean;
 var t:boolean;
     i,j:byte;
 begin
   t:=false;
   for i:=1 to bl.mx do
       for j:=bl.my downto 1 do
           if ( bl.matr[i,j]<>0 )and
              ( f.matr[bl.x+i-1,bl.y+j]<>0 )
           then t:=true;
   fall:=t;
 end;

function left(const bl:tblock; const f:tfield):boolean;
 var t:boolean;
     i,j:byte;
 begin
   t:=false;
   for j:=1 to bl.my do
       for i:=bl.mx downto 1 do
           if ( bl.matr[i,j]<>0 )and
              ( f.matr[bl.x+i-2,bl.y+j-1]<>0 )
           then t:=true;
   left:=t;
 end;

function right(const bl:tblock; const f:tfield):boolean;
 var t:boolean;
     i,j:byte;
 begin
   t:=false;
   for j:=1 to bl.my do
       for i:=bl.mx downto 1 do
           if ( bl.matr[i,j]<>0 )and
              ( f.matr[bl.x+i,bl.y+j-1]<>0 )
           then t:=true;
   right:=t;
 end;

procedure AddBlock( const b:tblock; var f:tfield);
var i,j:byte;
begin
 for i:=1 to b.mx do
     for j:=1 to b.my do
         if b.matr[i,j]=1 then f.matr[b.x+i-1,b.y+j-1]:=1;
 b.done;
 end;

procedure NextFigure(var t1,p1:integer);
var bb:tblock;
begin
ramka.clear;
ramka.draw;
ramka.light;
OutTextXY(10,10,'Next:');
bb.init;
bb.x:=4-(bb.mx div 2);
bb.y:=5-(bb.my div 2);
bb.draw;
t1:=bb.t;
p1:=bb.pos;
bb.done;
end;

function CanBeRotated(const block:tblock;
             const field:tfield):boolean;
 var m,i,j:byte;
     t:boolean;
 begin
  if block.mx>block.my then m:=block.mx else m:=block.my;
  t:=true;
  for i:=1 to m do
      for j:=1 to m do
          if field.matr[block.x+i-1,block.y+j-1]<>0 then
             t:=false;
  CanBeRotated:=t;
 end;

procedure OutScore(score : integer);
 var strsc:string;
 begin
  r.clear;
  r.draw;
  r.light;
  str(score,strsc);
  outtextxy(5,10,'Score:');
  outtextxy(5,25, strsc);
 end;


procedure changeoptions(k:byte;var speed:real);
begin
if k=1 then begin size:=15;
                  maxX:=15;
                  maxY:=24;
       end;
if (k=2) then begin size:=12;
                  maxX:=20;
                  maxY:=30
       end;
if k=3 then begin size:=12;
                  maxX:=25;
                  maxY:=35
       end;

if k=4 then speed:=0.5;
if k=5 then speed:=0.45;
if k=6 then speed:=0.4;
if k=6 then speed:=0.37;
if k=7 then speed:=0.33;
if (k>=4)and(k<=8)then level:=k-3;
end;
procedure StartGame;
var i,j:byte;
    tm,sc:real;
    k1,k2:integer;
    re:longint;
    stt:string;
begin
 re:=0;
 score:=0;
 sc:=score;
 f.init(level);
 f.draw;
 ramka.init(350,50,6*size,7*size);
 ramka.draw;
 r.init(350,200,50,50);
 r.draw;
 nextfigure( k1,k2 );
 Outscore(score);
 setviewport( f.x1,f.y1,f.x1+size*maxX,f.y1 + size*maxY, false);
while (not f.full)do begin
tm:=time;
bl.init2(k1,k2);
nextfigure( k1,k2 );
setviewport( f.x1,f.y1,f.x1+size*maxX,f.y1 + size*maxY, false);
bl.draw;
{ch:='/'; }
while (not fall(bl,f))do begin delay(1000);
      if keypressed then begin
         ch:=readkey;
         if ch=#0 then ch:=readkey;
         bl.clear;
         case ch of
                #75: if not left(bl,f) then bl.x:=bl.x-1;
                #77: if not right(bl,f) then bl.x:=bl.x+1;
                #72: if canberotated(bl,f)then bl.rotate;
                end; bl.draw; end;
           if (time>=tm+speed)or (ch=#80) then begin
         bl.clear;
         bl.y:=bl.y+1;
         tm:=time ;
         bl.draw;
       end;
         if (ch=#27) then BEGIN
            ramka.unlight;r.unlight;
            REPEAT cont:=true;
            drawmenu(re);
            ch:='?';
            if re=-1 then best ;
            if re=-2 then begin clearbest;best;end;
            if (re>=3)or(re=1)or(re=-3) then begin
            if cont then begin
            entername(score,stt);
            bl.done;
            f.clear;
            ramka.clear;
            r.clear;
            ramka.done;
            r.done;
            changeoptions(re-2,speed);
            end;
            if re=-3 then halt;
            exit;end;
          UNTIL RE=2;
          ch:='?';
          ramka.light;r.light;
          setviewport( f.x1,f.y1,f.x1+size*maxX,
          f.y1+size*maxY, false);
            END;
      end;
addblock(bl,f);
bl.done;
for j:=1 to maxY do begin;
 if f.fline(j) then begin
  f.dline(j);
  f.clear;
  f.draw;
  score:=score+10;
  outscore( score );
  setviewport( f.x1,f.y1,f.x1+size*maxX,f.y1 + size*maxY ,true);
  if score>=sc+50 then begin
   sc:=score;
   speed:=0.8*speed;
   end;
  end;
 CH:=' '
 end;
end;
cont:=false;
bl.done;
f.clear;
ramka.clear;
r.clear;
ramka.done;
r.done;
entername(score,stt);
drawmenu(re);
end;
begin
CONT:=FALSE;
end.
Download: Tetris.zip (46Kb)
Случайный анекдот

Домашняя идиллия в семье программиста. Папа смотрит телевизор. Сынишка выходит из-за компьютера и спрашивает:
- Папа, а что означает "Format drive C: completed" ???
Дата: 24-10-2004   Автор: Admin   Подрубрика: Компьютеры и дети