Версия для печати темы

Нажмите сюда для просмотра этой темы в обычном формате

Форум «Всё о Паскале» _ Задачи _ неожиданный рисунок

Автор: compiler 11.07.2007 22:51

Добрый день!
есть программка которая должна отрисовывать 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.

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

Автор: volvo 11.07.2007 23:04

Это не 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;

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

Автор: compiler 11.07.2007 23:18

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

Автор: compiler 12.07.2007 17:16

еще одна проблемка, не меняется фон...

(*{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.

что делать?

Автор: volvo 12.07.2007 17:23

В Турбо Паскале как раз меняется ...

Автор: compiler 12.07.2007 17:49

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

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

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

Автор: volvo 12.07.2007 19:07

Открываем исходники и читаем:

  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...

Автор: compiler 12.07.2007 19:48

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


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

Автор: volvo 12.07.2007 20:29

Цитата
А без отчистки экрана никак?
С использованием 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;

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

Цитата
у меня шрифты не отличаются.
Показывай, что делаешь.

Автор: compiler 12.07.2007 20:41

Цитата(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;


Автор: volvo 12.07.2007 21:01

Так:

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 имя файла}... У меня все работает по первому варианту.

Автор: compiler 12.07.2007 21:51

что такое SetTextJustify?

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

Автор: volvo 12.07.2007 23:19

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


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

Автор: compiler 13.07.2007 0:48

вот моя менюшка...

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.

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

Автор: volvo 13.07.2007 1:07

Так?

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.


Автор: compiler 13.07.2007 15:42

Цитата(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) выводит посредине, почему?


Автор: volvo 13.07.2007 16:42

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

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

Автор: compiler 13.07.2007 16:54

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

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