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


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


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

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

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


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

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


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





Группа: Пользователи
Сообщений: 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 
 К началу страницы 
+ Ответить 

Сообщений в этой теме


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

 





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