nlve/src/uSubtitles.pas

{
  uSubtitles — текст поверх картинки.

  Рисует не эта программа, а libass: он есть и внутри mpv, и внутри
  ffmpeg, поэтому предпросмотр и готовый ролик показывают одно и то же.
  Наше дело — собрать для него файл ASS.

  Почему переносы считаем сами. libass умеет переносить, но тогда
  неизвестно, сколько выйдет строк, и подобрать размер под отведённую
  полосу нечем. Поэтому меряем и переносим здесь, а в файл отдаём готовые
  переводы строк: что померили, то и нарисуется.

  Чем меряем. Тем же шрифтом, что уйдёт в libass, через холст LCL — за
  обоими стоит FreeType, и ширины сходятся. Небольшой запас всё равно
  берём: настройки сглаживания у них разные.

  Замер, на котором держится подбор размера (DejaVu Sans, кадр 1280x720):
  шаг строк почти равен размеру шрифта, высота блока из N строк ≈
  размер × (N − 0.16). В полосу 20% высоты влезает три строки размером до
  50, четыре до 37, пять до 30.
}
unit uSubtitles;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, uAppTypes, uProject, uFlatten;

type
  { Как померить ширину строки. Возвращает ширину в точках кадра. }
  TTextMeasure = function(const AText: string; const AStyle: TTextStyle;
    ASize: Integer): Integer;

var
  { Замерщик ширины текста.

    Подключается снаружи: точный замер требует холста, а холст —
    работающего оконного набора. Служебной программе без экрана он
    недоступен, и она обходится оценкой (см. EstimateWidth) — для
    проверки самого файла ASS этого хватает.

    Окно ставит сюда замер тем же шрифтом, каким libass будет рисовать. }
  TextMeasure: TTextMeasure = nil;

{ Собирает ASS из всех текстовых клипов проекта.

  Возвращает пустую строку, если текста нет вовсе — тогда и файл писать
  незачем. }
function BuildAss(AProject: TProject): string;

{ Пишет ASS в файл. False — писать было нечего или не вышло. }
function WriteAssFile(AProject: TProject; const APath: string): Boolean;

{ Есть ли в проекте хоть один текстовый клип. }
function HasText(AProject: TProject): Boolean;

{ Подбор размера и переносов — для окна редактора: оно показывает, во что
  превратится надпись, ещё до сборки разметки. Тот же код, что и в самой
  сборке, поэтому расхождения быть не может. }
