Помощь - Поиск - Пользователи - Календарь
Полная версия: Помогите дописать программу...
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи
Mr.L@mbert_13
13.04.2007 3:44
Всем, доброго времени суток! У меня такая трабла с реализацией некоторых функций программы
Я написал программу постоения графика на заданном промежутке... Не могу, точнее не умею, сделать сжатие растяжение графика вдоль оси ОХ ("-"-сжатие, "+"-растяжение), и постраничный вывод таблицы значений... 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... Заранее, спс...
Нажмите для просмотра прикрепленного файла
volvo
13.04.2007 5:18
Ну, с растяжением/сжатием графика проблема решается достаточно просто:

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(c)
  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;
Постраничный вывод - скорее всего завтра, если никто раньше не поможет...
Mr.L@mbert_13
14.04.2007 15:02
2 volvo: За сжатие/растяжение спс огромное... Всё работает... good.gif smile.gif по тому же принципу сделал 1.gif сжатие и растяжение вдоль OY. Но появился вопросик: А что за команда cleardevice? И что она даёт?
Артемий
14.04.2007 17:31
Цитата
А что за команда cleardevice?

Это процедура очищает граф. экран..
Mr.L@mbert_13
15.04.2007 15:14
А постраничный вывод никто не поможет сделать??? !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;
volvo
15.04.2007 19:21
Зачем тебе постраничный вывод, если всех данных может быть максимально 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 не изменяется...)
Mr.L@mbert_13
16.04.2007 11:18
Да дело в том что элементов должно быть больше... Это я собственноручно ограничил STEP не мешьне единицы.... А так должен быть постраничный вывод и никаких столбцов.... С возможностью перехода на первую и последнюю страницу....
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.