nlve/src/uExport.pas

{
  uExport — сборка готового ролика из сегментов без перекодирования.

  Схема работы и почему она такая.

  Напрашивающийся способ — отдать ffmpeg один список кусков с директивами
  inpoint и outpoint и получить результат за один проход, не создавая
  временных файлов. На пробе он оказался неточным: запрошенные 600 кадров
  превратились в 574, а метки времени не пересчитались. Поэтому каждый
  кусок вырезается отдельным запуском ffmpeg с -ss и -to до -i, что даёт
  ровно запрошенную длину, и только потом всё склеивается.

  Плата — временные файлы размером с использованный материал. Это принятое
  решение: диск дешевле, чем перекодирование, и дешевле, чем неточный рез.

  Второй важный момент — через какой формат идут промежуточные куски.

  Когда все куски происходят из одного файла, у них один и тот же набор
  параметров кодека, и склеить их можно напрямую. Но стоит появиться
  куску от другого кодировщика — из второго исходника или из созданной
  нами вставки под картинку, — как наборы параметров расходятся. MP4 и
  Matroska хранят такой набор один на дорожку, поэтому декодер применяет
  параметры первого куска ко всем и на стыках сыплет ошибками.

  Замерено на проекте из шести кусков: прямая склейка в Matroska дала
  384 ошибки декодера HEVC при верном числе кадров, склейка через
  промежуточный MPEG-TS — ни одной. MPEG-TS повторяет параметры прямо
  в потоке перед каждым опорным кадром, поэтому их смена посреди ролика
  для него нормальна.

  Отсюда правило: один источник — прямая склейка (быстрее), несколько —
  через MPEG-TS. Если кодек в MPEG-TS не помещается, собираем напрямую
  и честно предупреждаем.

  Начало каждого куска притягивается к опорному кадру. Без этого начало
  вырезки нечем декодировать: кадры в середине группы хранят разницу с
  соседями, а не самостоятельное изображение. Конец притягивать не нужно —
  оборванная группа воспроизводится нормально.

  Длина куска при этом сохраняется: сдвигается только то, какой участок
  исходника показывается. Иначе притягивание одного реза сдвинуло бы всё,
  что стоит на монтаже правее.
}
unit uExport;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, uAppTypes, uKeyframeIndex, uMediaProbe;

type
  { Настройки сборки с перекодированием.

    Enabled = False означает обычную сборку копированием — то, ради чего
    редактор и делался. Всё остальное имеет смысл только при True. }
  TEncodeProfile = record
    Enabled: Boolean;
    Width: Integer;
    Height: Integer;
    BitrateKbps: Integer;
    { Кодек в привычных именах: h264 или hevc. Кодировщик под него
      подбирается сам, с предпочтением аппаратного. }
    Codec: string;
  end;

  { Что получилось с одной частью.

    Кусок монтажа обычно даёт одну часть, но при точном резе — две:
    перекодированный огрызок до ближайшего опорного кадра и скопированный
    остаток. Поэтому частей может быть больше, чем кусков, и у каждой
    указано, из какого куска она произошла. }
  TSegmentReport = record
    Index: Integer;
    SourcePath: string;
    RequestedStart: Double;
    ActualStart: Double;
    Duration: Double;
    TempPath: string;
    Packets: Int64;
    Encoded: Boolean;
  end;

  TSegmentReports = array of TSegmentReport;

  TExportReport = record
    Succeeded: Boolean;
    Cancelled: Boolean;
    Message: string;
    OutputPath: string;
    CacheDir: string;
    Segments: TSegmentReports;
    { Сумма пакетов вырезанных кусков и число пакетов в готовом файле.
      Расхождение означает, что склейка что-то потеряла или продублировала. }
    ExpectedPackets: Int64;
    ActualPackets: Int64;
    TotalDuration: Double;
  end;

  TExportThread = class(TThread)
  private
    FSegments: TFlatSegmentArray;
    { Куски звука. Отдельный список: звук можно двигать независимо от
      картинки, и точки реза у них разные. }
    FAudio: TFlatSegmentArray;
    { Собранная звуковая дорожка и картинка без звука. }
    FAudioPath: string;
    FVideoPath: string;
    FOutputPath: string;
    FCacheDir: string;
    FKeepIntermediate: Boolean;

    FCancelRequested: Boolean;
    FStageText: string;
    FFraction: Double;
    FPendingLog: string;
    FReport: TExportReport;

    FOnProgress: TNotifyEvent;
    FOnLog: TNotifyEvent;

    { Учёт общего прогресса: сколько работы уже позади и сколько весит
      текущий шаг. Единица работы — секунда обрабатываемого материала. }
    FTotalWork: Double;
    FDoneWork: Double;
    FStepWork: Double;
    FStepPosition: Double;
    { Приёмник числа, которое печатает ffprobe при подсчёте пакетов. }
    FPacketCount: Int64;

    FMaster: TMediaInfo;
    FProfile: TEncodeProfile;
    FSubtitlePath: string;
    { Формат промежуточных кусков: 'matroska' или 'mpegts'. }
    FIntermediateFormat: string;
    FIntermediateExt: string;

    function DistinctSourceCount: Integer;
    procedure ChooseIntermediateFormat;

    procedure SyncProgress;
    procedure SyncLog;
    procedure Log(const AText: string);
    procedure SetStage(const AText: string);
    procedure PublishProgress;

    function CancelQuery: Boolean;
    procedure ProgressLine(const ALine: string);
    procedure ErrorLine(const ALine: string);
    procedure PacketCountLine(const ALine: string);

    function RunFfmpeg(const AArgs: array of string; const AWhat: string): Boolean;
    function CountPackets(const APath: string): Int64;
    function ExtractSegments: Boolean;
    function WriteConcatList(out AListPath: string): Boolean;
    function ConcatAll(const AListPath: string): Boolean;
    procedure Verify;
    { Сборка звука: куски сводятся в сырой поток и сжимаются одним
      проходом. Сырой поток нужен для точности — стык получается с
      точностью до отсчёта, а не до звукового кадра. }
    function BuildAudio: Boolean;
    function MixLayers(const ASeg: TFlatSegment; ADest: TStream;
      ANeed: Int64; ARate, AChannels: Integer): Boolean;
    function MuxFinal: Boolean;
  protected
    procedure Execute; override;
  public
    { AMaster нужен, чтобы понять, влезут ли кодеки проекта в MPEG-TS.
      Можно передать пустую запись — тогда способ склейки выберется
      по одному лишь числу источников. }
    constructor Create(const ASegments, AAudio: TFlatSegmentArray;
      const AOutputPath: string; AKeepIntermediate: Boolean;
      const AMaster: TMediaInfo; const AProfile: TEncodeProfile);

    procedure RequestCancel;

    { Читать из потока интерфейса только внутри обработчиков. }
    property StageText: string read FStageText;
    property Fraction: Double read FFraction;
    property PendingLog: string read FPendingLog;
    property Report: TExportReport read FReport;

    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
    property OnLog: TNotifyEvent read FOnLog write FOnLog;
    { Разметка субтитров, которую надо вложить в готовый файл отдельной
      дорожкой. Пусто — либо текста нет, либо он вжигается в картинку.
      Годится только для Matroska: MP4 хранит субтитры без оформления. }
    property SubtitlePath: string read FSubtitlePath write FSubtitlePath;
  end;

