0 / 0 / 0
Регистрация: 16.08.2015
Сообщений: 1
1

Старый добрый тетрис

17.05.2008, 18:02. Показов 1890. Ответов 0
Метки нет (Все метки)

Студворк — интернет-сервис помощи студентам
Помогите вывести текущий результат и следующую фигуру. Заранее благодарен.
Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
{ Программа Тетрис}
 
uses crt, graph;
 
type tFigure=array[1..4,1..4] of byte;
     tFigures=array[1..7,1..4] of tFigure;
     tColors=record
       workbox:byte;
       figures:array[1..7] of byte;
     end;
 
Const HeightBox=18; WidthBox=9; { размеры стакана }
 
var Figures:^tFigures; Colors:tColors;
 
Procedure LoadFigures; { чтение фигур из файла }
var f:text; s:string; i,j,k,l:byte;
begin
  assign(f,'c:\tetris.dat'); reset(f);
  for j:=1 to 7 do
    for i:=1 to 4 do
      for k:=1 to 4 do begin
        readln(f,s);
        for l:=1 to 4 do if s[l]='1' then Figures^[j,i,k,l]:=1 else Figures^[j,i,k,l]:=0;
  end;
  close(f);
end;
 
Procedure Game(x,y:byte);
var box:array[1..HeightBox+1,0..WidthBox+1] of byte; { стакан }
    num,rot,xf,yf:integer; { тип фигуры, ее положение и координаты }
    c:char;
    i,j,k:integer;
 
    Lines:word; { кол-во убраных линий }
    Speed:Word; { скорость - чем меньше, тем быстрее }
 
    timer:longint absolute $40:$6c; old:longint; { для реализации задержки }
 
Procedure PutBox; { вывод стакана }
var i,j:integer;
begin
  for i:=1 to HeightBox do begin
    gotoxy(x+1,y+i);
    for j:=1 to WidthBox do begin
      textattr:=box[i,j];
      if box[i,j]=0 then textattr:=colors.workbox;
      write('  ');
    end;
  end;
end;
 
Procedure PutFigure; { вывод фигуры }
var i,j:integer;
begin
  textattr:=colors.figures[num];
  for i:=1 to 4 do begin
    for j:=1 to 4 do begin
      if Figures^[num,rot,i,j]=1 then begin
        gotoxy(x+1+xf*2+pred(j)*2,y+i+pred(yf)); write('  ');
      end;
    end;
  end;
end;
 
Function Check(dx,dy:shortint):boolean; { проверка может ли фигура сместиться
                                          по dx,dy }
var i,j:integer; ok:boolean;
begin
  ok:=true;
  for i:=1 to 4 do for j:=1 to 4 do
    if figures^[num,rot,i,j]=1 then
      if box[yf+pred(i)+dy,xf+j+dx]>0 then ok:=false;
  Check:=ok;
end;
 
Procedure Loser; { что будет в случае проигрывания }
begin
  textattr:=7; clrscr;
  writeln('вы проиграли набрав ',lines,' полных линий');
  readkey;
  c:=#27;
end;
 
