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

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

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

Автор: 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 килобайт ) Кол-во скачиваний: 425


Цитата
что такое 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