{ Каталог для временных кусков рядом с готовым файлом. }
function CacheDirFor(const AOutputPath: string): string;

implementation

uses
  Math, FileUtil, uFfmpegCmd, uProcRunner;

function CacheDirFor(const AOutputPath: string): string;
begin
  Result := IncludeTrailingPathDelimiter(ExtractFilePath(AOutputPath)) +
    ChangeFileExt(ExtractFileName(AOutputPath), '') + '.nlve-cache' +
    PathDelim;
end;

constructor TExportThread.Create(const ASegments, AAudio: TFlatSegmentArray;
  const AOutputPath: string; AKeepIntermediate: Boolean;
  const AMaster: TMediaInfo; const AProfile: TEncodeProfile);
var
  I: Integer;
begin
  FMaster := AMaster;
  FProfile := AProfile;
  inherited Create(True);
  FreeOnTerminate := False;

  { Все пути приводятся к абсолютным немедленно.

    Иначе получается ловушка: путь в списке склейки с префиксом file:
    разбирается относительно текущего рабочего каталога, а не относительно
    самого списка. Совпало — работает, не совпало — ffmpeg не находит
    куски. Проще не давать относительным путям попасть внутрь вообще. }
  SetLength(FSegments, Length(ASegments));
  for I := 0 to High(ASegments) do
  begin
    FSegments[I] := ASegments[I];
    if FSegments[I].FilePath <> '' then
      FSegments[I].FilePath := ExpandFileName(FSegments[I].FilePath);
  end;

  SetLength(FAudio, Length(AAudio));
  for I := 0 to High(AAudio) do
  begin
    FAudio[I] := AAudio[I];
    if FAudio[I].FilePath <> '' then
      FAudio[I].FilePath := ExpandFileName(FAudio[I].FilePath);
  end;

  FOutputPath := ExpandFileName(AOutputPath);
  FCacheDir := CacheDirFor(FOutputPath);
  FKeepIntermediate := AKeepIntermediate;

  FReport.Succeeded := False;
  FReport.Cancelled := False;
  FReport.OutputPath := FOutputPath;
  FReport.CacheDir := FCacheDir;
  FReport.TotalDuration := TotalDuration(ASegments);
end;

procedure TExportThread.RequestCancel;
begin
  FCancelRequested := True;
end;

function TExportThread.CancelQuery: Boolean;
begin
  Result := FCancelRequested or Terminated;
