TPU Funcs

{***************************************************************************}
{*                                                                         *}
{*  FUNCS.PAS     Модуль функциональных блоков программы                   *}
{*  Ярослав Стерхов 1997 МТ7-21                 Турбо-Паскаль 5.5          *}
{*                                                                         *}
{***************************************************************************}
{Функциональные части программы}
{$F+,N+,E+,D-}
UNIT Funcs;{Functions}
INTERFACE
USES CRT,Graph,Screen,IntrFace;

VAR
  ExitOrNot:Boolean;

{Подтверждение выхода}
PROCEDURE DoExit;
{Работа с матрицей}
PROCEDURE DoMatrix;
{Работа с интегралом}
PROCEDURE DoIntegral;
{Работа с графиком}
PROCEDURE DoPlot;

CONST
  MenuData:TMenuData =(
  (Name:'Сортировка матрицы';KeyInd:1; Key:['C','c','1','C','c']; Proc: DoMatrix),
  (Name:'найти Интеграл';    KeyInd:7; Key:['B','b','2','И','и']; Proc: DoIntegral),
  (Name:'построить График';  KeyInd:11; Key:['U','u','3','Г','г']; Proc: DoPlot),
  (Name:'Выход в ДОС';       KeyInd:1; Key:['D','d','4','В','в']; Proc: DoExit));

IMPLEMENTATION
{***************************************************************************}
{**********************  Сортировка строк матрицы  *************************}
{***************************************************************************}
TYPE
{Тип размерности элемента матрицы}
  MSize = 1..11;
{Матрица}
  TRow   = array[MSize] of Integer;
  Matrix = RECORD
              elements: array[MSize] of TRow;
              cols,rows:MSize;
  END;

{***************************************************************************}
{* Показать справку об использовании редактора матрицы                     *}
{* используется в: DoMatrix                                                *}
{***************************************************************************}

PROCEDURE HelpOnMatrix;
VAR W    :PWindow;
    PrevW:PWindow;
    a    :Byte;
    c    :Char;
    wr,op:Rect;
BEGIN
 PrevW := CurWindow;
  AssignRect(wr,10,6,71,19);
  AssignRect(op,11,7,70,18);
  A := Attrib(Black,Cyan);
  New(W);
  CreateWindow(W, 'Справка', wr,op, a,a, TRUE);
  GlobalOFF;
  a := Attrib(Yellow,Cyan);
  WriteString(1,2,'   При вводе/редактировании матрицы вы можете',a);
  WriteString(1,3,' использовать клавиши управления курсором для',a);
  WriteString(1,4,' перемещения от элемента к элементу и <Enter>',a);
  WriteString(1,5,' для изменения значения элемента.            ',a);
  WriteString(1,6,'   Для окончания ввода выделите надпись ''око-',a);
  WriteString(1,7,' нчание ввода матрицы'' и нажмите <Enter>.   ',a);
  a := Attrib(Black,LightGray);
  GlobalON;
  WriteString(2,25,gStrings[3],a);
  GlobalOff;
  REPEAT
    c :=ReadKey;
  UNTIL c=#27;
  HideWindow(W);
  WriteChar(1,25,' ',80,a);
  WriteString(2,25,gStrings[2],a);
  GlobalOff;
  CurWindow := PrevW;
  DisposeWindow(W);
END;

{***************************************************************************}
{* сортировать строки M по неубыванию первых элементов                     *}
{* используется в: DoMatrix                                                *}
{***************************************************************************}
PROCEDURE MatrixSort(var M:Matrix);
var
  Rmin : TRow;
  K,I : MSize;
  n   : MSize;
BEGIN
  FOR K:=1 TO M.rows-1 DO BEGIN
    Rmin := M.elements[K];
    n := k;
    FOR I:=K+1 TO M.Rows DO BEGIN
      IF M.elements[I,1] > Rmin[1] THEN BEGIN
        Rmin := M.elements[I];
        n :=I;
      END;
    END;
    M.elements[n]:=M.elements[k];
    M.elements[k]:=Rmin;
  END;
END;

{***************************************************************************}
{* Показать матрицу Matr в виде таблицы                                    *}
{* используется в: DoMatrix                                                *}
{***************************************************************************}
PROCEDURE ShowMatrix(var Matr:Matrix);
var
    W      :PWindow;
    PrevW  :PWindow;
    wr,op  :Rect;
    Rw,Cl  :MSize;
    S,ms,ns:String;
    M      :Matrix;
    a      :Byte;
    c      :Char;