function FitTextForPreview(const AText: string; const AStyle: TTextStyle;
  AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer;

{ Занят ли текстом этот отрезок монтажа. Нужно сборке: вжигать текст
  приходится только в те куски, которые он покрывает. }
function TextCovers(AProject: TProject; const AFrom, ATo: Double): Boolean;

{ Разметка для одного куска монтажа: события сдвинуты к его началу и
  обрезаны по его длине.

  Нужно вжиганию. Фильтр subtitles рисует по времени того файла, который
  ему дали, а кусок начинается со своего нуля — общая разметка легла бы
  не туда. }
function WriteAssForRange(AProject: TProject; const AFrom, ATo: Double;
  const APath: string): Boolean;

{ Готовит куски к вжиганию: тем, которые задевает текст, ставит признак
  пересборки и подкладывает свою разметку.

  Возвращает, сколько секунд придётся пересобрать сверх того, что и так
  пересобиралось: человеку это говорят до начала. }
function BurnTextIntoSegments(AProject: TProject;
  var ASegments: TFlatSegmentArray; const ACacheDir: string): Double;

implementation

uses
  Math, LazUTF8;

const
  { Запас по ширине: наши мерки и мерки libass расходятся на проценты. }
  WidthSafety = 0.95;
  { Поля от краёв кадра в долях ширины и высоты. }
  MarginShare = 0.05;
  { Ниже этого размер не опускаем: дальше текст всё равно не прочесть,
    и лучше показать его крупным с выходом за полосу, чем нечитаемым. }
  MinFontSize = 14;

{ Время в записи ASS: часы:минуты:секунды.сотые. }
function AssTime(const ASeconds: Double): string;
var
  T: Double;
  H, M: Integer;
  S: Double;
begin
  T := Max(0, ASeconds);
  H := Trunc(T) div 3600;
  M := (Trunc(T) mod 3600) div 60;
  S := T - H * 3600 - M * 60;
  { Дробную часть добиваем нулём вручную: %05.2f у Паскаля дополняет
    пробелом, а ASS с пробелом внутри времени не читается. }
  Result := Format('%d:%.2d:%.2d.%.2d',
    [H, M, Trunc(S), Round(Frac(S) * 100)]);
end;

{ Цвет в записи ASS: &HAABBGGRR. Порядок обратный привычному, а первым
  идёт не прозрачность, а её отсутствие — ноль значит «непрозрачно». }
function AssColor(AColor: TRgb; ATransparent: Boolean = False): string;
var
  Alpha: Integer;
begin
  if ATransparent then
    Alpha := $FF
  else
    Alpha := 0;
  Result := Format('&H%.2X%.2X%.2X%.2X',
    [Alpha, (AColor shr 16) and $FF, (AColor shr 8) and $FF, AColor and $FF]);
end;

{ Внутри строки ASS перевод строки записывается как \N, а фигурные скобки
  начинают команду — их надо обезвредить. }
function AssEscape(const AText: string): string;
begin
  Result := StringReplace(AText, '\', '\\', [rfReplaceAll]);
  Result := StringReplace(Result, '{', '(', [rfReplaceAll]);
  Result := StringReplace(Result, '}', ')', [rfReplaceAll]);
  Result := StringReplace(Result, LineEnding, '\N', [rfReplaceAll]);
  Result := StringReplace(Result, #10, '\N', [rfReplaceAll]);
  Result := StringReplace(Result, #13, '\N', [rfReplaceAll]);
end;

{ Оценка ширины, когда точного замера нет.

  Множитель взят из замера: DejaVu Sans, размер 54, строка из двадцати
  знаков кириллицы заняла 530 точек — это 0.49 размера на знак. Оценка
  грубая, но для проверки самой разметки годится, а окно всегда ставит
  точный замер. }
function EstimateWidth(const AText: string; ASize: Integer): Integer;
begin
  Result := Round(UTF8Length(AText) * ASize * 0.49);
end;

function MeasureWidth(const AText: string; const AStyle: TTextStyle;
  ASize: Integer): Integer;
begin
  if Assigned(TextMeasure) then
    Result := TextMeasure(AText, AStyle, ASize)
  else
    Result := EstimateWidth(AText, ASize);
end;

{ Перенос по словам под заданную ширину. Возвращает число строк, сами
  строки складывает в ALines. }
function WrapText(const AText: string; const AStyle: TTextStyle;
  ASize, AMaxWidth: Integer; ALines: TStringList): Integer;
var
  Src: TStringList;
  I: Integer;
  Rest, Word, Line: string;
  Space: Integer;
begin
  ALines.Clear;
  Src := TStringList.Create;
  try
    { Свои переводы строк человек ставил не зря — они остаются. }
    Src.Text := AText;
    for I := 0 to Src.Count - 1 do
    begin
      Rest := Src[I];
      if Trim(Rest) = '' then
      begin
        ALines.Add('');
        Continue;
      end;

      Line := '';
      while Rest <> '' do
      begin
        Space := Pos(' ', Rest);
        if Space = 0 then
        begin
          Word := Rest;
          Rest := '';
        end
        else
        begin
          Word := Copy(Rest, 1, Space - 1);
          Rest := Copy(Rest, Space + 1, Length(Rest));
        end;

        if Line = '' then
          Line := Word
        else if MeasureWidth(Line + ' ' + Word, AStyle, ASize) <= AMaxWidth then
          Line := Line + ' ' + Word
        else
        begin
          ALines.Add(Line);
          Line := Word;
        end;
      end;
      if Line <> '' then
        ALines.Add(Line);
    end;
  finally
    Src.Free;
  end;
  Result := ALines.Count;
end;

{ Подбор размера и переносов под отведённую полосу.

  Идём от заданного размера вниз: он же и верхняя граница. Уменьшаем,
  пока блок не влезет по высоте — по ширине перенос справляется сам. }
function FitText(const AText: string; const AStyle: TTextStyle;
  AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer;
var
  MaxWidth, MaxHeight, Size, BlockHeight: Integer;
  Lo, Hi, Mid, Best, Count: Integer;
begin
  MaxWidth := Round(AFrameWidth * (1 - MarginShare * 2) * WidthSafety);
  MaxHeight := Round(AFrameHeight * AStyle.MaxHeight);
  Size := AStyle.FontSize;
  if Size < MinFontSize then
    Size := MinFontSize;

  { Ищем наибольший размер, при котором блок влезает, делением отрезка
    пополам.

    Прикидка «уменьшить во столько же раз, во сколько не влезли» даёт
    слишком мелкий шрифт: после переноса строк становится меньше, и
    места остаётся вдоволь. Проверено на длинной надписи — вместо 29
    помещался 40. Десятка кругов хватает на любой разумный размер. }
  Lo := MinFontSize;
  Hi := Size;
  Best := MinFontSize;

  while Lo <= Hi do
  begin
    Mid := (Lo + Hi) div 2;
    Count := WrapText(AText, AStyle, Mid, MaxWidth, ALines);
    if Count < 1 then
      Count := 1;
    { Высота блока по замеру: шаг строк равен размеру, последняя строка
      занимает чуть меньше. }
    BlockHeight := Round(Mid * (Count - 0.16));
    if BlockHeight <= MaxHeight then
    begin
      Best := Mid;
      Lo := Mid + 1;
    end
    else
      Hi := Mid - 1;
  end;

  { Последний перенос должен соответствовать выбранному размеру: во время
    поиска он мог остаться от неподошедшей примерки. }
  WrapText(AText, AStyle, Best, MaxWidth, ALines);
  Result := Best;
end;

function FitTextForPreview(const AText: string; const AStyle: TTextStyle;
  AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer;
begin
  Result := FitText(AText, AStyle, AFrameWidth, AFrameHeight, ALines);
end;

function HasText(AProject: TProject): Boolean;
var
  T, C: Integer;
begin
  Result := False;
  if AProject = nil then
    Exit;
  for T := 0 to AProject.TrackCount - 1 do
  begin
    if AProject.Tracks[T].Kind <> tkText then
      Continue;
    if not AProject.TrackAudible(AProject.Tracks[T]) then
      Continue;
    for C := 0 to AProject.Tracks[T].Count - 1 do
      if Trim(AProject.Tracks[T][C].Text) <> '' then
        Exit(True);
  end;
end;

function TextCovers(AProject: TProject; const AFrom, ATo: Double): Boolean;
var
  T, C: Integer;
  Clip: TClip;
begin
  Result := False;
  if AProject = nil then
    Exit;
  for T := 0 to AProject.TrackCount - 1 do
  begin
    if AProject.Tracks[T].Kind <> tkText then
      Continue;
    if not AProject.TrackAudible(AProject.Tracks[T]) then
      Continue;
    for C := 0 to AProject.Tracks[T].Count - 1 do
    begin
      Clip := AProject.Tracks[T][C];
      if Trim(Clip.Text) = '' then
        Continue;
      { Пересечение отрезков, а не попадание точки: кусок может быть
        длиннее надписи и наоборот. }
      if (Clip.TlStart < ATo - 0.0005) and (Clip.TlEnd > AFrom + 0.0005) then
        Exit(True);
    end;
  end;
end;

{ Общая сборка. AFrom и ATo ограничивают выборку; ATo меньше нуля значит
  «до конца монтажа». При ненулевом AFrom времена сдвигаются к нулю — так
  разметка годится для отдельного куска. }
function BuildAssRange(AProject: TProject; const AFrom, ATo: Double): string;
var
  Lines: TStringList;
  Styles, Events: TStringList;
  T, C, I, Size: Integer;
  Clip: TClip;
  Track: TTrack;
  Name, Body: string;
  W, H, MarginH, MarginV: Integer;
  StartAt, EndAt: Double;
begin
  Result := '';
  if (AProject = nil) or (not HasText(AProject)) then
    Exit;

  W := AProject.Master.Width;
  H := AProject.Master.Height;
  if (W < 2) or (H < 2) then
  begin
    W := 1920;
    H := 1080;
  end;
  MarginH := Round(W * MarginShare);
  MarginV := Round(H * MarginShare);

  Lines := TStringList.Create;
  Styles := TStringList.Create;
  Events := TStringList.Create;
  try
    for T := 0 to AProject.TrackCount - 1 do
    begin
      Track := AProject.Tracks[T];
      if Track.Kind <> tkText then
        Continue;
      if not AProject.TrackAudible(Track) then
        Continue;

      for C := 0 to Track.Count - 1 do
      begin
        Clip := Track[C];
        if Trim(Clip.Text) = '' then
          Continue;
        { Надписи, не попадающие в нужный отрезок, разбирать незачем. }
        if (ATo >= 0) and (Clip.TlStart >= ATo - 0.0005) then
          Continue;
        if Clip.TlEnd <= AFrom + 0.0005 then
          Continue;

        Size := FitText(Clip.Text, Clip.TextStyle, W, H, Lines);

        { У каждого клипа своё оформление, поэтому и свой стиль. Имя
          выводим из номера дорожки и клипа — оно должно быть
          неповторимым и не содержать запятых. }
        Name := Format('s%d_%d', [T, C]);
        Styles.Add(Format(
          'Style: %s,%s,%d,%s,%s,%s,%s,%d,%d,0,0,100,100,0,0,1,%d,%d,%d,' +
          '%d,%d,%d,1',
          [Name, Clip.TextStyle.FontName, Size,
           AssColor(Clip.TextStyle.Color),
           AssColor(Clip.TextStyle.Color),
           AssColor(Clip.TextStyle.OutlineColor),
           AssColor(Clip.TextStyle.ShadowColor,
             Clip.TextStyle.Shadow <= 0),
           Ord(Clip.TextStyle.Bold) * -1, Ord(Clip.TextStyle.Italic) * -1,
           Clip.TextStyle.Outline, Clip.TextStyle.Shadow,
           Ord(Clip.TextStyle.Place),
           MarginH, MarginH, MarginV]));

        Body := '';
        for I := 0 to Lines.Count - 1 do
        begin
          if Body <> '' then
            Body := Body + '\N';
          Body := Body + AssEscape(Lines[I]);
        end;

        { Обрезаем по границам куска и сдвигаем к его началу. }
        StartAt := Max(Clip.TlStart, AFrom) - AFrom;
        EndAt := Clip.TlEnd - AFrom;
        if ATo >= 0 then
          EndAt := Min(EndAt, ATo - AFrom);
        if EndAt <= StartAt then
          Continue;

        Events.Add(Format('Dialogue: 0,%s,%s,%s,,0,0,0,,%s',
          [AssTime(StartAt), AssTime(EndAt), Name, Body]));
      end;
    end;

    if Events.Count = 0 then
      Exit;

    Result :=
      '[Script Info]' + LineEnding +
      'ScriptType: v4.00+' + LineEnding +
      Format('PlayResX: %d', [W]) + LineEnding +
      Format('PlayResY: %d', [H]) + LineEnding +
      { Переносы мы уже расставили, libass переносить нечего. }
      'WrapStyle: 2' + LineEnding +
      'ScaledBorderAndShadow: yes' + LineEnding +
      'YCbCr Matrix: None' + LineEnding +
      LineEnding +
      '[V4+ Styles]' + LineEnding +
      'Format: Name,Fontname,Fontsize,PrimaryColour,SecondaryColour,' +
      'OutlineColour,BackColour,Bold,Italic,Underline,StrikeOut,ScaleX,' +
      'ScaleY,Spacing,Angle,BorderStyle,Outline,Shadow,Alignment,' +
      'MarginL,MarginR,MarginV,Encoding' + LineEnding +
      Styles.Text +
      LineEnding +
      '[Events]' + LineEnding +
      'Format: Layer,Start,End,Style,Name,MarginL,MarginR,MarginV,' +
      'Effect,Text' + LineEnding +
      Events.Text;
  finally
    Events.Free;
    Styles.Free;
    Lines.Free;
  end;
end;

function BuildAss(AProject: TProject): string;
begin
  Result := BuildAssRange(AProject, 0, -1);
end;

function WriteText(const AText, APath: string): Boolean;
var
  Stream: TFileStream;
begin
  Result := False;
  try
    ForceDirectories(ExtractFilePath(APath));
    Stream := TFileStream.Create(APath, fmCreate);
    try
      if Length(AText) > 0 then
        Stream.WriteBuffer(AText[1], Length(AText));
    finally
      Stream.Free;
    end;
    Result := True;
  except
    Result := False;
  end;
end;

function WriteAssForRange(AProject: TProject; const AFrom, ATo: Double;
  const APath: string): Boolean;
var
  Text: string;
begin
  Text := BuildAssRange(AProject, AFrom, ATo);
  Result := (Text <> '') and WriteText(Text, APath);
end;

function BurnTextIntoSegments(AProject: TProject;
  var ASegments: TFlatSegmentArray; const ACacheDir: string): Double;
var
  I: Integer;
  At, SegEnd: Double;
  Path: string;
begin
  Result := 0;
  if (AProject = nil) or (not HasText(AProject)) then
    Exit;

  At := 0;
  for I := 0 to High(ASegments) do
  begin
    SegEnd := At + ASegments[I].Duration;
    if TextCovers(AProject, At, SegEnd) then
    begin
      Path := IncludeTrailingPathDelimiter(ACacheDir) +
        Format('burn_%.3d.ass', [I]);
      if WriteAssForRange(AProject, At, SegEnd, Path) then
      begin
        { Кусок, который и так пересобирался, дороже не становится —
          считаем только те, что раньше копировались. }
        if not (ASegments[I].Transcode or (Length(ASegments[I].Layers) > 0)) then
          Result := Result + ASegments[I].Duration;
        ASegments[I].SubFile := Path;
        ASegments[I].Transcode := True;
      end;
    end;
    At := SegEnd;
  end;
end;

function WriteAssFile(AProject: TProject; const APath: string): Boolean;
var
  Text: string;
begin
  Result := False;
  Text := BuildAss(AProject);
  if Text = '' then
  begin
    { Текста не стало — старый файл убираем, иначе плеер покажет то,
      чего на монтаже уже нет. }
    if FileExists(APath) then
      SysUtils.DeleteFile(APath);
    Exit;
  end;

  Result := WriteText(Text, APath);
end;

end.