end;

{ --- Передача состояния в поток интерфейса --- }

procedure TExportThread.SyncProgress;
begin
  if Assigned(FOnProgress) then
    FOnProgress(Self);
end;

procedure TExportThread.SyncLog;
begin
  if Assigned(FOnLog) then
    FOnLog(Self);
end;

procedure TExportThread.Log(const AText: string);
begin
  FPendingLog := AText;
  Synchronize(@SyncLog);
end;

procedure TExportThread.PublishProgress;
begin
  if FTotalWork > 0 then
    FFraction := Min(1, (FDoneWork + FStepPosition) / FTotalWork)
  else
    FFraction := 0;
  Synchronize(@SyncProgress);
end;

procedure TExportThread.SetStage(const AText: string);
begin
  FStageText := AText;
  PublishProgress;
end;

{ --- Разбор вывода ffmpeg --- }

procedure TExportThread.ProgressLine(const ALine: string);
var
  Seconds: Double;
  { Именно AtEnd, а не Finished: у TThread уже есть свойство с таким
    именем, и локальная переменная его бы перекрыла. }
  AtEnd: Boolean;
begin
  Seconds := FStepPosition;
  AtEnd := False;
  if not ParseProgressLine(ALine, Seconds, AtEnd) then
    Exit;
  { Позиция не может превысить вес шага: у ffmpeg она иногда чуть
    забегает вперёд из-за округления меток времени. }
  FStepPosition := Min(Seconds, FStepWork);
  PublishProgress;
end;

procedure TExportThread.ErrorLine(const ALine: string);
begin
  { Журнал ffmpeg при -loglevel warning короткий: сюда попадают только
    настоящие предупреждения и ошибки, их стоит показать. }
  Log('ffmpeg: ' + ALine);
end;

procedure TExportThread.PacketCountLine(const ALine: string);
var
  Value: Int64;
begin
  { ffprobe печатает ровно одно число — количество пакетов видеопотока. }
  if TryStrToInt64(Trim(ALine), Value) then
    FPacketCount := Value;
end;

{ --- Шаги --- }

function TExportThread.RunFfmpeg(const AArgs: array of string;
  const AWhat: string): Boolean;
var
  Res: TProcResult;
begin
  Log('> ' + CommandToString(FfmpegExe, AArgs));

  FStepPosition := 0;
  Res := RunProcess(FfmpegExe, AArgs, @ProgressLine, @ErrorLine, @CancelQuery);

  if not Res.Started then
  begin
    FReport.Message := Res.ErrorText;
    Exit(False);
  end;
  if Res.Cancelled then
  begin
    FReport.Cancelled := True;
    FReport.Message := 'Отменено.';
    Exit(False);
  end;
  if Res.ExitCode <> 0 then
  begin
    FReport.Message := AWhat + ': ffmpeg завершился с кодом ' +
      IntToStr(Res.ExitCode) + '. Подробности в журнале.';
    Exit(False);
  end;

  FDoneWork := FDoneWork + FStepWork;
  FStepPosition := 0;
  PublishProgress;
  Result := True;
end;

function TExportThread.CountPackets(const APath: string): Int64;
var
  Res: TProcResult;
begin
  FPacketCount := -1;
  Res := RunProcess(FfprobeExe, ArgsCountVideoPackets(APath),
    @PacketCountLine, nil, @CancelQuery);
  if (not Res.Started) or (Res.ExitCode <> 0) then
    Exit(-1);
  Result := FPacketCount;
end;

function TExportThread.DistinctSourceCount: Integer;
var
  I: Integer;
  Seen: TStringList;
begin
  Seen := TStringList.Create;
  try
    Seen.Sorted := True;
    Seen.Duplicates := dupIgnore;
    for I := 0 to High(FSegments) do
      if FSegments[I].FilePath <> '' then
        Seen.Add(FSegments[I].FilePath);
    Result := Seen.Count;
  finally
    Seen.Free;
  end;
end;

procedure TExportThread.ChooseIntermediateFormat;
var
  Sources, I: Integer;
  HasEncoded: Boolean;
