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

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

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

 
 Ответить  Открыть новую тему 
> Бегущая строка
сообщение
Сообщение #1


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

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


Поискал по форуму, особо ничего не нашел, так что предлагайте свои варианты smile.gif

Вот мой вариант, но есть пара нюансов. Первый связан с чтением текста из файла, есть 2 варианта, 1 - читать по строкам, суммировать длины строк, а потом вторым проходом по файлу опять же читать строками и присоединять к динамическому массиву (вариант подсказан volvo). Этот вариант быстрее, но из-за чтения строками проскакивают управляющие символы, что неприемлемо + строки в файле могут быть > 255 символов. Второй вариант - сначала читать посимвольно, вычисляя размерность массива, а потом опять же посимвольно читать и заносить в массив, попутно проверяя, является ли символ допустимым. 2-й вариант годится, но работает медленнее.

И вторая проблема - это мерцание из-за clrscr. Ну тут видимо надо просто алгоритм вывода другой придумать, чтобы не затирать постоянно экран (clreol дает тот же эффект) smile.gif

управление: "-","+" - уменьшение/увеличение скорости "бега" строки
"c" - поменять цвет smile.gif))

ps текстовый файлик в аттаче.
pps комилятор BP 7.0 Так что для FPC например придется подкорректировать задержку и дельту изменения задержки, у меня по дефолту 25000 и 5000 соответвенно.

program _running_string;

uses crt;

type

PTMESSAGE = ^TMESSAGE;
TMESSAGE = array [1..1] of char;
INT = word;
LINT = longint;

TRUNSTR = object
msg: PTMESSAGE;
msg_len: INT;

_delay: INT;
color: byte;

rows, cols: byte;

constructor create(const file_name: string;
const delay_time: INT; const _color: byte);

destructor free;
procedure run;

procedure define_scrmode;

{ test procs }
procedure msg_print;
{ test procs }
end;



{ test procs }
procedure TRUNSTR.msg_print;
var
i: INT;
begin
clrscr;
for i := 1 to msg_len do begin
if i mod cols = 0 then writeln;
write(msg^[i]);
end;
end;
{ test procs }

procedure TRUNSTR.define_scrmode;

function get_scrsize: INT;
var
r: byte absolute $0000:$0484;
c: byte absolute $0000:$044A;
begin
if Hi ( LastMode ) = 1 then
get_scrsize := succ( r ) * c * 2
else
get_scrsize := 25 * c * r;
end;

function get_col_count: INT;
begin
get_col_count := MEM[0:$44A];
end;

function get_row_count: INT;
begin
get_row_count := get_scrsize div get_col_count div 2;
end;

begin
rows := get_row_count;
cols := get_col_count;
end;

constructor TRUNSTR.create(const file_name: string;
const delay_time: INT; const _color: byte);
var
f: text;
temp: string;
symbs: INT;
ch: char;
begin
define_scrmode;
_delay := delay_time;
color := _color;

textcolor(color);

assign(f, file_name);
reset(f);

(* 1 variant *)
msg_len := 0;

while not(eof(f)) do begin
read(f, ch);
if byte(ch) in [32..125] then inc(msg_len);
end;

reset(f);

getmem(msg, msg_len * sizeof(char));

symbs := 0;

while not(eof(f)) do begin
read(f, ch);
if byte(ch) in [32..125] then begin
inc(symbs);
msg^[symbs] := ch;
end;
end;

{

(* 2 variant *)

reset(f);
msg_len := 0;

while not(eof(f)) do begin
readln(f, temp);
inc(msg_len, length(temp));
end;

getmem(msg, msg_len * sizeof(char));

reset(f);

symbs := 0;

while not(eof(f)) do begin
readln(f, temp);
move(temp, msg^[symbs], sizeof(temp));
inc(symbs, length(temp));
end;
}
close(f);
end;

destructor TRUNSTR.free;
begin
freemem(msg, msg_len * sizeof(char));
end;

procedure TRUNSTR.run;
var
first, p: LINT;
i: INT;
ch: char;
begin
first := cols;

repeat

