Заполнить массив змейкой

[NeGaTiVe]

Спасибо за помощь, разобрался

[LeBron]

Вот Вам задача: Змейка.
Вот мой солюшн этой задачи:

var input,output:text;i,q,n,j,t,x,y:longint; ar:array[1..100,1..100] of longint;
begin
assign(input,'input.txt');reset(input);
assign(output,'output.txt');rewrite(output);
readln(input,n);
for i:=1 to n*2-1 do begin if i mod 2=1 then begin x:=0;y:=i+1; 
for t:=1 to i do begin inc(x);
dec(y);if (x>0) and (x<=n) and (y>0) and (y<=n) then begin inc(q);ar[x,y]:=q;end;end;end 
else begin y:=0;x:=i+1;
for t:=1 to i do begin inc(y);dec(x);if (x>0) and (x<=n) and (y>0) and (y<=n) then begin inc(q);ar[x,y]:=q;end;end;end;end;

for i:=1 to n do begin for j:=1 to n do begin write(output,ar[i,j],' ');end;writeln(output); end;

close(output);close(input);
end.

Смотрите, читайте, анализируйте... Делайте, что хотите

[NeGaTiVe]

это как-то очень сложно, мне бы сделать двумерный массив, как на рисунке (см.1 пост) без ввода чисел...

[LeBron]

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

это как-то очень сложно, мне бы сделать двумерный массив, как на рисунке (см.1 пост) без ввода чисел...

Тогда такой вариант:

var {input,output:text;}i,q,n,j,t,x,y:longint; ar:array[1..100,1..100] of longint;
begin
{assign(input,'input.txt');reset(input);
assign(output,'output.txt');rewrite(output);  }
readln(n);
for i:=1 to n do begin if i mod 2=1 then begin x:=0;y:=i+1;
for t:=1 to i do begin inc(x);
dec(y);if (x>0) and (x<=n) and (y>0) and (y<=n) then begin inc(q);ar[x,y]:=q;end;end;end
else begin y:=0;x:=i+1;
for t:=1 to i do begin inc(y);dec(x);if (x>0) and (x<=n) and (y>0) and (y<=n) then begin inc(q);ar[x,y]:=q;end;end;end;end;
for i:=1 to n do begin for j:=1 to n do begin write({output,}ar[i,j],' ');end;writeln{(output)}; end;
{close(output);close(input); }
end.

Здесь закоментировал изменения относительно начального - работу с файлами вырезал, так же поменял одно из значений внутри кода. Работает корректно. В коде оставил ту часть, которая связана с заполнением нижней части массива. Потрудитесь найти и удалить ее сами - она хоть и не делает решение неверным, но явно лишняя. Если надо - можете вписать свои комментарии и сделать позиционированный вывод. В общем, доделать.
По поводу ввода чисел - и в этом, и в предидущем коде надо ввести только одно число - размер массива. Если размер стандартный, то объявите его константой, или вместо считывания напишите присвоение.

[NeGaTiVe]

Спасибо за помощь, разобрался

[Евгенийgg]

помогите доделать 2 4асть немогу((

var a:array[1..100,1..100] of integer;
    i,j,n,m,k,l,b:integer;
begin
read(n); k:=0; m:=0;    l:=sqr(n); b:=0;
repeat
 l:=l div 10;
 b:=b+1;
until l=0;
while m<>n do
 begin
  m:=m+1;
   if m mod 2<>0 then
    for i:=1 to m do
     begin
      k:=k+1;
      for j:=1 to m do
       if i+j=m+1 then a[i,j]:=k;
     end
    else
     begin
      k:=k+m+1;
      for i:=1 to m do
       begin
        k:=k-1;
        for j:=1 to n do
         if i+j=m+1 then a[i,j]:=k;
        end;
      k:=k+m-1;
     end;
     end;
  for i:=1 to n do
   begin
    for j:=1 to n do write(a[i,j]:b,' ');
    writeln;
   end;
end.

___________
Код нужно оформлять по правилам:
тегом [CODE]..[/СODE] (это кнопочка с решёточкой #)
Не забывайте об этом!
Модератор.

[Serge_Bliznykov]

мне, честно говоря, решение от LeBron более понятно.. Только доработать его чуток и всё..

а ещё можете сходить сюда:
http://programmersforum.ru/showthread.php?t=3338
http://www.programmersforum.ru/showthread.php?t=27203
http://www.programmersforum.ru/showthread.php?t=80002

ну ещё можно поискать: например, по ключевой фразе "Заполнение матрицы зигзагом."


по одной из ссылочек взял решение (c) eoln

var a: array[1..100, 1..100] of integer;
  i, j, n, l, k, b, q : integer;
begin
  read(n);
  l := sqr(n); b := 0;
  repeat
    l := l div 10;
    b := b + 1;
  until l = 0;


  { алгоритм для квадратной матрицы }
  q := 0;
  for i := 1 to 2 * n - 1 do
  begin
    if i > n then k := n else k := i; {ограничение для строк}
    if i mod 2 = 1 then {вверх}
      for j := 1 + i - k to k do begin
         inc(q);
         a[1 - j + i, j] := q
      end
    else {вниз}
      for j := k downto 1 + i - k do begin
        inc(q);
        a[1 - j + i, j] := q
      end;
  end;


  for i := 1 to n do
  begin
    for j := 1 to n do write(a[i, j]: b, ' ');
    writeln;
  end;
end.

[Евгенийgg]

Пишет ,что решение долгое надо короче(

[Serge_Bliznykov]

1) кто пишет, что надо короче?!
Это решение от eoln надо короче?! типа полтора десятка строк это слишком много?!!
меньше строчек кода надо? Так запишите в одну строчку весь цикл!

2) короче - можно выкинуть вычисление b (и саму переменную b)
как ещё короче - я лично не знаю... Пусть тот, кто знает - подскажет..
я всё сказал..

[Евгенийgg]

http://acmp.ru/index.asp?main=task&id_task=197
тута попробуй решить все время пишет ''Time limit exceeded''