begin
  Sources := DistinctSourceCount;

  { Точный рез сам по себе создаёт кусок от другого кодировщика, даже если
    исходник всего один. }
  { Любой кусок, который придётся закодировать заново, — это ещё один
    набор параметров кодека рядом со скопированными. }
  HasEncoded := False;
  for I := 0 to High(FSegments) do
    if FSegments[I].PreciseIn or FSegments[I].Transcode then
      HasEncoded := True;

  if (Sources <= 1) and (not HasEncoded) then
  begin
    { Всё из одного файла — параметры кодека заведомо одни и те же,
      можно склеивать напрямую и не тратить лишний проход по материалу. }
    FIntermediateFormat := 'matroska';
    FIntermediateExt := '.mkv';
    Exit;
  end;

  if not TsSupportsCodecs(FMaster.VideoCodec, FMaster.AudioCodec) then
  begin
    FIntermediateFormat := 'matroska';
    FIntermediateExt := '.mkv';
    Log('ВНИМАНИЕ: кусков от разных кодировщиков несколько, но кодек ' +
      FMaster.VideoCodec + ' не переносится в MPEG-TS. Собираю напрямую — ' +
      'на стыках возможны ошибки декодирования.');
    Exit;
  end;

  FIntermediateFormat := 'mpegts';
  FIntermediateExt := '.ts';
  if HasEncoded then
    Log('Есть куски, которые кодируются заново, склейка идёт через ' +
      'MPEG-TS: иначе декодер применил бы параметры первого куска ко ' +
      'всем остальным.')
  else
    Log('Источников несколько (' + IntToStr(Sources) +
      '), склейка идёт через MPEG-TS: иначе декодер применил бы параметры ' +
      'первого куска ко всем остальным.');
end;

{ Первый опорный кадр строго правее указанного времени. Ноль означает,
  что правее ничего нет. }
function NextKeyframeAfter(const AIndex: TKeyframeIndex;
  const ATime: Double): Double;
var
  I: Integer;
begin
  Result := 0;
  for I := 0 to High(AIndex.Times) do
    if AIndex.Times[I] > ATime + 0.0005 then
      Exit(AIndex.Times[I]);
end;

function TExportThread.ExtractSegments: Boolean;
var
  I, PartCount: Integer;
  Index: TKeyframeIndex;
  IndexError: string;
  HasIndex: Boolean;
  Snapped, NextKey, EncodeUntil: Double;
  SegEnd: Double;
  Dst: string;
  Rep: TSegmentReport;

  procedure AddPart(const APart: TSegmentReport);
  begin
    if PartCount >= Length(FReport.Segments) then
      SetLength(FReport.Segments, PartCount + 8);
    FReport.Segments[PartCount] := APart;
    Inc(PartCount);
  end;