if first = 1 then first := cols + msg_len
else dec(first);

if (first <= cols) and (first > 0) then begin
gotoxy(first, rows div 2); write(msg^[1]);
end;

for i := 2 to msg_len do begin

p := first + i - 1;

if p > cols + msg_len then
p := p - cols - msg_len;


if (p <= cols) and (p > 0) then begin
gotoxy(p, rows div 2); write(msg^[i]);
end;

end;

if keypressed then begin
ch := readkey;
case ch of
'-': if _delay + 5000 < 65500 then inc(_delay, 5000);
'=': if _delay - 5000 > 0 then dec(_delay, 5000);
'c','C': textcolor(1 + random(15));
end;
end;

delay(_delay);
clrscr;
until ch = #27;
end;

var
running_string: TRUNSTR;

begin
running_string.create('runstr.txt', 25000, WHITE);
running_string.run;
running_string.free;
end.




Прикрепленные файлы
Прикрепленный файл  runstr.txt ( 1015 байт ) Кол-во скачиваний: 227


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


просто человек
******

Группа: Пользователи
Сообщений: 3 641
Пол: Женский
Реальное имя: Юлия

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


Ассемблерные вставки допустимы? (просто не знаю, для чего это пишется... просто из интереса?)


--------------------
Все содержимое данного сообщения (кроме цитат) является моим личным скромным мнением и на статус истины в высшей инстанции не претендует.
На вопросы по программированию, физике, математике и т.д. в аське и личке не отвечаю. Даже "один-единственный раз" в виде исключения!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

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


Цитата
Ассемблерные вставки допустимы?


В принципе можно, только что они дадут ? Мне думается сам алгоритм надо менять ...

Цитата
(просто не знаю, для чего это пишется... просто из интереса?)


ага)) давным давно хотел бегущую строку сделать, на море когда был, вспомнил про нее)

в принципе есть у меня еще одна идея, может завтра сделаю, выложу.

Сообщение отредактировано: klem4 -


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


просто человек
******

Группа: Пользователи
Сообщений: 3 641
Пол: Женский
Реальное имя: Юлия

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


просто подумала про использование видеопамяти.


--------------------
Все содержимое данного сообщения (кроме цитат) является моим личным скромным мнением и на статус истины в высшей инстанции не претендует.
На вопросы по программированию, физике, математике и т.д. в аське и личке не отвечаю. Даже "один-единственный раз" в виде исключения!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Perl. Just code it!
******

Группа: Пользователи
Сообщений: 4 100
Пол: Мужской
Реальное имя: Андрей

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


Так ее из без ассемблера можно напрямую юзать, в общем я уже кое-что придумал, если сделаю завтра покажу smile.gif


--------------------
perl -e 'print for (map{chr(hex)}("4861707079204E6577205965617221"=~/(.{2})/g)), "\n";'
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Гость






Немного изменяем метод TRunStr.Run, и избавляемся необходимости постоянной очистки экрана:


procedure TRUNSTR.run;
var
first, p: LINT;
i: INT;
ch: char;
s, init_s: string;
begin
init_s := '';
for i := 1 to cols do init_s := init_s + ' ';

first := cols;

repeat
gotoxy(1, rows div 2);
s := init_s;

if first = 1 then first := cols + msg_len
else dec(first);

if (first <= cols) and (first > 0) then begin
{ gotoxy(first, rows div 2); write(msg^[1]); }
s[first] := msg^[1];
end;

for i := 2 to msg_len do begin

p := first + i - 1;

if p > cols + msg_len then
p := p - cols - msg_len;


if (p <= cols) and (p > 0) then begin
{gotoxy(p, rows div 2); write(msg^[i]);}
s[p] := msg^[i];
end;

end;
write(s);

if keypressed then begin
ch := readkey;
case ch of
'-': if _delay + 5000 < 65500 then inc(_delay, 5000);
'=': if _delay - 5000 > 0 then dec(_delay, 5000);
'c','C': textcolor(1 + random(15));
end;
end;

delay(_delay);
{ clrscr; }
until ch = #27;
end;
 К началу страницы 
+ Ответить 

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

 





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