4aiman/nlve
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
nlve/tests/lfmcheck/lfmcheck.lpr
4aiman ffd105a8c0 Щелчок в месте наезда перебирает клипы 
Наезд двух клипов на одной дорожке — заказ на переход, то есть обычное
дело. Нажатие же всегда попадало в верхний по списку, и нижний клип
нельзя было ни выделить, ни потащить: чтобы до него добраться,
приходилось сперва убирать верхний.

Правило такое. Нажатие берёт тот из накрытых клипов, который уже выделен,
иначе верхний. Щелчок без движения по уже выделенному переводит выделение
на следующий, после последнего снова на верхний. Переключение сделано на
отпускании намеренно: пока кнопку не отпустили, неизвестно, щелчок это
или начало протяжки, а менять клип под рукой посреди протяжки нельзя.
Благодаря этому протяжка тащит именно то, что перед ней выбрали
щелчками.

Строка состояния говорит, сколько клипов под указателем: перебор, о
котором не сказали, — тайное знание.

Отбор вынесен в TTrack.ClipsAt, числовая проверка — в lfmcheck.
tests/pickcycle.sh щёлкает дважды и тащит: на прежней сборке уезжает
верхний клип, а нижний едет за ним схлопыванием.
2026-10-16 15:43:01 +03:00