begin
  Result := False;
  PartCount := 0;
  SetLength(FReport.Segments, Length(FSegments) + 8);

  for I := 0 to High(FSegments) do
  begin
    if CancelQuery then
    begin
      FReport.Cancelled := True;
      FReport.Message := 'Отменено.';
      Exit;
    end;

    SetStage(Format('Вырезаю кусок %d из %d', [I + 1, Length(FSegments)]));

    { Сгенерированные вставки берутся из файла, который заведомо длиннее
      нужного: так одна и та же чёрная вставка годится для дыр любой
      длины. Значит вырезать надо и из них, но притягивать к опорному
      кадру нечего — они начинаются с нуля, а ноль всегда опорный. }
    if FSegments[I].Kind <> skVideo then
    begin
      Dst := FCacheDir + Format('part_%.3d_a%s', [I, FIntermediateExt]);
      Rep.Index := I;
      Rep.SourcePath := FSegments[I].FilePath;
      Rep.RequestedStart := 0;
      Rep.ActualStart := 0;
      Rep.Duration := FSegments[I].Duration;
      Rep.Packets := -1;
      Rep.Encoded := False;

      FStepWork := FSegments[I].Duration;
      if not RunFfmpeg(ArgsExtract(FSegments[I].FilePath, Dst,
        0, FSegments[I].Duration, FIntermediateFormat,
        FSegments[I].Volume, FMaster.AudioCodec),
        'Подготовка вставки ' + IntToStr(I + 1)) then
        Exit;

      Rep.TempPath := Dst;
      AddPart(Rep);
      Continue;
    end;

    { Участок с наложением: полупрозрачный клип поверх нижнего либо
      переход между двумя клипами одной дорожки. Собирается из двух
      входов сразу, копированием такое не получить. }
    if Length(FSegments[I].Layers) > 0 then
    begin
      SetStage(Format('Собираю наложение, кусок %d из %d',
        [I + 1, Length(FSegments)]));
      Dst := FCacheDir + Format('part_%.3d_x%s', [I, FIntermediateExt]);
      Rep.Index := I;
      Rep.SourcePath := FSegments[I].Layers[0].FilePath;
      Rep.RequestedStart := FSegments[I].Layers[0].SrcStart;
      Rep.ActualStart := Rep.RequestedStart;
      Rep.Duration := FSegments[I].Duration;
      Rep.Packets := -1;
      Rep.Encoded := True;

      FStepWork := FSegments[I].Duration;
      if not RunFfmpeg(ArgsRenderLayers(FSegments[I].Layers, Dst,
        FSegments[I].Duration, FMaster.Width, FMaster.Height,
        FMaster.FpsNum, FMaster.FpsDen, FMaster.PixFmt,
        PreferredEncoder(FMaster.VideoCodec),
        FIntermediateFormat = 'mpegts', FMaster.VideoBitrate,
        FSegments[I].SubFile),
        'Наложение в куске ' + IntToStr(I + 1)) then
        Exit;

      Rep.TempPath := Dst;
      AddPart(Rep);
      Continue;
    end;

    { Кусок от файла, не совпадающего с параметрами проекта. Скопировать
      его нельзя — пересобираем. Но только его: соседние куски, снятые тем
      же оборудованием, что и весь проект, по-прежнему копируются. }
    if FSegments[I].Transcode then
    begin
      SetStage(Format('Пересобираю кусок %d из %d (файл не совпадает с проектом)',
        [I + 1, Length(FSegments)]));
      Dst := FCacheDir + Format('part_%.3d_a%s', [I, FIntermediateExt]);
      Rep.Index := I;
      Rep.SourcePath := FSegments[I].FilePath;
      Rep.RequestedStart := FSegments[I].SrcStart;
      Rep.ActualStart := FSegments[I].SrcStart;
      Rep.Duration := FSegments[I].Duration;
      Rep.Packets := -1;
      Rep.Encoded := True;

      FStepWork := FSegments[I].Duration;
      if not RunFfmpeg(ArgsTranscodeSegment(FSegments[I].FilePath, Dst,
        FSegments[I].SrcStart, FSegments[I].SrcStart + FSegments[I].Duration,
        FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen,
        FMaster.VideoCodec, FMaster.PixFmt, FMaster.AudioCodec,
        FMaster.SampleRate, FMaster.Channels, FSegments[I].Volume,
        FIntermediateFormat, FSegments[I].Filter, FSegments[I].SubFile,
        FMaster.VideoBitrate),
        'Пересборка куска ' + IntToStr(I + 1)) then
        Exit;

      Rep.TempPath := Dst;
      AddPart(Rep);
      Continue;
    end;

    HasIndex := BuildKeyframeIndex(FSegments[I].FilePath, Index, IndexError);
    if not HasIndex then
      Log('Кусок ' + IntToStr(I + 1) +
        ': индекс опорных кадров недоступен (' + IndexError +
        '), режу как есть — начало может оказаться повреждённым.');

    SegEnd := FSegments[I].SrcStart + FSegments[I].Duration;

    Rep.Index := I;
    Rep.SourcePath := FSegments[I].FilePath;
    Rep.RequestedStart := FSegments[I].SrcStart;
    Rep.Packets := -1;

    if FSegments[I].PreciseIn and HasIndex then
    begin
      { Точный рез. Копировать можно только с опорного кадра, поэтому
        отрезок от запрошенной точки до следующего опорного кадра
        пересобираем заново, а всё, что дальше, копируем как обычно.
        Перекодируются доли секунды, а не весь материал. }
      NextKey := NextKeyframeAfter(Index, FSegments[I].SrcStart);
      if (NextKey <= 0) or (NextKey >= SegEnd) then
        EncodeUntil := SegEnd
      else
        EncodeUntil := NextKey;

      Log(Format('Кусок %d: точный рез, перекодирую %s..%s (%s с), остальное копирую',
        [I + 1, SecondsToStr(FSegments[I].SrcStart), SecondsToStr(EncodeUntil),
         SecondsToStr(EncodeUntil - FSegments[I].SrcStart)]));

      Dst := FCacheDir + Format('part_%.3d_a%s', [I, FIntermediateExt]);
      FStepWork := EncodeUntil - FSegments[I].SrcStart;
      if not RunFfmpeg(ArgsEncodeFragment(FSegments[I].FilePath, Dst,
        FSegments[I].SrcStart, EncodeUntil,
        FMaster.FpsNum, FMaster.FpsDen,
        FMaster.VideoCodec, FMaster.PixFmt, FMaster.AudioCodec,
        FMaster.SampleRate, FMaster.Channels, FIntermediateFormat),
        'Перекодирование стыка куска ' + IntToStr(I + 1)) then
        Exit;

      Rep.ActualStart := FSegments[I].SrcStart;
      Rep.Duration := EncodeUntil - FSegments[I].SrcStart;
      Rep.TempPath := Dst;
      Rep.Encoded := True;
      AddPart(Rep);

      if EncodeUntil < SegEnd - 0.0005 then
      begin
        Dst := FCacheDir + Format('part_%.3d_b%s', [I, FIntermediateExt]);
        FStepWork := SegEnd - EncodeUntil;
        if not RunFfmpeg(ArgsExtract(FSegments[I].FilePath, Dst,
          EncodeUntil, SegEnd, FIntermediateFormat,
          FSegments[I].Volume, FMaster.AudioCodec),
          'Вырезание куска ' + IntToStr(I + 1)) then
          Exit;

        Rep.ActualStart := EncodeUntil;
        Rep.Duration := SegEnd - EncodeUntil;
        Rep.TempPath := Dst;
        Rep.Encoded := False;
        AddPart(Rep);
      end;

      Continue;
    end;

    { Обычный рез: начало притягивается к ближайшему опорному кадру,
      длина сохраняется. }
    Snapped := FSegments[I].SrcStart;
    if HasIndex then
    begin
      Snapped := SnapNearest(Index, FSegments[I].SrcStart);
      if Abs(Snapped - FSegments[I].SrcStart) > 0.0005 then
        Log(Format('Кусок %d: начало притянуто к опорному кадру, %s вместо %s (сдвиг %s с)',
          [I + 1, SecondsToStr(Snapped), SecondsToStr(FSegments[I].SrcStart),
           SecondsToStr(Snapped - FSegments[I].SrcStart)]));
    end;

    Dst := FCacheDir + Format('part_%.3d_a%s', [I, FIntermediateExt]);

    FStepWork := FSegments[I].Duration;
    if not RunFfmpeg(ArgsExtract(FSegments[I].FilePath, Dst,
      Snapped, Snapped + FSegments[I].Duration, FIntermediateFormat,
      FSegments[I].Volume, FMaster.AudioCodec),
      'Вырезание куска ' + IntToStr(I + 1)) then
      Exit;

    Rep.ActualStart := Snapped;
    Rep.Duration := FSegments[I].Duration;
    Rep.TempPath := Dst;
    Rep.Encoded := False;
    AddPart(Rep);
  end;

  SetLength(FReport.Segments, PartCount);
  Result := True;