BEGIN
  M:=Matr;
  PrevW:=CurWindow;
  Str(M.rows,ms);
  Str(M.cols,ns);
  AssignRect(wr,(80-M.Cols*7-4) div 2,
             (25-M.Rows-4) div 2,
             (80-M.Cols*7-4) div 2 + M.Cols*7+6,
             (25-M.Rows-4) div 2 + M.Rows+4);
  AssignRect(op,wr.left+2,wr.top+1,wr.right-1, wr.bottom-1);
  a := Attrib(White,Blue);
  New(W);
  CreateWindow(W, 'Матрица '+ms+' x '+ns, wr,op, a,a, TRUE);

  GlobalOff;
  FOR Rw:=1 TO M.rows DO
   FOR Cl:=1 TO M.cols DO BEGIN
     Str(M.elements[Rw][Cl]:6,S);
     WriteString((Cl-1)*7+1,Rw,S,Attrib(Yellow,Blue));
   END;
  WriteChar(1,Rw+1,'_',m.Cols*7+2,Attrib(Yellow,Blue));
  CenterString(Rw+2,'Нажмите любую клавишу...',FALSE,Attrib(Yellow,Blue));
  REPEAT UNTIL KeyPressed;
  c:=ReadKey;
  HideWindow(W);
  DisposeWindow(W);
  CurWindow:=PrevW;
END;

{***************************************************************************}
{* Осуществить редактировние матрицы М                                     *}
{* используется в: DoMatrix                                                *}
{***************************************************************************}
FUNCTION ReadMatrix(var M:Matrix):Boolean;
VAR
  W,PrevW:PWindow;
  wr,op  :Rect;
  Rw,Cl,
  pRw,pCl:MSize;
  S,ms,ns:String;
  a      :Byte;

  ch     :Char;
  el     :Integer;
  Entered,
  Ended  :Boolean;
BEGIN
  PrevW:=CurWindow;
  Str(M.rows,ms);
  Str(M.cols,ns);
  AssignRect(wr,(80-M.Cols*7-4) div 2,
             (25-M.Rows-4) div 2,
             (80-M.Cols*7-4) div 2 + M.Cols*7+6,
             (25-M.Rows-4) div 2 + M.Rows+2);
  AssignRect(op,wr.left+2,wr.top+1,wr.right-1, wr.bottom-1);
  a := Attrib(White,Blue);
  New(W);
  CreateWindow(W, 'Матрица '+ms+' x '+ns, wr,op, a,a, TRUE);

  GlobalOff;
  FOR Rw:=1 TO M.rows DO
   FOR Cl:=1 TO M.cols DO BEGIN
     Str(M.elements[Rw][Cl]:6,S);
     WriteString((Cl-1)*7+1,Rw,S,Attrib(Yellow,Blue));
   END;
  CenterString(M.Rows+1,'Окончание ввода матрицы',FALSE,Attrib(White,Blue));

  {Вывод статус-строки}
  GlobalOn;
  WriteChar(1,25,' ',80,Attrib(Black,LightGray));
  WriteString(2,25,'F1 - Справка   <┘ - Ввод ',Attrib(Black,LightGray));
  GlobalOFF;

  {Начало агоритма ввода матрицы}
  Rw:=1; Cl:=1;
  Str(M.elements[Rw][Cl]:6,S);
  WriteString((Cl-1)*7+1,Rw,S,Attrib(Yellow,Black));
  Ended := False;
  REPEAT
   ch := ReadKey;
   pRw:= Rw;
   pCl:= Cl;
   CASE ch OF
     #13: {редактирование элемента/обработка завершения}
          {Индекс Rw = 11 эквивалентен строке выхода}
         IF Rw = 11 THEN Ended:=TRUE ELSE BEGIN
             Str(M.rows,ms); Str(M.cols,ns);
             el:=AskInteger('Элемент ('+ms+';'+ns+')',
                    'Введите значение элемента:',M.elements[Rw][Cl],
                    Entered,DumbCheck);
             IF Entered THEN M.elements[Rw][Cl] := el;
             GlobalOn;
             WriteChar(1,25,' ',80,Attrib(Black,LightGray));
             WriteString(2,25,'F1 - Справка   <┘ - Ввод ',Attrib(Black,LightGray));
             GlobalOFF;
          END;

     #00: {расширенный код}
          BEGIN
             ch:=ReadKey;
             CASE ch OF
               #59: {F1}
                   HelpOnMatrix;
               #72: {вверх}
                   IF Rw=11 THEN rw:=M.Rows ELSE
                    IF Rw>1 THEN Dec(Rw);
               #75: {влево}
                   IF Cl=1 THEN Cl:=M.Cols ELSE Dec(Cl);
               #77: {вправо}
                   IF Cl=M.Cols THEN Cl:=1 ELSE Inc(Cl);
               #80: {вниз}
                   IF Rw>=M.Rows THEN Rw:=11 ELSE Inc(Rw);
             END;
          END;
   END;
   IF NOT ((pRw=Rw) AND (pCl=Cl)) THEN BEGIN
      IF pRw=11 THEN
         CenterString(M.Rows+1,'Окончание ввода матрицы',FALSE,Attrib(White,Blue))
      ELSE BEGIN
        Str(M.elements[pRw][pCl]:6,S);
        WriteString((pCl-1)*7+1,pRw,S,Attrib(Yellow,Blue));
      END;
      IF Rw=11 THEN
         CenterString(M.Rows+1,'Окончание ввода матрицы',FALSE,Attrib(White,Black))
      ELSE BEGIN
        Str(M.elements[Rw][Cl]:6,S);
        WriteString((Cl-1)*7+1,Rw,S,Attrib(Yellow,Black));
      END;
   END;
  UNTIL Ended;
  HideWindow(W);
  DisposeWindow(W);
  CurWindow:=PrevW;