1227 lines
48 KiB
ObjectPascal
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
Проверка того, что свойства, записанные в файле формы, у наших
элементов действительно есть.
Зачем отдельно. Файл формы разбирается при запуске, а не при сборке:
опечатка в имени свойства или в значении перечисления даёт не ошибку
компиляции, а падение окна на старте. Здесь то же самое проверяется без
окна — по сведениям о типах.
}
program lfmcheck;
{$mode objfpc}{$H+}
uses
{ Interfaces нужен, чтобы связалась вся LCL и заработала загрузка
файлов форм. }
Interfaces, Forms, Controls, Classes, SysUtils, Math, TypInfo, uTheme,
uFfmpegCmd, uAppTypes,
uMediaProbe, uProject, uTransform, uTimelineCtrl,
uPanCropForm, uDepsForm, uMismatchForm, uProgressForm, uProjectInfoForm,
uRemuxForm;
var
Failed: Integer = 0;
procedure CheckProp(AClass: TClass; const AName: string);
begin
if GetPropInfo(AClass, AName) <> nil then
WriteLn(' ok ', AClass.ClassName, '.', AName)
else
begin
WriteLn(' ПЛОХО ', AClass.ClassName, '.', AName, ' — свойства нет');
Inc(Failed);
end;
end;
procedure CheckEnum(ATypeInfo: PTypeInfo; const AName: string);
begin
if GetEnumValue(ATypeInfo, AName) >= 0 then
WriteLn(' ok значение ', AName)
else
begin
WriteLn(' ПЛОХО значение ', AName, ' — такого нет');
Inc(Failed);
end;
end;
{ Создаёт окно и тут же убирает.
Смысл в самом создании: файл формы разбирается именно тогда. Элемент,
который есть в файле формы и которого нет в классе, или обработчик с
опечаткой в имени — всё это здесь и вскрывается, а иначе вскрылось бы у
человека при открытии окна.
Главное окно не проверяется: оно при создании читает настройки, строит
меню и заводит плеер — это уже не проверка формы, а запуск программы. }
procedure CheckForm(AClass: TFormClass);
var
F: TForm;
begin
try
F := AClass.Create(nil);
try
WriteLn(' ok ', AClass.ClassName, ' — форма загружена');
finally
F.Free;
end;
except
on E: Exception do
begin
WriteLn(' ПЛОХО ', AClass.ClassName, ': ', E.Message);
Inc(Failed);
end;
end;
end;
procedure CheckTrue(const AName: string; AValue: Boolean);
begin
if AValue then
WriteLn(' ok ', AName)
else
begin
WriteLn(' ПЛОХО ', AName);
Inc(Failed);
end;
end;
{ Прилипание курсора воспроизведения к границам клипов.
Проверяется числами, а не мышью: расчёт открыт наружу именно ради
этого. Мышью пришлось бы поднимать окно, а окно в проверках — это уже
не проверка расчёта, а проверка окружения. }
procedure CheckPlayheadSnap;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
begin
WriteLn;
WriteLn('Прилипание курсора к границам клипов');
WriteLn;
Info := Default(TMediaInfo);
Info.Valid := True;
Info.Kind := mkVideo;
Info.Duration := 600;
Info.HasVideo := True;
Info.VideoCodec := 'hevc';
Info.Width := 1920;
Info.Height := 1080;
Info.FpsNum := 30;
Info.FpsDen := 1;
Info.PixFmt := 'yuv420p';
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
{ Два куска встык: границы на 0, 1.5 и 3. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 1.5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 10, 1.5, 1.5);
Timeline.Project := Proj;
{ Сто точек в секунду: порог прилипания в восемь точек — это 0.08 с. }
Timeline.PixelsPerSecond := 100;
Timeline.PlayheadSnap := True;
CheckTrue('стык рядом — притянуло',
Abs(Timeline.SnapPlayhead(1.53) - 1.5) < 0.0001);
CheckTrue('с другой стороны — тоже',
Abs(Timeline.SnapPlayhead(1.47) - 1.5) < 0.0001);
CheckTrue('далеко от границ — не тронуло',
Abs(Timeline.SnapPlayhead(0.7) - 0.7) < 0.0001);
CheckTrue('начало монтажа притягивает',
Abs(Timeline.SnapPlayhead(0.05)) < 0.0001);
CheckTrue('конец последнего клипа притягивает',
Abs(Timeline.SnapPlayhead(2.96) - 3) < 0.0001);
{ На мелком масштабе порог в точках даёт больший запас по времени. }
Timeline.PixelsPerSecond := 10;
CheckTrue('масштаб мельче — притягивает дальше',
Abs(Timeline.SnapPlayhead(1.7) - 1.5) < 0.0001);
Timeline.PixelsPerSecond := 100;
Timeline.PlayheadSnap := False;
CheckTrue('выключено — не притягивает',
Abs(Timeline.SnapPlayhead(1.53) - 1.53) < 0.0001);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Рез не должен терять настройки клипа.
Половина клипа после реза — тот же клип, и цветовой ключ, кадрирование,
прозрачность, громкость и текст должны остаться при обеих половинах.
Однажды не остались: у хвоста пропадал ключ, клип переставал быть
наложением и закрывал собой всё, что под ним. }
procedure CheckSplitKeepsSettings;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
Head, Tail, Cl: TClip;
Key: TColorKey;
Tr: TMediaTransform;
I: Integer;
begin
WriteLn;
WriteLn('Рез сохраняет настройки клипа');
WriteLn;
Info := Default(TMediaInfo);
Info.Valid := True;
Info.Kind := mkVideo;
Info.Duration := 600;
Info.HasVideo := True;
Info.VideoCodec := 'hevc';
Info.Width := 1920;
Info.Height := 1080;
Info.FpsNum := 30;
Info.FpsDen := 1;
Info.PixFmt := 'yuv420p';
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Cl := Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0);
Key := DefaultColorKey;
Key.Enabled := True;
Key.Similarity := 22;
Cl.ColorKey := Key;
Cl.Opacity := 0.5;
Cl.Volume := 0.3;
Tr := Cl.Transform;
Tr.Zoom := 0.4;
Tr.OffsetX := 0.7;
Cl.Transform := Tr;
Cl.GroupId := 'g1';
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
Timeline.Playhead := 4;
Timeline.SplitAtPlayhead(False);
CheckTrue('клипов стало два', Proj.Tracks[0].Count = 2);
if Proj.Tracks[0].Count <> 2 then
Exit;
Head := nil;
Tail := nil;
for I := 0 to Proj.Tracks[0].Count - 1 do
if Proj.Tracks[0][I].TlStart < 0.001 then
Head := Proj.Tracks[0][I]
else
Tail := Proj.Tracks[0][I];
CheckTrue('обе половины нашлись', (Head <> nil) and (Tail <> nil));
if (Head = nil) or (Tail = nil) then
Exit;
CheckTrue('ключ остался у хвоста', Tail.ColorKey.Enabled);
CheckTrue('и с тем же цветом', Tail.ColorKey.Color = Key.Color);
CheckTrue('и с тем же допуском', Tail.ColorKey.Similarity = 22);
CheckTrue('прозрачность осталась', Abs(Tail.Opacity - 0.5) < 0.001);
CheckTrue('громкость осталась', Abs(Tail.Volume - 0.3) < 0.001);
CheckTrue('кадрирование осталось',
(Abs(Tail.Transform.Zoom - 0.4) < 0.001) and
(Abs(Tail.Transform.OffsetX - 0.7) < 0.001));
CheckTrue('ключ остался и у головы', Head.ColorKey.Enabled);
{ Связки разные, и обе не пустые: иначе удаление одной половины
уносило бы вторую. }
CheckTrue('связка у половин разная и не пустая',
(Head.GroupId <> Tail.GroupId) and (Head.GroupId <> '') and
(Tail.GroupId <> ''));
CheckTrue('появление у хвоста снято', Abs(Tail.FadeIn) < 0.001);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Схлопывание дыры без мыши.
Ctrl+Shift+R искал дыру только на дорожке под указателем мыши, а руки в
этот момент на клавиатуре. Со стороны выглядело как «горячая клавиша не
работает»: команда молча ничего не делала. }
procedure CheckRippleWithoutMouse;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
begin
WriteLn;
WriteLn('Схлопывание дыры с клавиатуры');
WriteLn;
Info := Default(TMediaInfo);
Info.Valid := True;
Info.Kind := mkVideo;
Info.Duration := 600;
Info.HasVideo := True;
Info.VideoCodec := 'hevc';
Info.Width := 1920;
Info.Height := 1080;
Info.FpsNum := 30;
Info.FpsDen := 1;
Info.PixFmt := 'yuv420p';
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Дыра с 5 по 12 секунду. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 20, 5, 12);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
Timeline.ActiveTrack := 0;
Timeline.Playhead := 8;
{ Мышь не над дорожками: так и бывает, когда жмут сочетание клавиш. }
CheckTrue('дыра схлопнута без мыши', Timeline.RippleCloseGap);
CheckTrue('второй клип придвинут к первому',
Abs(Proj.Tracks[0][1].TlStart - 5) < 0.001);
{ Второй раз схлопывать нечего — и об этом надо сказать, а не молчать. }
CheckTrue('повторный вызов честно отвечает «нечего»',
not Timeline.RippleCloseGap);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Копирование клипа: модель должна переносить всё, кроме места.
Само сочетание клавиш проверяется руками, а вот перенос свойств —
числами: именно из-за него копия отбивки или текстового блока была бы
бесполезной. }
procedure CheckClipCopy;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Src, Dst: TClip;
Key: TColorKey;
begin
WriteLn;
WriteLn('Копия клипа');
WriteLn;
Info := Default(TMediaInfo);
Info.Valid := True;
Info.Kind := mkVideo;
Info.Duration := 600;
Info.HasVideo := True;
Info.VideoCodec := 'hevc';
Info.Width := 1920;
Info.Height := 1080;
Info.FpsNum := 30;
Info.FpsDen := 1;
Info.PixFmt := 'yuv420p';
Proj := TProject.Create;
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Src := Proj.AddClip(Proj.Tracks[0], Media, 30, 7, 5);
Src.Kind := ckText;
Src.Text := 'Отбивка';
Src.Volume := 0.4;
Src.Opacity := 0.6;
Key := DefaultColorKey;
Key.Enabled := True;
Src.ColorKey := Key;
Src.FadeIn := 1.25;
Src.EdgeOut := edPrecise;
Src.GroupId := 'g7';
Dst := TClip.Create;
try
Dst.CopyAllFrom(Src);
CheckTrue('вид клипа перенесён', Dst.Kind = ckText);
CheckTrue('текст перенесён', Dst.Text = 'Отбивка');
CheckTrue('файл и кусок исходника перенесены',
(Dst.MediaId = Src.MediaId) and (Abs(Dst.SrcIn - 30) < 0.001) and
(Abs(Dst.Duration - 7) < 0.001));
CheckTrue('края перенесены', Dst.EdgeOut = edPrecise);
CheckTrue('громкость и прозрачность перенесены',
(Abs(Dst.Volume - 0.4) < 0.001) and (Abs(Dst.Opacity - 0.6) < 0.001));
CheckTrue('ключ перенесён', Dst.ColorKey.Enabled);
CheckTrue('затухание перенесено', Abs(Dst.FadeIn - 1.25) < 0.001);
{ Место и связка — дело того, кто вставляет. }
CheckTrue('место не перенесено', Abs(Dst.TlStart) < 0.001);
CheckTrue('связка не перенесена', Dst.GroupId = '');
finally
Dst.Free;
end;
finally
Proj.Free;
end;
end;
{ Общая заготовка: проект с одним файлом и заданной сеткой кадров. }
function TestInfo: TMediaInfo;
begin
Result := Default(TMediaInfo);
Result.Valid := True;
Result.Kind := mkVideo;
Result.Duration := 600;
Result.HasVideo := True;
Result.VideoCodec := 'hevc';
Result.Width := 1920;
Result.Height := 1080;
Result.FpsNum := 30;
Result.FpsDen := 1;
Result.PixFmt := 'yuv420p';
end;
{ Выделение областью.
Проверяется расчётом, а не мышью: сама протяжка проверена на невидимом
экране, а вот что попадает в рамку — числами, иначе первая же правка
захвата пройдёт незамеченной. }
procedure CheckRubberBand;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
begin
WriteLn;
WriteLn('Выделение областью');
WriteLn;
Info := TestInfo;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Proj.AddTrack('V2');
Proj.AddTrack('V3');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ V1: клип 0..5 и клип 20..25. V2: длинный клип 0..30.
V3: клип 0..5 — дорожка вне рамки. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 100, 5, 20);
Proj.AddClip(Proj.Tracks[1], Media, 0, 30, 0);
Proj.AddClip(Proj.Tracks[2], Media, 0, 5, 0);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
{ Рамка по дорожкам 0 и 1, время 2..10. }
Timeline.SelectInRange(2, 10, 0, 1, False);
CheckTrue('задетый клип выделен', Proj.Tracks[0][0].Selected);
CheckTrue('клип за рамкой не выделен', not Proj.Tracks[0][1].Selected);
CheckTrue('длинный клип задет и выделен', Proj.Tracks[1][0].Selected);
CheckTrue('чужая дорожка не тронута', not Proj.Tracks[2][0].Selected);
{ Рамку тянут и справа налево — это та же рамка. }
Timeline.SelectInRange(25, 18, 0, 0, False);
CheckTrue('обратная протяжка выделила второй клип',
Proj.Tracks[0][1].Selected);
CheckTrue('прежнее выделение снято', not Proj.Tracks[0][0].Selected);
{ С Ctrl прежнее выделение остаётся. }
Timeline.SelectInRange(2, 4, 0, 0, True);
CheckTrue('добавление сохранило прежнее', Proj.Tracks[0][1].Selected);
CheckTrue('добавление выделило новое', Proj.Tracks[0][0].Selected);
{ Рамка, не задевшая ничего, просто снимает выделение. }
Timeline.SelectInRange(6, 8, 0, 0, False);
CheckTrue('пустая рамка ничего не выделила',
Proj.SelectedCount = 0);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Рез по курсору режет все дорожки.
Раньше резалась только дорожка под указателем мыши, и стоило указателю
оказаться над пустым местом, как клавиша S молча не делала ничего. }
procedure CheckSplitAllTracks;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
begin
WriteLn;
WriteLn('Рез по курсору на всех дорожках');
WriteLn;
Info := TestInfo;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Proj.AddTrack('V2');
Proj.AddTrack('A1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Клипы 0..10 на первой и третьей дорожках, на второй — 20..30:
под курсором её нет, и резать там нечего. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0);
Proj.AddClip(Proj.Tracks[1], Media, 0, 10, 20);
Proj.AddClip(Proj.Tracks[2], Media, 0, 10, 0);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
Timeline.ActiveTrack := 1;
Timeline.Playhead := 4;
CheckTrue('разрезаны обе задетые дорожки',
Timeline.SplitAtPlayhead(False) = 2);
CheckTrue('на первой дорожке два клипа', Proj.Tracks[0].Count = 2);
CheckTrue('на звуковой дорожке два клипа', Proj.Tracks[2].Count = 2);
CheckTrue('нетронутая дорожка осталась с одним клипом',
Proj.Tracks[1].Count = 1);
{ Курсор ровно на стыке — резать нечего, и клипов нулевой длины
появиться не должно. }
CheckTrue('на стыке рез отвечает нулём',
Timeline.SplitAtPlayhead(False) = 0);
CheckTrue('лишних клипов не появилось',
(Proj.Tracks[0].Count = 2) and (Proj.Tracks[2].Count = 2));
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Схлопывание дыры не требует попадать в тайминг.
Курсор может стоять не точно на краю дыры: во время воспроизведения он
останавливается там, где успел, а после перезагрузки предпросмотра —
где оказался плеер. Раньше дыра при этом не находилась. }
procedure CheckGapTolerance;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
begin
WriteLn;
WriteLn('Схлопывание дыры с допуском');
WriteLn;
Info := TestInfo;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Proj.AddTrack('A1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Дыра на картинке с 5 по 12. У звука дыры нет вовсе. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 20, 5, 12);
Proj.AddClip(Proj.Tracks[1], Media, 0, 17, 0);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
{ Указатель и выбранная дорожка — звуковая, дыры на ней нет. }
Timeline.ActiveTrack := 1;
{ Курсор не в дыре, а на четыре сотых раньше её начала. }
Timeline.Playhead := 4.96;
CheckTrue('дыра найдена, хотя курсор чуть раньше края',
Timeline.RippleCloseGap);
CheckTrue('названа дорожка, где схлопнули',
Timeline.LastGapTrack = 'V1');
CheckTrue('клип придвинут вплотную',
Abs(Proj.Tracks[0][1].TlStart - 5) < 0.001);
{ Курсор далеко от дыры — ничего не двигаем. }
Proj.Tracks[0][1].TlStart := 12;
Timeline.Playhead := 2;
CheckTrue('далеко от дыры — не схлопываем',
not Timeline.RippleCloseGap);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Починка проекта: клипы на кадровую сетку.
Между кадрами времени нет, и монтаж не должен хранить доли кадра:
картинка выйдет целым числом кадров, звук наберётся до отсчёта, и
округление разведёт их. Правка двигает клип не больше чем на полкадра,
но сама сетка обязана получиться ровной. }
procedure CheckFrameGridRepair;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Step: Double;
I: Integer;
Clip: TClip;
OnGrid: Boolean;
begin
WriteLn;
WriteLn('Починка: клипы на кадровую сетку');
WriteLn;
Info := TestInfo;
{ 59.94 к/с — та самая сетка, на которой доли кадра особенно заметны. }
Info.FpsNum := 60000;
Info.FpsDen := 1001;
Proj := TProject.Create;
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
Step := Info.FpsDen / Info.FpsNum;
{ Времена как в настоящем проекте: ни одно не попадает на кадр. }
Proj.AddClip(Proj.Tracks[0], Media, 48.558521, 2.457599, 0);
Proj.AddClip(Proj.Tracks[0], Media, 56.054198, 1.469934, 2.457599);
{ И клип короче кадра: его нельзя схлопнуть в ничто. }
Proj.AddClip(Proj.Tracks[0], Media, 62.710196, 0.004, 3.927533);
CheckTrue('все три клипа мимо сетки', Proj.OffGridClipCount = 3);
CheckTrue('починка подвинула три клипа', Proj.SnapClipsToFrameGrid = 3);
CheckTrue('мимо сетки не осталось', Proj.OffGridClipCount = 0);
OnGrid := True;
for I := 0 to Proj.Tracks[0].Count - 1 do
begin
Clip := Proj.Tracks[0][I];
if Abs(Clip.TlStart / Step - Round(Clip.TlStart / Step)) > 0.001 then
OnGrid := False;
if Abs(Clip.Duration / Step - Round(Clip.Duration / Step)) > 0.001 then
OnGrid := False;
if Abs(Clip.SrcIn / Step - Round(Clip.SrcIn / Step)) > 0.001 then
OnGrid := False;
end;
CheckTrue('начала, длины и точки входа — целые кадры', OnGrid);
CheckTrue('короткий клип остался длиной в кадр',
Abs(Proj.Tracks[0][2].Duration - Step) < 0.0001);
CheckTrue('клипы не разъехались больше чем на полкадра',
Abs(Proj.Tracks[0][0].TlStart - 0) < Step);
CheckTrue('повторная починка ничего не двигает',
Proj.SnapClipsToFrameGrid = 0);
finally
Proj.Free;
end;
end;
{ Рез и курсор: где режет S и куда после этого встаёт курсор.
Раньше курсор оставался там, где был, а рез мог попасть на долю кадра.
Теперь рез кладётся на кадровую сетку, а курсор встаёт ровно на место
реза — с ним и работают дальше. }
{ Раздвижка монтажа под вставку.
Клип из списка файлов встаёт туда, где стоит курсор, а не в конец
дорожки. Место под ним освобождается: клип, накрывающий точку вставки,
режется, и всё от этой точки правее едет вправо на длину нового — на
всех дорожках сразу, иначе звук отстанет от картинки. }
procedure CheckMakeRoom;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
Moved, I: Integer;
Gaps, Overlaps: Integer;
Step, At, Shift: Double;
Track: TTrack;
begin
WriteLn;
WriteLn('Раздвижка монтажа под вставку');
WriteLn;
Info := TestInfo;
Info.FpsNum := 60000;
Info.FpsDen := 1001;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Proj.AddTrackOfKind('A1', tkAudio);
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Три клипа встык на картинке и столько же на звуке: 0..10, 10..20,
20..30. }
for I := 0 to 2 do
begin
Proj.AddClip(Proj.Tracks[0], Media, 0, 10, I * 10);
Proj.AddClip(Proj.Tracks[1], Media, 0, 10, I * 10);
end;
Timeline.Project := Proj;
{ Вставляем пять секунд посреди второго клипа.
Ожидаемое считается по той же кадровой сетке, а не круглыми
числами: при 60000/1001 ни 15, ни 5 на кадр не попадают, и точка
реза с величиной сдвига садятся на ближайшие кадры. }
Step := Info.FpsDen / Info.FpsNum;
At := Round(15 / Step) * Step;
Shift := Round(5 / Step) * Step;
Moved := Timeline.MakeRoomAt(15, 5);
CheckTrue('что-то отодвинуто: ' + IntToStr(Moved), Moved >= 4);
CheckTrue('второй клип разошёлся надвое: клипов стало ' +
IntToStr(Proj.Tracks[0].Count), Proj.Tracks[0].Count = 4);
CheckTrue('звук разошёлся так же', Proj.Tracks[1].Count = 4);
{ Голова второго клипа осталась на месте, хвост уехал ровно на пять. }
CheckTrue('голова на месте: ' + SecondsToStr(Proj.Tracks[0][1].TlStart),
Abs(Proj.Tracks[0][1].TlStart - 10) < 0.001);
CheckTrue('хвост отъехал на длину вставки: ' +
SecondsToStr(Proj.Tracks[0][2].TlStart),
Abs(Proj.Tracks[0][2].TlStart - (At + Shift)) < 0.001);
CheckTrue('третий клип отъехал на столько же: ' +
SecondsToStr(Proj.Tracks[0][3].TlStart),
Abs(Proj.Tracks[0][3].TlStart - (20 + Shift)) < 0.001);
CheckTrue('звук уехал вместе с картинкой',
Abs(Proj.Tracks[1][2].TlStart - (At + Shift)) < 0.001);
CheckTrue('освобождено ровно столько, сколько просили: ' +
SecondsToStr(Proj.Tracks[0][2].TlStart - Proj.Tracks[0][1].TlEnd),
Abs((Proj.Tracks[0][2].TlStart - Proj.Tracks[0][1].TlEnd) - Shift)
< 0.001);
{ В освобождённом месте никого нет, и больше нигде не появилось ни
дыр, ни наездов. }
CheckTrue('место освобождено', Proj.Tracks[0].ClipAt(At + 1) = nil);
Gaps := 0;
Overlaps := 0;
for I := 0 to Proj.TrackCount - 1 do
begin
Track := Proj.Tracks[I];
for Moved := 0 to Track.Count - 2 do
if Track[Moved].TlEnd > Track[Moved + 1].TlStart + 0.001 then
Inc(Overlaps)
else if (Track[Moved].TlEnd < Track[Moved + 1].TlStart - 0.001) and
(Abs(Track[Moved].TlEnd - At) > 0.001) then
Inc(Gaps);
end;
CheckTrue('наездов не появилось', Overlaps = 0);
CheckTrue('лишних дыр не появилось', Gaps = 0);
{ Вставка в свободное место за концом монтажа ничего не двигает. }
Moved := Timeline.MakeRoomAt(100, 5);
CheckTrue('за концом монтажа двигать нечего', Moved = 0);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ В месте наезда под указателем несколько клипов.
Наезд двух клипов на одной дорожке — заказ на переход, то есть обычное
дело. Пока отбор возвращал только первый по списку, нижний клип нельзя
было ни выделить, ни потащить. }
procedure CheckClipsAt;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
A, B: TClip;
Got: TClipArray;
begin
WriteLn;
WriteLn('Клипы под одной точкой');
WriteLn;
Info := TestInfo;
Proj := TProject.Create;
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Второй наехал на первый на две секунды: 0..10 и 8..18. }
A := Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0);
B := Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 8);
Got := Proj.Tracks[0].ClipsAt(9);
CheckTrue('в наезде под точкой двое: ' + IntToStr(Length(Got)),
Length(Got) = 2);
if Length(Got) = 2 then
begin
CheckTrue('первым идёт верхний по списку', Got[0] = A);
CheckTrue('вторым — тот, что под ним', Got[1] = B);
end;
Got := Proj.Tracks[0].ClipsAt(3);
CheckTrue('вне наезда клип один: ' + IntToStr(Length(Got)),
(Length(Got) = 1) and (Got[0] = A));
Got := Proj.Tracks[0].ClipsAt(100);
CheckTrue('за концом монтажа никого', Length(Got) = 0);
{ Прежний отбор остаётся прежним: он берёт верхний. }
CheckTrue('ClipAt по-прежнему даёт верхний',
Proj.Tracks[0].ClipAt(9) = A);
finally
Proj.Free;
end;
end;
{ Клип притягивается к границе и хвостом, а не только головой.
Подводят кусок к началу соседа слева: голова встаёт в свободное место,
а хвост при этом накрывает соседа. Наезд на одной дорожке — это заказ
на переход, то есть минуты сборки из-за промаха на полпикселя. }
procedure CheckSnapTail;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
Mover: TClip;
Got: Double;
begin
WriteLn;
WriteLn('Прилипание хвостом');
WriteLn;
Info := TestInfo;
Info.FpsNum := 60000;
Info.FpsDen := 1001;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ Сосед занимает 20..30, двигаемый длиной 4 стоит пока в сторонке. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 20);
Mover := Proj.AddClip(Proj.Tracks[0], Media, 0, 4, 50);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 10; { допуск прилипания — 1.2 с }
{ Голова метит в 15.7, хвост при этом пришёлся бы на 19.7 — почти
встык с соседом. Правильный ответ: 16, тогда хвост ровно на 20. }
Got := Timeline.SnapTime(15.7, Mover, Mover.Duration);
CheckTrue('хвост сел на начало соседа: ' + SecondsToStr(Got),
Abs(Got - 16) < 0.001);
{ Голова у границы по-прежнему липнет головой: там ближе она. }
Got := Timeline.SnapTime(19.8, Mover, Mover.Duration);
CheckTrue('голова села на начало соседа: ' + SecondsToStr(Got),
Abs(Got - 20) < 0.001);
{ Без длины поведение прежнее: хвост не рассматривается. }
Got := Timeline.SnapTime(15.7, Mover);
CheckTrue('без длины притяжения хвостом нет: ' + SecondsToStr(Got),
Abs(Got - 15.7) < 0.001);
{ Хвост липнет и к концу соседа: клип встаёт вплотную справа. }
Got := Timeline.SnapTime(25.8, Mover, Mover.Duration);
CheckTrue('хвост сел на конец соседа: ' + SecondsToStr(Got),
Abs(Got - 26) < 0.001);
finally
Timeline.Free;
Proj.Free;
end;
end;
procedure CheckSplitAndPlayhead;
var
Proj: TProject;
Info: TMediaInfo;
Media: TMediaItem;
Timeline: TTimelineControl;
Step: Double;
I, N: Integer;
begin
WriteLn;
WriteLn('Рез, промежуток и курсор');
WriteLn;
Info := TestInfo;
Info.FpsNum := 60000;
Info.FpsDen := 1001;
Step := Info.FpsDen / Info.FpsNum;
Proj := TProject.Create;
Timeline := TTimelineControl.Create(nil);
try
Proj.Clear;
Proj.AddTrack('V1');
Proj.AddTrack('A1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
{ По два клипа на каждой дорожке, встык: 0..10 и 10..20. }
Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0);
Proj.AddClip(Proj.Tracks[0], Media, 20, 10, 10);
Proj.AddClip(Proj.Tracks[1], Media, 0, 10, 0);
Proj.AddClip(Proj.Tracks[1], Media, 20, 10, 10);
Timeline.Project := Proj;
Timeline.PixelsPerSecond := 100;
{ Рез по курсору: место кладётся на кадр, курсор встаёт на него. }
Timeline.Playhead := 3.3177;
CheckTrue('разрезаны обе дорожки', Timeline.SplitAtPlayhead(False) = 2);
CheckTrue('курсор встал на место реза',
Abs(Timeline.Playhead - Round(3.3177 / Step) * Step) < 0.0001);
CheckTrue('курсор на кадровой сетке',
Abs(Timeline.Playhead / Step - Round(Timeline.Playhead / Step)) < 0.001);
N := 0;
for I := 0 to Proj.Tracks[0].Count - 1 do
if Abs(Proj.Tracks[0][I].TlStart - Timeline.Playhead) < 0.0001 then
Inc(N);
CheckTrue('рез пришёлся ровно туда, где курсор', N = 1);
{ Промежуток по времени: рез по обоим краям, курсор — на начало. }
Timeline.SelectionMode := smRange;
Timeline.SetSelectionRange(12.13, 16.77);
CheckTrue('промежуток отмечен', Timeline.HasSelectionRange);
CheckTrue('разрезано по два клипа на дорожке',
Timeline.SplitAtPlayhead(False) = 4);
CheckTrue('курсор — на начале промежутка',
Abs(Timeline.Playhead - Timeline.RangeFrom) < 0.0001);
N := 0;
for I := 0 to Proj.Tracks[1].Count - 1 do
if (Abs(Proj.Tracks[1][I].TlStart - Timeline.RangeFrom) < 0.0001) or
(Abs(Proj.Tracks[1][I].TlStart - Timeline.RangeTo) < 0.0001) then
Inc(N);
CheckTrue('на звуковой дорожке резы по обоим краям', N = 2);
{ После реза выделена середина — то, что между краями: следующим
действием её обычно удаляют. }
N := 0;
for I := 0 to Proj.Tracks[0].Count - 1 do
if Proj.Tracks[0][I].Selected then
begin
Inc(N);
CheckTrue('выделенное лежит внутри промежутка',
(Proj.Tracks[0][I].TlStart >= Timeline.RangeFrom - 0.0001) and
(Proj.Tracks[0][I].TlEnd <= Timeline.RangeTo + 0.0001));
end;
CheckTrue('на дорожке картинки выделена одна середина', N = 1);
{ Смена режима снимает промежуток: резать по невидимой метке нельзя. }
Timeline.SelectionMode := smClips;
CheckTrue('смена режима сняла промежуток',
not Timeline.HasSelectionRange);
{ Удаление со схлопыванием: курсор встаёт на место стыка. }
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
Proj.RippleEnabled := True;
Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 10, 5, 5);
Proj.AddClip(Proj.Tracks[0], Media, 20, 5, 10);
Timeline.Playhead := 0;
Proj.Tracks[0][1].Selected := True;
Timeline.DeleteSelected;
CheckTrue('после удаления клипов стало два', Proj.Tracks[0].Count = 2);
CheckTrue('курсор — на месте вырезанного куска',
Abs(Timeline.Playhead - 5) < 0.0001);
CheckTrue('хвост придвинут к стыку',
Abs(Proj.Tracks[0][1].TlStart - 5) < 0.0001);
{ Схлопывание дыры с клавиатуры: курсор тоже на стык. }
Proj.Clear;
Proj.AddTrack('V1');
Media := Proj.AddMedia('/несуществующий/видео.mp4', Info);
Proj.Master := Info;
Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 0);
Proj.AddClip(Proj.Tracks[0], Media, 20, 5, 12);
Timeline.ActiveTrack := 0;
Timeline.Playhead := 8;
CheckTrue('дыра схлопнута', Timeline.RippleCloseGap);
CheckTrue('курсор — на стыке', Abs(Timeline.Playhead - 5) < 0.0001);
finally
Timeline.Free;
Proj.Free;
end;
end;
{ Кнопка нижней панели и быстрые щелчки.
Второй щелчок подряд оконная библиотека отдаёт не как щелчок, а как
двойной — и обработчик кнопки его не видел. Человек нажимал кнопку
дважды, а срабатывало один раз.
Проверяется двумя способами: у кнопки нет csDoubleClicks (тогда
двойных щелчков к ней вообще не приходит), и даже если двойной
придёт, он считается за щелчок. }
type
TButtonProbe = class(TThemedButton)
public
procedure Twice;
end;
procedure TButtonProbe.Twice;
begin
DblClick;
end;
var
ClickCount: Integer = 0;
type
TClickCounter = class
procedure Clicked(Sender: TObject);
end;
procedure TClickCounter.Clicked(Sender: TObject);
begin
Inc(ClickCount);
end;
{ Рамка источника и фильтр сборки должны говорить об одном.
Одна и та же настройка записана двумя способами: сборка растягивает
кадр и вырезает из него кусок, а окно кадрирования и предпросмотр
говорят, какая часть исходника видна. Разойдутся — окно начнёт обещать
не то, что покажет плеер, а плеер не то, что даст сборка. }
procedure CheckSourceRect;
var
T: TMediaTransform;
R: TRect;
Chain: string;
begin
WriteLn;
WriteLn('Рамка источника и фильтр сборки');
WriteLn;
T := DefaultTransform;
T.Zoom := 2.77;
CheckTrue('увеличение описывается рамкой',
TransformSourceRect(T, 2688, 1512, 2688, 1512, R));
{ Растянули в 2.77 раза — значит видна 1/2.77 часть кадра, посередине. }
CheckTrue('ширина рамки: ' + IntToStr(R.Right - R.Left),
Abs((R.Right - R.Left) - Round(2688 / 2.77)) <= 2);
CheckTrue('высота рамки: ' + IntToStr(R.Bottom - R.Top),
Abs((R.Bottom - R.Top) - Round(1512 / 2.77)) <= 2);
CheckTrue('рамка посередине по горизонтали',
Abs((R.Left + R.Right) - 2688) <= 3);
CheckTrue('рамка посередине по вертикали',
Abs((R.Top + R.Bottom) - 1512) <= 3);
{ Тот же расчёт с другой стороны: сборка растягивает до 7446x4188 и
вырезает 2688x1512 с отступом 2379:1338. Делим отступ на масштаб —
обязано выйти начало рамки. }
Chain := TransformFilter(T, 2688, 1512, 2688, 1512);
CheckTrue('сборка растягивает и вырезает: ' + Chain,
(Pos('scale=7446:4188', Chain) > 0) and
(Pos('crop=2688:1512:2379:1338', Chain) > 0));
CheckTrue('начало рамки совпадает с отступом обрезки',
Abs(R.Left - Round(2379 / 2.77)) <= 2);
{ Растяжение рамкой не описывается: там кадр жмётся неравномерно. }
T := DefaultTransform;
T.Fit := fmStretch;
CheckTrue('растяжение рамкой не описывается',
not TransformSourceRect(T, 2688, 1512, 1920, 1080, R));
{ Отражение обрезкой на выводе не показать — свойства для него нет. }
T := DefaultTransform;
T.FlipH := True;
CheckTrue('отражение обрезкой на выводе не показывается',
not TransformFitsOutputCrop(T));
T := DefaultTransform;
T.Rotation := 90;
CheckTrue('поворот показать можно: у него своё свойство',
TransformFitsOutputCrop(T));
end;
{ Сведение слоёв просит распаковку у видеокарты.
На длинном затухании это разница между тремя минутами и одной, а
ключ входной: ffmpeg принимает его только перед тем входом, к которому
он относится. Забыть его легко и незаметно — команда останется рабочей,
просто медленной. }
{ Разбор строк о ходе работы ffmpeg.
Ход приходит блоками, и последняя строка блока — «progress=continue».
Места в ней нет: она сообщает только, что работа продолжается. Разбор
обязан оставить переданное число как было, а вызывающий — передавать
туда уже известное место, а не ноль. Иначе каждый блок заканчивается
обнулением доли, и показатель стоит на месте, дёргаясь вверх лишь
тогда, когда опрос попадёт между строкой со временем и этой. }
procedure CheckProgressParsing;
var
Seconds: Double;
AtEnd: Boolean;
begin
WriteLn;
WriteLn('Разбор хода работы ffmpeg');
WriteLn;
Seconds := 0;
AtEnd := False;
CheckTrue('время узнаётся', ParseProgressLine('out_time_us=2500000',
Seconds, AtEnd));
CheckTrue('и разбирается верно: ' + FloatToStrF(Seconds, ffFixed, 8, 3),
Abs(Seconds - 2.5) < 0.001);
CheckTrue('«продолжается» — тоже знакомая строка',
ParseProgressLine('progress=continue', Seconds, AtEnd));
CheckTrue('и она не трогает время: ' + FloatToStrF(Seconds, ffFixed, 8, 3),
Abs(Seconds - 2.5) < 0.001);
CheckTrue('и не объявляет конец', not AtEnd);
CheckTrue('конец узнаётся', ParseProgressLine('progress=end',
Seconds, AtEnd) and AtEnd);
CheckTrue('время и тут осталось прежним',
Abs(Seconds - 2.5) < 0.001);
CheckTrue('незнакомая строка не узнаётся',
not ParseProgressLine('bitrate= 12.3kbits/s', Seconds, AtEnd));
end;
procedure CheckLayerHwDecode;
var
Layers: array[0..0] of TSegmentLayer;
A: TArgs;
I, Hw, Input: Integer;
begin
WriteLn;
WriteLn('Распаковка слоёв видеокартой');
WriteLn;
Layers[0] := Default(TSegmentLayer);
Layers[0].FilePath := '/несуществующий/видео.mp4';
Layers[0].SrcStart := 10;
Layers[0].FadeFrom := 1;
Layers[0].FadeTo := 0;
A := ArgsRenderLayers(Layers, '/выход.mkv', 70, 2688, 1512, 60000, 1001,
'yuv420p', 'hevc', False, 0, '', NotPiped, False);
Hw := -1;
for I := 0 to High(A) do
if A[I] = '-hwaccel' then
Hw := I;
CheckTrue('без просьбы ключа нет', Hw < 0);
A := ArgsRenderLayers(Layers, '/выход.mkv', 70, 2688, 1512, 60000, 1001,
'yuv420p', 'hevc', False, 0, '', NotPiped, True);
Hw := -1;
Input := -1;
for I := 0 to High(A) do
begin
if A[I] = '-hwaccel' then
Hw := I;
if (A[I] = '-i') and (Input < 0) then
Input := I;
end;
{ Просьба выполняется только там, где кодировать будет та же карта. На
машине без неё проверять нечего, и это не поломка. }
if Pos('nvenc', PreferredEncoder('hevc')) = 0 then
WriteLn(' -- видеокарты для кодирования нет, проверять нечего')
else
begin
CheckTrue('по просьбе ключ появляется', Hw >= 0);
CheckTrue('и стоит перед входом, а не после', (Hw >= 0) and (Hw < Input));
end;
end;
procedure CheckButtonClicks;
var
Btn: TButtonProbe;
Counter: TClickCounter;
begin
WriteLn;
WriteLn('Кнопки нижней панели');
WriteLn;
Counter := TClickCounter.Create;
Btn := TButtonProbe.Create(nil);
try
Btn.OnClick := @Counter.Clicked;
CheckTrue('двойные щелчки кнопке не приходят',
not (csDoubleClicks in Btn.ControlStyle));
ClickCount := 0;
Btn.Twice;
CheckTrue('двойной щелчок считается за щелчок', ClickCount = 1);
finally
Btn.Free;
Counter.Free;
end;
end;
begin
WriteLn('Свойства из файлов форм');
WriteLn;
CheckProp(TThemedButton, 'Icon');
CheckProp(TThemedButton, 'Down');
CheckProp(TThemedButton, 'Arrow');
CheckProp(TThemedButton, 'Caption');
CheckProp(TThemedButton, 'ShowHint');
CheckEnum(TypeInfo(TThemedIcon), 'tiSnap');
CheckEnum(TypeInfo(TThemedIcon), 'tiRipple');
CheckEnum(TypeInfo(TThemedIcon), 'tiLog');
CheckEnum(TypeInfo(TThemedIcon), 'tiNone');
WriteLn;
WriteLn('Загрузка файлов форм');
WriteLn;
Application.Initialize;
CheckForm(TPanCropForm);
CheckForm(TDepsForm);
CheckForm(TMismatchForm);
CheckForm(TProgressForm);
CheckForm(TProjectInfoForm);
CheckForm(TRemuxForm);
CheckPlayheadSnap;
CheckSplitKeepsSettings;
CheckRippleWithoutMouse;
CheckClipCopy;
CheckRubberBand;
CheckFrameGridRepair;
CheckSplitAndPlayhead;
CheckMakeRoom;
CheckClipsAt;
CheckSnapTail;
CheckSplitAllTracks;
CheckGapTolerance;
CheckSourceRect;
CheckProgressParsing;
CheckLayerHwDecode;
CheckButtonClicks;
WriteLn;
if Failed = 0 then
WriteLn('ВЕРДИКТ: все проверки пройдены')
else
begin
WriteLn('ВЕРДИКТ: не пройдено проверок: ', Failed);
Halt(1);
end;
end.
Reference in a new issue View git blame Copy permalink