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

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

17.05.2008, 18:02. Показов 1951. Ответов 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
Эксперт
39485 / 9562 / 3019
Регистрация: 12.04.2006
Сообщений: 41,671
Блог
17.05.2008, 18:02
Ответы с готовыми решениями:

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

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

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

0
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
inter-admin
Эксперт
29715 / 6470 / 2152
Регистрация: 06.03.2009
Сообщений: 28,500
Блог
17.05.2008, 18:02
Помогаю со студенческими работами здесь

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

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

Снова старый добрый DOS
/* Текст программы и выходные результаты */ #include <stdio.h> #include <dos.h> main() { int h,i; unsigned char...

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

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


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

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

Новые блоги и статьи
Генераторы Python для эффективной обработки данных
AI_Generated 21.05.2025
В Python существует инструмент настолько мощный и в то же время недооценённый, что я часто сравниваю его с тайным оружием в арсенале программиста. Речь идёт о генераторах — одной из самых элегантных. . .
Чем заменить Swagger в .NET WebAPI
stackOverflow 21.05.2025
Если вы создавали Web API на . NET в последние несколько лет, то наверняка сталкивались с зелёным интерфейсом Swagger UI. Этот инструмент стал практически стандартом для документирования и. . .
Использование Linq2Db в проектах C# .NET
UnmanagedCoder 21.05.2025
Среди множества претендентов на корону "идеального ORM" особое место занимает Linq2Db — микро-ORM, балансирующий между мощью полноценных инструментов и легковесностью ручного написания SQL. Что. . .
Реализация Domain-Driven Design с Java
Javaican 20.05.2025
DDD — это настоящий спасательный круг для проектов со сложной бизнес-логикой. Подход, предложенный Эриком Эвансом, позволяет создавать элегантные решения, которые точно отражают реальную предметную. . .
Возможности и нововведения C# 14
stackOverflow 20.05.2025
Выход версии C# 14, который ожидается вместе с . NET 10, приносит ряд интересных нововведений, действительно упрощающих жизнь разработчиков. Вы уже хотите опробовать эти новшества? Не проблема! Просто. . .
Собеседование по Node.js - вопросы и ответы
Reangularity 20.05.2025
Каждому разработчику рано или поздно приходится сталкиватся с техническими собеседованиями - этим стрессовым испытанием, где решается судьба карьерного роста и зарплатных ожиданий. В этой статье я. . .
Cython и C (СИ) расширения Python для максимальной производительности
py-thonny 20.05.2025
Python невероятно дружелюбен к начинающим и одновременно мощный для профи. Но стоит лишь заикнуться о высокопроизводительных вычислениях — и энтузиазм быстро улетучивается. Да, Питон медлительнее. . .
Безопасное программирование в Java и предотвращение уязвимостей (SQL-инъекции, XSS и др.)
Javaican 19.05.2025
Самые распространёные векторы атак на Java-приложения за последний год выглядят как классический "топ-3 хакерских фаворитов": SQL-инъекции (31%), межсайтовый скриптинг или XSS (28%) и CSRF-атаки. . .
Введение в Q# - язык квантовых вычислений от Microsoft
EggHead 19.05.2025
Microsoft вошла в гонку технологических гигантов с собственным языком программирования Q#, специально созданным для разработки квантовых алгоритмов. Но прежде чем погружаться в синтаксические дебри. . .
Безопасность Kubernetes с Falco и обнаружение вторжений
Mr. Docker 18.05.2025
Переход организаций к микросервисной архитектуре и контейнерным технологиям сопровождается лавинообразным ростом векторов атак — от тривиальных попыток взлома до многоступенчатых кибератак, способных. . .
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin
Copyright ©2000 - 2025, CyberForum.ru