nlve/src/uKeyframeIndex.pas

{
  uKeyframeIndex — где в файле находятся опорные кадры.

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

  Быстрый путь: разбор заголовка MP4.

  В MP4 есть таблица stss — номера кадров, которые являются опорными, и
  таблица stts — длительность каждого кадра. Вместе они дают точные метки
  времени всех опорных кадров, и лежат обе в блоке moov, который занимает
  единицы мегабайт независимо от размера файла.

  На пробе: файл 6.28 ГБ, moov 2.9 МБ. Разбор заголовка дал 892 опорных
  кадра за 23 мс. Тот же результат через ffprobe требовал 12.2 секунды,
  потому что ffprobe читает все 6.28 ГБ насквозь. Разница в 500 раз, при
  полном совпадении значений.

  Запасной путь: опрос ffprobe. Медленно, но работает с любым контейнером.

  Чего этот разбор пока не учитывает: блок elst (список правок), который
  способен сдвинуть всю дорожку по времени. У обычных записей с камер его
  нет. Если появится материал, где метки разъезжаются, начинать копать
  надо отсюда.
}
unit uKeyframeIndex;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, uAppTypes;

type
  TDoubleArray = array of Double;

  TKeyframeSource = (kfNone, kfMp4Header, kfFfprobe, kfAllFrames);

  TKeyframeIndex = record
    Times: TDoubleArray;
    Source: TKeyframeSource;
    { Кодек без межкадрового сжатия: опорным является каждый кадр, и
      резать можно где угодно. Таблица при этом пуста. }
    AllFrames: Boolean;
  end;

{ Строит индекс. Сначала пробует разобрать заголовок MP4, при неудаче
  опрашивает ffprobe. Вызывать из рабочего потока: запасной путь читает
  файл целиком. }
