4aiman/nlve
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Курсор прилипает к границам клипов

Browse source 
Курсор воспроизведения по щелчку вставал ровно туда, куда попала мышь.
В стык двух кусков так не попасть: на общем плане одна точка экрана —
это секунды материала, а ставят курсор чаще всего именно на стык.

Теперь он притягивается к границам клипов на любой дорожке и к началу
монтажа. Работает и при щелчке по клипу, и по линейке, и по пустому
месту, и при протяжке. Shift меняет решение на противоположное — как у
прилипания клипов.

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

Расчёт открыт наружу и проверяется числами: семь проверок в lfmcheck,
от «стык рядом — притянуло» до «выключено — не притягивает».
This commit is contained in:
4aiman 2026-08-31 00:32:44 +03:00
commit 4c422ef57d
12 changed files with 274 additions and 22 deletions
Download patch file Download diff file Expand all files Collapse all files

85
tests/lfmcheck/lfmcheck.lpr
View file

@ -14,7 +14,8 @@ program lfmcheck;
uses
{ Interfaces нужен, чтобы связалась вся LCL и заработала загрузка
файлов форм. }
Interfaces, Forms, Classes, SysUtils, TypInfo, uTheme,
Interfaces, Forms, Classes, SysUtils, Math, TypInfo, uTheme,
uMediaProbe, uProject, uTimelineCtrl,
uPanCropForm, uDepsForm, uMismatchForm, uProgressForm, uProjectInfoForm,
uRemuxForm;
@ -72,6 +73,86 @@ begin
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;
begin
WriteLn('Свойства из файлов форм');
WriteLn;
@ -98,6 +179,8 @@ begin
CheckForm(TProjectInfoForm);
CheckForm(TRemuxForm);
CheckPlayheadSnap;
WriteLn;
if Failed = 0 then
WriteLn('ВЕРДИКТ: все проверки пройдены')