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

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

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

 
 Ответить  Открыть новую тему 
> Помогите дописать программу..., График... сжатие/растяжение
сообщение
Сообщение #1





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

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


Всем, доброго времени суток! У меня такая трабла с реализацией некоторых функций программы
Я написал программу постоения графика на заданном промежутке... Не могу, точнее не умею, сделать сжатие растяжение графика вдоль оси ОХ ("-"-сжатие, "+"-растяжение), и постраничный вывод таблицы значений... sad.gif
Так основной код построения графика вот он (кое что там в коментаторных скобках эт то что я уже пробывал проэксперементировать):
Код
Procedure Graphik (Var c:char;min,max:real;S1:string);
Var DM,DG:integer;
     {Mx,My:real;}
     x1,y1:integer;
     x,y:integer;
     i:byte;
     b:integer;
     s:string;
     {k:char;}
begin
  {Mx:=1;
  My:=1;
  Repeat}
  If min=max then ERROR (c) Else begin
  DM:=detect;
  DG:=0;
  InitGraph (DM,DG,'G:\BP\BGI');
  If GraphResult=GrOK then
   begin
    x1:=GetMaxX div 2;
    y1:=GetMaxY div 2;
    SetColor (White);
    Line (0,y1,640,y1);
    Line (x1,0,x1,480);
    SetColor (black);
    SetTextStyle (4,0,0);
    Bar (0,445,310,480);
    OutTextXY (10,437,S1);
    b:=-1;
    Str (b,s);
    {Repeat
    If k=#45 then a:=a*0.9;
    If k=#43 then a:=a*1.1;}
    SetTextStyle (2,0,0);
    For i:=1 to 30 do
     begin
      SetColor (blue);
      line (x1-20*i,y1-2,x1-20*i,y1+2);
      OutTextXY (x1-20*i-5,y1+5,s);
      dec(b);
      Str (b,s);
     end;
    b:=1;
    Str (b,s);
    For i:=1 to 30 do
     begin
      line (x1+20*i,y1-2,x1+20*i,y1+2);
      OutTextXY (x1+20*i,y1+5,s);
      inc(b);
      Str (b,s);
     end;
    b:=8;
    str (b,s);
    For i:=0 to 17 do
     begin
      line (x1-2,30*i,x1+2,30*i);
      OutTextXY (x1+5,30*i,s);
      dec (b);
      str (b,s);
     end;
    Repeat
     x:=Round(20*min)+x1;
     y:=-(Round(30*min/(1-sqr(min)+0.0005)))+y1;
     min:=min+0.05;
     PutPixel (x,y,red);
    Until min>max;
    { k:=readkey;
    Until (k=#27) or (k=#43) or (k=#45);}
    end Else
     begin
      OKHO_MAIN;
      OKHO2;
      GoToXY (30,1);
      Write (S1);
      OKHO1;
      GoToXY (4,6);
      TextColor (Red);
      Write ('Module "GRAPH" not found.');
     end;
    Repeat
     c:=Readkey;
    Until (c=#27){ or (c=#45) or (c=#61)};
    {If c=#45 then Mx:=Mx*0.7;
    If c=#61 then Mx:=Mx*1.5;}
  end;
  {Until c=#27;}
  CloseGraph;
end;



Помогите, плиз... Заодно прикрепляю архив с файлами .pas и .exe... Заранее, спс...
Прикрепленный файл  proga.rar ( 20.26 килобайт ) Кол-во скачиваний: 189


--------------------
PhotoShop & Progr@mming FOREVER!!!
!!!Resist@nce is futule!!!
by Mr.L@mbert_13....
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2


Гость






Ну, с растяжением/сжатием графика проблема решается достаточно просто:

procedure graphik(var c: char; min, max: real;
s1: string);

var
DM, DG: integer;
x1, y1: integer;
x, y: integer;
i: byte;
s: string;

value, mult_x: real;
finished: boolean;
ch: char;

begin

if min = max then ERROR©
else begin

mult_x := 1.0;
DM := detect; DG := 0;

InitGraph (DM,DG,'G:\BP\BGI');
{ InitGraph (DM,DG,''); }

If GraphResult = grOK then begin

finished := false;
repeat
cleardevice;
x1 := GetMaxX div 2;
y1 := GetMaxY div 2;
SetColor(White);
Line(0, y1, 640, y1);
Line(x1, 0, x1, 480);
SetColor(Black);
SetTextStyle(4, 0, 0);
Bar(0, 445, 310, 480);
OutTextXY(10, 437, S1);

SetTextStyle(2, 0, 0);
for i := 1 to 30 do begin
SetColor(Blue);
Line(Trunc(x1-mult_x*20*i), y1-2, Trunc(x1-mult_x*20*i), y1+2);
str(-i, s);
OutTextXY(Trunc(x1-mult_x*20*i-5), y1+5, s);
end;

for i:=1 to 30 do begin
line(Trunc(x1+mult_x*20*i), y1-2, Trunc(x1+mult_x*20*i), y1+2);
str(i, s);
OutTextXY(Trunc(x1+mult_x*20*i), y1+5, s);
end;

for i := 0 to 17 do begin
line(x1-2, 30*i, x1+2, 30*i);
str(8 - i, s);
OutTextXY(x1+5, 30*i, s);
end;

value := min;
repeat
x := Round(20*value*mult_x)+x1;
y := -(Round(30*value/(1-sqr(value)+0.0005)))+y1;
value := value + 0.05;
PutPixel(x, y, red);
until value > max;

repeat
ch := readkey;
case ch of

#45: mult_x := mult_x - 0.1; { minus }
#61: mult_x := mult_x + 0.1; { plus }
#27:
finished := true;

end;
until ch in [#45, #61, #27];

until finished;

end
else begin
OKHO_MAIN;
OKHO2;
GoToXY(30, 1);
Write(S1);
OKHO1;
GoToXY(4, 6);
TextColor(Red);
Write('Module "GRAPH" not found.');
end;

end;
closegraph;
end;

Постраничный вывод - скорее всего завтра, если никто раньше не поможет...
 К началу страницы 
+ Ответить 
сообщение
Сообщение #3





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

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


2 volvo: За сжатие/растяжение спс огромное... Всё работает... good.gif smile.gif по тому же принципу сделал 1.gif сжатие и растяжение вдоль OY. Но появился вопросик: А что за команда cleardevice? И что она даёт?


--------------------
PhotoShop & Progr@mming FOREVER!!!
!!!Resist@nce is futule!!!
by Mr.L@mbert_13....
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #4


Помощник капитана
****

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

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


Цитата
А что за команда cleardevice?

Это процедура очищает граф. экран..


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





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

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


А постраничный вывод никто не поможет сделать??? !help.gif sad.gif плиз...
 
Procedure Output (min,max,st:real);
Const t5='H/C';
Var y:real; k,i:byte;
begin
i:=3;
TextColor (Green);
k:=1;
While min<=max do
Begin
If (i>18) then begin k:=40; i:=3; end;
If (min>0.9999) and (min<1.0001) or (min>-1.0001) and (min<-0.9999)
then begin
GoToXY (k,i);
WriteLn (min:13:3,t5:13);
min:=min+st;
i:=i+1;
end
else begin
y:=min/(1-min*min);
GoToXY (k,i);
writeLn (min:13:3,y:13:3);
min:=min+st;
i:=i+1;
end;
end;
end;

Procedure Tab (Xmn,Xmx,st:real);
var c:char;
begin
If Xmin=Xmax then ERROR Else begin
OKHO_MAIN;
TextColor (White);
GoToXY (23,1);
Write ('TA6JluCa (Xmin=',Xmn:4:3,',Xmax=',Xmx:4:3,',step=',st:4:3,')');
Output (Xmn,Xmx,st);
OKHO2;
GoToXY (35,1);
Write ('ESC - return to MENU');
Repeat
c:=Readkey;
Until c=#27;
end;
end;



--------------------
PhotoShop & Progr@mming FOREVER!!!
!!!Resist@nce is futule!!!
by Mr.L@mbert_13....
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #6


Гость






Зачем тебе постраничный вывод, если всех данных может быть максимально 30, что прекрасно помещается в твои 2 столбца по 18 записей?

Ну, в принципе, конечно нет проблем, только по-моему это лишнее:
procedure Output(min, max, st: real);
const t5 = 'H/C';
var
y: real; k, i: byte;
value: real;
curr: integer;

begin
curr := 0;
value := min;

while value < (max + st / 2) do begin

gotoxy(1, 3 + (curr mod 18));

If (abs(value - 1) < 0.01) or
(abs(value + 1) < 0.01) then writeLn(value:13:3, t5:13)
else begin

y := value / (1 - sqr(value));
writeLn(value:13:3, y:13:3);

end;
value := value + st;
inc(curr);

if curr mod 18 = 0 then begin
repeat until keypressed;
while keypressed do readkey;
end;

end;

end;

(Tab не изменяется...)

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





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

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


Да дело в том что элементов должно быть больше... Это я собственноручно ограничил STEP не мешьне единицы.... А так должен быть постраничный вывод и никаких столбцов.... С возможностью перехода на первую и последнюю страницу....


--------------------
PhotoShop & Progr@mming FOREVER!!!
!!!Resist@nce is futule!!!
by Mr.L@mbert_13....
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

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

 





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