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

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

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

> Движущийся текст ... :?
сообщение
Сообщение #1


Новичок
*

Группа: Пользователи
Сообщений: 11

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


    Народ, срочно нужна помощь.....
 Подскажите сылку где мона достать текст проги в которой напечатоное слово передвигалось бы по экрану С КАКИМИНИБУДЬ ЭФЕКТАМИ. У меня ето слово только по кругу ездиет и УСЕ sad.gif .
Если у когонибудь есть чтонибудь похожее, ПЛИЗ подскажите текст проги  :-/ .
                    ??? ??? ???


--------------------
Умная мысль может пpийти и к дуpаку. Hо с ее стоpоны это будет глупостью.
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
 
 Ответить  Открыть новую тему 
Ответов
сообщение
Сообщение #2


Профи
****

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

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


Получай, эксперементируй... (минимум асма!)

Код
{$R-,Q-,S-,Q-}
uses Crt;

{-$i pal_rad.src}
procedure SetPalette;
var   N:Integer;
begin
 Port[$3C8] := 0;
 for N := 0 to 2 do
   Port[$3C9] := 0;
 for N := 3 to 256*3-1 do
   Port[$3C9] := Round(Abs(Sin(N*21167.0))*63);
end; {of SetPalette}

var BIOSTicks: Longint absolute $0040:$006C;

procedure VIDMode(Mode : Byte);assembler;
 asm mov ah,$00;  mov al,mode; int 10h; end;

var Scr: array[0..199,0..319] of Byte absolute $A000:$0000;

type TFont=array[0..32767] of Byte;
var  Font:^TFont absolute 0:$10C;
const FontHeight:Byte=8;
const FontScale:Byte=2;

procedure DrawLetter(L:Char; X,Y:Word; Color:Byte);
var I,J:Word;
begin
 for I:=0 to 7 do
   for J:=0 to 7 do
     if X-J*FontScale*(Y-80) div 50<320 then begin
      Inc(Scr[Y+I*FontScale,X-J*FontScale]
            ,((Font^[Ord(L)*8+I] shr J) and 1)*Color);
      Inc(Scr[Y+I*FontScale,X-J*FontScale+1]
            ,((Font^[Ord(L)*8+I] shr J) and 1)*Color);
      Inc(Scr[Y+I*FontScale+1,X-J*FontScale]
            ,((Font^[Ord(L)*8+I] shr J) and 1)*Color);
      Inc(Scr[Y+I*FontScale+1,X-J*FontScale+1]
            ,((Font^[Ord(L)*8+I] shr J) and 1)*Color);
     end;
end;

procedure Letter(L:Char; X:Word; Color:Byte);
begin
 X:=340-(640-X) mod 400;
 DrawLetter(L,X,160-Abs(Round(50*Cos((200-X)/256*2*PI))),Color);
end;

{---------------------------MAIN PROGRAM-------------------------}

var
 I : Longint;
 J,K,L: Word;
 X:Word;
const S:string='Test string';
begin
 Randomize;

 VIDMode($13);                       { 320x200x256 graphics mode }
 SetPalette;

 I:=0;
 repeat

   for K:=1 to Length(S) do begin
     if I<>0 then
       Letter(S[K],320-(I-1)+K*8*FontScale,-K*16);
       Letter(S[K],320-I+K*8*FontScale,K*16);
     {for L:=0 to 7 do
       for J:=0 to 7 do begin
         Dec(Scr[80+L*FontScale+Round(-32*Abs(Sin(((-(I-1)/8+K)*8)*2*PI/64)))
            ,50+(-(I-1)-J+K*8)*FontScale]
            ,((Font^[Ord(S[K])*8+L] shr J) and 1)*(K)*16);
         Inc(Scr[80+L*FontScale+Round(-32*Abs(Sin(((-I/8+K)*8)*2*PI/64)))
            ,50+(-I-J+K*8)*FontScale]
            ,((Font^[Ord(S[K])*8+L] shr J) and 1)*(K)*16);
         end;}
   end;
   if KeyPressed then case ReadKey of
     ' ': ReadKey;
     #27: Break;
   end;
   Inc(I);
 until False;

 vidMode($03);                       { return to 80x25 textmode }
end.

 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

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


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

 





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