END;


{***************************************************************************}
{* сортировать строки M по неубыванию первых элементов  (основная)         *}
{***************************************************************************}
FUNCTION MatrixSize(Value:Real):Boolean;far;
VAR MS:Boolean;
BEGIN
  MS := (Value>=3) AND (Value<=10);
  IF NOT MS THEN
       Message('Размерность матрицы - от 3 до 10!',Attrib(Yellow,Red));
  MatrixSize:=MS;
END;

PROCEDURE DoMatrix;
LABEL lab1,lab2;
VAR
  M       : Matrix;
  Entered : Boolean;
  ToExit  : Boolean;
  Step    : Integer;

BEGIN
  Message('Сортировка матрицы',Attrib(Black,LightGray));
  Step:=1;
  Entered:=FALSE;
  ToExit:=FALSE;
  REPEAT
    CASE Step OF
       0:  ToExit:=TRUE;
       1:  BEGIN
            M.Rows:=AskInteger('Ввод',
            'Введите количество строк матрицы (3..10)',3,Entered,MatrixSize);
            IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       2:  BEGIN
            M.Cols:=AskInteger('Ввод',
             'Введите количество столбцов матрицы (3..10)',3,Entered,MatrixSize);
            IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
    END;
  UNTIL  (Step=3) OR ToExit;
  IF ToExit THEN Exit;
  ReadMatrix(M);
  MatrixSort(M);
  ShowMatrix(M);
END;

{***************************************************************************}
{****************  Вычисление определенного интеграла  *********************}
{***************************************************************************}
TYPE
  XToYFunc = FUNCTION (x:real):real;

{***************************************************************************}
{* вычисление функции f при значении аргумента x (в радианах)              *}
{* используется в: DoIntegral                                              *}
{***************************************************************************}
FUNCTION Func1(x:real):real;
BEGIN
  Func1:= cos(x)/x
END;
{***************************************************************************}
{* вычисление интегральной суммы функции f при аппроксимации n отрезками   *}
{* (шаг итерации) на промежутке [a;b]                                      *}
{* используется в: Integral                                                *}
{***************************************************************************}
FUNCTION Iteration( f: XToYFunc; a,b:real; n:Word) : real;
VAR
  x, dx:real;
  sum :real;
BEGIN
  x := a;
  dx := (b-a)/n;
  sum := (f(a)+f(b))/2 * dx;
  REPEAT
    x := x + dx;
    sum := sum + f(x) * dx;
  UNTIL x = b;
  Iteration := sum;
END;

{***************************************************************************}
{* вычисление интеграла функции f на промежутке [a;b] с точностью до eps   *}
{* используется в: DoIntegral                                              *}
{***************************************************************************}
PROCEDURE Integral( f: XtoYFunc; a,b:real; eps:real; var value:Real);
VAR
  Prev,Cur : real;
  n        : Word;
BEGIN
  Prev := 0;
  n    := 1;
  Cur  := Iteration(f,a,b,n);
  REPEAT
    Prev := Cur;
    n := n * 2;
    Cur := Iteration(f,a,b,n);
    GotoXY(1,20);
  UNTIL (abs(Cur - Prev) < eps) OR (n >= 32768);
  Value:=Cur;
end;