end;

function TExportThread.WriteConcatList(out AListPath: string): Boolean;
var
  List: TStringList;
  I: Integer;
begin
  AListPath := FCacheDir + 'concat.txt';
  List := TStringList.Create;
  try
    for I := 0 to High(FReport.Segments) do
      List.Add(ConcatListLine(FReport.Segments[I].TempPath));
    try
      { Концы строк только LF: список читает разборщик ffmpeg, а не
        текстовый редактор, и лишний возврат каретки попадёт в имя файла. }
      List.LineBreak := #10;
      List.SaveToFile(AListPath);
      Result := True;
    except
      on E: Exception do
      begin
        FReport.Message := 'Не удалось записать список склейки: ' + E.Message;
        Result := False;
      end;
    end;
  finally
    List.Free;
  end;
end;

function TExportThread.ConcatAll(const AListPath: string): Boolean;
begin
  FStepWork := FReport.TotalDuration;

  if FProfile.Enabled then
  begin
    { Перекодирование всего ролика одним проходом. Так весь результат
      выходит из одного кодировщика с одними настройками: пересобирать
      куски по отдельности здесь нельзя, на стыках была бы видна смена
      качества. }
    SetStage('Склеиваю и перекодирую');
    if RunFfmpeg(ArgsConcatEncode(AListPath, FVideoPath,
      FProfile.Width, FProfile.Height, FMaster.FpsNum, FMaster.FpsDen,
      FProfile.BitrateKbps, FProfile.Codec, FMaster.PixFmt, True),
      'Склейка с перекодированием') then
      Exit(True);

    if Terminated then
      Exit(False);

    { Аппаратная распаковка не пошла — повторяем без неё.

      Она даёт впятеро, но зависит от драйвера и от того, знаком ли
      видеокарте кодек исходника. Отказываться из-за неё от сборки
      нельзя: медленно лучше, чем никак. }
    Log('Аппаратная распаковка не пошла, повторяю на процессоре.');
    Exit(RunFfmpeg(ArgsConcatEncode(AListPath, FVideoPath,
      FProfile.Width, FProfile.Height, FMaster.FpsNum, FMaster.FpsDen,
      FProfile.BitrateKbps, FProfile.Codec, FMaster.PixFmt, False),
      'Склейка с перекодированием без аппаратной распаковки'));
  end;

  SetStage('Склеиваю');
  Result := RunFfmpeg(ArgsConcat(AListPath, FVideoPath), 'Склейка');
end;

procedure TExportThread.Verify;
var
  I: Integer;
  Sum, Actual, N: Int64;
begin
  SetStage('Проверяю результат');

  Sum := 0;
  for I := 0 to High(FReport.Segments) do
  begin
    N := CountPackets(FReport.Segments[I].TempPath);
    FReport.Segments[I].Packets := N;
    if N > 0 then
      Inc(Sum, N);
  end;

  Actual := CountPackets(FOutputPath);
  FReport.ExpectedPackets := Sum;
  FReport.ActualPackets := Actual;
end;


{ --- Звук --- }

function TExportThread.BuildAudio: Boolean;
var
  RawPath, PartPath: string;
  All, Part: TFileStream;
  I: Integer;
  Need: Int64;
  Zero: array[0..65535] of Byte;
  Res: TProcResult;
  Chunk: Int64;
  Rate, Channels: Integer;
