nlve/src/uGenerate.pas

{
  uGenerate — создание клипов для картинок и дыр.

  Картинку нельзя просто положить на монтаж: и предпросмотр, и сборка
  работают с видеофайлами. Дыра между клипами — та же история: чтобы
  чёрный кусок вёл себя как все остальные, он должен быть настоящим
  файлом.

  Проверено на mpv 0.37: подсовывать в список кусков саму картинку или
  генератор lavfi нельзя — плеер на этом зависает. Поэтому оба случая
  сводятся к одному механизму: заранее создать небольшой клип в
  параметрах проекта и дальше не делать между ними различий.

  Файлы называются по содержанию запроса, поэтому одинаковые запросы
  дают один файл и делаются один раз.
}
unit uGenerate;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, uAppTypes, uFlatten, uMediaProbe;

type
  TGenerateThread = class(TThread)
  private
    FRequests: TGenRequests;
    FMaster: TMediaInfo;
    FCancelRequested: Boolean;
    FStageText: string;
    FFraction: Double;
    FPendingLog: string;
    FSucceeded: Boolean;
    FCancelled: Boolean;
    FMessage: string;
    FCurrent: Integer;
    FOnProgress: TNotifyEvent;
    FOnLog: TNotifyEvent;

    procedure SyncProgress;
    procedure SyncLog;
    procedure Log(const AText: string);
    function CancelQuery: Boolean;
    procedure ErrorLine(const ALine: string);
    procedure Publish;
  protected
    procedure Execute; override;
  public
    constructor Create(const ARequests: TGenRequests; const AMaster: TMediaInfo);
    procedure RequestCancel;

    property StageText: string read FStageText;
    property Fraction: Double read FFraction;
    { Сколько всего заказано и сколько уже сделано. Нужно показателю
      работы: по ним он знает, докуда ползти до следующей вехи. }
    function Total: Integer;
    property Done: Integer read FCurrent;
    { Место на монтаже, которое считается прямо сейчас. Ноль в обоих —
      значит, к монтажу это отношения не имеет. }
    function BusyFrom: Double;
    function BusyTo: Double;
    property PendingLog: string read FPendingLog;
    property Succeeded: Boolean read FSucceeded;
    property Cancelled: Boolean read FCancelled;
    property Message: string read FMessage;

    property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
    property OnLog: TNotifyEvent read FOnLog write FOnLog;
  end;

implementation

uses
  uFfmpegCmd, uProcRunner;

constructor TGenerateThread.Create(const ARequests: TGenRequests;
  const AMaster: TMediaInfo);
var
  I: Integer;
begin
  inherited Create(True);
  FreeOnTerminate := False;
  SetLength(FRequests, Length(ARequests));
  for I := 0 to High(ARequests) do
    FRequests[I] := ARequests[I];
  FMaster := AMaster;
end;

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

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

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

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

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

procedure TGenerateThread.ErrorLine(const ALine: string);
begin
  Log('ffmpeg: ' + ALine);
end;

function TGenerateThread.Total: Integer;
begin
  Result := Length(FRequests);
end;

function TGenerateThread.BusyFrom: Double;
begin
  if (FCurrent >= 0) and (FCurrent <= High(FRequests)) then
    Result := FRequests[FCurrent].TlStart
  else
    Result := 0;
end;

function TGenerateThread.BusyTo: Double;
begin
  if (FCurrent >= 0) and (FCurrent <= High(FRequests)) then
    Result := FRequests[FCurrent].TlEnd
  else
    Result := 0;
end;

procedure TGenerateThread.Publish;
begin
  if Length(FRequests) > 0 then
    FFraction := FCurrent / Length(FRequests)
  else
    FFraction := 1;
  Synchronize(@SyncProgress);
end;

procedure TGenerateThread.Execute;
var
  I: Integer;
  Args: TArgs;
  Res: TProcResult;
  ToolError: string;
  AudioCodec: string;