{***************************************************************************}
{* вычисление интеграла функции f на промежутке [a;b] с точностью до eps   *}
{***************************************************************************}
PROCEDURE DoIntegral;
VAR
 epsilon:Real;
 a,b    :Real;
 Value  :Real;
 Entered:Boolean;
 ToExit :Boolean;
 Step   :Byte;
 S      :String;

BEGIN
 Message('Вычисление интеграла функции Cos(X)/X',Attrib(Black,LightGray));
 Step:=1;
 Entered:=FALSE;
 ToExit:=FALSE;
 REPEAT
    CASE Step OF
       0:  ToExit:=TRUE;
       1:  BEGIN
             a:=AskReal('Ввод параметров','Введите нижий предел интегрирования',
                            0,Entered, DumbCheck);
             IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       2:  BEGIN
             b:=AskReal('Ввод параметров','Введите верхний предел интегрирования',
                            0,Entered,DumbCheck);
             IF Entered THEN BEGIN
                IF b<=a THEN
                   Message('Должно быть больше нижнего!',Attrib(Yellow,Red))
                ELSE Inc(Step);
             END ELSE Dec(Step);
           END;
       3:  BEGIN
              Epsilon:=AskReal('Ввод параметров','Введите точность интегрирования',
                      0,Entered,DumbCheck);
              IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
    END;
  UNTIL (Step=4) OR ToExit;
  IF ToExit THEN Exit;

  Integral( Func1, a,b, epsilon, value);
  Str(value:7:5,S);
  Message('Найдено значение интеграла: '+S+'.',Attrib(Yellow,Blue));
END;

{***************************************************************************}
{**********************  Построение графика функции  ***********************}
{******************************* CRT,Graph *********************************}
{***************************************************************************}

{ тип-функция от параметра t}
TYPE
  FofT = FUNCTION(t:real):real;
  {Процедура изготовление сетки}

{ глобальные переменные - параметры функции A и B }
VAR
  par_A,par_B :real;

CONST
  BgiPath:String = '';

{***************************************************************************}
{* Наша функция (астроида)                                                 *}
{***************************************************************************}
FUNCTION YofT(t:real):real;far;
BEGIN YofT := par_A * sin(t)*sin(t)*sin(t); END;

FUNCTION XofT(t:real):real;far;
BEGIN XofT := par_B * cos(t)*cos(t)*cos(t); END;

{***************************************************************************}
{* Построить график функции, заданной параметрически (x,y)                 *}
{*    t1,t2 - промежуток;                                                  *}
{*    dt - шаг итерации;                                                   *}
{*    px,py - масштаб по Ox и Oy (единиц/пиксел)                           *}
{* используется в: DoPlot                                                  *}
{***************************************************************************}
PROCEDURE PlotParmFunc(x,y:FofT; t1,t2,dt:real; px,py:real);
VAR
 MaxX, MaxY  : Word; {Размеры экрана}
 curx, cury,
 prevx, prevy: Integer; {Координаты точек на экране}
 x0, y0      : Word; {Начало координат}
 curt        : Real; {Текущее значение параметра t}
 GDriver,
 GMode, GRes : Integer; {необходимо для инициализации Graph}

PROCEDURE DrawGrid;
  VAR
    i   :word;
    s,s2:string;
  BEGIN
    {Координатные оси}
    SetColor(White);
    Line(X0,0,X0,MaxY);
    Line(0,Y0,MaxX,Y0);
    SetColor(LightBlue);
    {Вертикальные линии}
    i:=round(1/px);
    REPEAT
      Line(X0+i,0,X0+i,MaxY);
      Line(X0-i,0,X0-i,MaxY);
      i:=i + round(1/px);
    UNTIL i >= X0;
    {Горизонтальные линии}
    i:= round(1/py);
    REPEAT
      Line(0,Y0+i,MaxX,Y0+i);
      Line(0,Y0-i,MaxX,Y0-i);
      i:=i + round(1/py);
    UNTIL i >= Y0;
    {Основная надпись}
    SetColor(White);
    OutTextXY(1,1,'Dimension of grid - 1 unit.');
    OutTextXY(1,12,'Plot of parametrical function:');
    Str(par_A:5:2,s);
    SetColor(Yellow);
    OutTextXY(20,24,'y = '+s+'*sin(t)^3');
    Str(par_B:5:2,s);
    OutTextXY(20,36,'x = '+s+'*cos(t)^3');
    Str(t1:6:4,s);Str(t2:6:4,s2);
    SetColor(White);
    OutTextXY(1,48,'at t = '+s+'...'+s2+'.');
    {Оси и начало координат}
    OutTextXY(X0+2,1,'Y');
    OutTextXY(MaxX-10,Y0+2,'X');
    OutTextXY(X0+2,Y0+2,'O');
  END;

