[angvelem]

Сообщение от angvelem

Могу перевести только в Дельфи 3-й версии, Подойдёт?

Конечно это шутка, а если серьёзно, то:

Код:

program Pascal;

{$APPTYPE CONSOLE}

uses
  Windows, crt32;
 
const 
  maxn		= 10; 

type 
  Data		= Single; 
  Matrix	= array[1..maxn, 1..maxn] of Data; 
  Vector	= array[1..maxn] of Data; 

// Процедура ввода расширенной матрицы системы
procedure ReadSystem(n : Integer; var a : Matrix; var b : Vector); 
var 
  I, J, R : Integer; 
begin 
  r := WhereY; 
  GotoXY(2, r);
  Write('A'); 

  for I := 1 to n do
  begin 
    GotoXY(I * 6 + 2, R); 
    Write(I); 
    GotoXY(1, R + I + 1); 
    Write(I:2); 
  end; 

  GotoXY((n + 1) * 6 + 2, R); 
  Write('b'); 

  for I := 1 to n do
  begin
    for J := 1 to n do
    begin 
      GotoXY(J * 6 + 2, R + I + 1); 
      Read(a[I, J]); 
    end; 
    GotoXY((n + 1) * 6 + 2, R + I + 1); 
    Read(b[i]);
  end; 
end; 

// Процедура вывода результатов
procedure WriteX(n : Integer; x : Vector); 
var 
  I : Integer; 
begin 
  for I := 1 to n do 
    WriteLn('x', I, ' = ', x[i]); 
end; 

// Функция, реализующая метод Зейделя
function Zeidel(n : Integer; a : Matrix; b : Vector; var x : Vector; e : Data) : Boolean; 
var 
  I, J    : Integer; 
  s1, s2,
  v, m    : Data; 
begin 
  repeat 
    m := 0; 
    for I := 1 to n do
    begin 
      // Вычисляем суммы
      s1 := 0; 
      s2 := 0; 

      for J := 1 to I - 1 do 
        s1 := s1 + a[I, J] * x[J]; 

      for J := I to n do 
        s2 := s2 + a[I, J] * x[J]; 

      // Вычисляем новое приближение и погрешность
      v := x[i]; 
      x[i] := x[i] - (1 / a[I, I]) * (s1 + s2 - b[i]); 
      if Abs(v - x[i]) > m then 
        m := Abs(v - x[i]); 
    end; 
  until m < e; 

  Result := True;
end; 

var 
  N, I : Integer;
  a    : Matrix;
  b, x : Vector;
  e    : Data;
begin 
  ClrScr;
  WriteLn('Программа решения систем линейных уравнений по методу Зейде-ля');
  WriteLn;
  WriteLn('Введите порядок матрицы системы (макс. 10)'); 

  repeat 
    Write('>');
    Read(N);
  until (N > 0) and (N <= maxn); 

  WriteLn;
  ReadLn;
  WriteLn('Введите точность вычислений');
  
  repeat
    Write('>'); 
    Read(e); 
  until (e > 0) and (e < 1);

  WriteLn;
  ReadLn;
  WriteLn('Введите расширенную матрицу системы'); 
  ReadSystem(n, a, b);
  WriteLn;
  ReadLn;

  // Предполагаем начальное приближение равным нулю
  for I := 1 to n do 
    x[i] := 0; 

  if Zeidel(n, a, b, x, e) then
  begin
    WriteLn('Результат вычислений по методу Зейделя');
    WriteX(n, x);
    ReadLn;
  end
  else
    WriteLn('Метод Зейделя не сходится для данной системы'); 
  
  WriteLn;
  ReadLn;
end.

также потребуется юнит crt32:

Код:

{$APPTYPE CONSOLE}

unit crt32;

interface

uses
  Windows, Messages;

{$ifdef win32}
const
  Black           = 0;
  Blue            = 1;
  Green           = 2;
  Cyan            = 3;
  Red             = 4;
  Magenta         = 5;
  Brown           = 6;
  LightGray       = 7;
  DarkGray        = 8;
  LightBlue       = 9;
  LightGreen      = 10;
  LightCyan       = 11;
  LightRed        = 12;
  LightMagenta    = 13;
  Yellow          = 14;
  White           = 15;

  function WhereX: integer;
  function WhereY: integer;
  procedure ClrEol;
  procedure ClrScr;
  procedure InsLine;
  Procedure DelLine;
  Procedure GotoXY(const x,y:integer);
  procedure HighVideo;
  procedure LowVideo;
  procedure NormVideo;
  procedure TextBackground(const Color:word);
  procedure TextColor(const Color:word);
  procedure TextAttribut(const Color,Background:word);
  procedure Delay(const ms:integer);
  function KeyPressed:boolean;
  function ReadKey:Char;
  Procedure Sound;
  Procedure NoSound;
  procedure FlushInputBuffer;
  function Pipe:boolean;

var
  HConsoleInput:tHandle;
  HConsoleOutput:thandle;
  HConsoleError:Thandle;
  WindMin:tcoord;
  WindMax:tcoord;
  ViewMax:tcoord;
  TextAttr : Word;
  LastMode : Word;
  SoundFrequenz :Integer;
  SoundDuration : Integer;

{$endif win32}

implementation

{$ifdef win32}
uses
  sysutils;

var
  StartAttr:word;
  OldCP:integer;
  CrtPipe : Boolean;
  German : boolean;

