29. Умножение по Аль-Хорезми, в row - 1 число,в col - 2 число

{Результат пишется в конец массива ROW                    }

procedure Multiplying;

var i,j,cr,cc:integer;

    carry,sum:longint;

begin

    dp:=high(row); cr:=nr; cc:=nc;

    carry := 0;

    while (cc>0) do begin

        i:=cr; j:=cc; sum:=carry;

        while (i<=nr) and (j>=1) do begin

           sum:=sum+row[i]*col[j];

           inc(i); dec(j);

        end;

        row[dp]:=sum mod 10; dec(dp);

        carry:=sum div 10;

        if cr>1 then dec(cr) else dec(cc);

    end;

    while (carry<>0) do begin

        row[dp]:=carry mod 10;

        carry:=carry div 10;

        dec(dp);

    end;

    inc(dp);

end;

 

begin

     {обнуление массивов-множителей}

     fillchar(row,sizeof(row),0); fillchar(col,sizeof(col),0);

     {поразрядный ввод 1-го числа}

     writeln('введите 1-е число число:');

     c:=#0;

     while NOT(c in ['0'..'9']) do c:=readkey;

     nr:=0;

     while (c in ['0'..'9']) do begin

        write(c);

        inc(nr); row[nr]:=ord(c)-ord('0');

        c:=readkey;

     end;

     writeln;

     {поразрядный ввод 2-го числа}

     writeln('введите 2-е число число:');

     while NOT(c in ['0'..'9']) do c:=readkey;

     nc:=0;

     while (c in ['0'..'9']) do begin

        write(c);

        inc(nc); col[nc]:=ord(c)-ord('0');

        c:=readkey;

     end;

     writeln;

     {вызов процедуры умножения, затем - вызов процедуры вывода результата}

     Multiplying; PrintResult;

end.

30. Кодировка. Пример простой кодировки (сдвиг по ключу)

{--------------------------------------------------------------------------}

{ Алгоритм: каждый код символа увеличивается на некоторое число - "ключ"   }

{--------------------------------------------------------------------------}

 

var s:string;

    i,key:integer;

begin

     writeln('Введите текст'); readln(s);

     writeln('Введите ключ (число от 1 до 255)'); readln(key);

     for i:=1 to length(s) do s[i]:=char( ord(s[i]) + key  );

     writeln('Зашифрованный текст: ',s);

end.

31. Обработка текста

Подсчет количества слов в тексте

{--------------------------------------------------------------------------}

{ На входе - текст, на выходе - количество слов в тексте                   }

{--------------------------------------------------------------------------}

const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я'];

var s:string;

    i:integer;

    wc:integer;

begin

     writeln('Введите текст'); readln(s);

     i:=1; wc:=0;

     Repeat

        while NOT(s[i] in Alpha) and (i<=length(s)) do inc(i);

        if (i<=length(s)) then inc(wc);

        while (s[i] in Alpha) and (i<=length(s)) do inc(i);

     Until (i>length(s));

     writeln('Количество слов в этом тексте = ',wc);

end.

Выделение слов из текста

{--------------------------------------------------------------------------}

{ На входе - текст, на выходе - список слов                                }

{--------------------------------------------------------------------------}

const Alpha : set of char=['A'..'Z','А'..'П','Р'..'Я','a'..'z','а'..'п','р'..'я'];

var s,t:string;

    i:integer;

begin

     writeln('Введите текст'); readln(s);

     writeln('Список слов в тексте:');

     i:=1;

     Repeat

        while NOT(s[i] in Alpha) and (i<=length(s)) do inc(i);

        t:='';

        while (s[i] in Alpha) and (i<=length(s)) do begin

              t:=t+s[i];

              inc(i);

        end;

        if length(t)<>0 then writeln(t);

     Until (i>length(s));

end.

Выделение чисел из текста

{--------------------------------------------------------------------------}

{ На входе - текст, на выходе - список чисел                               }

{--------------------------------------------------------------------------}

const Digits : set of char=['0'..'9'];

var s,d:string;

    i:integer;

