[js_m1m]

Задали в вузике две задачки, одну осилил сам, но почему-то какие-то проблемы. Вторую не очень понимаю, как реализовать. Помогите, пожалуйста. Спасибо заранее.

1.Дан целочисленный массив Х(3n). Последовательность элементов этого массива оп-ределяет на плоскости n квадратов со сторонами, параллельными осям координат. Так, (х1,х2) - координаты левого верхнего угла первого квадрата, а х3 - длина его стороны, и т. д. Определить номера квадратов, которым принадлежит точка с известными координа-тами (p,q).

Код:

program Project4;

{$APPTYPE CONSOLE}                

uses
SysUtils;

var
   X: array[0..8] of integer;
   p,q: integer;
   l,i,j: integer;
   x1,x2,x3: integer;

begin
  Writeln('vvedi p,q');
  Readln(p,q);
  X[0]:=3;
  X[1]:=5;
  X[2]:=4;
  X[3]:=9;
  X[4]:=1;
  X[5]:=15;
  X[6]:=4;
  X[7]:=17;
  X[8]:=2;
   l := Length(X);
   i := 0;
   j := 1;
   while (i < l) do begin
      x1 := X[i];
      x2 := X[i + 1];
      x3 := X[i + 2];
      //Writeln(x1,',',x2,',',x3);
      if ((p >= x1) and (q >= x2) and (p <= (x1 + x3)) and (q <= (x2 + x3))) then
      begin
         writeLn(j);
         //writeln(l);
      end;
      Inc(j);
      Inc(i,3);
   end;
   readln;
end.

В итоге номер квадрата все-таки почему-то не выводится.

2. Приложил условие.

[poli-smen]

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

Код:

.....
      if ((p >= x1) and (q >= x2) and (p <= (x1 + x3)) and (q <= (x2 + x3))) then
.....

В итоге номер квадрата все-таки почему-то не выводится.

Потому что у тебя неправильное условие.
Должно быть так:

Код:

if ((p >= x1) and (q <= x2) and (p <= (x1 + x3)) and (q >= (x2 - x3))) then

[js_m1m]

Благодарю, все верно. А есть какие-нибудь аналоги clrscr на делфи? И как ими пользоваться(погугли и ЯННП).

[nixel]

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

Благодарю, все верно. А есть какие-нибудь аналоги clrscr на делфи? И как ими пользоваться(погугли и ЯННП).

Просто так виндовое консольное окно не очистить. Самый простой способ - забить окно пустыми символами или сразу строками.

Для символов (выдрано из контекста):

procedure ClearConsoleWindow;
var
ConsoleHandle:THandle;
ConsoleInfo: TConsoleScreenBufferInfo;
Coord:TCoord;
WrittenChars:DWORD;
begin
FillChar(ConsoleInfo,SizeOf(TConsoleScreenBufferIn fo),0);

[lmikle]

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

Благодарю, все верно. А есть какие-нибудь аналоги clrscr на делфи? И как ими пользоваться(погугли и ЯННП).

А зачем?
В чем смысл очистки консоли. Как раз для консольного приложения чистить окно является плохим тоном. Если уж очень приспичило, то просто открой свою консоль.

[js_m1m]

Cделал без чистки консоли. И чистить ее все-таки заодно научился. Теперь со второй программой.

Сделал, но опять не работает. Что не так?

Код:

program laba_5;

{$APPTYPE CONSOLE}

uses
SysUtils;
var
   l,i,j,m: integer;
   a: array[0..255,0..255] of char;
procedure filling;
var i,j,m:integer;
b: array[0..2] of char;
begin
b[0]:='*';
b[1]:='?';
b[2]:='$';
randomize;
 for i:= 1 to m do
  for j:=1 to m do
    a[i,j]:=b[random(3)];
  end;
procedure cut;
var m1,m2,d1,d2,i1,i2,s2,m,k:integer;
begin
m1:=m;
m2:=m;
  repeat
  m2:=1+m2 div sqr(m2)*(m-1);
  m1:=1+(m1 div m2)*(m2 div m1)*(m-1);
  d2:=1-2*(m2 div sqr(m2));
  d1:=1-2*(m1 div sqr(m1));
  i1:=m1-d1*k;
  s2:=m2;
    while i1 <> m1 do begin
    i1:=i1+d1;
    s2:=s2-d2;
    i2:=s2;
      while i2<> m2 do begin
      i2:=i2+d2;
      a[i1,i2]:=' ';
      end;
    end;
  until (m1=m) and (m2=m);
end;

procedure print;
var i,j,m:integer;
begin
  for i:=1 to m do begin
    for j:=1 to m do
      write(a[i,j]);
      writeln;
    end;
  end;
begin
Writeln('Enter the length of the square');
Readln(m);
filling;
cut;
print;
Writeln('Press enter to exit.');
readln;
end.

[js_m1m]

Код:

program laba_5;

{$APPTYPE CONSOLE}

uses
SysUtils;
var
   m: integer;
   a: array[0..255,0..255] of char;
procedure filling;
var i,j:integer;
b: array[0..2] of char;
begin
b[0]:='*';
b[1]:='?';
b[2]:='$';
randomize;
 for i:= 1 to m do
  for j:=1 to m do
    a[i,j]:=b[random(3)];
  end;
procedure cut;
var zv,pr,i1,i2,k:integer;
begin
pr:=m div 2;
zv:=1;
For k:=1 to m div 2 do
  begin
  for i1:=1 to pr do
    Write(' ');
  for i1:=1 to zv do
    Write(A[pr+i1,k]);
    WriteLn;
  Inc(zv,2);
  Dec(pr);
  end;
For k:=((m div 2)+1) to m do
  begin
  for i1:=1 to pr do
    Write(' ');
  for i1:=1 to zv do
    Write(A[pr+i1,k]);
    WriteLn;
  Inc(pr);
  Dec(zv,2);
  end;
end;
begin
Writeln('Enter the length of the square');
Readln(m);
filling;
cut;
Writeln('Press enter to exit.');
readln;
end.

[js_m1m]

Код:

program Project2;
 
{$APPTYPE CONSOLE}
 
uses
  SysUtils;
 
const m = 17;
      k = 9;

var a: array[1..m, 1..m] of char;
 
procedure fill;
const b: array[0..2] of char = ('*', '$', '?');
var i, j: integer;
begin
  randomize;
  for i := 1 to m do
    for j := 1 to m do
      a[i, j] := b[random(3)];
end;
 
procedure cut;
  function f (const x1, x2: integer): integer;
  begin
    f := byte(x1 = 1) * x2 + 1;
  end;
var m1, m2, d1, d2, i1, i2, s2: integer;
begin
  m1 := m; m2 := m;
  repeat
    m2 := f(m2, m - 1);
    m1 := f(m1 xor m2 + 1, m - 1);
    d2 := f(m2, -2);
    d1 := f(m1, -2);
    i1 := m1 - d1 * k;
    s2 := m2;
    while i1 <> m1 do begin
      i1 := i1 + d1;
      s2 := s2 - d2;
      i2 := s2;
      while i2 <> m2 do begin
        i2 := i2 + d2;
        a[i1, i2] := ' ';
      end;
    end;
  until (m1 = m) and (m2 = m);
end;
 
procedure print;
var i, j: integer;
begin
  for i := 1 to m do begin
    for j := 1 to m do
      write(a[i, j]);
    writeln;
  end;
  readln;
end;
 
begin
  fill();
  cut();
  print();
  readln;
end.