Авторські розв'язки задач четвертого туру

Задача 1. Проблема королів

const input_file='kings.dat';
      output_file='kings.sol';
      con=30;
{array of vectors
  HUE
  LoR
  GDF
}
      vec:array[1..8,1..2] of integer=((-1,0),(-1,1),(0,1),(1,1),
                                       (1,0),(1,-1),(0,-1),(-1,-1));
      s:string='UERFDGLH';             {letters corresponding to vec array}
var n,m:longint;                       {sizes of table}
    s1,s2:string;                      {strings for commands}
    n1,n2:longint;                     {count of commands}
    cant:boolean;                      {set true if 2-nd king out of table}
    was:boolean;                       {set true if 1-st king do not out of table}
    y1,x1,y2,x2:longint;               {positions of king when we keep moving}
    ty1,tx1,ty2,tx2:longint;           {cycles indices}
    d:longint;                         {time of move}
    a:array[1..con,1..con] of longint; {answer}
    i,j:longint;
    mx1,my1,mx2,my2:longint;

procedure read_data;
 begin
   assign(input,input_file); reset(input);
   readln(n,m);
   readln(s1);
   readln(s2);
   n1:=length(s1); n2:=length(s2);
   close(input);
 end;

procedure algor;
{move (y;x) according to letter c}
procedure moveit(var y:longint;var x:longint; c:char);
 begin
   y:=y+vec[pos(c,s)][1];
   x:=x+vec[pos(c,s)][2];
 end;

procedure place;
 begin
   y1:=ty1; x1:=tx1; y2:=ty2; x2:=tx2;
   {get from cycles indices}
   d:=1;    cant:=false;
   while (d<=length(s1)) or (d<=length(s2)) do
    begin
      if d<=n1 then moveit(y1,x1,s1[d]);
      if d<=n2 then moveit(y2,x2,s2[d]);
      if (y1<1) or (x1<1) or (y1>n) or (x1>m) then exit;
      if (y2<1) or (x2<1) or (y2>n) or (x2>m) then cant:=true;
      if not(cant) and ((y1=y2) and (x1=x2)) then begin inc(a[ty1][tx1]); was:=true; exit; end;
      inc(d);
    end;
   was:=true;
 end;

begin
  y1:=0; x1:=0;
  for i:=1 to n1 do
  begin
    moveit(y1,x1,s1[i]);
    if abs(x1)>mx1 then mx1:=abs(x1);
    if abs(y1)>my1 then my1:=abs(y1);
  end;
  y1:=0; x1:=0;
  for i:=1 to n2 do
  begin
    moveit(y1,x1,s2[i]);
    if abs(x1)>mx2 then mx2:=abs(x1);
    if abs(y1)>my2 then my2:=abs(y1);
  end;
  for ty1:=1 to n do
    for tx1:=1 to m do
    begin
     was:=false;
     for ty2:=ty1-my1-my2 to ty1+my1+my2 do
      for tx2:=tx1-mx1-mx2 to tx1+mx1+mx2 do
       if ((ty1<>ty2) or (tx1<>tx2))
       and (ty2>=1) and (tx2>=1) and
           (ty2<=n) and (tx2<=m)
       then place;
     if not was then a[ty1][tx1]:=-1;
    end;
end;

procedure write_data;
 begin
   assign(output,output_file); rewrite(output);
   for i:=1 to n do
   begin
     for j:=1 to m-1 do
       write(a[i][j],' ');
     writeln(a[i][m]);
   end;
   close(output);
end;

begin
  read_data;
  algor;
  write_data;
end.

Задача 2. Проблема «Синіх» та «Помаранчевих»

{$n+,q-,r-,s-}
{$m 65520,0,655360}
type rebro=record
  x,y:longint;
  l:extended;
end;
var i,j,n,m,mm,x,y,k,o:longint;
    a:array[1..2001]of rebro;
    kk:array[1..201]of longint;
    b:array[1..201]of real;
    c,e,ou,out:array[1..201]of longint;
    d:array[1..201,1..2]of real;
    t,l,v:extended;
procedure rec(x:longint;l:extended);
var j:longint;
 begin
  c[x]:=1;
  if l<t then
  for j:=kk[x] to kk[x+1]-1 do
    if (c[a[j].y]=0)and(l+a[j].l/v<b[a[j].y]) then begin     b[a[j].y]:=l+a[j].l/v;rec(a[j].y,b[a[j].y]); end;
  c[x]:=0;
end;
procedure sort(l,r:longint);
var i,j,x:longint;
    y:rebro;
begin
  i:=l;j:=r;x:=a[(i+j)div 2].x;
  repeat
   while a[i].x<x do inc(i);
   while a[j].x>x do dec(j);
   if i<=j then
    begin
     y:=a[i];a[i]:=a[j];a[j]:=y;
     inc(i);dec(j);
    end;
  until i>j;
  if i<r then sort(i,r);
  if j>l then sort(l,j);
end;
begin
  assign(input,'victory.in');reset(input);
  assign(output,'victory.out');rewrite(output);
  read(n,m);
  for i:=1 to m do
  begin
    read(a[2*i-1].x,a[2*i-1].y,a[2*i-1].l);
    if a[2*i-1].l=0 then a[2*i-1].l:=1e-8;a[2*i].x:=a[2*i-1].y;
    a[2*i].y:=a[2*i-1].x;
    a[2*i].l:=a[2*i-1].l;
    inc(kk[a[2*i].x+1]);
    inc(kk[a[2*i].y+1]);
  end;
  inc(kk[1]);
  for i:=2 to n do
    kk[i]:=kk[i]+kk[i-1];
  kk[n+1]:=2*m+1;
  sort(1,2*m);
  read(k);
  for i:=1 to k do begin read(d[i,1]);read(d[i,2]); end;
  read(mm);
  for i:=1 to mm do read(e[i]);
  readln(t);
  for i:=1 to k do
  begin
    v:=d[i,2];
    for j:=1 to n do b[j]:=1e10;
    if v>0 then rec(trunc(d[i,1]),0);
    for j:=1 to mm do
     if b[e[j]]<t then ou[e[j]]:=1;
  end;
  for i:=1 to n do if ou[i]=1 then begin inc(o);out[o]:=i; end;
  writeln(o);
  if o>0 then begin for i:=1 to o-1 do begin write(out[i],' ');end;writeln(out[o]); end;
  close(input);close(output);
end.

Задача 3. Проблема «множення»

var a:array[1..100] of longint;
    b:array[1..100,1..100] of longint;
    i,j,k,l,m,n:longint;
begin
  assign(input,'mpuzzle.in'); reset(input);
  assign(output,'mpuzzle.out'); rewrite(output);
  read(n);
  for i:=1 to n do read(a[i]);
  for j:=2 to n do
   for i:=1 to n-j do
    for k:=i+1 to i+j-1 do
     if (b[i,i+j]=0) or (b[i,i+j]>b[i,k]+b[k,i+j]+a[i]*a[k]*a[i+j]) then     b[i,i+j]:=b[i,k]+b[k,i+j]+a[i]*a[k]*a[i+j];
  writeln(b[1,n]);
  close(output);
  close(input);
end.