begin
  Result := False;
  FAudioPath := '';
  if Length(FAudio) = 0 then
    Exit;

  Rate := FMaster.SampleRate;
  if Rate <= 0 then
    Rate := 48000;
  Channels := FMaster.Channels;
  if Channels <= 0 then
    Channels := 2;

  RawPath := FCacheDir + 'audio.raw';
  PartPath := FCacheDir + 'audio_part.raw';
  FillChar(Zero, SizeOf(Zero), 0);

  SetStage('Собираю звук');

  try
    All := TFileStream.Create(RawPath, fmCreate);
    try
      for I := 0 to High(FAudio) do
      begin
        if Terminated then
          Exit;

        { Сколько байт должен занять кусок. Считается из длительности, а
          не берётся у ffmpeg: тогда длина всей дорожки совпадает с
          монтажом до отсчёта, и звук не уезжает от картинки. }
        Need := Round(FAudio[I].Duration * Rate) * Channels * 2;

        if Length(FAudio[I].Layers) > 0 then
        begin
          { Переход или наложение: слои сводятся прямо в отсчётах. Здесь
            это проще и точнее, чем через фильтры ffmpeg — доля каждого
            слоя считается на каждый отсчёт, без округлений по кадрам. }
          if MixLayers(FAudio[I], All, Need, Rate, Channels) then
            Need := 0;
        end
        else if FAudio[I].FilePath <> '' then
        begin
          Res := RunProcess(FfmpegExe,
            ArgsExtractAudioRaw(FAudio[I].FilePath, PartPath,
              FAudio[I].SrcStart, FAudio[I].Duration, Rate, Channels,
              FAudio[I].Volume),
            nil, @ErrorLine, @CancelQuery);
          if Res.Cancelled then
            Exit;
          if Res.Started and (Res.ExitCode = 0) and FileExists(PartPath) then
          begin
            Part := TFileStream.Create(PartPath, fmOpenRead or fmShareDenyNone);
            try
              Chunk := Part.Size;
              if Chunk > Need then
                Chunk := Need;
              if Chunk > 0 then
                All.CopyFrom(Part, Chunk);
              Dec(Need, Chunk);
            finally
              Part.Free;
            end;
            SysUtils.DeleteFile(PartPath);
          end;
        end;

        { Чего не хватило — дополняем тишиной. Так же заполняются дыры и
          куски файлов без звука. }
        while Need > 0 do
        begin
          Chunk := SizeOf(Zero);
          if Chunk > Need then
            Chunk := Need;
          All.WriteBuffer(Zero, Chunk);
          Dec(Need, Chunk);
        end;

        { Учёт работы: секунда звука весит столько же, сколько секунда
          картинки на вырезании. }
        FDoneWork := FDoneWork + FAudio[I].Duration;
        PublishProgress;
      end;
    finally
      All.Free;
    end;

    SetStage('Сжимаю звук');
    FAudioPath := FCacheDir + 'audio.m4a';
    Res := RunProcess(FfmpegExe,
      ArgsEncodeAudio(RawPath, FAudioPath, Rate, Channels, FMaster.AudioCodec),
      @ProgressLine, @ErrorLine, @CancelQuery);
    if Res.Cancelled then
      Exit;
    if (not Res.Started) or (Res.ExitCode <> 0) or (not FileExists(FAudioPath)) then
    begin
      FReport.Message := 'Не удалось сжать звук.';
      Exit;
    end;

    Result := True;
  finally
    SysUtils.DeleteFile(RawPath);
    SysUtils.DeleteFile(PartPath);
  end;
end;

{ Сведение слоёв звука в один поток.

  Доля каждого слоя меняется от начала куска к концу: так получается
  переход. Смешивание идёт по отсчётам, поэтому длина результата ровно
  такая, какая нужна. }
function TExportThread.MixLayers(const ASeg: TFlatSegment; ADest: TStream;
  ANeed: Int64; ARate, AChannels: Integer): Boolean;
var
  L, I, N: Integer;
  Parts: array of TMemoryStream;
  PartPath: string;
  Res: TProcResult;
  Src: TFileStream;
  Samples, S, Ch: Integer;
  Acc: Double;
  K: Double;
  V: SmallInt;
  Out16: SmallInt;
  Buf: array of SmallInt;