begin
  try
    if Length(FRequests) = 0 then
    begin
      FSucceeded := True;
      FMessage := 'Создавать нечего.';
      Exit;
    end;

    if not ToolsAvailable(ToolError) then
    begin
      FMessage := ToolError;
      Exit;
    end;

    if not FMaster.Valid then
    begin
      FMessage := 'Параметры проекта не заданы: добавьте сначала видеофайл.';
      Exit;
    end;

    { Звуковая дорожка добавляется только если она есть у проекта: иначе
      при склейке у одних кусков звук будет, у других нет, и результат
      развалится. }
    if FMaster.HasAudio then
      AudioCodec := FMaster.AudioCodec
    else
      AudioCodec := '';

    for I := 0 to High(FRequests) do
    begin
      if CancelQuery then
      begin
        FCancelled := True;
        FMessage := 'Отменено.';
        Exit;
      end;

      FCurrent := I;
      case FRequests[I].Kind of
        gkBlack:
          FStageText := Format('Делаю чёрную вставку %d из %d',
            [I + 1, Length(FRequests)]);
        gkImage:
          FStageText := Format('Делаю клип из картинки %d из %d',
            [I + 1, Length(FRequests)]);
        gkSilence:
          FStageText := Format('Делаю вставку тишины %d из %d',
            [I + 1, Length(FRequests)]);
        gkLayers:
          FStageText := Format('Собираю наложение %d из %d',
            [I + 1, Length(FRequests)]);
      end;
      Publish;

      if not ForceDirectories(ExtractFilePath(FRequests[I].TargetPath)) then
      begin
        FMessage := 'Не удалось создать каталог для сгенерированных клипов.';
        Exit;
      end;

      case FRequests[I].Kind of
        gkBlack:
          Args := ArgsBlackClip(FRequests[I].TargetPath, FRequests[I].Duration,
            FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen,
            FMaster.VideoCodec, FMaster.PixFmt, AudioCodec,
            FMaster.SampleRate, FMaster.Channels);
        gkImage:
          { Фотография попадает в ролик наравне со съёмкой, и жать её
            сильнее, чем её соседей, незачем. }
          Args := ArgsImageClip(FRequests[I].SourcePath, FRequests[I].TargetPath,
            FRequests[I].Duration,
            FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen,
            FMaster.VideoCodec, FMaster.PixFmt, AudioCodec,
            FMaster.SampleRate, FMaster.Channels, FMaster.VideoBitrate);
        gkSilence:
          Args := ArgsSilenceClip(FRequests[I].TargetPath,
            FRequests[I].Duration, AudioCodec,
            FMaster.SampleRate, FMaster.Channels);
        gkLayers:
          { Тот же расчёт, что и при сборке ролика: прозрачность —
            наложением с приглушённым альфа-каналом, переход — фильтром
            xfade. Разными путями считать одно и то же нельзя, иначе
            предпросмотр разойдётся с готовым роликом. }
          Args := ArgsRenderLayers(FRequests[I].Layers,
            FRequests[I].TargetPath, FRequests[I].Duration,
            FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen,
            FMaster.PixFmt, FMaster.VideoCodec, False, FMaster.VideoBitrate);
      else
        Continue;
      end;

      Log('> ' + CommandToString(FfmpegExe, Args));
      Res := RunProcess(FfmpegExe, Args, nil, @ErrorLine, @CancelQuery);

      if Res.Cancelled then
      begin
        FCancelled := True;
        FMessage := 'Отменено.';
        if FileExists(FRequests[I].TargetPath) then
          DeleteFile(FRequests[I].TargetPath);
        Exit;
      end;
      if (not Res.Started) or (Res.ExitCode <> 0) then
      begin
        FMessage := 'Не удалось создать ' +
          ExtractFileName(FRequests[I].TargetPath) + '. Подробности в журнале.';
        Exit;
      end;
      if not FileExists(FRequests[I].TargetPath) then
      begin
        FMessage := 'ffmpeg отработал, но файла нет: ' + FRequests[I].TargetPath;
        Exit;
      end;
    end;

    FCurrent := Length(FRequests);
    FSucceeded := True;
    FMessage := 'Готово.';
  except
    on E: Exception do
      FMessage := 'Внутренняя ошибка: ' + E.Message;
  end;

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

end.