procedure ClrEol;
var
  tC      : tCoord;
  Len, Nw : DWORD;
  Cbi     : TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(HConsoleOutput,cbi);
  len := cbi.dwsize.x-cbi.dwcursorposition.x;
  tc.x := cbi.dwcursorposition.x;
  tc.y := cbi.dwcursorposition.y;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,len,tc,nw);
  FillConsoleOutputCharacter(HConsoleOutput,#32,len,tc,nw);
end;

procedure ClrScr;
var tc :tcoord;
  nw: DWORD;
  cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  tc.x := 0;
  tc.y := 0;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
  FillConsoleOutputCharacter(HConsoleOutput,#32,cbi.dwsize.x*cbi.dwsize.y,tc,nw);
  setConsoleCursorPosition(hconsoleoutput,tc);
end;

Function WhereX: integer;
var cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  result := tcoord(cbi.dwCursorPosition).x+1
end;

Function WhereY: integer;
var cbi : TConsoleScreenBufferInfo;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  result := tcoord(cbi.dwCursorPosition).y+1
end;

Procedure GotoXY(const x,y:integer);
var coord :tcoord;
begin
  coord.x := x-1;
  coord.y := y-1;
  setConsoleCursorPosition(hconsoleoutput,coord);
end;

procedure InsLine;
var
 cbi : TConsoleScreenBufferInfo;
 ssr:tsmallrect;
 coord :tcoord;
 ci :tcharinfo;
 nw:DWORD;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  coord := cbi.dwCursorPosition;
  ssr.left := 0;
  ssr.top := coord.y;
  ssr.right := cbi.srwindow.right;
  ssr.bottom := cbi.srwindow.bottom;
  ci.asciichar := #32;
  ci.attributes := cbi.wattributes;
  coord.x := 0;
  coord.y := coord.y+1;
  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
  coord.y := coord.y-1;
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;

procedure DelLine;
var
 cbi : TConsoleScreenBufferInfo;
 ssr:tsmallrect;
 coord :tcoord;
 ci :tcharinfo;
 nw:DWORD;
begin
  getConsoleScreenBufferInfo(HConsoleOutput,cbi);
  coord := cbi.dwCursorPosition;
  ssr.left := 0;
  ssr.top := coord.y+1;
  ssr.right := cbi.srwindow.right;
  ssr.bottom := cbi.srwindow.bottom;
  ci.asciichar := #32;
  ci.attributes := cbi.wattributes;
  coord.x := 0;
  coord.y := coord.y;
  ScrollConsoleScreenBuffer(HconsoleOutput,ssr,nil,coord,ci);
  FillConsoleOutputAttribute(HConsoleOutput,textattr,cbi.dwsize.x*cbi.dwsize.y,coord,nw);
end;

procedure TextBackground(const Color:word);
begin
  LastMode := TextAttr;
  textattr := (color shl 4) or (textattr and $f);
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure TextColor(const Color:word);
begin
  LastMode := TextAttr;
  textattr := (color and $f) or (textattr and $f0);
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure TextAttribut(const Color,Background:word);
begin
  LastMode := TextAttr;
  textattr := (color and $f) or (Background shl 4);
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure HighVideo;
begin
  LastMode := TextAttr;
  textattr := textattr or $8;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure LowVideo;
begin
  LastMode := TextAttr;
  textattr := textattr and $f7;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure NormVideo;
begin
  LastMode := TextAttr;
  textattr := startAttr;
  SetConsoleTextAttribute(hconsoleoutput,textattr);
end;

procedure FlushInputBuffer;
begin
  FlushConsoleInputBuffer(hconsoleinput)
end;

function keypressed:boolean;
var NumberOfEvents:DWORD;
begin
  GetNumberOfConsoleInputEvents(hconsoleinput,NumberOfEvents);
  result := NumberOfEvents > 0;
end;

function ReadKey: Char;
var
  NumRead:       DWORD;
  InputRec:      TInputRecord;
begin
  while not ReadConsoleInput(HConsoleInput,
                             InputRec,
                             1,
                             NumRead) or
           (InputRec.EventType <> KEY_EVENT) do;
  Result := InputRec.Event.KeyEvent.AsciiChar
end;

procedure delay(const ms:integer);
begin
  sleep(ms);
end;

Procedure Sound;
begin
  windows.beep(SoundFrequenz,soundduration);
end;

Procedure NoSound;
begin
  windows.beep(soundfrequenz,0);
end;

function Pipe:boolean;
begin
  result := crtpipe;
end;

procedure init;
var
  cbi : TConsoleScreenBufferInfo;
  tc  : tcoord;
begin
  SetActiveWindow(0);
  HConsoleInput  := GetStdHandle(STD_InPUT_HANDLE);
  HConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
  HConsoleError  := GetStdHandle(STD_Error_HANDLE);

  if getConsoleScreenBufferInfo(HConsoleOutput, cbi) then
  begin
    TextAttr  := cbi.wAttributes;
    StartAttr := cbi.wAttributes;
    lastmode  := cbi.wAttributes;
    tc.x      := cbi.srwindow.left+1;
    tc.y      := cbi.srwindow.top+1;
    windmin   := tc;
    ViewMax   := cbi.dwsize;
    tc.x      := cbi.srwindow.right+1;
    tc.y      := cbi.srwindow.bottom+1;
    windmax   := tc;
    crtpipe   := false;
  end
  else
    crtpipe := true;

  SoundFrequenz := 1000;
  SoundDuration := -1;
  oldCp := GetConsoleoutputCP;
  SetConsoleoutputCP(1251);
  german := $07 = (LoWord(GetUserDefaultLangID) and $3ff);
end;

initialization
  init;

finalization
  SetConsoleoutputCP(oldcp);
{$endif win32}

end.