begin
  x:=pred(x); y:=pred(y);
  textattr:=colors.workbox;
 
  fillchar(box,sizeof(box),0); { очистка стакана }
  { задание границ движений фигуры }
  for i:=1 to HeightBox do begin box[i,0]:=2; box[i,WidthBox+1]:=2 end;
  for j:=0 to WidthBox+1 do box[HeightBox+1,j]:=2;
 
  Randomize;
 
  Speed:=36; { установка задержки до опускания фигуры вниз примерно на
               2 секунды ( генерация 18.2 раза в секунду * 2секунды = ~36 ) }
  lines:=0;  { убраных линий нет }
 
  { The GAME }
  num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
  old:=timer;
  repeat
    PutBox; { выводим стаканчик }
    PutFigure; { выводим фигуру }
    gotoxy(80,25); { убираем курсор }
    repeat until keypressed or (abs(old-timer)>speed);
    { обработка клавиатуры }
    if keypressed then begin
      c:=readkey;
      if c=#0 then case readkey of
        #72:begin { поворот фигуры }
              inc(rot); if rot=5 then rot:=1;  { произвели поворот }
              if not check(0,0) then begin { проверка на невозможность }
                dec(rot); if rot=0 then rot:=4; { вернули все обратно }
              end;
            end;
        #75:if Check(-1,0) then dec(xf); { сдвиг влево }
        #77:if Check(1,0) then inc(xf);  { сдвиг вправо }
        #80:begin                        { падение фигуры }
              while Check(0,1) do inc(yf); { фигура движется вниз пока возможно }
 
              for i:=1 to 4 do for j:=1 to 4 do { оставляем след фигуры в стакане }
                if figures^[num,rot,i,j]=1 then
                  box[yf+pred(i),xf+j]:=colors.figures[num];
 
              { генерируем новую фигуру }
              num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
 
              { проверка стакана на наличие полных линий }
              for i:=1 to HeightBox do begin
                k:=0;
                for j:=1 to WidthBox do if box[i,j]>0 then inc(k);
                if k=WidthBox then begin { линия заполнена }
                  inc(Lines); { увеличиваем счет}
                  { удаляем линию }
                  for k:=i downto 2 do for j:=1 to WidthBox do box[k,j]:=box[pred(k),j];
                end;
              end;
 
              if not check(0,0) then loser; { если новой фигуре негде
                 появиться, то проигрыш }
            end;
      end;
    end else
    { обработка прошедшего времени }
    begin
      { если возможно, то сдвигаем фигуру вниз }
      if Check(0,1) then inc(yf) else begin { иначе... }
        { оставляем след фигуры в стакане }
        for i:=1 to 4 do for j:=1 to 4 do
          if figures^[num,rot,i,j]=1 then box[yf+pred(i),xf+j]:=colors.figures[num];
 
        { генерируем новую фигуру }
        num:=random(7)+1; rot:=1; xf:=WidthBox div 2-2; yf:=1;
 
        { проверка стакана на наличие полных линий }
        for i:=1 to HeightBox do begin
          k:=0;
          for j:=1 to WidthBox do if box[i,j]>0 then inc(k);
          if k=WidthBox then begin
            inc(Lines);
            for k:=i downto 2 do for j:=1 to WidthBox do box[k,j]:=box[pred(k),j];
          end;
        end;
 
        if not check(0,0) then loser; { если новой фигуре негде
           появиться, то проигрыш }
      end;
      old:=timer;
    end;
  until c=#27;
end;
 
var i:byte;
begin
  textattr:=7; clrscr;
  New(Figures);
  with Colors do begin
    workbox:=7*16;
    for i:=1 to 7 do figures[i]:=16*pred(i);
    figures[1]:=6*16;
  end;
  LoadFigures;
  Game(2,2);
 
  textattr:=7; clrscr;
end.
файл образов фигур TETRIS.DAT
0000 ---- первая фигура
1111
0000
0000
0100
0100
0100
0100
0000
1111
0000
0000
0100
0100
0100
0100 ---- конец первой фигуры
0000 ---- вторая фигура
1110
0010
0000
0100
0100
1100
0000
0000
1000
1110
0000
0110
0100
0100
0000 ---- конец второй фигуры
0000 ---- третья фигура
0010
1110
0000
0100
0100
0110
0000
0000
1110
1000
0000
0110
0010
0010
0000 ---- конец третьей фигуры
0000 ---- четвертая фигура
0110
0110
0000
0000
0110
0110
0000
0000
0110
0110
0000
0000
0110
0110
0000 ---- конец четвертой фигуры
0100 ---- пятая фигура
1110
0000
0000
0100
0110
0100
0000
0000
1110
0100
0000
0100
1100
0100
0000 ---- конец пятой фигуры
0010 ---- шестая фигура
0110
0100
0000
1100
0110
0000
0000
0010
0110
0100
0000
1100
0110
0000
0000 ---- конец шестой фигуры
0100 ---- седьмая фигура
0110
0010
0000
0011
0110
0000
0000
0100
0110
0010
0000
0011
0110
0000
0000 ---- конец !!!
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
17.05.2008, 18:02
Ответы с готовыми решениями:

Старый добрый дос
Всем привет. Интересует программа прозвонки IP адреса из списка например CSV по определенному порту...

Старый добрый COMPORT
Как же надоели эти ком порты, уже неделю занимаюсь с ними а толку ноль. У меня C++ Bulder....

Старый добрый экран смерти
Здравствуйте! Проблема заключается в том, что в процессе работы за ПК происходит длительное (1-2...

Старый добрый Runas и локалка
Добрый день всем форумчанам! Было время, и пользовался я WinXP и был я доволен как небольшой...

0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
17.05.2008, 18:02
Помогаю со студенческими работами здесь

старый добрый ряд фурье
народ расскажите что делаю не так... делалось в мат каде нужно разложить функцию в ряд Фурье,...

Снова старый добрый DOS
/* Текст программы и выходные результаты */ #include <stdio.h> #include <dos.h>...

старый добрый синий экран
Здравствуйте. Сегодня решил включить комп после четырёх лет простоя. Все 4 года он был отключен и...

А давайте, приукрасим старый добрый VB6
Всем добрый день! Надоела "серая обыденность" VB6..)) Перепробовал ряд манифестов (в основном от...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
1
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2023, CyberForum.ru