IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

> The Matrix V1.01, Для прикола написал
сообщение
Сообщение #1


Новичок
*

Группа: Пользователи
Сообщений: 40
Пол: Мужской

Репутация: -  0  +


Код
uses crt;
var Del:word;
   i:byte;

procedure WWD(Del:word;Col:byte;Str:string);
   var i:byte;
   begin
   TextColor(Col);
   for i:=1 to length(Str) do
       begin
       delay(Del);
       write(str[i]);
       end;
   for i:=1 to 5 do Delay(Del);
   writeln;
   end;
Procedure MI; {MatrixInitialized}
   type arr35b=array[1..15] of byte;
   var matrix:record
                    element:array[1..25,1..80] of char;
                    color:array[1..25,1..80] of byte;
                    pos:arr35b;          
                    leng:arr35b;        
              end;
       f:boolean;
       i,j,j_2,n:byte;
       s:string;
   begin
   TextColor(2);
   s:='';
   with matrix do        
        for j_2:=1 to 15 do
            begin
            pos[j_2]:=random(80)+1;
            leng[j_2]:=random(15)+1;
            end;
   for i:=25 downto 1 do
       begin
       for j:=1 to 80 do
           begin
           f:=false;
           n:=random(16);
           matrix.color[i,j]:=2;
           for j_2:=1 to n do
               if j=matrix.pos[j_2] then
                  if matrix.leng[j_2]>0 then
                     begin
                     with matrix do
                          begin
                          element[i,j]:=chr(random(256));
                          if leng[j_2]>random(15) then color[i,pos[j_2]]:=10;
                          leng[j_2]:=leng[j_2]-1;
                          end;
                     f:=true;
                     end;
           if f=false then matrix.element[i,j]:=' ';
           end;
       end;            
   while TRUE do      
         begin
         if KeyPressed then
            begin
            s:=s+ReadKey;
            if s='godd rulez forever' then exit;
            if s[length(s)]=#27 then s:='';
            end;
         for i:=1 to 25 do    
             begin
             for j:=1 to 80 do
                 begin
                 GotoXY(j,i);
                 TextColor(matrix.color[i,j]);
                 write(matrix.element[i,j]);    
                 with matrix do
                      begin
                      element[i,j]:=element[i+1,j];
                      color[i,j]:=color[i+1,j];
                      end
                 end;
             Delay(random(10));
             end;              
         for j:=1 to 80 do
             with matrix do
                  begin
                  element[25,j]:=' ';
                  color[25,j]:=2;
                  end;
         with matrix do
              for j_2:=1 to 15 do
                  begin
                  leng[j_2]:=leng[j_2]-1;
                  if leng[j_2]<=0 then
                     begin
                     f:=true;
                     pos[j_2]:=random(80)+1;
                     leng[j_2]:=random(15)+1;
                     element[25,pos[j_2]]:=chr(random(256));
                     color[25,pos[j_2]]:=10;
                     end
                  else element[25,pos[j_2]]:=chr(random(256));
                  if leng[j_2]>random(10)+1 then color[25,pos[j_2]]:=10;
                  end;
         end;
   end;                

begin
clrscr;
randomize;
CheckBreak:=false;
Del:=150;
clrscr;
WWD(Del,8,'Entering the MATRIX v1.01');
WWD(Del*2,2,'');
WWD(Del,2,'Loading');
WWD(Del*2,11,'..........................................');
WWD(trunc(Del*0.5),2,'');
WWD(trunc(Del*0.5),12,'All modules loaded.');
WWD(Del*2,2,'');
WWD(Del,2,'Testing the System');
WWD(Del*2,11,'..........................................');
WWD(trunc(Del*0.5),2,'');
WWD(trunc(Del*0.5),12,'System is OK.');
WWD(Del*2,2,'');
WWD(Del,7,'We are in the MATRIX now!');
WWD(trunc(Del*0.8),2,'');
WWD(Del,2,'Go follow white rabbit and remember...');
WWD(trunc(Del*0.8),2,'');
WWD(Del,10,'MATRIX HAD YOU !!!');
for i:=1 to 10 do Delay(del);
MI;
clrscr;
WWD(Del,2,'Password is right.');
WWD(Del,10,'Yes godd rulez, you right )))');
WWD(Del,2,'Bye!');
for i:=1 to 25 do delay(Del);
clrscr;
TextColor(15);
end.


P.S. Delay настроил под пропатченный CRT.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Бывалый
***

Группа: Пользователи
Сообщений: 180
Пол: Мужской

Репутация: -  2  +


godd
недавно решил нормальную матрицу написать
да ты крут! :D
только это, надо еще людям дырки в затылках проделать, а то с экрана ощущения не те smile.gif (шучу)

chr(7) в наушниках не услышишь, паскаль с саундбластером работать не умеет, только со спикером smile.gif

у xds в проге ассемблер вообще непонятно зачем используется (уж явно не для вывода на экран) - readkey и keypressed (да и setmode вроде) есть в модуле crt, а режим вообще по умолчанию текстовый...
а вывод напрямую в видеопамять можно и без буферов делать - в текстовом режиме скорость достаточная и мерцания не будет (если не очищать экран, конечно):
mem[$B800: y*160+x*2]:=2 - вывод закрашенного смайлика в позицию x,y
mem[$B800: y*160+x*2+1]:=$1E - установка аттрибута там же - желтый на синем фоне...
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

Сообщений в этой теме


 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 





- Текстовая версия 29.03.2024 17:21
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name