begin
  Result := False;
  SetLength(Parts, Length(ASeg.Layers));
  for I := 0 to High(Parts) do
    Parts[I] := nil;

  try
    for L := 0 to High(ASeg.Layers) do
    begin
      PartPath := FCacheDir + Format('mix_%d.raw', [L]);
      Res := RunProcess(FfmpegExe,
        ArgsExtractAudioRaw(ASeg.Layers[L].FilePath, PartPath,
          ASeg.Layers[L].SrcStart, ASeg.Duration, ARate, AChannels, 1),
        nil, @ErrorLine, @CancelQuery);
      Parts[L] := TMemoryStream.Create;
      if Res.Started and (Res.ExitCode = 0) and FileExists(PartPath) then
      begin
        Src := TFileStream.Create(PartPath, fmOpenRead or fmShareDenyNone);
        try
          Parts[L].CopyFrom(Src, Src.Size);
        finally
          Src.Free;
        end;
        SysUtils.DeleteFile(PartPath);
      end;
      Parts[L].Position := 0;
    end;

    Samples := ANeed div (AChannels * 2);
    if Samples <= 0 then
      Exit;
    SetLength(Buf, AChannels);

    for S := 0 to Samples - 1 do
    begin
      for Ch := 0 to AChannels - 1 do
      begin
        Acc := 0;
        for L := 0 to High(ASeg.Layers) do
        begin
          { Доля слоя меняется линейно по ходу куска. }
          if Samples > 1 then
            K := ASeg.Layers[L].FadeFrom +
              (ASeg.Layers[L].FadeTo - ASeg.Layers[L].FadeFrom) * S / (Samples - 1)
          else
            K := ASeg.Layers[L].FadeFrom;

          N := (S * AChannels + Ch) * 2;
          if N + 1 < Parts[L].Size then
          begin
            Move(PByte(Parts[L].Memory)[N], V, 2);
            Acc := Acc + V * K;
          end;
        end;
        if Acc > 32767 then
          Acc := 32767;
        if Acc < -32768 then
          Acc := -32768;
        Out16 := Round(Acc);
        Buf[Ch] := Out16;
      end;
      ADest.WriteBuffer(Buf[0], AChannels * 2);
    end;

    Result := True;
  finally
    for I := 0 to High(Parts) do
      Parts[I].Free;
  end;
end;

function TExportThread.MuxFinal: Boolean;
var
  Res: TProcResult;
begin
  SetStage('Сшиваю');
  Res := RunProcess(FfmpegExe,
    ArgsMux(FVideoPath, FAudioPath, FOutputPath, FSubtitlePath),
    @ProgressLine, @ErrorLine, @CancelQuery);
  Result := Res.Started and (Res.ExitCode = 0) and FileExists(FOutputPath);
  if Res.Cancelled then
    Result := False
  else if not Result then
    FReport.Message := 'Не удалось сшить картинку со звуком.';
end;

procedure TExportThread.Execute;
var
  ListPath: string;
  I: Integer;
  ToolError: string;
begin
  try
    if Length(FSegments) = 0 then
    begin
      FReport.Message := 'Нечего экспортировать: список сегментов пуст.';
      Exit;
    end;

    if not ToolsAvailable(ToolError) then
    begin
      FReport.Message := ToolError;
      Exit;
    end;

    SetStage('Готовлю');

    if not ForceDirectories(FCacheDir) then
    begin
      FReport.Message := 'Не удалось создать каталог для временных кусков: ' +
        FCacheDir;
      Exit;
    end;
    Log('Временные куски: ' + FCacheDir);

    ChooseIntermediateFormat;

    { Единица учёта работы — секунда материала. Каждая секунда проходит
      через вырезание, склейку и сборку звука, отсюда тройной вес. }
    FTotalWork := FReport.TotalDuration * 3;
    FDoneWork := 0;

    if not ExtractSegments then
      Exit;
    if not WriteConcatList(ListPath) then
      Exit;

    { Картинка собирается в отдельный файл, а не сразу в конечный: звук у
      неё свой, из исходников, и он почти наверняка не тот, что нужен.
      Настоящий звук собирается отдельно и подставляется при сшивании. }
    FVideoPath := FCacheDir + 'video' + ExtractFileExt(FOutputPath);
    if not ConcatAll(ListPath) then
      Exit;

    if not BuildAudio then
    begin
      if FReport.Cancelled then
        Exit;
      { Без звука ролик всё равно лучше, чем ничего: картинка уже собрана. }
      Log('Звук собрать не удалось, оставляю картинку как есть.');
      if not RenameFile(FVideoPath, FOutputPath) then
        FileUtil.CopyFile(FVideoPath, FOutputPath);
    end
    else if not MuxFinal then
      Exit;

    Verify;

    if not FileExists(FOutputPath) then
    begin
      FReport.Message := 'ffmpeg отработал, но выходного файла нет: ' + FOutputPath;
      Exit;
    end;

    FReport.Succeeded := True;
    FReport.Message := 'Готово.';

    if not FKeepIntermediate then
    begin
      for I := 0 to High(FReport.Segments) do
        { Удаляем только то, что сами создали в своём каталоге. Части,
          указывающие на общий кэш сгенерированных вставок, трогать нельзя:
          они нужны и предпросмотру, и следующей сборке. }
        if Copy(FReport.Segments[I].TempPath, 1, Length(FCacheDir)) = FCacheDir then
          DeleteFile(FReport.Segments[I].TempPath);
      DeleteFile(ListPath);
      RemoveDir(FCacheDir);
      Log('Временные куски удалены.');
    end;
  except
    on E: Exception do
    begin
      FReport.Succeeded := False;
      FReport.Message := 'Внутренняя ошибка: ' + E.Message;
    end;
  end;

  FFraction := 1;
  Synchronize(@SyncProgress);
end;

end.