KWAY - Trao đổi thông tin

Tác giả: ll931110

Ngôn ngữ: Pascal

program KWAY;
const
  input  = '';
  output = '';
  maxn = 102;
  maxt = 1000000;
var
  d,c,f: array[1..maxn,1..maxn] of longint;
  free: array[1..maxn,1..maxn] of boolean;

  trace,best: array[1..maxn] of longint;

  list: array[1..maxn] of longint;
  nl: longint;

  n,m,k,s,t: longint;
  count: longint;
  fi,fo: text;

  q: array[0..maxn] of longint;
  inqueue: array[1..maxn] of boolean;
  front,rear: longint;

procedure openfile;
begin
  assign(fi, input);  reset(fi);
  assign(fo, output);  rewrite(fo);
end;

procedure init;
var
  u,v,i: longint;
begin
  readln(fi, n, m, k, s, t);
  fillchar(c, sizeof(c), 0);
  fillchar(d, sizeof(d), 0);
  fillchar(f, sizeof(f), 0);

  for i := 1 to m do
    begin
      readln(fi, u, v, d[u,v]);
      d[v,u] := d[u,v];
      c[u,v] := 1;  c[v,u] := 1;
    end;
end;

function FindPath: boolean;
var
  u,v: longint;
  nt,tmp: longint;
begin
  fillchar(trace, sizeof(trace), 0);
  fillchar(inqueue, sizeof(inqueue), false);
  for v := 1 to n do best[v] := maxt;
  best[s] := 0;

  front := 1;  rear := 1;  q[1] := s;
  nt := 1;
  repeat
    u := q[front];
    dec(nt);
    inqueue[u] := false;
    front := (front + 1) mod maxn;

    for v := 1 to n do
      if c[u,v] > f[u,v] then
        begin
          if f[u,v] = 0 then tmp := d[u,v] else tmp := d[u,v] * f[u,v] div abs(f[u,v]);
          if best[v] > best[u] + tmp then
            begin
              trace[v] := u;
              best[v] := best[u] + tmp;

              if not inqueue[v] then
                begin
                  inqueue[v] := true;
                  inc(nt);
                  rear := (rear + 1) mod maxn;
                  q[rear] := v;
                end;
            end;
        end;
  until nt = 0;

  FindPath := best[t] < maxt;
end;

procedure IncFlow;
var
  u,v: longint;
begin
  v := t;
  inc(count);
  while v <> s do
    begin
      u := trace[v];
      inc(f[u,v]);
      dec(f[v,u]);
      v := u;
    end;
end;

procedure solve;
begin
  count := 0;
  repeat
    if not FindPath then break;
    IncFlow;
  until count = k;
end;

procedure track(u: longint);
var
  v: longint;
begin
  inc(nl);  list[nl] := u;
  if u = t then exit;

  for v := 1 to n do
    if free[u,v] and (f[u,v] = 1) then
      begin
        free[u,v] := false;
        track(v);
        break;
      end;
end;

procedure printresult;
var
  i,j: longint;
  cost: longint;
begin
  if count < k then writeln(fo, -1) else
    begin
      fillchar(free, sizeof(free), true);
      cost := 0;
      for i := 1 to n do
        for j := 1 to n do
          if f[i,j] = 1 then cost := cost + d[i,j];

      writeln(fo, cost);
      for i := 1 to k do
        begin
          nl := 0;
          track(s);
          write(fo, nl, ' ');
          for j := 1 to nl do write(fo, list[j], ' ');
          writeln(fo);
        end;
    end;
end;

procedure closefile;
begin
  close(fo);
  close(fi);
end;

begin
  openfile;
  init;
  solve;
  printresult;
  closefile;
end.

Download