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

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

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

 
 Ответить  Открыть новую тему 
> неожиданный рисунок
сообщение
Сообщение #1


Человек
*****

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

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


Добрый день!
есть программка которая должна отрисовывать 5 прямоугольников в вертикальном положении через небольшое расстаяние, но она не работает:(
uses Graph;
function init:integer;
var
grDriver: Integer;
grMode: Integer;
begin
grDriver := Detect;
InitGraph(grDriver, grMode, '');
init := GraphResult;
end;

procedure dr;
var
i:integer;
x1,x2,y1,y2,k:integer;
begin
ClearViewPort;
k:=round ((GetMaxY / 200));//отступ
x2:=round (GetMaxX*(2/3));
x1:=round (GetMaxX*(1 / 3));
for i:=1 to 5 do begin
y1:=round ((GetMaxY / 9)*(1+i) -k);
y2:=round ((GetMaxY/9)*(1+ 2*i ));
Rectangle(X1,Y1,X2,Y2);
end;
end;

begin
if init = grOk then begin
Dr;
Readln;
CloseGraph;
end;
end.

Прикрепленное изображение
на скрине видно что отступы между прямоугольниками пропадают, и откуда-то берется шестой прямоугольник...
помогите...

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


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Гость






Это не 6 прямоугольников, а 5, но переплетены так, что wacko.gif

Поменяй
        for i:=1 to 5 do begin
y1:=round ((GetMaxY/9)*(1+i) - k);
y2:=round ((GetMaxY/9)*(2+i)); { <--- Здесь }
Rectangle(X1,Y1,X2,Y2);
readln; { <--- Для теста }
end;

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

Сообщение отредактировано: volvo -
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3


Человек
*****

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

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


и отнимать К, надо было от другого у...
спасибо..


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Человек
*****

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

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


еще одна проблемка, не меняется фон...
(*{TP mode}*)
uses Graph;
function init:integer;
var
grDriver: Integer;
grMode: Integer;
begin
grDriver := Detect;
InitGraph(grDriver, grMode, '');
writeln(grDriver);//15
writeln( grMode);//5
init := GraphResult;
end;
function ColorToString(color:word):string;
begin
case color of
0: ColorToString:='Black';
1: ColorToString:='Blue';
2: ColorToString:='Green';
3: ColorToString:='Cyan';{бирюзовый}
4: ColorToString:='Red';
5: ColorToString:='Magenta';{Фиолетовый}
6: ColorToString:='Brown';
7: ColorToString:='LightGray';
8: ColorToString:='DarkGray';
9: ColorToString:='LightBlue';
10: ColorToString:='LightGreen';
11: ColorToString:='LightCyan';
12: ColorToString:='LightRed';
13: ColorToString:='LightMagenta';
14: ColorToString:='Yellow';
15: ColorToString:='White';
128:ColorToString:='Blink';
else ColorToString:='unknown';
end;
end;

procedure dr;
var
Color: Word;
i:integer;


begin
for i:=0 to 15 do begin
readln(color);
SetBkColor(Color); //почему не меняется фон?
OutTextXY (100,100+(i*10), ColorToString(Color));
end;

end;
begin
if init = grOk then begin
Dr;
Readln;
CloseGraph;
end;
end.

что делать?


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #5


Гость






В Турбо Паскале как раз меняется ...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Человек
*****

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

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


Цитата(volvo @ 12.07.2007 13:23) *
В Турбо Паскале как раз меняется ...
но у меня его нет... точнее где-то на диске...
как сделать что б менялся в FP?

Добавлено через 19 мин.
прошу перенести тему в соответствующий раздел...

в документации (rtl/graph/setbkcolor) есть подобная процедура SetBkColor -- Set background drawing color
Errors -- None.


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #7


Гость






Открываем исходники и читаем:
  procedure SetBkColor(ColorNum: Word);
{ Background color means background screen color in this case, and it is }
{ INDEPENDANT of the viewport settings, so we must clear the whole screen }
{ with the color. }
...


То есть, после вызова SetBkColor, чтобы изменения вступили в силу, надо вызвать ClearDevice, следовательно программа не будет работать точно так же, как и в TP...

Сообщение отредактировано: volvo -
 К началу страницы 
+ Ответить 
сообщение
Сообщение #8


Человек
*****

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

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


Цитата(volvo @ 12.07.2007 15:07) *
То есть, после вызова SetBkColor, чтобы изменения вступили в силу, надо вызвать ClearDevice, следовательно парограмма не будет работать точно так же, как и в TP...
А без отчистки экрана никак?


Добавлено через 11 мин.
и что надо сделать что б работало SetTextStyle? а то у меня шрифты не отличаются...

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


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #9


Гость






Цитата
А без отчистки экрана никак?
С использованием SetBkColor - никак. А по-другому - очень медленно:

	for i:=0 to 15 do begin
readln(color);
setfillstyle(solidfill, color);
floodfill(1, 1, getbkcolor);
OutTextXY (100,100+(i*10), ColorToString(Color));
end;

(да и артефакты остаются)

Цитата
у меня шрифты не отличаются.
Показывай, что делаешь.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #10


Человек
*****

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

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


Цитата(volvo @ 12.07.2007 16:29) *
(да и артефакты остаются)
это кто?
Цитата(volvo @ 12.07.2007 16:29) *
Показывай, что делаешь.
вот процедурка... использую так же как и dr
procedure text;
var i:integer;
begin
SetTextStyle(DefaultFont, HorizDir,10); OutTextXY (100,100+(i*100), 'TEXT'); inc(i);
SetTextStyle(TriplexFont, HorizDir,10); OutTextXY (100,100+(i*100), 'TEXT'); inc(i);
SetTextStyle(TSCRFont, HorizDir,10); OutTextXY (100,100+(i*100), 'TEXT'); inc(i);
SetTextStyle(LCOMFont, HorizDir,10); OutTextXY (100,100+(i*100), 'TEXT'); inc(i);
SetTextStyle(ScriptFont, HorizDir,10); OutTextXY (100,100+(i*100), 'TEXT'); inc(i);
end;



--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #11


Гость






Так:
procedure text;
var i:integer;
begin
i := 100;
settextjustify(lefttext, toptext);

SetTextStyle(DefaultFont, HorizDir,2); OutTextXY (100,i+10, 'TEXT');
inc(i, textheight('W'));
SetTextStyle(TriplexFont, HorizDir,2); OutTextXY (100,i+10, 'TEXT');
inc(i, textheight('W'));
SetTextStyle(TSCRFont, HorizDir,2); OutTextXY (100,i+10, 'TEXT');
inc(i, textheight('W'));
SetTextStyle(LCOMFont, HorizDir,2); OutTextXY (100,i+10, 'TEXT');
inc(i, textheight('W'));
SetTextStyle(ScriptFont, HorizDir,2); OutTextXY (100,i+10, 'TEXT');
inc(i, textheight('W')); // <--- Не обязательно
end;

и все CHR-файлы либо в одной папке с программой, либо переведены в PP файлы с помощью подобной команды:
Цитата(Console)
BIN2OBJ -c LittFontProc LITT.CHR>LITT.PP
, и подключены к программе через {$i имя файла}... У меня все работает по первому варианту.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #12


Человек
*****

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

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


что такое SetTextJustify?
Цитата(volvo @ 12.07.2007 17:01) *
и все CHR-файлы
А где они?


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #13


Гость






Я брал из 7-го Турбо Паскаля - формат один и тот же...
Если надо - забирай: Прикрепленный файл  fonts.rar ( 71.69 килобайт ) Кол-во скачиваний: 241


Цитата
что такое SetTextJustify?
Устанавливает выравнивание текста. То что я привел - говорит компилятору, что точка, координаты которой задаешь в OutTextXY, будет левой (LeftText) верхней (TopText) точкой выводимого текста, то есть, весь текст пойдет от нее вправо и вниз. А вот для того, чтобы пропускать между строками, напечатанными разными шрифтами одинаковое расстояние, пользуемся TextHeight, которая выдаст высоту переданной ей буквы (обычно передают "W", как самую высокую) для текущего шрифта...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #14


Человек
*****

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

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


вот моя менюшка...
uses Graph,crt;
function menuText(i:integer):string;
const a: array[1 .. 6] of ShortString = (
('New'), ('last'), ('Record'), ('level'), ('Rules'), ('exit')
);
begin
menuText:=a[i];
end;

function init:integer;
var
grDriver: Integer;
grMode: Integer;
begin
grDriver := Detect;
InitGraph(grDriver, grMode, '');
init := GraphResult;
end;

procedure dr;
var
i:integer;
x1,x2,y1,y2,k:integer;
begin
ClearViewPort;
SetBkColor(blue);
ClearDevice;

k:=round ((GetMaxY / 50));
x1:=round (GetMaxX*(1 / 3));
x2:=round (GetMaxX*(2/3));
SetTextStyle(TSCRFont, HorizDir,3);
for i:=1 to 6 do begin
y1:=round ((GetMaxY / 10)*(i+1) +k);
y2:=round ((GetMaxY/10)*(i+2) );
Rectangle(X1,Y1,X2,Y2);
//должно выводить в ЦЕНТР текущего прямоугольника, а не выводит : (
OutTextXY ( round( ((x2+x1-Length(menuText(i)))/2 )), (y1+y2) div 2 , menuText(i));
end;
end;

function UserEnter():integer;
var select:integer;
ch:char;
x1,x2,y1,y2,k:integer;
C:word;
const
Up = #72;
Down = #80;
Esc =#27;
begin
k:=round ((GetMaxY / 50));
select:=1;
repeat
x1:=round (GetMaxX*(1 / 3));
x2:=round (GetMaxX*(2/3));
y1:=round ((GetMaxY / 10)*(select+1) +k);
y2:=round ((GetMaxY/10)*(select+2) );
Rectangle(X1-10,Y1-10,X2+10,Y2+10);
ch:=ReadKey;
if ch=Up then dec(select)//тут надо будет дописать, что б не уходили меньше 1...
else if ch=Down then inc(select);
C:=GetColor;
SetColor(GetBkColor);
Rectangle(X1-10,Y1-10,X2+10,Y2+10);
SetColor©;
writeln('ro',select);
until (ch <> Esc);
writeln('re',select);
UserEnter:=select;
end;

begin
if init = grOk then begin
Dr;
UserEnter();
{case UserEnter() of
1 : New
2 : last;
3 : Record;
4 : level;
5 : Rules;
6 : exit;
end; }
Readln;
CloseGraph;
end;
end.

проблема основная -- что-то с циклом отрисовки нового выбора пользователя(прямоугольник новый не отрисовывается)
проблемма второстепенная -- текст выводится не в центр
что делать?


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #15


Гость






Так?

uses Graph,crt;

const
max_items = 6;

function menuText(i: integer): string;
const
a: array[1 .. max_items] of string = (
'New', 'last', 'Record', 'level', 'Rules', 'exit'
);
begin
menuText:=a[i];
end;

function init:integer;
var
grDriver, grMode: smallint; // <--- Для FPC
begin
grDriver := Detect;
InitGraph(grDriver, grMode, '');
init := GraphResult;
end;

procedure dr;
var
i:integer;
x1,x2,y1,y2,k:integer;
begin
ClearViewPort;
SetBkColor(blue);
ClearDevice;

k:=round ((GetMaxY / 50));
x1:=round (GetMaxX*(1 / 3));
x2:=round (GetMaxX*(2/3));
SetTextStyle(TSCRFont, HorizDir,3);
settextjustify(centertext, centertext);

for i:=1 to 6 do begin
y1:=round ((GetMaxY / 10)*(i+1) +k);
y2:=round ((GetMaxY/10)*(i+2) );
Rectangle(X1,Y1,X2,Y2);
outtextxy(x1 + ((x2 - x1) div 2), y1 + ((y2 - y1) div 2), menuText(i));
end;
end;

function UserEnter():integer;
var
select:integer;
ch:char;
x1,x2,y1,y2,k:integer;
C:word;
const
Up = #72;
Down = #80;
Esc =#27;
begin
k:=round ((GetMaxY / 50));
select:=1;
repeat
x1:=round (GetMaxX*(1 / 3));
x2:=round (GetMaxX*(2/3));
y1:=round ((GetMaxY / 10)*(select+1) +k);
y2:=round ((GetMaxY/10)*(select+2) );
Rectangle(X1-10,Y1-10,X2+10,Y2+10);
ch:=ReadKey;
case ch of
#0:
case readkey of
Up:
if select > 1 then dec(select);
Down:
if select < max_items then inc(select);
end;
Esc:
break;
end;

C:=GetColor;
SetColor(GetBkColor);
Rectangle(X1-10,Y1-10,X2+10,Y2+10);
SetColor©;
writeln('ro',select);
until false;
writeln('re',select);
UserEnter:=select;
end;

begin
if init = grOk then begin
Dr;
UserEnter();
{
case UserEnter() of
1 : New
2 : last;
3 : Record;
4 : level;
5 : Rules;
6 : exit;
end;
}
Readln;
CloseGraph;
end;
end.

 К началу страницы 
+ Ответить 
сообщение
Сообщение #16


Человек
*****

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

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


Цитата(volvo @ 12.07.2007 21:07) *
Так?
...outtextxy(x1 + ((x2 - x1) div 2), y1 + ((y2 - y1) div 2), menuText(i));...
ага, только есть вопрос... к вот этому x1 + ((x2 - x1) div 2)
ведь round( ((x2+x1-Length(menuText(i))*ширина символа)/2 )) тоесть (х2 - х1) -- длина всего прямоугольника, (Length( menuText(i) )*ширина символа) -- ширина строки(далее L), тогда (х2 - х1)-L--<<остаток>>, делем на 2 и получаем левый остаток. Но и x1 + ((x2 - x1) div 2) выводит посредине, почему?



--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #17


Гость






Потому что именно так я нахожу центр прямоугольника, а потом заставляю текст выводиться со смещением (centertext, centertext), то есть, центр текста совпадает с центром прямоугольника.

Как это делается - проблема модуля Graph, это пусть он себе голову морочит, что надо сделать для правильного вывода текста. Я только говорю, что я хочу получить в результате.
 К началу страницы 
+ Ответить 
сообщение
Сообщение #18


Человек
*****

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

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


теперь ясно... спасибо.

Добавлено через 4 мин.
стройка начата... с ворот... smile.gif


--------------------
Спасибо!
Удачи!
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

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

 





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