function BuildKeyframeIndex(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;

{ Только разбор заголовка MP4, без обращения к ffprobe. Отдельно вынесено
  ради проверки: так видно, сработал быстрый путь или нет. }
function ReadMp4KeyframeIndex(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;

{ Только опрос ffprobe. Тоже вынесено отдельно, чтобы можно было сверять
  быстрый путь с медленным: если они разойдутся, разбору заголовка нельзя
  будет доверять. }
function BuildKeyframeIndexViaProbe(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;

{ Индекс с запоминанием на диске.

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

  Ключ кэша учитывает размер и время правки файла: подменили файл — кэш
  сам перестанет подходить. }
function CachedKeyframeIndex(const ACacheDir, APath: string;
  out AIndex: TKeyframeIndex; out AError: string): Boolean;

{ Ближайший опорный кадр не позже указанного времени. }
function SnapDown(const AIndex: TKeyframeIndex; const ATime: Double): Double;

{ Ближайший опорный кадр в любую сторону. Именно это поведение ожидается
  от реза по умолчанию: промахнуться на полкадра вперёд не хуже, чем назад. }
function SnapNearest(const AIndex: TKeyframeIndex; const ATime: Double): Double;

implementation

uses
  Math, md5, fpjson, jsonparser, jsonscanner, uFfmpegCmd, uProcRunner;

type
  { Пары «сколько подряд» и «значение» — так в MP4 хранятся и длительности
    кадров, и смещения времени показа. }
  TRunTable = record
    Counts: array of LongWord;
    Values: array of Int64;
  end;

{ --- Чтение чисел в сетевом порядке байт --- }

function ReadU32(AStream: TStream): LongWord;
var
  B: array[0..3] of Byte;
begin
  AStream.ReadBuffer(B, 4);
  Result := (LongWord(B[0]) shl 24) or (LongWord(B[1]) shl 16) or
            (LongWord(B[2]) shl 8) or LongWord(B[3]);
end;

function ReadU64(AStream: TStream): QWord;
var
  Hi, Lo: LongWord;
begin
  Hi := ReadU32(AStream);
  Lo := ReadU32(AStream);
  Result := (QWord(Hi) shl 32) or QWord(Lo);
end;

function ReadFourCC(AStream: TStream): string;
var
  B: array[0..3] of Char;
begin
  AStream.ReadBuffer(B, 4);
  SetLength(Result, 4);
  Move(B, Result[1], 4);
end;

{ Следующий блок в пределах [APos, AEnd). Возвращает False, когда блоки
  кончились или структура повреждена. APos сдвигается на начало следующего. }
function NextBox(AStream: TStream; var APos: Int64; AEnd: Int64;
  out AType: string; out ABodyStart, ABodyEnd: Int64): Boolean;
var
  Size: QWord;
  Header: Integer;
begin
  Result := False;
  AType := '';
  ABodyStart := 0;
  ABodyEnd := 0;

  if APos + 8 > AEnd then
    Exit;

  AStream.Position := APos;
  Size := ReadU32(AStream);
  AType := ReadFourCC(AStream);
  Header := 8;

  if Size = 1 then
  begin
    { Размер не поместился в 32 бита — он лежит следом восемью байтами. }
    if APos + 16 > AEnd then
      Exit;
    Size := ReadU64(AStream);
    Header := 16;
  end
  else if Size = 0 then
    { Ноль означает «до конца родителя». }
    Size := QWord(AEnd - APos);

  if (Size < QWord(Header)) or (APos + Int64(Size) > AEnd) then
    Exit;

  ABodyStart := APos + Header;
  ABodyEnd := APos + Int64(Size);
  APos := ABodyEnd;
  Result := True;
end;

{ Первый дочерний блок нужного типа. }
function FindBox(AStream: TStream; AStart, AEnd: Int64; const AType: string;
  out ABodyStart, ABodyEnd: Int64): Boolean;
var
  Pos: Int64;
  T: string;
  BS, BE: Int64;
begin
  Result := False;
  Pos := AStart;
  while NextBox(AStream, Pos, AEnd, T, BS, BE) do
    if T = AType then
    begin
      ABodyStart := BS;
      ABodyEnd := BE;
      Exit(True);
    end;
end;

{ Читает таблицу пар «количество, значение». ASigned важен для ctts
  версии 1, где смещение может быть отрицательным. }
procedure ReadRunTable(AStream: TStream; ABodyStart: Int64; ASigned: Boolean;
  out ATable: TRunTable);
var
  Version: Byte;
  Count, I: LongWord;
  Raw: LongWord;
begin
  ATable.Counts := nil;
  ATable.Values := nil;

  AStream.Position := ABodyStart;
  Version := 0;
  AStream.ReadBuffer(Version, 1);
  AStream.Position := ABodyStart + 4;
  Count := ReadU32(AStream);

  { Заведомо неправдоподобный размер — признак повреждения, а не повод
    пытаться выделить гигабайты. }
  if Count > 100 * 1000 * 1000 then
    Exit;

  SetLength(ATable.Counts, Count);
  SetLength(ATable.Values, Count);
  for I := 0 to Count - 1 do
  begin
    ATable.Counts[I] := ReadU32(AStream);
    Raw := ReadU32(AStream);
    if ASigned and (Version = 1) then
      ATable.Values[I] := LongInt(Raw)
    else
      ATable.Values[I] := Int64(Raw);
  end;
end;

{ Курсор по таблице пар: позволяет спрашивать значение для номера кадра,
  если номера спрашиваются по возрастанию. Так обход обеих таблиц
  выходит линейным, а не квадратичным. }
type
  TRunCursor = record
    Table: TRunTable;
    RunIdx: Integer;
    FirstSample: Int64;
    AccumulatedBefore: Int64;
  end;

procedure ResetCursor(out ACursor: TRunCursor; const ATable: TRunTable);
begin
  ACursor.Table := ATable;
  ACursor.RunIdx := 0;
  ACursor.FirstSample := 1;
  ACursor.AccumulatedBefore := 0;
end;

{ Сумма значений для кадров до ASample, то есть время начала показа
  кадра ASample при обходе таблицы длительностей. }
function CursorSumBefore(var ACursor: TRunCursor; ASample: Int64): Int64;
var
  Cnt: Int64;
begin
  while (ACursor.RunIdx <= High(ACursor.Table.Counts)) do
  begin
    Cnt := ACursor.Table.Counts[ACursor.RunIdx];
    if ASample < ACursor.FirstSample + Cnt then
      Break;
    Inc(ACursor.AccumulatedBefore, Cnt * ACursor.Table.Values[ACursor.RunIdx]);
    Inc(ACursor.FirstSample, Cnt);
    Inc(ACursor.RunIdx);
  end;

  if ACursor.RunIdx > High(ACursor.Table.Counts) then
    Exit(ACursor.AccumulatedBefore);

  Result := ACursor.AccumulatedBefore +
    (ASample - ACursor.FirstSample) * ACursor.Table.Values[ACursor.RunIdx];
end;

{ Значение, приписанное конкретному кадру. Для ctts это смещение времени
  показа относительно времени декодирования. }
function CursorValueAt(var ACursor: TRunCursor; ASample: Int64): Int64;
var
  Cnt: Int64;
begin
  while (ACursor.RunIdx <= High(ACursor.Table.Counts)) do
  begin
    Cnt := ACursor.Table.Counts[ACursor.RunIdx];
    if ASample < ACursor.FirstSample + Cnt then
      Break;
    Inc(ACursor.FirstSample, Cnt);
    Inc(ACursor.RunIdx);
  end;

  if ACursor.RunIdx > High(ACursor.Table.Counts) then
    Exit(0);

  Result := ACursor.Table.Values[ACursor.RunIdx];
end;

function ReadMp4KeyframeIndex(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;
var
  Stream: TFileStream;
  FileEnd, Pos: Int64;
  T: string;
  BS, BE: Int64;
  MoovStart, MoovEnd: Int64;
  TrakStart, TrakEnd: Int64;
  MdiaStart, MdiaEnd: Int64;
  MinfStart, MinfEnd: Int64;
  StblStart, StblEnd: Int64;
  MdhdStart, MdhdEnd: Int64;
  HdlrStart, HdlrEnd: Int64;
  SttsStart, SttsEnd: Int64;
  CttsStart, CttsEnd: Int64;
  StssStart, StssEnd: Int64;
  Version: Byte;
  Timescale: LongWord;
  Handler: string;
  SttsTable, CttsTable: TRunTable;
  HasCtts: Boolean;
  SyncCount, I: LongWord;
  Sample: Int64;
  DtsCursor, CttsCursor: TRunCursor;
  Pts: Int64;
  FoundVideo: Boolean;
begin
  Result := False;
  AError := '';
  AIndex.Times := nil;
  AIndex.Source := kfNone;
  AIndex.AllFrames := False;

  if not FileExists(APath) then
  begin
    AError := 'Файл не найден: ' + APath;
    Exit;
  end;

  try
    Stream := TFileStream.Create(APath, fmOpenRead or fmShareDenyNone);
  except
    on E: Exception do
    begin
      AError := 'Не удалось открыть файл: ' + E.Message;
      Exit;
    end;
  end;

  try
    FileEnd := Stream.Size;

    { moov может лежать и в начале файла, и в конце — стандарт этого не
      предписывает. Записи с камер обычно кладут его в конец. }
    MoovStart := -1;
    MoovEnd := -1;
    Pos := 0;
    while NextBox(Stream, Pos, FileEnd, T, BS, BE) do
      if T = 'moov' then
      begin
        MoovStart := BS;
        MoovEnd := BE;
        Break;
      end;

    if MoovStart < 0 then
    begin
      AError := 'Это не MP4 или MOV: блок moov не найден.';
      Exit;
    end;

    FoundVideo := False;
    Pos := MoovStart;
    while NextBox(Stream, Pos, MoovEnd, T, TrakStart, TrakEnd) do
    begin
      if T <> 'trak' then
        Continue;

      if not FindBox(Stream, TrakStart, TrakEnd, 'mdia', MdiaStart, MdiaEnd) then
        Continue;

      { Нас интересует только видеодорожка. У DJI в файле их две — сама
        съёмка и MJPEG-обложка, — плюс потоки телеметрии. }
      if not FindBox(Stream, MdiaStart, MdiaEnd, 'hdlr', HdlrStart, HdlrEnd) then
        Continue;
      Stream.Position := HdlrStart + 8;
      Handler := ReadFourCC(Stream);
      if Handler <> 'vide' then
        Continue;

      if not FindBox(Stream, MdiaStart, MdiaEnd, 'mdhd', MdhdStart, MdhdEnd) then
        Continue;

      Stream.Position := MdhdStart;
      Version := 0;
      Stream.ReadBuffer(Version, 1);
      if Version = 1 then
        { версия 1: два восьмибайтных времени, затем шкала }
        Stream.Position := MdhdStart + 4 + 8 + 8
      else
        { версия 0: два четырёхбайтных времени, затем шкала }
        Stream.Position := MdhdStart + 4 + 4 + 4;
      Timescale := ReadU32(Stream);
      if Timescale = 0 then
        Continue;

      if not FindBox(Stream, MdiaStart, MdiaEnd, 'minf', MinfStart, MinfEnd) then
        Continue;
      if not FindBox(Stream, MinfStart, MinfEnd, 'stbl', StblStart, StblEnd) then
        Continue;
      if not FindBox(Stream, StblStart, StblEnd, 'stts', SttsStart, SttsEnd) then
        Continue;

      ReadRunTable(Stream, SttsStart, False, SttsTable);

      HasCtts := FindBox(Stream, StblStart, StblEnd, 'ctts', CttsStart, CttsEnd);
      if HasCtts then
        ReadRunTable(Stream, CttsStart, True, CttsTable);

      FoundVideo := True;

      if not FindBox(Stream, StblStart, StblEnd, 'stss', StssStart, StssEnd) then
      begin
        { Таблицы опорных кадров нет — по стандарту это значит, что
          опорным является каждый кадр. Так бывает у MJPEG и прочих
          кодеков без межкадрового сжатия. }
        AIndex.AllFrames := True;
        AIndex.Source := kfAllFrames;
        Exit(True);
      end;

      Stream.Position := StssStart + 4;
      SyncCount := ReadU32(Stream);
      if SyncCount > 50 * 1000 * 1000 then
      begin
        AError := 'Таблица опорных кадров неправдоподобного размера.';
        Exit;
      end;

      SetLength(AIndex.Times, SyncCount);
      ResetCursor(DtsCursor, SttsTable);
      if HasCtts then
        ResetCursor(CttsCursor, CttsTable);

      for I := 0 to SyncCount - 1 do
      begin
        { Номера кадров в stss начинаются с единицы. }
        Sample := ReadU32(Stream);
        Pts := CursorSumBefore(DtsCursor, Sample);
        if HasCtts then
          Inc(Pts, CursorValueAt(CttsCursor, Sample));
        AIndex.Times[I] := Pts / Timescale;
      end;

      AIndex.Source := kfMp4Header;
      Exit(True);
    end;

    if FoundVideo then
      AError := 'В видеодорожке нет таблицы длительностей кадров.'
    else
      AError := 'В файле не нашлось видеодорожки.';
  finally
    Stream.Free;
  end;
end;

{ --- Запасной путь через ffprobe --- }

type
  TProbeCollector = class
  private
    FTimes: TDoubleArray;
    FCount: Integer;
  public
    procedure Line(const ALine: string);
    function Take: TDoubleArray;
  end;

procedure TProbeCollector.Line(const ALine: string);
var
  P: Integer;
  TimeStr, Flags: string;
  Value: Double;
begin
  { Формат строки: pts_time,flags — например «1.001000,K__». }
  P := Pos(',', ALine);
  if P <= 1 then
    Exit;
  TimeStr := Copy(ALine, 1, P - 1);
  Flags := Copy(ALine, P + 1, Length(ALine) - P);
  if Pos('K', Flags) = 0 then
    Exit;
  if not TryStrToFloat(TimeStr, Value, InvariantFormat) then
    Exit;

  if FCount = Length(FTimes) then
    SetLength(FTimes, Max(64, Length(FTimes) * 2));
  FTimes[FCount] := Value;
  Inc(FCount);
end;

function TProbeCollector.Take: TDoubleArray;
begin
  SetLength(FTimes, FCount);
  Result := FTimes;
end;

function BuildKeyframeIndexViaProbe(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;
var
  Collector: TProbeCollector;
  Res: TProcResult;
begin
  Result := False;
  AError := '';
  AIndex.Times := nil;
  AIndex.Source := kfNone;
  AIndex.AllFrames := False;

  if FfprobeExe = '' then
  begin
    AError := 'ffprobe не найден, построить индекс опорных кадров нечем.';
    Exit;
  end;

  Collector := TProbeCollector.Create;
  try
    Res := RunProcess(FfprobeExe, ArgsPacketFlags(APath),
      @Collector.Line, nil, nil);
    if not Res.Started then
    begin
      AError := Res.ErrorText;
      Exit;
    end;
    if Res.ExitCode <> 0 then
    begin
      AError := 'ffprobe завершился с кодом ' + IntToStr(Res.ExitCode) + '.';
      Exit;
    end;

    AIndex.Times := Collector.Take;
    if Length(AIndex.Times) = 0 then
    begin
      AError := 'ffprobe не нашёл ни одного опорного кадра.';
      Exit;
    end;
    AIndex.Source := kfFfprobe;
    Result := True;
  finally
    Collector.Free;
  end;
end;

function BuildKeyframeIndex(const APath: string; out AIndex: TKeyframeIndex;
  out AError: string): Boolean;
var
  Mp4Error: string;
begin
  { Сначала быстрый путь. Он работает только с MP4 и MOV, зато на порядки
    быстрее и не зависит от наличия ffprobe. }
  if ReadMp4KeyframeIndex(APath, AIndex, Mp4Error) then
    Exit(True);

  Result := BuildKeyframeIndexViaProbe(APath, AIndex, AError);
  if not Result then
    AError := 'Разбор заголовка: ' + Mp4Error + LineEnding + 'ffprobe: ' + AError;
end;

{ --- Запоминание на диске --- }

{ Имя файла кэша: отпечаток пути, размера и времени правки. }
function CacheFileName(const ACacheDir, APath: string): string;
var
  Info: TSearchRec;
  Size: Int64;
  Stamp: LongInt;
  Key: string;
begin
  Size := 0;
  Stamp := 0;
  if FindFirst(APath, faAnyFile, Info) = 0 then
  begin
    Size := Info.Size;
    Stamp := Info.Time;
    FindClose(Info);
  end;
  Key := APath + '|' + IntToStr(Size) + '|' + IntToStr(Stamp);
  Result := IncludeTrailingPathDelimiter(ACacheDir) + 'idx' + PathDelim +
    MD5Print(MD5String(Key)) + '.json';
end;

function LoadIndexFile(const AFile: string; out AIndex: TKeyframeIndex): Boolean;
var
  Text: TStringList;
  Parser: TJSONParser;
  Root: TJSONData;
  Obj: TJSONObject;
  Arr: TJSONArray;
  I: Integer;
begin
  Result := False;
  AIndex.Times := nil;
  AIndex.Source := kfNone;
  AIndex.AllFrames := False;

  if not FileExists(AFile) then
    Exit;

  Text := TStringList.Create;
  try
    try
      Text.LoadFromFile(AFile);
      Parser := TJSONParser.Create(Text.Text, [joUTF8]);
      try
        Root := Parser.Parse;
      finally
        Parser.Free;
      end;
    except
      { Испорченный кэш — не повод падать: просто построим индекс заново. }
      Exit;
    end;
  finally
    Text.Free;
  end;

  if (Root = nil) or (not (Root is TJSONObject)) then
  begin
    Root.Free;
    Exit;
  end;

  try
    Obj := TJSONObject(Root);
    AIndex.AllFrames := Obj.Get('all_frames', False);
    if Obj.Get('source', '') = 'mp4' then
      AIndex.Source := kfMp4Header
    else if Obj.Get('source', '') = 'ffprobe' then
      AIndex.Source := kfFfprobe
    else if AIndex.AllFrames then
      AIndex.Source := kfAllFrames;

    Arr := Obj.Find('times', jtArray) as TJSONArray;
    if Arr <> nil then
    begin
      SetLength(AIndex.Times, Arr.Count);
      for I := 0 to Arr.Count - 1 do
        AIndex.Times[I] := Arr.Floats[I];
    end;

    Result := AIndex.AllFrames or (Length(AIndex.Times) > 0);
  finally
    Root.Free;
  end;
end;

procedure SaveIndexFile(const AFile: string; const AIndex: TKeyframeIndex);
var
  Root: TJSONObject;
  Arr: TJSONArray;
  I: Integer;
  Text: TStringList;
  SourceName: string;
begin
  if not ForceDirectories(ExtractFilePath(AFile)) then
    Exit;

  case AIndex.Source of
    kfMp4Header: SourceName := 'mp4';
    kfFfprobe: SourceName := 'ffprobe';
    kfAllFrames: SourceName := 'all';
  else
    SourceName := 'none';
  end;

  Root := TJSONObject.Create;
  try
    Root.Add('source', SourceName);
    Root.Add('all_frames', AIndex.AllFrames);
    Arr := TJSONArray.Create;
    for I := 0 to High(AIndex.Times) do
      Arr.Add(AIndex.Times[I]);
    Root.Add('times', Arr);

    Text := TStringList.Create;
    try
      Text.Text := Root.AsJSON;
      try
        Text.SaveToFile(AFile);
      except
        { Не смогли записать кэш — работать это не мешает. }
      end;
    finally
      Text.Free;
    end;
  finally
    Root.Free;
  end;
end;

function CachedKeyframeIndex(const ACacheDir, APath: string;
  out AIndex: TKeyframeIndex; out AError: string): Boolean;
var
  CacheFile: string;
begin
  AError := '';
  CacheFile := CacheFileName(ACacheDir, APath);

  if LoadIndexFile(CacheFile, AIndex) then
    Exit(True);

  Result := BuildKeyframeIndex(APath, AIndex, AError);
  if Result then
    SaveIndexFile(CacheFile, AIndex);
end;

{ --- Поиск ближайшего опорного кадра --- }

{ Номер последнего элемента, значение которого не превышает ATime.
  Минус один, если таких нет. }
function LowerBoundIdx(const ATimes: TDoubleArray; const ATime: Double): Integer;
var
  Lo, Hi, Mid: Integer;
begin
  Result := -1;
  Lo := 0;
  Hi := High(ATimes);
  while Lo <= Hi do
  begin
    Mid := (Lo + Hi) div 2;
    if ATimes[Mid] <= ATime then
    begin
      Result := Mid;
      Lo := Mid + 1;
    end
    else
      Hi := Mid - 1;
  end;
end;

function SnapDown(const AIndex: TKeyframeIndex; const ATime: Double): Double;
var
  Idx: Integer;
begin
  if AIndex.AllFrames or (Length(AIndex.Times) = 0) then
    Exit(ATime);
  Idx := LowerBoundIdx(AIndex.Times, ATime);
  if Idx < 0 then
    Exit(AIndex.Times[0]);
  Result := AIndex.Times[Idx];
end;

function SnapNearest(const AIndex: TKeyframeIndex; const ATime: Double): Double;
var
  Idx: Integer;
begin
  if AIndex.AllFrames or (Length(AIndex.Times) = 0) then
    Exit(ATime);

  Idx := LowerBoundIdx(AIndex.Times, ATime);
  if Idx < 0 then
    Exit(AIndex.Times[0]);
  if Idx >= High(AIndex.Times) then
    Exit(AIndex.Times[High(AIndex.Times)]);

  if (ATime - AIndex.Times[Idx]) <= (AIndex.Times[Idx + 1] - ATime) then
    Result := AIndex.Times[Idx]
  else
    Result := AIndex.Times[Idx + 1];
end;

end.