BEGIN
 {Инициализация}
 Gdriver := Detect;
 InitGraph(GDriver,GMode,BgiPath);
 GRes := GraphResult;
 IF Gres<>GrOk THEN BEGIN
   {Выдадим сообщение}
   InitInterFace;
   Message(GraphErrorMsg(Gres),Attrib(Yellow,Red));
   Exit;
 END;
 {Присвоение начальных значчений}
 MaxX := GetMaxX;  MaxY := GetMaxY;
 curt := t1;
 x0 := MaxX div 2; y0 := MaxY div 2;
 SetBkColor(Blue);
 SetColor(LightGreen);
 DrawGrid;
 {первая точка графика}
 prevx := x0 + round(x(curt)/px);
 prevy := y0 - round(y(curt)/py);
 {цикл нахождения точек и соединения их линиями}
 REPEAT
   curt:= curt + dt;
   curx := round(x0 + x(curt)/px);
   cury := round(y0 - y(curt)/py);
   SetColor(Yellow);
   Line(prevx,prevy,curx,cury);
   prevx := curx;
   prevy := cury;
 UNTIL curt > t2;
 {выход при нажатии клавиши}
 REPEAT UNTIL KeyPressed;
 CloseGraph;
 InitInterFace;
END;


PROCEDURE DoPlot;
VAR
  S          :String;
  Tbegin,Tend:Real;
  DeltaT,Ratio:Real;
  Entered    :Boolean;
  ToExit     :Boolean;
  Step       :Byte;
  Dim        :Byte;
CONST
  Dimensions :ARRAY[1..4] OF TmenuItem = (
 (Name:'В градусах';KeyInd:3; Key:['Г','г','1','U','u']; Proc: nil),
 (Name:'В радианах';KeyInd:3; Key:['Р','р','2','H','h']; Proc: nil),
 (Name:'В ''пи'' радиан';KeyInd:4; Key:['П','п','3','G','G']; Proc: nil),
 (Name:'Отмена';KeyInd:1; Key:['о','О','4','J','j']; Proc: nil));

BEGIN
  Message('Черчение графика кардиоиды',Attrib(Black,LightGray));
  Step:=1;
  Entered:=FALSE;
  ToExit:=FALSE;
  REPEAT
    CASE Step OF
       0:  ToExit:=TRUE;
       1:  BEGIN
            Dim := AskVariant('Параметры','Выберите размерность',4,Dimensions);
            IF Dim=4 THEN Dec(Step) ELSE Inc(Step);
           END;
       2:  BEGIN
            TBegin:=AskReal('Ввод','Введите начальное значение параметра',
                  0,Entered,DumbCheck);
            IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       3:  BEGIN
            TEnd:=AskReal('Ввод','Введите конечное значение параметра',
                      0,Entered,DumbCheck);
            IF Entered THEN BEGIN
               IF Tend<=TBegin THEN
                  Message('Должно быть больше начального!',Attrib(Yellow,Red))
               ELSE Inc(Step);
            END ELSE Dec(Step);
           END;
       4:  BEGIN
             DeltaT:= AskReal('Ввод','Введите шаг изменения параметра',
                      0.01,Entered,DumbCheck);
             IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       5:  BEGIN
             par_A:= AskReal('Ввод параметров','Введите высоту кардиодиды:',
                      10,Entered,DumbCheck);
             IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       6:  BEGIN
             par_B:= AskReal('Ввод параметров','Введите ширину кардиодиды:',
                      10,Entered,DumbCheck);
             IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
       7:  BEGIN
             Ratio:=AskReal('Ввод параметров','Введите масштаб (единиц/пиксел):',
                      0.05,Entered,DumbCheck);
             IF Entered THEN Inc(Step) ELSE Dec(Step);
           END;
    END;
  UNTIL (Step=8) OR ToExit;

  IF ToExit THEN Exit;

  {Приведение ук.единиц к радианам}
  CASE Dim OF
    1:  BEGIN
         TBegin := TBegin*Pi/180;
         TEnd := TEnd*Pi/180;
        END;
    3:  BEGIN
         TBegin := TBegin*Pi;
         TEnd := TEnd*Pi;
        END;
  END;
  ClrScr;
  PlotParmFunc(XofT,YofT, TBegin,TEnd,DeltaT,Ratio,Ratio);
  HideCursor;
END;

PROCEDURE DoExit;
BEGIN
 ExitOrNot := Ask('Вы дейстительно хотите выйти?');
END;

END.