begin

     writeln('Введите текст, в котором есть и цифры:'); readln(s);

     writeln('Список чисел в тексте:');

     i:=1;

     Repeat

        while NOT(s[i] in Digits) and (i<=length(s)) do inc(i);

        d:='';

        while (s[i] in Digits) and (i<=length(s)) do begin

              d:=d+s[i];

              inc(i);

        end;

        if length(d)<>0 then writeln(d);

     Until (i>length(s));

end.

Разрешение ввода только цифр

{--------------------------------------------------------------------------}

{ На входе - текст с цифрами (но будут вводиться только цифры              }

{--------------------------------------------------------------------------}

uses crt;

const ENTER=#13;

var c:char;

 

begin

     writeln('Вводите буквы и цифры');

     c:=readkey;

     while (c<>ENTER) do begin

        if c in ['0'..'9'] then write(c);

        c:=readkey;

     end;

     writeln;

end.

Перевод в маленькие буквы (нижний регистр)

{--------------------------------------------------------------------------}

{ На входе - текст, на выходе - текст из маленьких букв                    }

{--------------------------------------------------------------------------}

var s:string;

 

function SmallAlpha(ps:string):string;

var i:integer;

begin

   for i:=1 to length(ps) do begin

     case ps[i] of

        'A'..'Z','А'..'П': inc(ps[i],32);

        'Р'..'Я'         : inc(ps[i],80);

     end;

   end;

   SmallAlpha:=ps;

end;

 

begin

     writeln('Введите любой текст'); readln(s);

     writeln('Этот же текст маленькими буквами:');

     writeln(SmallAlpha(s));

end.

Перевод в заглавные буквы (верхний регистр)

{--------------------------------------------------------------------------}

{ На входе - текст, на выходе - текст из больших букв                      }

{--------------------------------------------------------------------------}

var s:string;

 

function BigAlpha(ps:string):string;

var i:integer;

begin

   for i:=1 to length(ps) do begin

     case ps[i] of

        'a'..'z','а'..'п': dec(ps[i],32);

        'р'..'я'         : dec(ps[i],80);

     end;

   end;

   BigAlpha:=ps;

end;

 

begin

     writeln('Введите любой текст'); readln(s);

     writeln('Этот же текст большими буквами:');

     writeln(BigAlpha(s));

end.

Удаление из текста комметариев типа {...}

{--------------------------------------------------------------------------}

{ На входе - текст с комметариями, на выходе - текст без комментарив       }

{--------------------------------------------------------------------------}

var s,r:string;

    state,i:integer;

begin

     writeln('Введите любой текст с комментариями'); readln(s);

     r:=''; state:=0; {нормальное состояние}

     for i:=1 to length(s) do begin

        case s[i] of

           '{': if state=0 then state:=1;  {теперь мы внутри комментария}

           '}': if state=1 then state:=0   {теперь мы вышли из комментария}

                else r:=r+s[i];            {мы не в комментарии}

           else if state=0 then r:=r+s[i]; {мы не в комментарии}

        end;

     end;

     writeln('новый текст:'); writeln(r);

end.

32.       Бэк-трекинг: Города

{--------------------------------------------------------------------------}

{ Задача "Города".  (А.Н.Никитин)                                          }

{    Широко известна  игра "Города". Называется какой-нибудь город, допус- }

{ тим, "Саратов". Кончается на "в", значит требуется назвать другой город, }

{ у которого в названии первая буква "в". Это может быть "Воронеж". Следу- }

{ ющий город должен начинаться на "ж" и т.д.  Запрещено повторять название }

{ городов. Надо написать программу, которая  из  набора  названий  городов }

{ (все названия разные) строит цепочку максимальной длины.                 }

{                                                                          }

{    Входные данные: файл TOWN.IN в 1-й строке содержит  количество слов в }

{ наборе. Начиная  со второй строки  (по одному в строке) следуют названия }

{ городов (все буквы в названиях - заглавные).                             }

{                                                                          }

{    Выходные данные: 1-я строка TOWN.OUT содержит  длину максимальной це- }

{ почки. Начиная со второй строки идет вариант цепочки,  т.е. названия (по }

{ одному в строке) городов в порядке, который требуют условия игры.        }

{                                                                          }

{    Примечание: Список городов во входном файле не превышает 20.          }

{                Время тестирования - 2 секунды. (Pentium)                 }

{                                                                          }

{ ПРИМЕР:                                                                  }

{   ┌──────── TOWN.IN ──────────────┬─────────── TOWN.OUT ───────────────┐ }

{   │5                              │5                                   │ }

{   │НОВОСИБИРСК                    │САМАРА                              │ }

{   │АСТРАХАН                       │АСТРАХАН                            │ }

{   │САМАРА                         │НОВОСИБИРСК                         │ }

{   │ВЛАДИМИР                       │КИРОВ                               │ }

{   │КИРОВ                          │ВЛАДИМИР                            │ }

{   └───────────────────────────────┴────────────────────────────────────┘ }

{--------------------------------------------------------------------------}

{$M $8000,0,$1FFFF}

program towns;          { "Города". Решение А.Никитина, Самара  }

const mnt         = 20; { максимальное количество слов на входе }

var   list,chain,store :array [1..mnt] of string; { для списка и цепочек }

      numin       :integer; { реальное количество слов на входе }

      pc          :integer; { Указатель на хвост цепочки }

      ml          :integer; { Длина наибольшей цепочки }

      sym         :char;    { Первичная буква для перебора }

 

procedure read_data; { Начальные установки и чтение данных }

var i : integer;

begin

     pc:=0; ml:=0; numin:=0;

     assign(input,'TOWN.IN'); reset(input);

     fillchar(chain,sizeof(chain),0);

     readln(numin);

     if (numin>mnt) then numin:=mnt;

     for i:=1 to numin do readln(list[i]);

     close(input);

end;

procedure write_results; { Запись результатов в файл }

var i : integer;

begin

     assign(output,'TOWN.OUT'); rewrite(output);

     writeln(ml);

     if (ml>0) then begin

        for i:=1 to ml do writeln(store[i]);

     end;

     close(output);

end;

procedure store_chain; { Запоминаем только более длинную цепочку }

var i:integer;

begin

     if (pc>ml) then begin

        store:=chain;

        ml:=pc;

     end;

end;

{ Возвращает указатель названия по 1-й букве, 0 - такого элемента нет }

function find_next_item( c:char; n:integer ):integer;

var i:integer;

begin

    i:=1; find_next_item:=0;

    while (i<=numin) and (n>0) do begin

       if (list[i][1]=c) then dec(n);

       inc(i);

    end;

    if (n=0) then find_next_item:=pred(i);

end;

{ Алгоритм построения цепочек. }

procedure build_chain( c:char; n:integer ); { Метод: перебор с возвратом.  }

var i:integer;                              { Известен как "back-tracking" }

begin

    i:=find_next_item(c,n);

    if (i>0) then begin

       inc(pc); chain[pc]:=list[i]; list[i][1]:='X'; { вычеркиваем }

       build_chain(list[i][length(list[i])], 1);

       dec(pc); list[i][1]:=c; { возвращаем }

       build_chain(c, n+1);

    end else store_chain;

end;

 

begin

     read_data;

     for sym:='А' to 'Я' do build_chain(sym,1);

     write_results;

end.

33.       Бэк-трекинг

Обход шахматной доски конем

Маршрут см. в файле OUTPUT.TXT

{--------------------------------------------------------------------------}

{$G+}

const wb=8; nb=wb*wb;

      s:array[1..8,1..2] of integer =

      ((-2,1),(-1,2),(1,2),(2,1),(2,-1),(1,-2),(-1,-2),(-2,-1));

 

var   b: array[1..wb,1..wb] of boolean;

      m: array[1..nb,1..2] of integer;

      p:    integer;

 

procedure PrintAndExit;

var i:integer;

begin

  assign(output,'output.txt'); rewrite(output);

  for i:=1 to nb-1 do write(m[i,1],':',m[i,2],',');

  writeln(m[nb,1],':',m[nb,2]); halt;

end;

 

procedure Solution(r,c:integer);

var d,i,j:integer;

begin

  if (p>pred(nb)) then PrintAndExit;

  for d:=1 to 8 do begin

    i:=r+s[d,1]; j:=c+s[d,2];

    if NOT(i in[1..wb]) or NOT(j in[1..wb]) or (b[i,j]) then continue;

    inc( p );

    m[p,1]:=i; m[p,2]:=j; b[i,j]:=true;

    Solution( i,j );

    dec( p );

    b[i,j]:=false;

  end;

end;

 

var i,j:integer;

begin

  fillchar(b,sizeof(b),false);

  for i:=1 to wb div 2 do

      for j:=1 to wb div 2 do begin

         p:=1; m[p,1]:=i; m[p,2]:=j; b[i,j]:=true;

         Solution(i,j);

         b[i,j]:=false;

      end;

end.

Проход по лабиринту

{ Есть матрица n:m, состоящая из 0 и 1. 1 - это стенка, 0 - проход.        }

{ Надо найти оптимальный проход из точки is,js (нчаало) в точку ie, je     }

{ (конец).                                                                 }

{                                                                          }

{ Входной файл LAB.IN содержит:                                            }

{ 1-я строка - размер поля                                                 }

{ 2-я строка - координаты начальной позиции (row,col)                      }

{ 3-я строка - координаты конечной позиции (row,col)                       }

{ 4-я строка и далее - схему лабиринта из 0 и 1                            }

{ Например:                                                                }

{ 10 10                                                                    }

{ 2 10                                                                     }

{ 1 6                                                                      }

{ 1 1 1 1 1 0 1 1 1 1                                                      }

{ 1 0 0 0 0 0 1 0 1 0                                                      }

{ 1 0 1 1 1 1 1 0 1 0                                                      }

{ 1 0 1 0 1 0 0 0 1 0                                                      }

{ 1 0 1 0 1 0 0 0 1 0                                                      }

{ 0 0 1 0 1 0 0 0 1 0                                                      }

{ 0 0 1 0 1 1 1 1 1 0                                                      }

{ 1 0 0 1 0 1 0 0 0 0                                                      }

{ 1 1 0 0 0 0 0 1 0 0                                                      }

{ 1 1 1 1 1 1 1 1 1 1                                                      }

{                                                                          }

{ Выходной файл LAB.OUT содержит маршрут прохода (i1:j1 ... in:jn):        }

{ 1:10                                                                     }

{ 2:10                                                                     }

{ 3:10                                                                     }

{ ....                                                                     }

{--------------------------------------------------------------------------}

const LN = 50; LM = 50;

var a:array[1..LN,1..LM] of byte;

    p:array[1..LN*LM,1..2] of byte;

    s:array[1..LN*LM,1..2] of byte;

    n,m,si,sj,ei,ej,index,min:integer;

 

procedure INIT;

var i,j:integer;

begin

     assign(input,'lab.in'); reset(input);

     assign(output,'lab.out'); rewrite(output);

     readln(n,m);

     readln(si,sj);

     readln(ei,ej);

     for i:=1 to n do begin

         for j:=1 to n-1 do begin

             read(a[i,j]);

         end;

         readln(a[i,n]);

     end;

     index:=0; min:=ln*lm;

end;

 

procedure Store;

begin

    if (min > index) then begin

        move( p, s, sizeof(p) );

        min:=index;

    end;

end;

 

procedure DONE;

var i:integer;

begin

    for i:=1 to min do writeln(s[i,1],':',s[i,2]);

end;

 

procedure FindPath(i,j:integer);

begin

    a[i,j]:=2;

    inc(index);

    p[index,1]:=i; p[index,2]:=j;

    if (i=ei) and (j=ej) then begin

        Store;

    end else begin

        if (i>1) and (a[i-1,j]=0) then FindPath(i-1,j);

        if (i<n) and (a[i+1,j]=0) then FindPath(i+1,j);

        if (j>1) and (a[i,j-1]=0) then FindPath(i,j-1);

        if (j<m) and (a[i,j+1]=0) then FindPath(i,j+1);

    end;

    dec(index);

    a[i,j]:=0;

end;

 

begin

     INIT;

     FindPath(si,sj);

     DONE;

end.

Домино

{--------------------------------------------------------------------------}

{ Берутся случайных N костяшек из одного набора домино (1<=N<=28).         }

{ Задача состоит в том, чтобы образовать из этих N костяшек самую длинную  }

{ цепочку, состыковывая их по правилам домино частями с равным количеством }

{ точек.                                                                   }

{                                                                          }

{ Входные данные: Входной файл с именем "D.IN" содержит информацию о       }

{ наборе костяшек. 1-я строка - количество костяшек.                       }

{ 2-я и последующие строки - парные наборы точек (числа разделены          }

{ пробелом). В каждой строке записана пара точек, указанной на одной       }

{ костяшке. Количество пар соответствует числу из первой строки.           }

{ Выходные данные: результаты работы программы записываются в файл "D.OUT".}

{ 1-я строка содержит длину максимальной цепочки костяшек. 2-я строка      }

{ содержит пример такой цепочки, при этом пары (цифры) на костяшках        }

{ записываются без пробелов, подряд, а между костяшками в цепочке ставится }

{ двоеточие.                                                               }

{ Пример входного файла:                   Пример выходного файла:         }

{ 5                                        5                               }

{ 1 2                                      56:62:21:13:36                  }

{ 1 3                                                                      }

{ 2 6                                                                      }

{ 3 6                                                                      }

{ 5 6                                                                      }

{--------------------------------------------------------------------------}

 

{ Задача "Домино", решение: А.Никитина, Самара }

{$M $C000,0,650000}

const max         = 28;

      maxtime     = 60;

      tl          :longint = (maxtime*18); { чуть меньше 60 сек }

      yes         :boolean = false; {флаг выхода, если уже есть цепочка из n}

var   m           :array [0..6,0..6] of boolean;

      n           :byte; {кол-во костяшек на входе, 1..28}

      cep,best :array [1..max*2] of byte; { цепочка/память }

      p,maxlen        :integer; { указатель на хвост цепочки/длина макс.цеп. }

      jiffy       :longint absolute $0040:$006C; { секундомер, точнее тикомер }

 

procedure ReadData; { начальные установки и считывание данных }

var i,a,b : byte;

begin

  tl:=jiffy + tl;

  p:=1; maxlen:=0;

  assign(input,'d.in'); reset(input);

  fillchar(cep,sizeof(cep),0);

  fillchar(m,sizeof(m),false);

  readln(n);

  for i:=1 to n do begin

     readln(a,b);

     m[a,b]:=true; m[b,a]:=true;

  end;

  close(input);

end;

 

procedure WriteResults; { запись результата }

var i : integer;

begin

  assign(output,'d.out'); rewrite(output);

  writeln(maxlen div 2);

  if (maxlen>1) then begin

     i:=1;

     while (i<pred(maxlen)) do begin

        write(best[i],best[i+1],':');

        inc(i,2);

     end;

     write(best[pred(maxlen)],best[maxlen]);

  end;

  close(output);

end;

{ более длинная цепочка запоминается в массиве best }

procedure s_cep;

begin

  if (p-1>maxlen) then begin

     move(cep,best,p-1);

     maxlen:=p-1;

     yes:=(maxlen div 2=n);

  end;

end;

{ сущеуствует ли еще подходящие костяшки? }

function exist(k:integer):boolean;

var i : integer;

begin

  i:=0; while (i<=6) and not(m[k,i]) do inc(i);

  exist:=(i<=6);

end;

{ построение цепочек }

procedure make_cep(f:integer);

var s:integer;

begin

  if (yes) or (tl-jiffy<=0) then exit; {пора остановиться?}

  if (m[f,f]) then begin  {исключение позволяет улучшить перебор}

         m[f,f]:=false; { убираем костяшку }

         cep[p]:=f; cep[succ(p)]:=f; inc(p,2); {идея исключения - Савин}

         if exist(f) then make_cep(f) else s_cep;

         dec(p,2);

         m[f,f]:=true; { возвращаем костяшку }

  end else

  for s:=0 to 6 do        {стандартный бэк-трекинг}

      if (m[f,s]) then begin

         m[f,s]:=false; m[s,f]:=false; { убираем костяшку }

         cep[p]:=f; cep[succ(p)]:=s; inc(p,2);

         if exist(s) then make_cep(s) else s_cep;

         dec(p,2);

         m[f,s]:=true; m[s,f]:=true; { возвращаем костяшку }

      end;

end;

 

var i:integer;

begin

 ReadData;

  for i:=0 to 6 do make_cep(i);

  WriteResults;

end.

Последовательность

{--------------------------------------------------------------------------}

{ Дана последовательность натуральных чисел (значение каждого числа        }

{ от 1 до 1000). После-довательность может быть не отсортирована.          }

{ Надо найти вариант самой большой (по количеству элементов) неубывающей   }

{ последовательности, составленной из чисел этого ряда. Порядок включения  }

{ чисел в неубывающую последовательность должен соответствовать порядку    }

{ следования чисел в первоначальной последова-тельности. Иными словами,    }

{ числа с большими номерам и в новой последовательности размещаются правее }

{ чисел с меньшими номерами.                                               }

{                                                                          }

{ Входные данные: файл SEQ.IN в 1-й строке содержит количество чисел в     }

{ последовательности - N (1<=N<=100).                                      }

{ Со 2-й строки и далее указан ряд чисел, каждое число размещается на      }

{ новой строке. Поиск ошибок в файле не требуется, входные данные          }

{ корректны.                                                               }

{                                                                          }

{ Выходные данные:                                                         }

{ В файле SEQ.OUT помещаются выходные данные.                              }

{ 1-я строка содержит длину максимальной неубыващей последовательности.    }

{ 2-я строка и далее - пример такой последовательности, каждое число в     }

{ порядке следования размещается на новой строке.                          }

{                                                                          }

{ Пример возможного теста:                                                 }

{                                                                          }

{ Файл "SEQ.IN" Файл "SEQ.OUT"                                             }

{ 12              7                                                        }

{ 59              4                                                        }

{ 4               21                                                       }

{ 21              27                                                       }

{ 36              34                                                       }

{ 18              45                                                       }

{ 27              47                                                       }

{ 79              93                                                       }

{ 34                                                                       }

{ 45                                                                       }

{ 47                                                                       }

{ 34                                                                       }

{ 93                                                                       }

{--------------------------------------------------------------------------}

 

{$M $8000,0,$4ffff} (* последовательность, Никитин *)

Const MaxItem = 100;

      TimeLimit = 29*18; {29 sec}

 

var Numbers, Seq, Best: array[1..MaxItem] of integer;

    pc,maxpc,num:integer;

    timer:longint absolute $0040:$006C;

    jiffy:longint;

 

Procedure Init;

var i:integer;

begin

     jiffy:=timer;

     fillchar(Numbers, Sizeof(Numbers),#0);

     Seq:=Numbers; Best:=Numbers; pc:=0; maxpc:=0;

     assign(input,'seq.in'); reset(input);

     readln(num); if num>MaxItem then num:=MaxItem;

    for i:=1 to num do readln(Numbers[i]);

     close(input);

end;

 

Procedure Done;

var i:integer;

begin

     assign(output,'seq.out'); rewrite(output);

     writeln(maxpc);

     for i:=1 to maxpc do writeln(Best[i]);

     close(output);

end;

 

procedure StoreChain;

begin

     if (pc>maxpc) then begin

         Best:=Seq;

         maxpc:=pc;

         if (maxpc=num) then begin

            Done;

            Halt(0);

         end;

     end;

end;

 

function testFWD(i:integer):integer;

var m:integer;

begin

     m:=Numbers[i]; inc(i);

     while (i<=num) and (m>Numbers[i]) do inc(i);

     if i>num then testFWD:=0 else testFWD:=i;

end;

 

procedure solution(n:integer); { Основная процедура }

var i,s:integer;

begin

   if ((timer-jiffy)>TimeLimit) then exit;

   i:=testFWD(n);

   if (i=0) then begin

       StoreChain;

   end else begin

       inc(pc);                       {проверили этот путь}

       Seq[pc]:=Numbers[i];

       solution(i);

       dec(pc);                       {идем по другому}

       s:=Numbers[i]; Numbers[i]:=-1; {вычеркнули}

       solution(n);

       Numbers[i]:=s;                 {вернули}

   end;

end;

 

var index:integer;

begin

     Init;

     index:=1;

     repeat

         pc:=1;

         Seq[pc]:=Numbers[index];

         solution(index);

         while (index<=num) and (Numbers[index]>=Seq[pc]) do inc(index);

     until (index>num);

     Done;

end.

Магические квадраты

{ Построить матрицу NxN, в которой сумма элементов в каждой строке, в      }

{ столбце, в каждой диагонали (их 2) имеют одинаковую сумму.               }

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

{            n*n(n*n+1) div (2*n)                                          }

{--------------------------------------------------------------------------}

const N=3; SQRN = N*N; {будет матрица NxN}

      IdealSum = N*(SQRN+1) div 2;

var   a:array[1..SQRN] of byte;

      b:array[1..SQRN] of byte;

      f:boolean; recurse:longint;

 

Procedure PRINT;

var i,j:integer;

begin

   assign(output,'magic.out'); rewrite(output);

   for i:=1 to N do begin

     for j:=1 to N do write(a[pred(i)*N+j],' ');

     writeln;

   end;

end;

 

function TestRow(i:integer):boolean;

var j,s:integer;

begin

    s:=0; i:=(i-1)*n;

    for j:=1 to N do s:=s+a[i+j];

    TestRow:=(s=IdealSum);

end;

 

function TestCol(i:integer):boolean;

var j,s:integer;

begin

    s:=0;

    for j:=1 to N do s:=s+a[(j-1)*N+i];

    TestCol:=(s=IdealSum);

end;

 

function TestDiag:boolean;

var j,s:integer;

begin

    s:=0;

    for j:=1 to N do s:=s+a[(N-j)*N+j];

    TestDiag:=(s=IdealSum);

end;

 

function TestMagic:boolean; {Тест всей матрицы на соотв. маг. квадрату}

var srow,scol,sdiag1,sdiag2,i,j:integer;

begin

    TestMagic:=FALSE;

    sdiag1:=0; sdiag2:=0;

    for i:=1 to N do begin

      srow:=0; scol:=0;

      for j:=1 to N do begin

         srow:=srow+a[pred(i)*N+j];

         scol:=scol+a[pred(j)*N+i];

      end;

      if (srow<>scol) or (scol<>IdealSum) then EXIT;

      sdiag1:=sdiag1+a[pred(i)*N+i];

      sdiag2:=sdiag2+a[(N-i)*N+i];

    end;

    if (sdiag1<>sdiag2) or (sdiag2<>IdealSum) then EXIT;

    TestMagic:=TRUE;

end;

 

procedure SqMagic(k:integer);

var i:integer; still:boolean;

begin

   i:=1;

   while (i<=SQRN) and NOT(f) do begin

      still:=true;

      if b[i]=0 then begin

        b[i]:=1; a[k]:=i;

        if k=SQRN then begin

           if TestMagic then begin PRINT; f:=true; still:=false; end;

        end else if (k mod n=0) then begin {если завершена строка}

           if NOT(TestRow(k div n)) then still:=false;

        end else if (k>SQRN-N) then begin  {если завершен столбец}

           if NOT(TestCol(k mod n)) then still:=false;

        end else if (k=SQRN-N+1) then begin {если завершена диагональ}

           if NOT(TestDiag) then still:=false;

        end;

        if still then SqMagic(k+1);

        b[i]:=0;

      end;

      inc(i);

   end;

end;

 

begin

     f:=false; recurse:=0;

     fillchar(a,sizeof(a),0); fillchar(b,sizeof(b),0);

     SqMagic(1);

end.