4aiman
36499edd50
До этого места не дотянуться ни отрисовкой пунктов (это не пункт), ни подложкой через SetMenuInfo: под Wine пункты выходят тёмными, а полоса остаётся светлой. Полоса живёт в неклиентской части окна, поэтому закрашиваем прямо туда: правый край последнего названия берётся из GetMenuItemRect, границы полосы из GetMenuBarInfo, всё что правее — заливается нашей кистью. Закраска подновляется на перерисовке рамки окна и по таймеру: система трогает полосу и по другим поводам, а рисуем мы поверх неё. Прямоугольник и цвет те же, поэтому подновление не видно. Заодно закраска сама отчитывается в журнал: какие прямоугольники выдала система и куда мы рисовали. Полоса упорно остаётся светлой, а гадать по снимкам экрана дальше некуда.
2771 lines
99 KiB
ObjectPascal
2771 lines
99 KiB
ObjectPascal
{
|
||
uMainForm — главное окно редактора.
|
||
|
||
Собирает вместе всё остальное: список файлов проекта, монтажный стол,
|
||
предпросмотр через mpv и сборку через ffmpeg.
|
||
|
||
Как связаны монтаж и предпросмотр. После каждой правки монтаж
|
||
раскладывается в плоский список кусков, из него собирается строка EDL,
|
||
и она отдаётся плееру. Пересборка отложена на несколько десятых секунды:
|
||
иначе при перетаскивании клипа плеер дёргался бы на каждое движение мыши.
|
||
|
||
Время на монтаже и время в предпросмотре совпадают в точности, потому
|
||
что список кусков покрывает отрезок от нуля до конца монтажа без
|
||
пропусков — дыры превращаются в чёрные вставки. Благодаря этому курсор
|
||
можно двигать в обе стороны: щелчок по линейке перематывает плеер, а
|
||
воспроизведение двигает курсор.
|
||
}
|
||
unit uMainForm;
|
||
|
||
{$mode objfpc}{$H+}
|
||
|
||
interface
|
||
|
||
uses
|
||
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls,
|
||
ComCtrls, Menus, Buttons, LCLType, LMessages,
|
||
uAppTypes, uEdl, uMpvLib, uMpvPlayer, uProject, uMediaProbe, uTimelineCtrl,
|
||
uFlatten, uGenerate, uExport, uProgressForm, uRemuxForm, uMismatchForm,
|
||
uFfmpegJob, uSettings, uThumbs, uTransform, uPanCropForm,
|
||
uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm, uWaveform;
|
||
|
||
const
|
||
{ Номера системных сообщений о перерисовке рамки окна. Берём числами, а
|
||
не из модуля Windows: тот переопределяет TRect и Point, и обычные
|
||
вызовы LCL начинают разбираться как системные. }
|
||
MsgNcPaint = $0085;
|
||
MsgNcActivate = $0086;
|
||
|
||
type
|
||
|
||
{ TMainForm }
|
||
|
||
TMainForm = class(TForm)
|
||
|
||
btnSnap: TThemedButton;
|
||
btnRipple: TThemedButton;
|
||
btnRippleMenu: TThemedButton;
|
||
lblPoolInfo: TLabel;
|
||
lblStatus: TLabel;
|
||
lblTime: TLabel;
|
||
|
||
lstPool: TListBox;
|
||
memoLog: TLogView;
|
||
OpenMediaDialog: TOpenDialog;
|
||
OpenProjectDialog: TOpenDialog;
|
||
pnlBottom: TPanel;
|
||
pnlLeft: TPanel;
|
||
pnlMain: TPanel;
|
||
pnlTimelineHost: TPanel;
|
||
pnlVideo: TPanel;
|
||
SaveExportDialog: TSaveDialog;
|
||
SaveProjectDialog: TSaveDialog;
|
||
splitVideo: TSplitter;
|
||
procedure btnSnapClick(Sender: TObject);
|
||
procedure btnRippleClick(Sender: TObject);
|
||
procedure btnRippleMenuClick(Sender: TObject);
|
||
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||
procedure FormCreate(Sender: TObject);
|
||
procedure FormDestroy(Sender: TObject);
|
||
procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
|
||
procedure FormShow(Sender: TObject);
|
||
{$IFDEF LCLWIN32}
|
||
{ Остаток полосы меню закрашивается после того, как систему нарисовала
|
||
рамку окна. Раньше — бесполезно: она закрасит поверх. }
|
||
procedure WMNCPaint(var Msg: TLMessage); message MsgNcPaint;
|
||
procedure WMNCActivate(var Msg: TLMessage); message MsgNcActivate;
|
||
{$ENDIF}
|
||
procedure lstPoolClick(Sender: TObject);
|
||
procedure lstPoolMouseDown(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
procedure lstPoolDrawItem(Control: TWinControl; Index: Integer;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
private
|
||
FProject: TProject;
|
||
FTimeline: TTimelineControl;
|
||
FPlayer: TMpvPlayer;
|
||
FStarted: Boolean;
|
||
|
||
FPreviewTimer: TTimer;
|
||
FPreviewDirty: Boolean;
|
||
FUpdatingFromPlayer: Boolean;
|
||
FLastLoadedEdl: string;
|
||
FLastLoadedAudioEdl: string;
|
||
{ Списки кусков звуковых дорожек для плеера. }
|
||
FPreviewAudioUrls: array of string;
|
||
FPreviewAudioTracks: array of TTrack;
|
||
FLastHwdec: string;
|
||
FLastAudioNote: string;
|
||
FLogFilePath: string;
|
||
FLogFileStarted: Boolean;
|
||
FLogFileBroken: Boolean;
|
||
FMenu: TMainMenu;
|
||
{ Отложенный показ списка меню. Номер списка и точка, где его
|
||
раскрыть; таймер срабатывает один раз. }
|
||
{ Показ фоновой работы. Пока что-то считается в стороне от окна,
|
||
здесь видно, что именно и сколько осталось. }
|
||
FJobLabel: TLabel;
|
||
FJobBar: TThemedProgress;
|
||
FJobTimer: TTimer;
|
||
{ Уплощённый монтаж, отданный плееру. Хранится, чтобы по времени
|
||
находить звучащий кусок и брать у него громкость. }
|
||
FPreviewSegments: TFlatSegmentArray;
|
||
FLastVolumeSent: Double;
|
||
FLastVolumeKey: string;
|
||
|
||
FGenerate: TGenerateThread;
|
||
FGenerateBusy: Boolean;
|
||
|
||
FExport: TExportThread;
|
||
FExportUi: TProgressForm;
|
||
|
||
FNormalize: TFfmpegJob;
|
||
FNormalizeUi: TProgressForm;
|
||
|
||
FSettings: TSettings;
|
||
|
||
FThumbs: TImageList;
|
||
FThumbThread: TThumbThread;
|
||
FPeaksThread: TPeaksThread;
|
||
FPeaksRestart: Boolean;
|
||
FPeaksFinished: Boolean;
|
||
{ Соответствие «путь к файлу -> номер картинки в списке изображений».
|
||
По пути, а не по номеру в списке проекта: пока миниатюра делается,
|
||
файлы могут добавиться или пропасть. Номер хранится увеличенным на
|
||
единицу, потому что ноль в Objects неотличим от «ничего нет». }
|
||
FThumbMap: TStringList;
|
||
|
||
{ Меню библиотеки и меню выбора режима схлопывания. }
|
||
FPoolMenu: TPopupMenu;
|
||
FPoolAddMenu: TMenuItem;
|
||
FRippleMenu: TPopupMenu;
|
||
{ Пункт «Недавние проекты» в меню «Файл». Его содержимое собирается
|
||
заново при каждом изменении списка. }
|
||
FRecentMenu: TMenuItem;
|
||
|
||
{ Пока плеер не доехал до запрошенного места, его сообщения о позиции
|
||
игнорируются. Без этого перезагрузка предпросмотра после правки
|
||
сбрасывала бы курсор в начало. }
|
||
FSeekPending: Boolean;
|
||
FSeekTarget: Double;
|
||
{ Сколько сообщений о позиции ждём прибытия, прежде чем сдаться.
|
||
|
||
Без этого ограничения признак «ждём» мог зависнуть навсегда: если
|
||
после правки монтажа запрошенное время оказалось за его концом,
|
||
плеер туда никогда не доедет, и курсор переставал двигаться
|
||
совсем. }
|
||
FSeekWaitTicks: Integer;
|
||
|
||
procedure ApplyVolumeAt(const ATime: Double);
|
||
procedure UpdateRippleButton;
|
||
procedure UpdateSnapButton;
|
||
procedure RippleModeChosen(Sender: TObject);
|
||
procedure ToggleRipple;
|
||
procedure BuildPoolMenu;
|
||
procedure RefreshRecentMenu;
|
||
procedure OpenRecentProject(Sender: TObject);
|
||
function OpenProjectFile(const APath: string): Boolean;
|
||
procedure PoolMenuPopup(Sender: TObject);
|
||
procedure PoolAddToTrack(Sender: TObject);
|
||
procedure PoolRemoveFromTracks(Sender: TObject);
|
||
procedure PoolRemoveFromProject(Sender: TObject);
|
||
procedure PoolEditTransform(Sender: TObject);
|
||
procedure TimelineClipTransform(Sender: TObject; AClip: TClip);
|
||
procedure MenuProjectInfo(Sender: TObject);
|
||
procedure FormFilesDropped(Sender: TObject; const FileNames: array of string);
|
||
function ThumbIndexFor(const APath: string): Integer;
|
||
procedure ApplySettings;
|
||
procedure CollectSettings;
|
||
procedure StartThumbs;
|
||
procedure StartPeaks;
|
||
procedure PeaksReady(Sender: TObject; const ASourcePath: string);
|
||
procedure PeaksDone(Sender: TObject);
|
||
procedure ThumbReady(Sender: TObject; const ASourcePath,
|
||
AThumbPath: string);
|
||
procedure SeekPlayerTo(const ATime: Double);
|
||
procedure TogglePlayback;
|
||
|
||
procedure TimelineMediaDrop(Sender: TObject; ASource: TObject;
|
||
ATrackIndex: Integer; const ATime: Double);
|
||
procedure TimelineTrackAdded(Sender: TObject);
|
||
procedure TimelineActiveTrackChange(Sender: TObject);
|
||
function AddClipFromPool(APoolIndex, ATrackIndex: Integer;
|
||
const ATime: Double): Boolean;
|
||
|
||
{ --- окно и меню --- }
|
||
procedure BuildMenu;
|
||
procedure BuildJobIndicator;
|
||
procedure JobTimerTick(Sender: TObject);
|
||
procedure BuildTimeline;
|
||
procedure StartPlayer;
|
||
procedure Log(const AText: string);
|
||
procedure LogToFile(const AText: string);
|
||
procedure SetStatus(const AText: string);
|
||
procedure UpdateCaption;
|
||
procedure UpdateTimeLabel;
|
||
procedure RefreshPool;
|
||
|
||
|
||
{ --- предпросмотр --- }
|
||
procedure PrewarmInserts;
|
||
procedure SchedulePreview;
|
||
procedure PreviewTimerTick(Sender: TObject);
|
||
{ Есть ли на монтаже файл другого соотношения сторон. Только ради
|
||
таких файлов и нужен фильтр в предпросмотре. }
|
||
function PreviewNeedsFitting: Boolean;
|
||
{ Заставляет предпросмотр показывать кадр проекта, а не кадр исходника. }
|
||
procedure ApplyPreviewFrame;
|
||
procedure RebuildPreview;
|
||
procedure LoadPreviewEdl(const ASegments, AAudio: TFlatSegmentArray);
|
||
procedure GenerateDone(Sender: TObject);
|
||
procedure GenerateProgress(Sender: TObject);
|
||
procedure GenerateLog(Sender: TObject);
|
||
|
||
{ --- обработчики компонентов --- }
|
||
procedure TimelinePlayheadChange(Sender: TObject);
|
||
procedure TimelineStructureChange(Sender: TObject);
|
||
procedure TimelineSelectionChange(Sender: TObject);
|
||
procedure PlayerLog(Sender: TObject; const APrefix, ALevel, AText: string);
|
||
procedure PlayerTimePos(Sender: TObject);
|
||
procedure PlayerDuration(Sender: TObject);
|
||
procedure PlayerPauseChange(Sender: TObject);
|
||
|
||
{ --- пункты меню --- }
|
||
procedure MenuNewProject(Sender: TObject);
|
||
procedure MenuOpenProject(Sender: TObject);
|
||
procedure MenuSaveProject(Sender: TObject);
|
||
procedure MenuSaveProjectAs(Sender: TObject);
|
||
procedure MenuExport(Sender: TObject);
|
||
procedure MenuRemux(Sender: TObject);
|
||
procedure MenuDeps(Sender: TObject);
|
||
procedure MenuQuit(Sender: TObject);
|
||
procedure MenuUndo(Sender: TObject);
|
||
procedure MenuRedo(Sender: TObject);
|
||
procedure MenuSplit(Sender: TObject);
|
||
procedure MenuSplitPrecise(Sender: TObject);
|
||
procedure MenuDelete(Sender: TObject);
|
||
procedure MenuSelectAll(Sender: TObject);
|
||
procedure MenuRipple(Sender: TObject);
|
||
procedure MenuToggleRipple(Sender: TObject);
|
||
procedure MenuGoStart(Sender: TObject);
|
||
procedure MenuGoEnd(Sender: TObject);
|
||
procedure MenuZoomFit(Sender: TObject);
|
||
procedure MenuZoomIn(Sender: TObject);
|
||
procedure MenuZoomOut(Sender: TObject);
|
||
procedure MenuAddTrack(Sender: TObject);
|
||
procedure MenuRemoveTrack(Sender: TObject);
|
||
|
||
{ --- вспомогательное --- }
|
||
function SaveProjectAs: Boolean;
|
||
function DoSaveProject: Boolean;
|
||
function ConfirmDiscard: Boolean;
|
||
procedure AddMediaFile(const APath: string);
|
||
procedure ChooseAndAddFiles(Sender: TObject);
|
||
procedure ExportProgress(Sender: TObject);
|
||
procedure ExportLog(Sender: TObject);
|
||
procedure ExportDone(Sender: TObject);
|
||
procedure ExportCancel(Sender: TObject);
|
||
procedure ShowExportReport(const AReport: TExportReport);
|
||
procedure NormalizeProgress(Sender: TObject);
|
||
procedure NormalizeLog(Sender: TObject);
|
||
procedure NormalizeDone(Sender: TObject);
|
||
procedure NormalizeCancel(Sender: TObject);
|
||
end;
|
||
|
||
var
|
||
MainFormInstance: TMainForm;
|
||
|
||
implementation
|
||
|
||
{$R *.lfm}
|
||
|
||
uses
|
||
Math, uProcRunner, uFfmpegCmd;
|
||
|
||
const
|
||
{ Задержка пересборки предпросмотра. Правка монтажа сообщается один раз,
|
||
по окончании перетаскивания, поэтому задержка нужна лишь чтобы склеить
|
||
несколько правок подряд — и должна быть маленькой: пока она идёт,
|
||
предпросмотр играет старую расстановку, а на монтаже уже новая. }
|
||
PreviewDebounceMs = 120;
|
||
|
||
{ Сколько сообщений о позиции ждать прибытия после перемотки.
|
||
Сообщения приходят на каждый кадр, так что это доли секунды. }
|
||
MaxSeekWaitTicks = 90;
|
||
|
||
function FormatTimecode(const Seconds: Double): string;
|
||
var
|
||
Total, H, M, S, Ms: Integer;
|
||
begin
|
||
if Seconds < 0 then
|
||
Exit('--:--:--.---');
|
||
Total := Trunc(Seconds);
|
||
Ms := Round(Frac(Seconds) * 1000);
|
||
if Ms > 999 then
|
||
Ms := 999;
|
||
H := Total div 3600;
|
||
M := (Total mod 3600) div 60;
|
||
S := Total mod 60;
|
||
Result := Format('%.2d:%.2d:%.2d.%.3d', [H, M, S, Ms]);
|
||
end;
|
||
|
||
{ --- Создание окна --- }
|
||
|
||
procedure TMainForm.FormCreate(Sender: TObject);
|
||
begin
|
||
FSettings := TSettings.Create;
|
||
FSettings.Load;
|
||
|
||
FProject := TProject.Create;
|
||
FProject.NewProject;
|
||
|
||
BuildMenu;
|
||
BuildTimeline;
|
||
ApplySettings;
|
||
|
||
pnlVideo.Color := clBlack;
|
||
memoLog.Clear;
|
||
FLogFilePath := ExtractFilePath(ExpandFileName(ParamStr(0))) + 'nlve.log';
|
||
|
||
FPlayer := TMpvPlayer.Create(pnlVideo);
|
||
FPlayer.OnLog := @PlayerLog;
|
||
FPlayer.OnTimePos := @PlayerTimePos;
|
||
FPlayer.OnDuration := @PlayerDuration;
|
||
FPlayer.OnPauseChange := @PlayerPauseChange;
|
||
|
||
FPreviewTimer := TTimer.Create(Self);
|
||
FPreviewTimer.Enabled := False;
|
||
FPreviewTimer.Interval := PreviewDebounceMs;
|
||
FPreviewTimer.OnTimer := @PreviewTimerTick;
|
||
|
||
{ Список изображений держит миниатюры. Размер задан жёстко, и ffmpeg
|
||
делает их ровно такими: список изображений в LCL требует одинакового
|
||
размера у всех элементов. }
|
||
FThumbs := TImageList.Create(Self);
|
||
FThumbs.Width := ThumbWidth;
|
||
FThumbs.Height := ThumbHeight;
|
||
|
||
FThumbMap := TStringList.Create;
|
||
FThumbMap.Sorted := True;
|
||
FThumbMap.Duplicates := dupIgnore;
|
||
|
||
{ Список рисуется вручную.
|
||
|
||
Готовый режим значков в LCL под gtk2 работает плохо: там TListView
|
||
построен на дереве, и крупные значки он попросту игнорирует. Своя
|
||
отрисовка надёжнее и заодно позволяет показать рядом с кадром
|
||
название и параметры файла. }
|
||
lstPool.Style := lbOwnerDrawFixed;
|
||
lstPool.ItemHeight := ThumbHeight + 10;
|
||
{ Перетаскивание из списка на монтаж начинается само. }
|
||
lstPool.DragMode := dmAutomatic;
|
||
|
||
BuildPoolMenu;
|
||
RefreshRecentMenu;
|
||
AllowDropFiles := True;
|
||
OnDropFiles := @FormFilesDropped;
|
||
|
||
RefreshPool;
|
||
UpdateRippleButton;
|
||
UpdateSnapButton;
|
||
UpdateCaption;
|
||
SetStatus('Готов. Добавьте файлы в проект.');
|
||
|
||
{ Цвета задаём сами: системная тема может быть светлой, и тогда тёмный
|
||
таймлайн оказался бы в белой рамке. Вызов идёт последним — меню и
|
||
всплывающие меню строятся выше по ходу, и раньше их не существует. }
|
||
ApplyDarkTheme(Self);
|
||
end;
|
||
|
||
{ Каждый шаг закрытия отмечается в журнале.
|
||
|
||
Под Wine программа зависала при выходе, и по молчаливому журналу
|
||
понять, на чём именно, нельзя: последняя запись оставалась от работы, а
|
||
не от закрытия. Записи дешёвые, а без них искать пришлось бы наугад. }
|
||
procedure TMainForm.FormDestroy(Sender: TObject);
|
||
begin
|
||
Log('Закрытие: останавливаю предпросмотр.');
|
||
FPreviewTimer.Enabled := False;
|
||
if Assigned(FThumbThread) then
|
||
begin
|
||
Log('Закрытие: жду поток миниатюр.');
|
||
{ Поток обращается к форме через Synchronize, поэтому дожидаться его
|
||
обязательно: иначе он попробует достучаться до уже разрушенного окна. }
|
||
FThumbThread.Terminate;
|
||
FThumbThread.WaitFor;
|
||
FreeAndNil(FThumbThread);
|
||
end;
|
||
if Assigned(FPeaksThread) then
|
||
begin
|
||
Log('Закрытие: жду разбор звука.');
|
||
{ При закрытии ждать приходится: поток обращается к окну. Ждать
|
||
недолго — запущенный ffmpeg прерывается по тому же признаку. }
|
||
FPeaksRestart := False;
|
||
FPeaksThread.Terminate;
|
||
FPeaksThread.WaitFor;
|
||
FreeAndNil(FPeaksThread);
|
||
end;
|
||
FreeAndNil(FThumbMap);
|
||
Log('Закрытие: сохраняю настройки.');
|
||
CollectSettings;
|
||
FSettings.Save;
|
||
FreeAndNil(FSettings);
|
||
Log('Закрытие: закрываю плеер.');
|
||
FreeAndNil(FPlayer);
|
||
|
||
{ Библиотеку не выгружаем.
|
||
|
||
Плеер отсоединяется от mpv, не дожидаясь, пока ядро добьёт свои
|
||
потоки, — иначе под Wine ожидание не кончалось вовсе. Значит, в
|
||
момент выхода эти потоки могут ещё жить внутри библиотеки, и
|
||
выгружать её из-под них нельзя. Программа всё равно закрывается,
|
||
и система освободит всё сама. }
|
||
Log('Закрытие: освобождаю проект.');
|
||
FreeAndNil(FProject);
|
||
Log('Закрытие завершено.');
|
||
{ Сами списки принадлежат форме и уничтожатся с ней; здесь только
|
||
перечень ссылок на них. }
|
||
end;
|
||
|
||
procedure TMainForm.ApplySettings;
|
||
begin
|
||
if (FSettings.WindowLeft >= 0) and (FSettings.WindowTop >= 0) then
|
||
begin
|
||
Position := poDesigned;
|
||
Left := FSettings.WindowLeft;
|
||
Top := FSettings.WindowTop;
|
||
end;
|
||
Width := FSettings.WindowWidth;
|
||
Height := FSettings.WindowHeight;
|
||
if FSettings.WindowMaximized then
|
||
WindowState := wsMaximized;
|
||
|
||
pnlVideo.Height := FSettings.VideoPanelHeight;
|
||
FTimeline.TrackHeight := FSettings.TrackHeight;
|
||
FTimeline.WaveGain := FSettings.WaveGain;
|
||
|
||
{ Режим схлопывания и его состояние переживают перезапуск. }
|
||
if FSettings.RippleAllTracks then
|
||
FProject.RippleMode := rmAllTracks
|
||
else
|
||
FProject.RippleMode := rmCurrentTrack;
|
||
FProject.RippleEnabled := FSettings.RippleEnabled;
|
||
|
||
{ Каталоги подставляем в диалоги, чтобы не искать одно и то же место
|
||
заново при каждом запуске. }
|
||
if FSettings.LastMediaDir <> '' then
|
||
OpenMediaDialog.InitialDir := FSettings.LastMediaDir;
|
||
if FSettings.LastProjectDir <> '' then
|
||
begin
|
||
OpenProjectDialog.InitialDir := FSettings.LastProjectDir;
|
||
SaveProjectDialog.InitialDir := FSettings.LastProjectDir;
|
||
end;
|
||
if FSettings.LastExportDir <> '' then
|
||
SaveExportDialog.InitialDir := FSettings.LastExportDir;
|
||
end;
|
||
|
||
procedure TMainForm.CollectSettings;
|
||
begin
|
||
FSettings.WindowMaximized := WindowState = wsMaximized;
|
||
{ Развёрнутое окно запоминать по координатам бессмысленно: они не те,
|
||
что были до разворачивания. }
|
||
if WindowState = wsNormal then
|
||
begin
|
||
FSettings.WindowLeft := Left;
|
||
FSettings.WindowTop := Top;
|
||
FSettings.WindowWidth := Width;
|
||
FSettings.WindowHeight := Height;
|
||
end;
|
||
FSettings.VideoPanelHeight := pnlVideo.Height;
|
||
FSettings.RippleAllTracks := FProject.RippleMode = rmAllTracks;
|
||
FSettings.RippleEnabled := FProject.RippleEnabled;
|
||
FSettings.WaveGain := FTimeline.WaveGain;
|
||
end;
|
||
|
||
procedure TMainForm.BuildTimeline;
|
||
begin
|
||
{ Компонент создаётся кодом, а не кладётся на форму: он свой, в палитре
|
||
его нет, а регистрировать пакет ради одного контрола незачем. }
|
||
FTimeline := TTimelineControl.Create(Self);
|
||
FTimeline.Parent := pnlTimelineHost;
|
||
FTimeline.Align := alClient;
|
||
FTimeline.Project := FProject;
|
||
FTimeline.OnPlayheadChange := @TimelinePlayheadChange;
|
||
FTimeline.OnStructureChange := @TimelineStructureChange;
|
||
FTimeline.OnSelectionChange := @TimelineSelectionChange;
|
||
FTimeline.OnMediaDrop := @TimelineMediaDrop;
|
||
FTimeline.OnClipTransform := @TimelineClipTransform;
|
||
FTimeline.OnTrackAdded := @TimelineTrackAdded;
|
||
FTimeline.OnActiveTrackChange := @TimelineActiveTrackChange;
|
||
end;
|
||
|
||
{ Меню строится кодом: в файле формы оно заняло бы сотню строк описания
|
||
вложенных пунктов, где легко ошибиться и трудно что-то найти.
|
||
|
||
Полоса меню — настоящая, TMainMenu.
|
||
|
||
Некоторое время она была своя, из обычных кнопок: под Windows системную
|
||
полосу нашим цветом не закрасить, SetMenuInfo меняет подложку пунктов, но
|
||
не саму полосу. Цена оказалась велика, и вся она в поведении: наведение
|
||
на соседнее название не перекидывало на него раскрытый список, не
|
||
работал переход по меню с Alt и стрелками. Подражать настоящему меню
|
||
своими руками пришлось бы до бесконечности.
|
||
|
||
Цвет решается иначе, на каждой системе своим способом: под gtk2 строкой
|
||
стиля (ApplyMenuStyle), под win32 отрисовкой пунктов своими руками
|
||
(ApplyDarkMenu). Остаток полосы правее последнего названия под Windows
|
||
по-прежнему рисует система — это известная и принятая уступка. }
|
||
procedure TMainForm.BuildMenu;
|
||
|
||
function AddTop(const ACaption: string): TMenuItem;
|
||
begin
|
||
Result := TMenuItem.Create(Self);
|
||
Result.Caption := ACaption;
|
||
FMenu.Items.Add(Result);
|
||
end;
|
||
|
||
procedure AddItem(AParent: TMenuItem; const ACaption: string;
|
||
AHandler: TNotifyEvent; AShortCut: TShortCut = 0);
|
||
var
|
||
Item: TMenuItem;
|
||
begin
|
||
Item := TMenuItem.Create(Self);
|
||
Item.Caption := ACaption;
|
||
Item.OnClick := AHandler;
|
||
Item.ShortCut := AShortCut;
|
||
AParent.Add(Item);
|
||
end;
|
||
|
||
procedure AddSep(AParent: TMenuItem);
|
||
var
|
||
Item: TMenuItem;
|
||
begin
|
||
Item := TMenuItem.Create(Self);
|
||
Item.Caption := '-';
|
||
AParent.Add(Item);
|
||
end;
|
||
|
||
var
|
||
MFile, MEdit, MView, MProject: TMenuItem;
|
||
begin
|
||
BuildJobIndicator;
|
||
FMenu := TMainMenu.Create(Self);
|
||
|
||
MFile := AddTop('Файл');
|
||
AddItem(MFile, 'Новый проект', @MenuNewProject, ShortCut(VK_N, [ssCtrl]));
|
||
AddItem(MFile, 'Открыть проект...', @MenuOpenProject, ShortCut(VK_O, [ssCtrl]));
|
||
|
||
FRecentMenu := TMenuItem.Create(Self);
|
||
FRecentMenu.Caption := 'Недавние проекты';
|
||
MFile.Add(FRecentMenu);
|
||
|
||
AddItem(MFile, 'Сохранить проект', @MenuSaveProject, ShortCut(VK_S, [ssCtrl]));
|
||
AddItem(MFile, 'Сохранить проект как...', @MenuSaveProjectAs);
|
||
AddSep(MFile);
|
||
AddItem(MFile, 'Добавить файлы в проект...', @ChooseAndAddFiles,
|
||
ShortCut(VK_I, [ssCtrl]));
|
||
AddSep(MFile);
|
||
AddItem(MFile, 'Собрать ролик...', @MenuExport, ShortCut(VK_E, [ssCtrl]));
|
||
AddItem(MFile, 'Перепаковка файлов...', @MenuRemux);
|
||
AddSep(MFile);
|
||
AddItem(MFile, 'Зависимости...', @MenuDeps);
|
||
AddSep(MFile);
|
||
AddItem(MFile, 'Выход', @MenuQuit, ShortCut(VK_Q, [ssCtrl]));
|
||
|
||
MEdit := AddTop('Правка');
|
||
AddItem(MEdit, 'Отменить', @MenuUndo, ShortCut(VK_Z, [ssCtrl]));
|
||
AddItem(MEdit, 'Повторить', @MenuRedo, ShortCut(VK_Y, [ssCtrl]));
|
||
AddSep(MEdit);
|
||
AddItem(MEdit, 'Разрезать по курсору', @MenuSplit, ShortCut(VK_S, []));
|
||
AddItem(MEdit, 'Разрезать точно (с перекодированием стыка)',
|
||
@MenuSplitPrecise, ShortCut(VK_S, [ssShift]));
|
||
AddItem(MEdit, 'Удалить выделенное', @MenuDelete, ShortCut(VK_DELETE, []));
|
||
AddItem(MEdit, 'Выделить всё', @MenuSelectAll, ShortCut(VK_A, [ssCtrl]));
|
||
AddSep(MEdit);
|
||
AddItem(MEdit, 'Схлопнуть дыру под курсором', @MenuRipple,
|
||
ShortCut(VK_R, [ssCtrl, ssShift]));
|
||
AddItem(MEdit, 'Автосхлопывание при перетаскивании', @MenuToggleRipple,
|
||
ShortCut(VK_K, [ssCtrl]));
|
||
|
||
MView := AddTop('Вид');
|
||
{ Home и End назначены пунктами меню, а не обрабатываются в компоненте:
|
||
так они работают независимо от того, где сейчас фокус. Иначе их
|
||
перехватывал бы список файлов, переводя в нём выделение. }
|
||
AddItem(MView, 'В начало монтажа', @MenuGoStart, ShortCut(VK_HOME, []));
|
||
AddItem(MView, 'В конец монтажа', @MenuGoEnd, ShortCut(VK_END, []));
|
||
AddSep(MView);
|
||
AddItem(MView, 'Вписать весь проект', @MenuZoomFit, ShortCut(VK_0, [ssCtrl]));
|
||
AddItem(MView, 'Приблизить', @MenuZoomIn, ShortCut(VK_ADD, [ssCtrl]));
|
||
AddItem(MView, 'Отдалить', @MenuZoomOut, ShortCut(VK_SUBTRACT, [ssCtrl]));
|
||
|
||
MProject := AddTop('Проект');
|
||
AddItem(MProject, 'Сведения о проекте...', @MenuProjectInfo);
|
||
AddSep(MProject);
|
||
AddItem(MProject, 'Добавить дорожку', @MenuAddTrack);
|
||
AddItem(MProject, 'Удалить последнюю дорожку', @MenuRemoveTrack);
|
||
|
||
{ Дважды, и оба раза нужны.
|
||
|
||
До присваивания — чтобы обработчики отрисовки стояли к первому показу.
|
||
После — чтобы задать подложку полосы: она задаётся через SetMenuInfo по
|
||
дескриптору меню, а дескриптор появляется только когда меню отдано
|
||
окну. Первый вызов до этого просто пропускал подложку, и справа от
|
||
последнего названия оставалась светлая полоса. }
|
||
ApplyDarkMenu(FMenu);
|
||
Menu := FMenu;
|
||
ApplyDarkMenu(FMenu);
|
||
end;
|
||
|
||
{ Показ фоновой работы.
|
||
|
||
Разбор звука читает файл целиком — на шести гигабайтах это больше
|
||
десяти секунд, и всё это время программа выглядит просто задумчивой.
|
||
Молчать об этом нельзя: непонятно, идёт ли что-то вообще.
|
||
|
||
Место справа в нижней полосе отводится сразу и насовсем, а надпись с
|
||
полоской показываются только когда работа есть. Так строка состояния и
|
||
показатель не наезжают друг на друга. }
|
||
procedure TMainForm.BuildJobIndicator;
|
||
const
|
||
JobWidth = 330;
|
||
begin
|
||
FJobLabel := TLabel.Create(Self);
|
||
FJobLabel.Parent := pnlBottom;
|
||
FJobLabel.AutoSize := False;
|
||
FJobLabel.Alignment := taRightJustify;
|
||
FJobLabel.Anchors := [akTop, akRight];
|
||
FJobLabel.SetBounds(pnlBottom.ClientWidth - JobWidth - 12, 6,
|
||
JobWidth, 16);
|
||
FJobLabel.ParentColor := False;
|
||
FJobLabel.Font.Color := ThemeTextDim;
|
||
FJobLabel.Visible := False;
|
||
|
||
FJobBar := TThemedProgress.Create(Self);
|
||
FJobBar.Parent := pnlBottom;
|
||
FJobBar.Anchors := [akTop, akRight];
|
||
FJobBar.SetBounds(pnlBottom.ClientWidth - JobWidth - 12, 26, JobWidth, 6);
|
||
FJobBar.Visible := False;
|
||
|
||
{ Строка состояния ужимается, чтобы её длинные сообщения не залезали
|
||
под показатель. }
|
||
lblStatus.Width := pnlBottom.ClientWidth - lblStatus.Left - JobWidth - 24;
|
||
|
||
FJobTimer := TTimer.Create(Self);
|
||
FJobTimer.Interval := 300;
|
||
FJobTimer.OnTimer := @JobTimerTick;
|
||
FJobTimer.Enabled := True;
|
||
end;
|
||
|
||
{ Опрос по таймеру, а не уведомления из потоков: поток сообщает о готовом
|
||
файле, а не о ходе внутри файла, и на шестигигабайтном файле между
|
||
сообщениями проходят десятки секунд. Опрос показывает движение и там. }
|
||
procedure TMainForm.JobTimerTick(Sender: TObject);
|
||
var
|
||
{ Не Text: так называется свойство самой формы, а имена в Паскале
|
||
нечувствительны к регистру. }
|
||
Note: string;
|
||
Frac: Double;
|
||
Total, Done: Integer;
|
||
begin
|
||
{$IFDEF LCLWIN32}
|
||
{ Заодно подновляем закраску остатка полосы меню.
|
||
|
||
Обработчика перерисовки рамки может не хватить: система трогает
|
||
полосу и по другим поводам, а рисуем мы поверх неё. Прямоугольник тот
|
||
же и цвет тот же, поэтому подновление не видно. }
|
||
PaintMenuBarTail(Self);
|
||
{$ENDIF}
|
||
|
||
Note := '';
|
||
Frac := 0;
|
||
|
||
if Assigned(FPeaksThread) and (not FPeaksFinished) then
|
||
begin
|
||
Total := FPeaksThread.Total;
|
||
Done := FPeaksThread.Done;
|
||
if Total > 0 then
|
||
begin
|
||
Note := Format('Разбор звука: %d из %d', [Done + 1, Total]);
|
||
Frac := Done / Total;
|
||
end;
|
||
end
|
||
else if Assigned(FThumbThread) then
|
||
begin
|
||
Total := FThumbThread.Total;
|
||
Done := FThumbThread.Done;
|
||
if (Total > 0) and (Done < Total) then
|
||
begin
|
||
Note := Format('Миниатюры: %d из %d', [Done + 1, Total]);
|
||
Frac := Done / Total;
|
||
end;
|
||
end;
|
||
|
||
if Note = '' then
|
||
begin
|
||
if FJobLabel.Visible then
|
||
begin
|
||
FJobLabel.Visible := False;
|
||
FJobBar.Visible := False;
|
||
end;
|
||
Exit;
|
||
end;
|
||
|
||
FJobLabel.Caption := Note;
|
||
FJobBar.Fraction := Frac;
|
||
if not FJobLabel.Visible then
|
||
begin
|
||
FJobLabel.Visible := True;
|
||
FJobBar.Visible := True;
|
||
end;
|
||
end;
|
||
|
||
{$IFDEF LCLWIN32}
|
||
procedure TMainForm.WMNCPaint(var Msg: TLMessage);
|
||
begin
|
||
inherited;
|
||
PaintMenuBarTail(Self);
|
||
end;
|
||
|
||
procedure TMainForm.WMNCActivate(var Msg: TLMessage);
|
||
begin
|
||
inherited;
|
||
PaintMenuBarTail(Self);
|
||
end;
|
||
{$ENDIF}
|
||
|
||
procedure TMainForm.FormShow(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
Added: Boolean;
|
||
Err: string;
|
||
begin
|
||
if FStarted then
|
||
Exit;
|
||
FStarted := True;
|
||
|
||
{ Подложка полосы меню задаётся здесь, а не при создании формы.
|
||
|
||
Она задаётся через SetMenuInfo по дескриптору меню, а тот появляется
|
||
вместе с дескриптором окна — то есть уже после создания формы. Вызов
|
||
из BuildMenu поэтому попадал на несозданный дескриптор и молча ничего
|
||
не делал: пункты рисовались нашими руками, а полоса правее последнего
|
||
названия оставалась светлой. }
|
||
ApplyDarkMenu(Menu);
|
||
PaintMenuBarTail(Self);
|
||
{$IFDEF LCLWIN32}
|
||
Log(MenuBarTailNote);
|
||
{$ENDIF}
|
||
|
||
StartPlayer;
|
||
|
||
{ Файлы из командной строки попадают в список проекта. Так на программу
|
||
можно перетащить файлы из файлового менеджера.
|
||
|
||
Файл проекта — особый случай: его надо открыть, а не пытаться
|
||
разобрать как видео. }
|
||
Added := False;
|
||
for I := 1 to ParamCount do
|
||
begin
|
||
if not FileExists(ParamStr(I)) then
|
||
Continue;
|
||
|
||
if LowerCase(ExtractFileExt(ParamStr(I))) = '.nlve' then
|
||
begin
|
||
if FProject.LoadFromFile(ExpandFileName(ParamStr(I)), Err) then
|
||
begin
|
||
Log('Открыт проект: ' + FProject.FileName);
|
||
FTimeline.ZoomToFit;
|
||
FLastLoadedEdl := '';
|
||
RefreshPool;
|
||
UpdateRippleButton;
|
||
UpdateCaption;
|
||
SchedulePreview;
|
||
end
|
||
else
|
||
Log('Не удалось открыть проект: ' + Err);
|
||
Continue;
|
||
end;
|
||
|
||
AddMediaFile(ExpandFileName(ParamStr(I)));
|
||
Added := True;
|
||
end;
|
||
if Added then
|
||
begin
|
||
RefreshPool;
|
||
UpdateCaption;
|
||
if lstPool.Items.Count > 0 then
|
||
lstPool.ItemIndex := 0;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.StartPlayer;
|
||
var
|
||
Err: string;
|
||
begin
|
||
if not LoadMpvLib(Err) then
|
||
begin
|
||
Log('ОШИБКА: ' + Err);
|
||
SetStatus('Предпросмотр недоступен: нет libmpv.');
|
||
Exit;
|
||
end;
|
||
Log('libmpv загружена: ' + MpvLibFileName);
|
||
|
||
pnlVideo.HandleNeeded;
|
||
|
||
if not FPlayer.Initialize(Err) then
|
||
begin
|
||
Log('ОШИБКА: ' + Err);
|
||
SetStatus('Предпросмотр недоступен.');
|
||
Exit;
|
||
end;
|
||
Log('Предпросмотр готов.');
|
||
|
||
if not ToolsAvailable(Err) then
|
||
begin
|
||
Log('ВНИМАНИЕ: ' + Err);
|
||
SetStatus('ffmpeg не найден — сборка и генерация работать не будут.');
|
||
end;
|
||
end;
|
||
|
||
{ --- Мелочи интерфейса --- }
|
||
|
||
{ Дублирование журнала в файл рядом с программой.
|
||
|
||
Нужно ровно для одного случая: программа падает до того, как окно
|
||
успело появиться. Тогда всё, что она о себе рассказала, пропадает
|
||
вместе с окном, и причина остаётся неизвестной. Файл переписывается
|
||
при каждом запуске: интересен последний.
|
||
|
||
Неудача записи ничего не значит — каталог может быть закрыт на запись,
|
||
и работать это мешать не должно. }
|
||
procedure TMainForm.LogToFile(const AText: string);
|
||
var
|
||
F: TextFile;
|
||
begin
|
||
if FLogFileBroken then
|
||
Exit;
|
||
try
|
||
AssignFile(F, FLogFilePath);
|
||
if FLogFileStarted then
|
||
Append(F)
|
||
else
|
||
begin
|
||
Rewrite(F);
|
||
FLogFileStarted := True;
|
||
end;
|
||
try
|
||
WriteLn(F, AText);
|
||
finally
|
||
CloseFile(F);
|
||
end;
|
||
except
|
||
FLogFileBroken := True;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.Log(const AText: string);
|
||
begin
|
||
memoLog.Add(AText);
|
||
LogToFile(AText);
|
||
end;
|
||
|
||
procedure TMainForm.SetStatus(const AText: string);
|
||
begin
|
||
lblStatus.Caption := AText;
|
||
end;
|
||
|
||
procedure TMainForm.UpdateCaption;
|
||
var
|
||
{ Не Name и не Position: оба имени заняты свойствами формы. }
|
||
ProjectName: string;
|
||
begin
|
||
if FProject.FileName = '' then
|
||
ProjectName := 'без имени'
|
||
else
|
||
ProjectName := ExtractFileName(FProject.FileName);
|
||
if FProject.Modified then
|
||
ProjectName := ProjectName + ' *';
|
||
Caption := 'nlve — ' + ProjectName;
|
||
end;
|
||
|
||
procedure TMainForm.UpdateTimeLabel;
|
||
begin
|
||
lblTime.Caption := FormatTimecode(FTimeline.Playhead) + ' / ' +
|
||
FormatTimecode(FProject.EndTime);
|
||
end;
|
||
|
||
procedure TMainForm.RefreshPool;
|
||
var
|
||
I: Integer;
|
||
Item: TMediaItem;
|
||
begin
|
||
lstPool.Items.BeginUpdate;
|
||
try
|
||
lstPool.Items.Clear;
|
||
{ Строки только несут номер: всё, что видно, рисуется вручную по
|
||
данным проекта, поэтому дублировать их в списке незачем. }
|
||
for I := 0 to FProject.PoolCount - 1 do
|
||
lstPool.Items.Add(ExtractFileName(FProject.Pool[I].Path));
|
||
finally
|
||
lstPool.Items.EndUpdate;
|
||
end;
|
||
lblPoolInfo.Caption := Format('%d %s в проекте',
|
||
[FProject.PoolCount,
|
||
Plural(FProject.PoolCount, 'файл', 'файла', 'файлов')]);
|
||
StartThumbs;
|
||
StartPeaks;
|
||
end;
|
||
|
||
{ Запускает изготовление недостающих миниатюр.
|
||
|
||
Один поток на всю очередь: миниатюры делаются последовательно, чтобы
|
||
не устраивать драку за диск при добавлении десятка файлов сразу. }
|
||
function TMainForm.ThumbIndexFor(const APath: string): Integer;
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
Result := -1;
|
||
if FThumbMap = nil then
|
||
Exit;
|
||
Idx := FThumbMap.IndexOf(APath);
|
||
if Idx >= 0 then
|
||
Result := PtrUInt(FThumbMap.Objects[Idx]) - 1;
|
||
end;
|
||
|
||
procedure TMainForm.StartThumbs;
|
||
var
|
||
Requests: TThumbRequests = nil;
|
||
I, N: Integer;
|
||
Item: TMediaItem;
|
||
begin
|
||
if Assigned(FThumbThread) then
|
||
begin
|
||
{ Предыдущая очередь ещё идёт — прерываем её: список изменился, и
|
||
часть работы могла стать ненужной. }
|
||
FThumbThread.Terminate;
|
||
FThumbThread.WaitFor;
|
||
FreeAndNil(FThumbThread);
|
||
end;
|
||
|
||
if FProject.PoolCount = 0 then
|
||
Exit;
|
||
|
||
SetLength(Requests, FProject.PoolCount);
|
||
N := 0;
|
||
for I := 0 to FProject.PoolCount - 1 do
|
||
begin
|
||
Item := FProject.Pool[I];
|
||
if ThumbIndexFor(Item.Path) >= 0 then
|
||
Continue;
|
||
{ Кадр берём из исходника, а не из приведённой копии: копии может ещё
|
||
не быть, а миниатюра нужна сразу. Ключом при этом остаётся исходный
|
||
путь — он не меняется. }
|
||
Requests[N].SourcePath := Item.Path;
|
||
Requests[N].TargetPath := ThumbPath(FProject.CacheDir, Item.Path);
|
||
Requests[N].Key := Item.Path;
|
||
if Item.Info.Kind = mkImage then
|
||
Requests[N].AtTime := 0
|
||
else
|
||
Requests[N].AtTime := ThumbTimeFor(Item.Info.Duration);
|
||
Inc(N);
|
||
end;
|
||
SetLength(Requests, N);
|
||
if N = 0 then
|
||
Exit;
|
||
|
||
FThumbThread := TThumbThread.Create(Requests);
|
||
FThumbThread.OnReady := @ThumbReady;
|
||
FThumbThread.Start;
|
||
end;
|
||
|
||
{ Разбор звука для формы волны. Отдельная очередь от миниатюр: разбор
|
||
идёт дольше, и держать миниатюры в ожидании звука незачем. }
|
||
procedure TMainForm.StartPeaks;
|
||
var
|
||
Requests: TPeaksRequests = nil;
|
||
I, N: Integer;
|
||
Item: TMediaItem;
|
||
Dummy: TPeaks;
|
||
begin
|
||
{ Ждать окончания разбора нельзя: он читает файл целиком, а это
|
||
гигабайты и десяток секунд. Ожидание идёт в главном потоке, и всё это
|
||
время окно не отвечает — меню не открывается вовсе.
|
||
|
||
Поэтому просто отмечаем, что список изменился: текущий проход
|
||
доработает и запустится заново. }
|
||
if Assigned(FPeaksThread) then
|
||
begin
|
||
if not FPeaksFinished then
|
||
begin
|
||
FPeaksRestart := True;
|
||
Exit;
|
||
end;
|
||
{ Уже завершился — ожидание мгновенное. }
|
||
FPeaksThread.WaitFor;
|
||
FreeAndNil(FPeaksThread);
|
||
end;
|
||
|
||
FPeaksRestart := False;
|
||
FPeaksFinished := False;
|
||
if FProject.PoolCount = 0 then
|
||
Exit;
|
||
|
||
SetLength(Requests, FProject.PoolCount);
|
||
N := 0;
|
||
for I := 0 to FProject.PoolCount - 1 do
|
||
begin
|
||
Item := FProject.Pool[I];
|
||
if not Item.Info.HasAudio then
|
||
Continue;
|
||
if CachedPeaks(FProject.CacheDir, Item.EffectivePath, Dummy) then
|
||
Continue;
|
||
Requests[N].SourcePath := Item.EffectivePath;
|
||
Requests[N].TargetPath := PeaksPath(FProject.CacheDir, Item.EffectivePath);
|
||
Inc(N);
|
||
end;
|
||
SetLength(Requests, N);
|
||
if N = 0 then
|
||
Exit;
|
||
|
||
FPeaksThread := TPeaksThread.Create(Requests);
|
||
FPeaksThread.OnReady := @PeaksReady;
|
||
FPeaksThread.OnTerminate := @PeaksDone;
|
||
{ Разбор звука не должен мешать работе: он тяжёлый и никуда не спешит. }
|
||
FPeaksThread.Priority := tpLowest;
|
||
FPeaksThread.Start;
|
||
end;
|
||
|
||
{ Проход разбора закончился. Освобождаем поток и, если за это время
|
||
список файлов менялся, начинаем заново. }
|
||
procedure TMainForm.PeaksDone(Sender: TObject);
|
||
begin
|
||
{ Освобождать поток прямо здесь нельзя: он ещё доживает свой цикл.
|
||
Отмечаем, что он закончил, а освободит его следующий заход. }
|
||
FPeaksFinished := True;
|
||
if FPeaksRestart then
|
||
StartPeaks;
|
||
end;
|
||
|
||
procedure TMainForm.PeaksReady(Sender: TObject; const ASourcePath: string);
|
||
begin
|
||
{ Запомненную неудачу надо забыть: пики только что появились. }
|
||
ForgetPeaks;
|
||
FTimeline.Invalidate;
|
||
end;
|
||
|
||
procedure TMainForm.ThumbReady(Sender: TObject; const ASourcePath,
|
||
AThumbPath: string);
|
||
var
|
||
Png: TPortableNetworkGraphic;
|
||
Bmp: TBitmap;
|
||
ImgIdx: Integer;
|
||
begin
|
||
if not FileExists(AThumbPath) then
|
||
Exit;
|
||
if ThumbIndexFor(ASourcePath) >= 0 then
|
||
Exit;
|
||
|
||
Png := TPortableNetworkGraphic.Create;
|
||
Bmp := TBitmap.Create;
|
||
try
|
||
try
|
||
Png.LoadFromFile(AThumbPath);
|
||
{ Список изображений принимает растр, а не картинку произвольного
|
||
формата, поэтому перерисовываем PNG в растр нужного размера. }
|
||
Bmp.SetSize(ThumbWidth, ThumbHeight);
|
||
Bmp.Canvas.Brush.Color := clBlack;
|
||
Bmp.Canvas.FillRect(0, 0, ThumbWidth, ThumbHeight);
|
||
Bmp.Canvas.Draw(0, 0, Png);
|
||
ImgIdx := FThumbs.Add(Bmp, nil);
|
||
except
|
||
{ Битая миниатюра — просто оставляем строку без картинки. }
|
||
Exit;
|
||
end;
|
||
finally
|
||
Bmp.Free;
|
||
Png.Free;
|
||
end;
|
||
|
||
FThumbMap.AddObject(ASourcePath, TObject(PtrUInt(ImgIdx + 1)));
|
||
lstPool.Invalidate;
|
||
end;
|
||
|
||
{ Колесо с Shift над журналом прокручивает его вбок.
|
||
|
||
Строки там бывают длиной в несколько экранов — команды ffmpeg целиком, —
|
||
и добраться до их конца иначе нечем: полоса прокрутки внизу есть, но
|
||
колесо само по себе на неё не действует. }
|
||
{ Своя отрисовка строки: кадр слева, название и параметры справа. }
|
||
procedure TMainForm.lstPoolDrawItem(Control: TWinControl; Index: Integer;
|
||
ARect: TRect; State: TOwnerDrawState);
|
||
var
|
||
C: TCanvas;
|
||
Item: TMediaItem;
|
||
ImgIdx, TextLeft: Integer;
|
||
begin
|
||
C := lstPool.Canvas;
|
||
|
||
{ Цвета берём свои, а не системные. clWindowText под Windows почти
|
||
чёрный, и на тёмном списке подписи к файлам пропадали. }
|
||
if odSelected in State then
|
||
C.Brush.Color := ThemeSelection
|
||
else
|
||
C.Brush.Color := ThemeSurface;
|
||
C.FillRect(ARect);
|
||
|
||
if (Index < 0) or (Index >= FProject.PoolCount) then
|
||
Exit;
|
||
Item := FProject.Pool[Index];
|
||
|
||
ImgIdx := ThumbIndexFor(Item.Path);
|
||
if ImgIdx >= 0 then
|
||
FThumbs.Draw(C, ARect.Left + 4, ARect.Top + 5, ImgIdx)
|
||
else
|
||
begin
|
||
{ Кадр ещё готовится — рисуем заглушку того же размера, чтобы строки
|
||
не прыгали, когда картинка появится. }
|
||
C.Brush.Color := clBlack;
|
||
C.FillRect(ARect.Left + 4, ARect.Top + 5,
|
||
ARect.Left + 4 + ThumbWidth, ARect.Top + 5 + ThumbHeight);
|
||
C.Font.Color := ThemeTextDim;
|
||
C.Brush.Style := bsClear;
|
||
C.TextOut(ARect.Left + 20, ARect.Top + 5 + ThumbHeight div 2 - 8, 'готовится...');
|
||
C.Brush.Style := bsSolid;
|
||
end;
|
||
|
||
TextLeft := ARect.Left + ThumbWidth + 12;
|
||
C.Brush.Style := bsClear;
|
||
if odSelected in State then
|
||
C.Font.Color := ThemeSelText
|
||
else
|
||
C.Font.Color := ThemeText;
|
||
|
||
C.Font.Style := [fsBold];
|
||
C.TextOut(TextLeft, ARect.Top + 8, ExtractFileName(Item.Path));
|
||
C.Font.Style := [];
|
||
if not (odSelected in State) then
|
||
C.Font.Color := ThemeTextDim;
|
||
C.TextOut(TextLeft, ARect.Top + 30, DescribeMedia(Item.Info));
|
||
if Item.Info.Duration > 0 then
|
||
C.TextOut(TextLeft, ARect.Top + 50,
|
||
SecondsToStr(Item.Info.Duration) + ' с');
|
||
if Item.NormalizedPath <> '' then
|
||
C.TextOut(TextLeft, ARect.Top + 70, 'приведён к проекту');
|
||
C.Brush.Style := bsSolid;
|
||
end;
|
||
|
||
{ Номер выбранного файла в списке проекта, минус один если ничего не выбрано. }
|
||
function SelectedPoolIndex(AList: TListBox): Integer;
|
||
begin
|
||
Result := AList.ItemIndex;
|
||
end;
|
||
|
||
procedure TMainForm.lstPoolClick(Sender: TObject);
|
||
var
|
||
Item: TMediaItem;
|
||
Idx: Integer;
|
||
begin
|
||
Idx := SelectedPoolIndex(lstPool);
|
||
if (Idx < 0) or (Idx >= FProject.PoolCount) then
|
||
Exit;
|
||
Item := FProject.Pool[Idx];
|
||
SetStatus(ExtractFileName(Item.Path) + ' — ' + DescribeMedia(Item.Info) +
|
||
', ' + SecondsToStr(Item.Info.Duration) + ' с');
|
||
end;
|
||
|
||
{ --- Список файлов --- }
|
||
|
||
procedure TMainForm.AddMediaFile(const APath: string);
|
||
var
|
||
Info: TMediaInfo;
|
||
Err: string;
|
||
Item: TMediaItem;
|
||
begin
|
||
if FProject.FindMediaByPath(APath) <> nil then
|
||
begin
|
||
Log('Уже в проекте: ' + ExtractFileName(APath));
|
||
Exit;
|
||
end;
|
||
|
||
Screen.Cursor := crHourGlass;
|
||
try
|
||
if not ProbeMedia(APath, Info, Err) then
|
||
begin
|
||
Log('Не удалось прочитать ' + ExtractFileName(APath) + ': ' + Err);
|
||
Exit;
|
||
end;
|
||
finally
|
||
Screen.Cursor := crDefault;
|
||
end;
|
||
|
||
FProject.BeginChange;
|
||
Item := FProject.AddMedia(APath, Info);
|
||
Log('Добавлен ' + ExtractFileName(APath) + ' — ' + DescribeMedia(Info));
|
||
if Info.ExtraStreams > 0 then
|
||
Log(' в файле ещё ' + IntToStr(Info.ExtraStreams) +
|
||
' поток(ов) — телеметрия или обложка, при сборке они отбрасываются');
|
||
if Item = FProject.Pool[0] then
|
||
begin
|
||
Log(' параметры проекта взяты из этого файла');
|
||
PrewarmInserts;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.ChooseAndAddFiles(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
begin
|
||
if not OpenMediaDialog.Execute then
|
||
Exit;
|
||
FSettings.LastMediaDir := ExtractFilePath(OpenMediaDialog.FileName);
|
||
for I := 0 to OpenMediaDialog.Files.Count - 1 do
|
||
AddMediaFile(OpenMediaDialog.Files[I]);
|
||
RefreshPool;
|
||
UpdateCaption;
|
||
end;
|
||
|
||
{ Кладёт файл из списка проекта на дорожку.
|
||
|
||
Общая точка для кнопки «На таймлайн» и для перетаскивания мышью:
|
||
предупреждение о несовпадении параметров и выбор места должны работать
|
||
одинаково, каким бы способом файл ни попал на монтаж.
|
||
|
||
ATrackIndex = -1 означает «завести новую дорожку внизу». }
|
||
function TMainForm.AddClipFromPool(APoolIndex, ATrackIndex: Integer;
|
||
const ATime: Double): Boolean;
|
||
var
|
||
Item: TMediaItem;
|
||
Track: TTrack;
|
||
Mismatches: TMismatches;
|
||
Duration, PlaceAt: Double;
|
||
NormPath: string;
|
||
begin
|
||
Result := False;
|
||
if (APoolIndex < 0) or (APoolIndex >= FProject.PoolCount) then
|
||
begin
|
||
SetStatus('Сначала выберите файл в списке.');
|
||
Exit;
|
||
end;
|
||
Item := FProject.Pool[APoolIndex];
|
||
|
||
if ATrackIndex < 0 then
|
||
begin
|
||
FProject.AddTrack('V' +
|
||
IntToStr(FProject.TrackCountOf(tkVideo) + 1));
|
||
ATrackIndex := FProject.TrackCount - 1;
|
||
Log('Заведена дорожка ' + FProject.Tracks[ATrackIndex].Name);
|
||
end;
|
||
if ATrackIndex >= FProject.TrackCount then
|
||
ATrackIndex := FProject.TrackCount - 1;
|
||
Track := FProject.Tracks[ATrackIndex];
|
||
|
||
{ Предупреждаем именно здесь, при попадании на монтаж: пока файл просто
|
||
лежит в списке, он ни с чем не склеивается. }
|
||
Mismatches := CompareToMaster(FProject.Master, Item.Info);
|
||
if Length(Mismatches) > 0 then
|
||
case AskAboutMismatch(Self, Item.Path, Mismatches) of
|
||
mcCancel:
|
||
Exit;
|
||
mcNormalize:
|
||
begin
|
||
NormPath := FProject.CacheDir + 'norm' + PathDelim +
|
||
ChangeFileExt(ExtractFileName(Item.Path), '') + '.mkv';
|
||
if not ForceDirectories(ExtractFilePath(NormPath)) then
|
||
begin
|
||
Log('Не удалось создать каталог для приведённых файлов.');
|
||
Exit;
|
||
end;
|
||
|
||
FNormalize := TFfmpegJob.Create(
|
||
ArgsNormalize(Item.Path, NormPath,
|
||
FProject.Master.Width, FProject.Master.Height,
|
||
FProject.Master.FpsNum, FProject.Master.FpsDen,
|
||
FProject.Master.VideoCodec, FProject.Master.PixFmt,
|
||
FProject.Master.AudioCodec,
|
||
FProject.Master.SampleRate, FProject.Master.Channels,
|
||
TransformFilter(Item.Transform, Item.Info.Width, Item.Info.Height,
|
||
FProject.Master.Width, FProject.Master.Height)),
|
||
Item.Info.Duration, 'Привожу к параметрам проекта', NormPath);
|
||
|
||
FNormalize.OnProgress := @NormalizeProgress;
|
||
FNormalize.OnLog := @NormalizeLog;
|
||
FNormalize.OnTerminate := @NormalizeDone;
|
||
|
||
FNormalizeUi := TProgressForm.Create(Self);
|
||
try
|
||
FNormalizeUi.Caption := 'Приведение к параметрам проекта';
|
||
FNormalizeUi.OnCancelRequest := @NormalizeCancel;
|
||
FNormalize.Start;
|
||
FNormalizeUi.ShowModal;
|
||
finally
|
||
FreeAndNil(FNormalizeUi);
|
||
end;
|
||
|
||
FNormalize.WaitFor;
|
||
if not FNormalize.Succeeded then
|
||
begin
|
||
Log('Приведение не удалось: ' + FNormalize.Message);
|
||
FreeAndNil(FNormalize);
|
||
Exit;
|
||
end;
|
||
FreeAndNil(FNormalize);
|
||
|
||
Item.NormalizedPath := NormPath;
|
||
{ Индекс опорных кадров относился к исходнику, у приведённой
|
||
копии он свой. }
|
||
Item.IndexLoaded := False;
|
||
Log('Файл приведён к параметрам проекта: ' + NormPath);
|
||
end;
|
||
end;
|
||
|
||
if Item.Info.Kind = mkImage then
|
||
Duration := DefaultImageDuration
|
||
else
|
||
Duration := Item.Info.Duration;
|
||
if Duration <= 0 then
|
||
Duration := DefaultImageDuration;
|
||
|
||
{ Ставим туда, куда попросили. Если там занято — в конец дорожки: молча
|
||
накладывать клипы друг на друга нельзя, порядок перекрытия должен быть
|
||
осознанным. }
|
||
PlaceAt := Max(0, ATime);
|
||
if (Track.ClipAt(PlaceAt) <> nil) or
|
||
(Track.ClipAt(PlaceAt + Duration - 0.001) <> nil) then
|
||
begin
|
||
PlaceAt := Track.EndTime;
|
||
Log('На дорожке ' + Track.Name + ' в этом месте занято — поставил в конец.');
|
||
end;
|
||
|
||
FProject.BeginChange;
|
||
{ Парой: клип картинки и его звук на соответствующей звуковой дорожке.
|
||
Связка держит их вместе, пока её не развяжут по Ctrl+G. }
|
||
FProject.AddClipPair(Track, Item, 0, Duration, PlaceAt);
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
UpdateTimeLabel;
|
||
SetStatus('Добавлен клип на дорожку ' + Track.Name);
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TMainForm.TimelineActiveTrackChange(Sender: TObject);
|
||
begin
|
||
if (FTimeline.ActiveTrack >= 0) and
|
||
(FTimeline.ActiveTrack < FProject.TrackCount) then
|
||
SetStatus('Выбрана дорожка ' +
|
||
FProject.Tracks[FTimeline.ActiveTrack].Name);
|
||
end;
|
||
|
||
{ Файл притащили мышью прямо на дорожку. }
|
||
procedure TMainForm.TimelineMediaDrop(Sender: TObject; ASource: TObject;
|
||
ATrackIndex: Integer; const ATime: Double);
|
||
begin
|
||
if ASource <> lstPool then
|
||
Exit;
|
||
AddClipFromPool(SelectedPoolIndex(lstPool), ATrackIndex, ATime);
|
||
end;
|
||
|
||
{ Дорожку завёл сам компонент, когда клип утащили ниже последней. }
|
||
procedure TMainForm.TimelineTrackAdded(Sender: TObject);
|
||
begin
|
||
UpdateCaption;
|
||
end;
|
||
|
||
{ --- Предпросмотр --- }
|
||
|
||
{ Готовит заготовку чёрной вставки заранее, чтобы первая дыра на монтаже
|
||
появилась мгновенно. }
|
||
procedure TMainForm.PrewarmInserts;
|
||
var
|
||
Requests: TGenRequests;
|
||
begin
|
||
if FGenerateBusy or (not FProject.MasterSet) then
|
||
Exit;
|
||
Requests := PrewarmRequests(FProject.CacheDir);
|
||
if Length(Requests) = 0 then
|
||
Exit;
|
||
|
||
FGenerateBusy := True;
|
||
FGenerate := TGenerateThread.Create(Requests, FProject.Master);
|
||
FGenerate.OnProgress := @GenerateProgress;
|
||
FGenerate.OnLog := @GenerateLog;
|
||
FGenerate.OnTerminate := @GenerateDone;
|
||
FGenerate.Start;
|
||
end;
|
||
|
||
procedure TMainForm.SchedulePreview;
|
||
begin
|
||
FPreviewDirty := True;
|
||
FPreviewTimer.Enabled := False;
|
||
FPreviewTimer.Enabled := True;
|
||
end;
|
||
|
||
procedure TMainForm.PreviewTimerTick(Sender: TObject);
|
||
begin
|
||
FPreviewTimer.Enabled := False;
|
||
if FPreviewDirty then
|
||
begin
|
||
FPreviewDirty := False;
|
||
RebuildPreview;
|
||
end;
|
||
end;
|
||
|
||
function TMainForm.PreviewNeedsFitting: Boolean;
|
||
var
|
||
T, C: Integer;
|
||
Track: TTrack;
|
||
Item: TMediaItem;
|
||
begin
|
||
Result := False;
|
||
if not FProject.MasterSet then
|
||
Exit;
|
||
|
||
for T := 0 to FProject.TrackCount - 1 do
|
||
begin
|
||
Track := FProject.Tracks[T];
|
||
for C := 0 to Track.Count - 1 do
|
||
begin
|
||
Item := FProject.FindMedia(Track.Clips[C].MediaId);
|
||
if (Item = nil) or (not Item.Info.HasVideo) then
|
||
Continue;
|
||
if (Item.Info.Width <= 0) or (Item.Info.Height <= 0) then
|
||
Continue;
|
||
|
||
{ Сравниваем именно соотношение сторон, а не размеры: файл 3840x2160
|
||
в проекте 2688x1512 показывается верно и без всякого фильтра —
|
||
mpv сам впишет его в панель, и картинка совпадёт до пикселя.
|
||
Умножение вместо деления, чтобы не ловить погрешность дробей. }
|
||
if Item.Info.Width * FProject.Master.Height <>
|
||
Item.Info.Height * FProject.Master.Width then
|
||
Exit(True);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.ApplyPreviewFrame;
|
||
begin
|
||
if (FPlayer = nil) or (not FPlayer.Initialized) then
|
||
Exit;
|
||
|
||
if PreviewNeedsFitting then
|
||
begin
|
||
{ Порядок важен: сначала переводим декодирование в обычную память,
|
||
иначе фильтру нечего будет обрабатывать и он откажется собираться. }
|
||
FPlayer.SetHwdec('auto-copy');
|
||
FPlayer.SetVideoFilter(
|
||
PreviewFitFilter(FProject.Master.Width, FProject.Master.Height));
|
||
end
|
||
else
|
||
begin
|
||
{ И обратно: сначала снимаем фильтр, потом возвращаем быстрый путь. }
|
||
FPlayer.SetVideoFilter('');
|
||
FPlayer.SetHwdec('auto-safe');
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.RebuildPreview;
|
||
var
|
||
Segments, AudioSegs, TrackSegs: TFlatSegmentArray;
|
||
Missing, TrackMissing: TGenRequests;
|
||
I, J: Integer;
|
||
TotalLen: Double;
|
||
begin
|
||
if (FPlayer = nil) or (not FPlayer.Initialized) then
|
||
Exit;
|
||
if FGenerateBusy then
|
||
begin
|
||
{ Пока идёт создание вставок, пересборку откладываем: иначе запустим
|
||
второй такой же поток. }
|
||
FPreviewDirty := True;
|
||
FPreviewTimer.Enabled := True;
|
||
Exit;
|
||
end;
|
||
|
||
if not FlattenProject(FProject, Segments, AudioSegs, Missing) then
|
||
begin
|
||
FPlayer.Stop;
|
||
FLastLoadedEdl := '';
|
||
UpdateTimeLabel;
|
||
Exit;
|
||
end;
|
||
|
||
{ Каждая звуковая дорожка идёт своим списком кусков: они смешиваются, а
|
||
не побеждают друг друга. Дыры в каждой дорожке свои, и вставки тишины
|
||
под них нужны свои — без этого список ссылается на несуществующий
|
||
файл, плеер его не открывает, и дорожка молчит целиком. }
|
||
FPreviewAudioUrls := nil;
|
||
FPreviewAudioTracks := nil;
|
||
TotalLen := Max(AudibleEnd(FProject, tkVideo), AudibleEnd(FProject, tkAudio));
|
||
for I := 0 to FProject.TrackCount - 1 do
|
||
begin
|
||
if FProject.Tracks[I].Kind <> tkAudio then
|
||
Continue;
|
||
if not FProject.TrackAudible(FProject.Tracks[I]) then
|
||
Continue;
|
||
if FProject.Tracks[I].Count = 0 then
|
||
Continue;
|
||
if not FlattenAudioTrack(FProject, FProject.Tracks[I], TotalLen,
|
||
TrackSegs, TrackMissing) then
|
||
Continue;
|
||
for J := 0 to High(TrackMissing) do
|
||
begin
|
||
SetLength(Missing, Length(Missing) + 1);
|
||
Missing[High(Missing)] := TrackMissing[J];
|
||
end;
|
||
SetLength(FPreviewAudioUrls, Length(FPreviewAudioUrls) + 1);
|
||
FPreviewAudioUrls[High(FPreviewAudioUrls)] := BuildEdlUri(TrackSegs);
|
||
{ Запоминаем сами дорожки: громкости потом берутся ровно по этому
|
||
списку. Пересчитывать его отдельным проходом нельзя — стоит одному
|
||
проходу пропустить дорожку, и громкости съедут на соседние. Тогда
|
||
дорожка с нулевой громкостью заглушила бы чужую. }
|
||
SetLength(FPreviewAudioTracks, Length(FPreviewAudioTracks) + 1);
|
||
FPreviewAudioTracks[High(FPreviewAudioTracks)] := FProject.Tracks[I];
|
||
end;
|
||
|
||
if Length(Missing) > 0 then
|
||
begin
|
||
FGenerateBusy := True;
|
||
SetStatus('Готовлю вставки для предпросмотра...');
|
||
FGenerate := TGenerateThread.Create(Missing, FProject.Master);
|
||
FGenerate.OnProgress := @GenerateProgress;
|
||
FGenerate.OnLog := @GenerateLog;
|
||
FGenerate.OnTerminate := @GenerateDone;
|
||
FGenerate.Start;
|
||
Exit;
|
||
end;
|
||
|
||
LoadPreviewEdl(Segments, AudioSegs);
|
||
end;
|
||
|
||
procedure TMainForm.LoadPreviewEdl(const ASegments, AAudio: TFlatSegmentArray);
|
||
var
|
||
Edl, AudioEdl: string;
|
||
Pos, Total: Double;
|
||
WasPaused: Boolean;
|
||
I: Integer;
|
||
begin
|
||
{ Кадр проекта задаётся до загрузки: mpv должен показывать то, что
|
||
получится в готовом ролике, а не размер очередного исходника. Файл
|
||
другого соотношения сторон иначе выглядел бы в предпросмотре во весь
|
||
экран, а в ролике — с полями по краям. }
|
||
ApplyPreviewFrame;
|
||
|
||
Edl := BuildEdlUri(ASegments);
|
||
{ Списки кусков звуковых дорожек уже построены при пересборке: там же
|
||
проверено, что все вставки тишины существуют. }
|
||
AudioEdl := '';
|
||
for I := 0 to High(FPreviewAudioUrls) do
|
||
AudioEdl := AudioEdl + FPreviewAudioUrls[I] + '|';
|
||
|
||
{ Список кусков запоминаем всегда, даже если строка не изменилась:
|
||
громкость в неё не входит, а брать её потом неоткуда. }
|
||
FPreviewSegments := AAudio;
|
||
FLastVolumeSent := -1;
|
||
if (Edl = FLastLoadedEdl) and (AudioEdl = FLastLoadedAudioEdl) then
|
||
Exit;
|
||
|
||
Pos := FTimeline.Playhead;
|
||
{ Курсор мог оказаться за концом монтажа, если правка его укоротила.
|
||
Просить у плеера несуществующее время бессмысленно. }
|
||
Total := TotalDuration(ASegments);
|
||
if Pos > Total then
|
||
Pos := Max(0, Total - 0.05);
|
||
WasPaused := FPlayer.Paused;
|
||
|
||
{ Позиция и состояние паузы задаются прямо при загрузке, а не отдельной
|
||
перемоткой следом. Иначе mpv успевает начать с нуля, и на каждой
|
||
правке монтажа слышен и виден кусок не оттуда. }
|
||
{ Внешний звук назначается до загрузки: он часть того, что открывается. }
|
||
FPlayer.SetAudioSources(FPreviewAudioUrls);
|
||
FPlayer.LoadUrl(Edl, Format('start=%s,pause=%s',
|
||
[SecondsToStr(Pos), BoolToStr(WasPaused, 'yes', 'no')]));
|
||
FLastLoadedEdl := Edl;
|
||
FLastLoadedAudioEdl := AudioEdl;
|
||
|
||
{ Пока плеер не доедет, его сообщения о позиции игнорируются — иначе
|
||
курсор на монтаже прыгнул бы в начало при каждой правке. }
|
||
FSeekTarget := Pos;
|
||
FSeekPending := True;
|
||
FSeekWaitTicks := 0;
|
||
|
||
SetStatus(Format('Предпросмотр: %d %s, %s с',
|
||
[Length(ASegments), Plural(Length(ASegments), 'кусок', 'куска', 'кусков'),
|
||
SecondsToStr(TotalDuration(ASegments))]));
|
||
UpdateTimeLabel;
|
||
end;
|
||
|
||
{ Ставит плееру громкость того куска, который звучит сейчас.
|
||
|
||
Композитинга нет, поэтому в каждый момент звучит ровно один кусок, и
|
||
громкость всего вывода можно просто приравнять его громкости. Ставим
|
||
только при изменении: команда на каждый кадр была бы напрасной. }
|
||
{ --- Недавние проекты --- }
|
||
|
||
procedure TMainForm.RefreshRecentMenu;
|
||
var
|
||
I: Integer;
|
||
Item: TMenuItem;
|
||
begin
|
||
if FRecentMenu = nil then
|
||
Exit;
|
||
FRecentMenu.Clear;
|
||
|
||
for I := 0 to FSettings.RecentProjects.Count - 1 do
|
||
begin
|
||
Item := TMenuItem.Create(FRecentMenu);
|
||
{ Номер в начале даёт быстрый выбор глазами, а полный путь в подсказке
|
||
различает одноимённые проекты из разных папок. }
|
||
Item.Caption := Format('%d. %s',
|
||
[I + 1, ExtractFileName(FSettings.RecentProjects[I])]);
|
||
Item.Hint := FSettings.RecentProjects[I];
|
||
Item.Tag := I;
|
||
Item.OnClick := @OpenRecentProject;
|
||
FRecentMenu.Add(Item);
|
||
end;
|
||
|
||
FRecentMenu.Enabled := FSettings.RecentProjects.Count > 0;
|
||
|
||
{ Пункты добавлены только что, своих цветов у них ещё нет. }
|
||
ApplyDarkMenu(FRecentMenu.GetParentMenu);
|
||
end;
|
||
|
||
procedure TMainForm.OpenRecentProject(Sender: TObject);
|
||
var
|
||
Idx: Integer;
|
||
Path: string;
|
||
begin
|
||
Idx := TMenuItem(Sender).Tag;
|
||
if (Idx < 0) or (Idx >= FSettings.RecentProjects.Count) then
|
||
Exit;
|
||
Path := FSettings.RecentProjects[Idx];
|
||
|
||
if not FileExists(Path) then
|
||
begin
|
||
ThemedMessageDlg('nlve', 'Файл больше не существует:' + LineEnding + Path,
|
||
mtWarning, [mbOK], 0);
|
||
FSettings.RecentProjects.Delete(Idx);
|
||
RefreshRecentMenu;
|
||
Exit;
|
||
end;
|
||
|
||
if not ConfirmDiscard then
|
||
Exit;
|
||
OpenProjectFile(Path);
|
||
end;
|
||
|
||
{ Открытие проекта из файла. Общая точка для меню, списка недавних и
|
||
командной строки: иначе часть из них забывала бы что-нибудь обновить. }
|
||
function TMainForm.OpenProjectFile(const APath: string): Boolean;
|
||
var
|
||
Err: string;
|
||
begin
|
||
Result := FProject.LoadFromFile(APath, Err);
|
||
if not Result then
|
||
begin
|
||
ThemedMessageDlg('nlve', Err, mtError, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
|
||
FTimeline.Playhead := 0;
|
||
FTimeline.ZoomToFit;
|
||
FLastLoadedEdl := '';
|
||
RefreshPool;
|
||
UpdateRippleButton;
|
||
UpdateCaption;
|
||
SchedulePreview;
|
||
|
||
FSettings.NoteRecentProject(FProject.FileName);
|
||
RefreshRecentMenu;
|
||
Log('Открыт проект: ' + FProject.FileName);
|
||
end;
|
||
|
||
{ --- Схлопывание --- }
|
||
|
||
{ Кнопка показывает и состояние, и режим: утоплена — автосхлопывание
|
||
включено, надпись говорит, на какие дорожки оно действует. }
|
||
procedure TMainForm.UpdateRippleButton;
|
||
var
|
||
ModeText: string;
|
||
begin
|
||
if FProject.RippleMode = rmAllTracks then
|
||
ModeText := 'все дорожки'
|
||
else
|
||
ModeText := 'текущая дорожка';
|
||
btnRipple.Caption := 'Схлопывание: ' + ModeText;
|
||
btnRipple.Down := FProject.RippleEnabled;
|
||
btnRipple.Hint := 'Ctrl+K — включить или выключить. ' +
|
||
'Режим действует и при выключенном автосхлопывании: по нему работает Ctrl+Shift+R.';
|
||
end;
|
||
|
||
{ Прилипание краёв клипов друг к другу.
|
||
|
||
Shift работает как переключатель наоборот: при включённом прилипании
|
||
временно отключает его, при выключенном — временно включает. Так одна
|
||
клавиша полезна в обоих режимах, и не нужно помнить, какой сейчас. }
|
||
procedure TMainForm.UpdateSnapButton;
|
||
begin
|
||
btnSnap.Down := FTimeline.SnapEnabled;
|
||
if FTimeline.SnapEnabled then
|
||
btnSnap.Caption := 'Прилипание: вкл'
|
||
else
|
||
btnSnap.Caption := 'Прилипание: выкл';
|
||
btnSnap.Hint := 'Shift во время перетаскивания меняет решение на противоположное.';
|
||
end;
|
||
|
||
procedure TMainForm.btnSnapClick(Sender: TObject);
|
||
begin
|
||
FTimeline.SnapEnabled := not FTimeline.SnapEnabled;
|
||
UpdateSnapButton;
|
||
end;
|
||
|
||
procedure TMainForm.ToggleRipple;
|
||
begin
|
||
FProject.RippleEnabled := not FProject.RippleEnabled;
|
||
UpdateRippleButton;
|
||
if FProject.RippleEnabled then
|
||
SetStatus('Автосхлопывание включено: клипы правее едут вместе с перетаскиваемым.')
|
||
else
|
||
SetStatus('Автосхлопывание выключено: клипы правее остаются на месте.');
|
||
end;
|
||
|
||
procedure TMainForm.btnRippleClick(Sender: TObject);
|
||
begin
|
||
ToggleRipple;
|
||
end;
|
||
|
||
procedure TMainForm.RippleModeChosen(Sender: TObject);
|
||
begin
|
||
if TMenuItem(Sender).Tag = 1 then
|
||
FProject.RippleMode := rmAllTracks
|
||
else
|
||
FProject.RippleMode := rmCurrentTrack;
|
||
{ Выбор режима из списка заодно включает автосхлопывание: иначе выбор
|
||
выглядел бы так, будто ничего не произошло. }
|
||
FProject.RippleEnabled := True;
|
||
UpdateRippleButton;
|
||
end;
|
||
|
||
procedure TMainForm.btnRippleMenuClick(Sender: TObject);
|
||
var
|
||
P: TPoint;
|
||
I: Integer;
|
||
begin
|
||
for I := 0 to FRippleMenu.Items.Count - 1 do
|
||
FRippleMenu.Items[I].Checked :=
|
||
(FRippleMenu.Items[I].Tag = 1) = (FProject.RippleMode = rmAllTracks);
|
||
P := btnRippleMenu.ClientToScreen(Point(0, btnRippleMenu.Height));
|
||
FRippleMenu.PopUp(P.X, P.Y);
|
||
end;
|
||
|
||
{ --- Меню библиотеки --- }
|
||
|
||
procedure TMainForm.BuildPoolMenu;
|
||
var
|
||
Item: TMenuItem;
|
||
begin
|
||
FPoolMenu := TPopupMenu.Create(Self);
|
||
FPoolMenu.OnPopup := @PoolMenuPopup;
|
||
|
||
FPoolAddMenu := TMenuItem.Create(FPoolMenu);
|
||
FPoolAddMenu.Caption := 'Добавить на дорожку';
|
||
FPoolMenu.Items.Add(FPoolAddMenu);
|
||
|
||
Item := TMenuItem.Create(FPoolMenu);
|
||
Item.Caption := '-';
|
||
FPoolMenu.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(FPoolMenu);
|
||
Item.Caption := 'Кадрирование и поворот...';
|
||
Item.OnClick := @PoolEditTransform;
|
||
FPoolMenu.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(FPoolMenu);
|
||
Item.Caption := '-';
|
||
FPoolMenu.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(FPoolMenu);
|
||
Item.Caption := 'Убрать со всех дорожек';
|
||
Item.OnClick := @PoolRemoveFromTracks;
|
||
FPoolMenu.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(FPoolMenu);
|
||
Item.Caption := 'Удалить из проекта';
|
||
Item.OnClick := @PoolRemoveFromProject;
|
||
FPoolMenu.Items.Add(Item);
|
||
|
||
lstPool.PopupMenu := FPoolMenu;
|
||
|
||
{ Меню режимов схлопывания. }
|
||
FRippleMenu := TPopupMenu.Create(Self);
|
||
|
||
Item := TMenuItem.Create(FRippleMenu);
|
||
Item.Caption := 'Только текущая дорожка';
|
||
Item.RadioItem := True;
|
||
Item.Tag := 0;
|
||
Item.OnClick := @RippleModeChosen;
|
||
FRippleMenu.Items.Add(Item);
|
||
|
||
Item := TMenuItem.Create(FRippleMenu);
|
||
Item.Caption := 'Все дорожки';
|
||
Item.RadioItem := True;
|
||
Item.Tag := 1;
|
||
Item.OnClick := @RippleModeChosen;
|
||
FRippleMenu.Items.Add(Item);
|
||
end;
|
||
|
||
{ Список дорожек в подменю строится при каждом открытии: дорожки
|
||
добавляются и удаляются, а держать меню в согласии с ними постоянно
|
||
дороже, чем собрать его заново. }
|
||
{ Правый щелчок выделяет файл под курсором.
|
||
|
||
Сам по себе список этого не делает: правая кнопка выделение не меняет.
|
||
А меню без выделенного файла отключается целиком и выглядит так, будто
|
||
оно не работает вовсе. }
|
||
procedure TMainForm.lstPoolMouseDown(Sender: TObject; Button: TMouseButton;
|
||
Shift: TShiftState; X, Y: Integer);
|
||
var
|
||
Idx: Integer;
|
||
begin
|
||
if Button <> mbRight then
|
||
Exit;
|
||
Idx := lstPool.ItemAtPos(Point(X, Y), True);
|
||
if Idx >= 0 then
|
||
lstPool.ItemIndex := Idx;
|
||
end;
|
||
|
||
procedure TMainForm.PoolMenuPopup(Sender: TObject);
|
||
var
|
||
I: Integer;
|
||
Item: TMenuItem;
|
||
{ Не Enabled: это имя занято свойством формы. }
|
||
HasSelection: Boolean;
|
||
begin
|
||
FPoolAddMenu.Clear;
|
||
for I := 0 to FProject.TrackCount - 1 do
|
||
begin
|
||
Item := TMenuItem.Create(FPoolAddMenu);
|
||
Item.Caption := FProject.Tracks[I].Name;
|
||
Item.Tag := I;
|
||
Item.OnClick := @PoolAddToTrack;
|
||
FPoolAddMenu.Add(Item);
|
||
end;
|
||
|
||
HasSelection := SelectedPoolIndex(lstPool) >= 0;
|
||
for I := 0 to FPoolMenu.Items.Count - 1 do
|
||
FPoolMenu.Items[I].Enabled := HasSelection;
|
||
end;
|
||
|
||
procedure TMainForm.PoolAddToTrack(Sender: TObject);
|
||
begin
|
||
AddClipFromPool(SelectedPoolIndex(lstPool), TMenuItem(Sender).Tag,
|
||
FTimeline.Playhead);
|
||
end;
|
||
|
||
{ Убирает клипы файла со всех дорожек, оставляя сам файл в проекте.
|
||
Дыры намеренно не схлопываются: убрать клип и переставить всё остальное —
|
||
два разных намерения. }
|
||
procedure TMainForm.PoolRemoveFromTracks(Sender: TObject);
|
||
var
|
||
Idx, T, C, Removed: Integer;
|
||
Item: TMediaItem;
|
||
Track: TTrack;
|
||
begin
|
||
Idx := SelectedPoolIndex(lstPool);
|
||
if (Idx < 0) or (Idx >= FProject.PoolCount) then
|
||
Exit;
|
||
Item := FProject.Pool[Idx];
|
||
|
||
FProject.BeginChange;
|
||
Removed := 0;
|
||
for T := 0 to FProject.TrackCount - 1 do
|
||
begin
|
||
Track := FProject.Tracks[T];
|
||
for C := Track.Count - 1 downto 0 do
|
||
if Track[C].MediaId = Item.Id then
|
||
begin
|
||
Track.Remove(Track[C]);
|
||
Inc(Removed);
|
||
end;
|
||
end;
|
||
|
||
if Removed = 0 then
|
||
begin
|
||
FProject.CancelChange;
|
||
SetStatus('Клипов этого файла на монтаже нет.');
|
||
Exit;
|
||
end;
|
||
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
SetStatus(Format('Убрано %d %s',
|
||
[Removed, Plural(Removed, 'клип', 'клипа', 'клипов')]));
|
||
end;
|
||
|
||
{ Кадрирование отдельного клипа. Вызывается кнопкой в углу клипа.
|
||
|
||
Настройка принадлежит клипу: два куска одного файла бывает нужно
|
||
кадрировать по-разному. У файла хранится такая же, но она лишь
|
||
заготовка для новых клипов. }
|
||
procedure TMainForm.TimelineClipTransform(Sender: TObject; AClip: TClip);
|
||
var
|
||
Item: TMediaItem;
|
||
T: TMediaTransform;
|
||
begin
|
||
if AClip = nil then
|
||
Exit;
|
||
Item := FProject.FindMedia(AClip.MediaId);
|
||
if Item = nil then
|
||
Exit;
|
||
|
||
if not FProject.MasterSet then
|
||
begin
|
||
ThemedMessageDlg('nlve',
|
||
'Параметры проекта ещё не заданы: добавьте сначала видеофайл.',
|
||
mtInformation, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
|
||
T := AClip.Transform;
|
||
if not EditTransform(Self, Item.EffectivePath, Item.Info,
|
||
FProject.Master.Width, FProject.Master.Height, T,
|
||
FProject.CacheDir + 'pancrop.png') then
|
||
Exit;
|
||
|
||
FProject.BeginChange;
|
||
AClip.Transform := T;
|
||
FTimeline.Invalidate;
|
||
FLastLoadedEdl := '';
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
end;
|
||
|
||
{ Заготовка кадрирования для файла: её берёт новый клип при добавлении. }
|
||
procedure TMainForm.PoolEditTransform(Sender: TObject);
|
||
var
|
||
Idx: Integer;
|
||
Item: TMediaItem;
|
||
T: TMediaTransform;
|
||
begin
|
||
Idx := SelectedPoolIndex(lstPool);
|
||
if (Idx < 0) or (Idx >= FProject.PoolCount) then
|
||
Exit;
|
||
Item := FProject.Pool[Idx];
|
||
|
||
if not FProject.MasterSet then
|
||
begin
|
||
ThemedMessageDlg('nlve',
|
||
'Параметры проекта ещё не заданы: добавьте сначала видеофайл.',
|
||
mtInformation, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
|
||
T := Item.Transform;
|
||
if not EditTransform(Self, Item.Path, Item.Info,
|
||
FProject.Master.Width, FProject.Master.Height, T,
|
||
FProject.CacheDir + 'pancrop.png') then
|
||
Exit;
|
||
|
||
FProject.BeginChange;
|
||
Item.Transform := T;
|
||
{ Приведённая копия сделана со старыми настройками и больше не годится. }
|
||
if Item.NormalizedPath <> '' then
|
||
begin
|
||
Item.NormalizedPath := '';
|
||
Item.IndexLoaded := False;
|
||
Log('Настройки кадра изменились — приведённую копию надо сделать заново.');
|
||
end;
|
||
UpdateCaption;
|
||
SchedulePreview;
|
||
SetStatus('Кадрирование обновлено: ' + FitModeCaption(T.Fit));
|
||
end;
|
||
|
||
procedure TMainForm.MenuProjectInfo(Sender: TObject);
|
||
begin
|
||
ShowProjectInfo(Self, FProject);
|
||
end;
|
||
|
||
procedure TMainForm.PoolRemoveFromProject(Sender: TObject);
|
||
var
|
||
Idx: Integer;
|
||
Item: TMediaItem;
|
||
begin
|
||
Idx := SelectedPoolIndex(lstPool);
|
||
if (Idx < 0) or (Idx >= FProject.PoolCount) then
|
||
Exit;
|
||
Item := FProject.Pool[Idx];
|
||
|
||
if ThemedMessageDlg('nlve', 'Удалить ' + ExtractFileName(Item.Path) +
|
||
' из проекта? Его клипы пропадут со всех дорожек.',
|
||
mtConfirmation, [mbYes, mbNo], 0) <> mrYes then
|
||
Exit;
|
||
|
||
FProject.BeginChange;
|
||
FProject.RemoveMedia(Item);
|
||
RefreshPool;
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
end;
|
||
|
||
{ Файлы бросили на окно программы.
|
||
|
||
Место броска решает, что с ними делать: над монтажом — сразу и в проект,
|
||
и на дорожку под указателем; в любом другом месте — только в проект.
|
||
Своих координат обработчик не получает, поэтому берём положение
|
||
указателя. }
|
||
procedure TMainForm.FormFilesDropped(Sender: TObject;
|
||
const FileNames: array of string);
|
||
var
|
||
I, TrackIdx: Integer;
|
||
Pt: TPoint;
|
||
OverTimeline: Boolean;
|
||
DropTime: Double;
|
||
Added: Boolean;
|
||
begin
|
||
Pt := FTimeline.ScreenToClient(Mouse.CursorPos);
|
||
OverTimeline := (Pt.X >= 0) and (Pt.Y >= 0) and
|
||
(Pt.X < FTimeline.Width) and (Pt.Y < FTimeline.Height);
|
||
|
||
Added := False;
|
||
for I := 0 to High(FileNames) do
|
||
if FileExists(FileNames[I]) then
|
||
begin
|
||
AddMediaFile(ExpandFileName(FileNames[I]));
|
||
Added := True;
|
||
end;
|
||
if not Added then
|
||
Exit;
|
||
|
||
RefreshPool;
|
||
UpdateCaption;
|
||
|
||
if not OverTimeline then
|
||
begin
|
||
SetStatus('Файлы добавлены в проект.');
|
||
Exit;
|
||
end;
|
||
|
||
{ Бросили над монтажом — кладём последний добавленный на дорожку под
|
||
указателем. }
|
||
lstPool.ItemIndex := FProject.PoolCount - 1;
|
||
TrackIdx := FTimeline.TrackIndexAtPoint(Pt.Y);
|
||
DropTime := FTimeline.TimeAtPoint(Pt.X);
|
||
AddClipFromPool(FProject.PoolCount - 1, TrackIdx, DropTime);
|
||
end;
|
||
|
||
{ Громкость клипов в предпросмотре.
|
||
|
||
Дорожки смешиваются, поэтому одной общей громкостью не обойтись: у
|
||
каждой дорожки под курсором свой клип со своей громкостью. Значения
|
||
собираются по дорожкам и отдаются плееру; он подставляет их в свою
|
||
цепочку смешивания.
|
||
|
||
Пересобирать цепочку на каждый кадр нельзя — она создаётся заново и
|
||
звук щёлкает. Поэтому только при изменении. }
|
||
procedure TMainForm.ApplyVolumeAt(const ATime: Double);
|
||
var
|
||
I: Integer;
|
||
Clip: TClip;
|
||
Vols: array of Double;
|
||
Key: string;
|
||
begin
|
||
if (FPlayer = nil) or (not FPlayer.Initialized) then
|
||
Exit;
|
||
if FProject = nil then
|
||
Exit;
|
||
|
||
Vols := nil;
|
||
Key := '';
|
||
for I := 0 to High(FPreviewAudioTracks) do
|
||
begin
|
||
Clip := FPreviewAudioTracks[I].ClipAt(ATime);
|
||
SetLength(Vols, Length(Vols) + 1);
|
||
if Clip <> nil then
|
||
Vols[High(Vols)] := Clip.Volume
|
||
else
|
||
Vols[High(Vols)] := 1;
|
||
Key := Key + SecondsToStr(Vols[High(Vols)]) + ',';
|
||
end;
|
||
|
||
if Key = FLastVolumeKey then
|
||
Exit;
|
||
FLastVolumeKey := Key;
|
||
|
||
{ Кто какую громкость получил — в журнал. Иначе разбираться, почему в
|
||
одном месте звук есть, а в соседнем нет, приходится по снимкам
|
||
экрана. }
|
||
Key := '';
|
||
for I := 0 to High(FPreviewAudioTracks) do
|
||
begin
|
||
if Key <> '' then
|
||
Key := Key + ', ';
|
||
Key := Key + FPreviewAudioTracks[I].Name + '=' + SecondsToStr(Vols[I]);
|
||
end;
|
||
Log(Format('Громкости на %s: %s', [SecondsToStr(ATime), Key]));
|
||
|
||
FPlayer.SetTrackVolumes(Vols);
|
||
if FPlayer.AudioGraph <> '' then
|
||
Log('Цепочка звука: ' + FPlayer.AudioGraph);
|
||
end;
|
||
|
||
procedure TMainForm.GenerateProgress(Sender: TObject);
|
||
begin
|
||
SetStatus(FGenerate.StageText);
|
||
end;
|
||
|
||
procedure TMainForm.GenerateLog(Sender: TObject);
|
||
begin
|
||
Log(FGenerate.PendingLog);
|
||
end;
|
||
|
||
procedure TMainForm.GenerateDone(Sender: TObject);
|
||
var
|
||
Ok: Boolean;
|
||
Msg: string;
|
||
begin
|
||
Ok := FGenerate.Succeeded;
|
||
Msg := FGenerate.Message;
|
||
FGenerate := nil;
|
||
FGenerateBusy := False;
|
||
|
||
if not Ok then
|
||
begin
|
||
Log('Не удалось подготовить вставки: ' + Msg);
|
||
SetStatus('Вставки подготовить не удалось.');
|
||
Exit;
|
||
end;
|
||
|
||
{ Файлы появились — теперь список кусков соберётся целиком. }
|
||
SchedulePreview;
|
||
end;
|
||
|
||
{ --- Обработчики компонентов --- }
|
||
|
||
{ Перемотка с отметкой «ждём прибытия».
|
||
|
||
Плеер после перемотки, а тем более после перезагрузки списка кусков,
|
||
какое-то время сообщает старую позицию или ноль. Если верить этим
|
||
сообщениям, курсор на монтаже прыгнет в начало — именно это и
|
||
происходило при перетаскивании клипа. Поэтому до тех пор, пока плеер
|
||
не окажется рядом с запрошенным местом, его сообщения о позиции
|
||
игнорируются. }
|
||
procedure TMainForm.SeekPlayerTo(const ATime: Double);
|
||
begin
|
||
if (FPlayer = nil) or (not FPlayer.Initialized) then
|
||
Exit;
|
||
FSeekTarget := ATime;
|
||
FSeekPending := True;
|
||
FSeekWaitTicks := 0;
|
||
FPlayer.SeekAbsolute(ATime);
|
||
end;
|
||
|
||
procedure TMainForm.TimelinePlayheadChange(Sender: TObject);
|
||
begin
|
||
UpdateTimeLabel;
|
||
{ Если курсор двинул сам плеер, перематывать его обратно нельзя —
|
||
получится бесконечная переброска. }
|
||
if FUpdatingFromPlayer then
|
||
Exit;
|
||
SeekPlayerTo(FTimeline.Playhead);
|
||
end;
|
||
|
||
procedure TMainForm.TimelineStructureChange(Sender: TObject);
|
||
begin
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
UpdateTimeLabel;
|
||
end;
|
||
|
||
procedure TMainForm.TimelineSelectionChange(Sender: TObject);
|
||
begin
|
||
SetStatus(Format('Выделено %d %s', [FProject.SelectedCount,
|
||
Plural(FProject.SelectedCount, 'клип', 'клипа', 'клипов')]));
|
||
end;
|
||
|
||
procedure TMainForm.PlayerLog(Sender: TObject; const APrefix, ALevel, AText: string);
|
||
begin
|
||
Log('[' + ALevel + '] ' + APrefix + ': ' + TrimRight(AText));
|
||
end;
|
||
|
||
procedure TMainForm.PlayerTimePos(Sender: TObject);
|
||
begin
|
||
if FSeekPending then
|
||
begin
|
||
Inc(FSeekWaitTicks);
|
||
{ Ещё не доехали до запрошенного места — не трогаем курсор.
|
||
Но ждём не бесконечно: запрошенное время может оказаться за концом
|
||
монтажа, и тогда плеер до него не доедет никогда. }
|
||
if (Abs(FPlayer.TimePos - FSeekTarget) > 0.35) and
|
||
(FSeekWaitTicks < MaxSeekWaitTicks) then
|
||
Exit;
|
||
FSeekPending := False;
|
||
end;
|
||
|
||
{ Обновляем курсор только при заметном сдвиге: mpv сообщает позицию на
|
||
каждый кадр, и перерисовывать монтаж 60 раз в секунду незачем. }
|
||
if Abs(FPlayer.TimePos - FTimeline.Playhead) < 0.01 then
|
||
Exit;
|
||
|
||
ApplyVolumeAt(FPlayer.TimePos);
|
||
|
||
FUpdatingFromPlayer := True;
|
||
try
|
||
FTimeline.Playhead := FPlayer.TimePos;
|
||
{ Во время воспроизведения держим курсор посередине: так видно, что
|
||
будет дальше, и не приходится гоняться за ним прокруткой. }
|
||
if not FPlayer.Paused then
|
||
FTimeline.ScrollToPlayhead(True);
|
||
finally
|
||
FUpdatingFromPlayer := False;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.PlayerDuration(Sender: TObject);
|
||
var
|
||
Hw: string;
|
||
begin
|
||
UpdateTimeLabel;
|
||
|
||
{ Момент, когда файл уже открыт и про декодирование известно всё.
|
||
Сообщаем один раз на загрузку и только при смене: если декодирует
|
||
процессор, тяжёлый материал поедет рывками, и знать об этом надо
|
||
заранее, а не гадать, почему предпросмотр дёргается. }
|
||
Hw := FPlayer.HwdecCurrent;
|
||
if Hw = FLastHwdec then
|
||
Exit;
|
||
FLastHwdec := Hw;
|
||
|
||
if (Hw = '') or (Hw = 'no') then
|
||
begin
|
||
Log('Внимание: видео декодирует процессор. ' +
|
||
'Тяжёлый материал может идти рывками.');
|
||
{ Больше не пробуем. Иначе на каждой правке монтажа mpv заново
|
||
перебирает способы аппаратного декодирования, каждый раз впустую и
|
||
каждый раз с десятком строк ошибок в журнале. Так ведёт себя Wine,
|
||
где ни DXVA2, ни CUDA не работают. }
|
||
FPlayer.SetHwdec('no');
|
||
end
|
||
else
|
||
Log('Декодирование видео: ' + Hw);
|
||
|
||
{ Откуда взялся звук. Строка меняется редко, поэтому пишется только при
|
||
изменении — иначе журнал забился бы повторами. }
|
||
if FPlayer.AudioTrackNote <> FLastAudioNote then
|
||
begin
|
||
FLastAudioNote := FPlayer.AudioTrackNote;
|
||
if FLastAudioNote <> '' then
|
||
Log(FLastAudioNote);
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.PlayerPauseChange(Sender: TObject);
|
||
begin
|
||
{ Отдельной кнопки пуска нет — пробел делает то же самое, а состояние
|
||
видно по тому, едет ли курсор. Здесь остаётся только отметка в
|
||
строке состояния. }
|
||
if FPlayer.Paused then
|
||
SetStatus('Пауза')
|
||
else
|
||
SetStatus('Воспроизведение');
|
||
end;
|
||
|
||
{ Пуск и пауза. При запуске подтягиваем окно просмотра к курсору: если
|
||
он уехал за край, воспроизведение шло бы вслепую. Масштаб при этом не
|
||
трогаем — он выставлен осознанно. }
|
||
procedure TMainForm.TogglePlayback;
|
||
begin
|
||
if (FPlayer = nil) or (not FPlayer.Initialized) then
|
||
Exit;
|
||
if FPlayer.Paused then
|
||
FTimeline.ScrollToPlayhead(False);
|
||
FPlayer.TogglePause;
|
||
end;
|
||
|
||
|
||
|
||
procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
|
||
Shift: TShiftState);
|
||
begin
|
||
{ Пробел обрабатываем здесь, а не пунктом меню: пункт меню с пробелом
|
||
в качестве сочетания мешает вводу текста в других полях. }
|
||
if (Key = VK_SPACE) and (Shift = []) then
|
||
begin
|
||
Key := 0;
|
||
TogglePlayback;
|
||
end;
|
||
end;
|
||
|
||
{ --- Пункты меню --- }
|
||
|
||
procedure TMainForm.MenuNewProject(Sender: TObject);
|
||
begin
|
||
if not ConfirmDiscard then
|
||
Exit;
|
||
FProject.NewProject;
|
||
FTimeline.Playhead := 0;
|
||
FTimeline.ZoomToFit;
|
||
FLastLoadedEdl := '';
|
||
RefreshPool;
|
||
UpdateCaption;
|
||
SchedulePreview;
|
||
Log('Новый проект.');
|
||
end;
|
||
|
||
procedure TMainForm.MenuOpenProject(Sender: TObject);
|
||
var
|
||
Err: string;
|
||
begin
|
||
if not ConfirmDiscard then
|
||
Exit;
|
||
if not OpenProjectDialog.Execute then
|
||
Exit;
|
||
FSettings.LastProjectDir := ExtractFilePath(OpenProjectDialog.FileName);
|
||
OpenProjectFile(OpenProjectDialog.FileName);
|
||
end;
|
||
|
||
function TMainForm.SaveProjectAs: Boolean;
|
||
var
|
||
Err: string;
|
||
begin
|
||
Result := False;
|
||
if not SaveProjectDialog.Execute then
|
||
Exit;
|
||
FSettings.LastProjectDir := ExtractFilePath(SaveProjectDialog.FileName);
|
||
if not FProject.SaveToFile(SaveProjectDialog.FileName, Err) then
|
||
begin
|
||
ThemedMessageDlg('nlve', Err, mtError, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
UpdateCaption;
|
||
FSettings.NoteRecentProject(FProject.FileName);
|
||
RefreshRecentMenu;
|
||
Log('Проект сохранён: ' + FProject.FileName);
|
||
Result := True;
|
||
end;
|
||
|
||
function TMainForm.DoSaveProject: Boolean;
|
||
var
|
||
Err: string;
|
||
begin
|
||
if FProject.FileName = '' then
|
||
Exit(SaveProjectAs);
|
||
Result := FProject.SaveToFile(FProject.FileName, Err);
|
||
if not Result then
|
||
ThemedMessageDlg('nlve', Err, mtError, [mbOK], 0)
|
||
else
|
||
begin
|
||
UpdateCaption;
|
||
Log('Проект сохранён.');
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.MenuSaveProject(Sender: TObject);
|
||
begin
|
||
DoSaveProject;
|
||
end;
|
||
|
||
procedure TMainForm.MenuSaveProjectAs(Sender: TObject);
|
||
begin
|
||
SaveProjectAs;
|
||
end;
|
||
|
||
function TMainForm.ConfirmDiscard: Boolean;
|
||
begin
|
||
Result := True;
|
||
if not FProject.Modified then
|
||
Exit;
|
||
case ThemedMessageDlg('nlve', 'Проект изменён. Сохранить?',
|
||
mtConfirmation, [mbYes, mbNo, mbCancel], 0) of
|
||
mrYes: Result := DoSaveProject;
|
||
mrNo: Result := True;
|
||
else
|
||
Result := False;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
||
begin
|
||
CanClose := ConfirmDiscard;
|
||
end;
|
||
|
||
procedure TMainForm.MenuQuit(Sender: TObject);
|
||
begin
|
||
Close;
|
||
end;
|
||
|
||
procedure TMainForm.MenuDeps(Sender: TObject);
|
||
begin
|
||
ShowDeps(Self);
|
||
|
||
{ Библиотека могла появиться только что. Перезапуск ради этого требовать
|
||
незачем: загрузка идёт по имени, и вторая попытка ничем не хуже
|
||
первой. }
|
||
if (FPlayer <> nil) and (not FPlayer.Initialized) then
|
||
begin
|
||
Log('Проверяю, появилась ли libmpv...');
|
||
StartPlayer;
|
||
if FPlayer.Initialized then
|
||
begin
|
||
FLastLoadedEdl := '';
|
||
SchedulePreview;
|
||
SetStatus('Предпросмотр заработал.');
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.MenuRemux(Sender: TObject);
|
||
var
|
||
Form: TRemuxForm;
|
||
begin
|
||
Form := TRemuxForm.Create(Self);
|
||
try
|
||
Form.ShowModal;
|
||
finally
|
||
Form.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.MenuUndo(Sender: TObject);
|
||
begin
|
||
if not FProject.CanUndo then
|
||
begin
|
||
SetStatus('Отменять нечего.');
|
||
Exit;
|
||
end;
|
||
FProject.Undo;
|
||
RefreshPool;
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
SetStatus('Отменено.');
|
||
end;
|
||
|
||
procedure TMainForm.MenuRedo(Sender: TObject);
|
||
begin
|
||
if not FProject.CanRedo then
|
||
begin
|
||
SetStatus('Повторять нечего.');
|
||
Exit;
|
||
end;
|
||
FProject.Redo;
|
||
RefreshPool;
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
SetStatus('Повторено.');
|
||
end;
|
||
|
||
procedure TMainForm.MenuSplit(Sender: TObject);
|
||
begin
|
||
FTimeline.SplitAtPlayhead(False, True);
|
||
end;
|
||
|
||
procedure TMainForm.MenuSplitPrecise(Sender: TObject);
|
||
begin
|
||
FTimeline.SplitAtPlayhead(True, True);
|
||
SetStatus('Точный рез: стык будет перекодирован при сборке.');
|
||
end;
|
||
|
||
procedure TMainForm.MenuDelete(Sender: TObject);
|
||
begin
|
||
FTimeline.DeleteSelected;
|
||
end;
|
||
|
||
procedure TMainForm.MenuSelectAll(Sender: TObject);
|
||
begin
|
||
FTimeline.SelectAll;
|
||
end;
|
||
|
||
procedure TMainForm.MenuRipple(Sender: TObject);
|
||
begin
|
||
FTimeline.RippleCloseGap;
|
||
end;
|
||
|
||
{ К началу самого раннего клипа по всем дорожкам. Если монтаж начинается
|
||
с пятой секунды, ноль — не то место, куда хотят попасть. }
|
||
procedure TMainForm.MenuToggleRipple(Sender: TObject);
|
||
begin
|
||
ToggleRipple;
|
||
end;
|
||
|
||
procedure TMainForm.MenuGoStart(Sender: TObject);
|
||
begin
|
||
FTimeline.Playhead := FTimeline.FirstClipTime;
|
||
FTimeline.ScrollToPlayhead(False);
|
||
end;
|
||
|
||
{ К концу самого позднего клипа по всем дорожкам. }
|
||
procedure TMainForm.MenuGoEnd(Sender: TObject);
|
||
begin
|
||
FTimeline.Playhead := FTimeline.LastClipTime;
|
||
FTimeline.ScrollToPlayhead(False);
|
||
end;
|
||
|
||
procedure TMainForm.MenuZoomFit(Sender: TObject);
|
||
begin
|
||
FTimeline.ZoomToFit;
|
||
end;
|
||
|
||
procedure TMainForm.MenuZoomIn(Sender: TObject);
|
||
begin
|
||
FTimeline.ZoomAt(1.5, FTimeline.ClientWidth div 2);
|
||
end;
|
||
|
||
procedure TMainForm.MenuZoomOut(Sender: TObject);
|
||
begin
|
||
FTimeline.ZoomAt(1 / 1.5, FTimeline.ClientWidth div 2);
|
||
end;
|
||
|
||
procedure TMainForm.MenuAddTrack(Sender: TObject);
|
||
begin
|
||
FProject.BeginChange;
|
||
FProject.AddTrack('V' +
|
||
IntToStr(FProject.TrackCountOf(tkVideo) + 1));
|
||
FTimeline.Invalidate;
|
||
UpdateCaption;
|
||
end;
|
||
|
||
procedure TMainForm.MenuRemoveTrack(Sender: TObject);
|
||
begin
|
||
if FProject.TrackCount <= 1 then
|
||
begin
|
||
SetStatus('Последнюю дорожку удалить нельзя.');
|
||
Exit;
|
||
end;
|
||
FProject.BeginChange;
|
||
FProject.RemoveTrack(FProject.TrackCount - 1);
|
||
if FTimeline.ActiveTrack >= FProject.TrackCount then
|
||
FTimeline.ActiveTrack := FProject.TrackCount - 1;
|
||
FTimeline.Invalidate;
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
end;
|
||
|
||
{ --- Приведение файла к параметрам проекта --- }
|
||
|
||
procedure TMainForm.NormalizeProgress(Sender: TObject);
|
||
begin
|
||
if Assigned(FNormalizeUi) then
|
||
begin
|
||
FNormalizeUi.SetStage(FNormalize.Title);
|
||
FNormalizeUi.SetFraction(FNormalize.Fraction);
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.NormalizeLog(Sender: TObject);
|
||
begin
|
||
if Assigned(FNormalizeUi) then
|
||
FNormalizeUi.AddLog(FNormalize.PendingLog);
|
||
end;
|
||
|
||
procedure TMainForm.NormalizeDone(Sender: TObject);
|
||
begin
|
||
if Assigned(FNormalizeUi) then
|
||
FNormalizeUi.Finish(FNormalize.Succeeded, FNormalize.Message);
|
||
end;
|
||
|
||
procedure TMainForm.NormalizeCancel(Sender: TObject);
|
||
begin
|
||
if Assigned(FNormalize) then
|
||
FNormalize.RequestCancel;
|
||
end;
|
||
|
||
{ --- Сборка ролика --- }
|
||
|
||
procedure TMainForm.MenuExport(Sender: TObject);
|
||
var
|
||
Segments, AudioSegs: TFlatSegmentArray;
|
||
Missing: TGenRequests;
|
||
HasPrecise: Boolean;
|
||
T, C: Integer;
|
||
Rebuilt: Double;
|
||
begin
|
||
if not FlattenProject(FProject, Segments, AudioSegs, Missing) then
|
||
begin
|
||
ThemedMessageDlg('nlve', 'На монтаже нечего собирать.', mtInformation, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
|
||
if Length(Missing) > 0 then
|
||
begin
|
||
ThemedMessageDlg('nlve',
|
||
'Ещё не готовы вставки для картинок или пустых мест. ' +
|
||
'Подождите, пока они создадутся, и повторите.',
|
||
mtInformation, [mbOK], 0);
|
||
SchedulePreview;
|
||
Exit;
|
||
end;
|
||
|
||
{ Сколько материала придётся пересобрать. Наложение, переход,
|
||
полупрозрачность и чужие параметры файла — всё это перекодирование, и
|
||
человек должен знать цену заранее, а не обнаружить её по времени
|
||
сборки. }
|
||
Rebuilt := 0;
|
||
for T := 0 to High(Segments) do
|
||
if Segments[T].Transcode or (Length(Segments[T].Layers) > 0) then
|
||
Rebuilt := Rebuilt + Segments[T].Duration;
|
||
|
||
if Rebuilt > 0.5 then
|
||
if ThemedMessageDlg('nlve',
|
||
Format('Часть ролика придётся пересобрать: %s с из %s.' + LineEnding +
|
||
LineEnding +
|
||
'Пересобираются участки с наложением, переходами, прозрачностью и ' +
|
||
'куски файлов, не совпадающих с параметрами проекта. Остальное ' +
|
||
'копируется без потерь и почти мгновенно.' + LineEnding + LineEnding +
|
||
'Продолжить?',
|
||
[SecondsToStr(Rebuilt), SecondsToStr(TotalDuration(Segments))]),
|
||
mtConfirmation, [mbYes, mbNo], 0) <> mrYes then
|
||
Exit;
|
||
|
||
{ Если есть хоть один точный рез, предупреждаем про контейнер: в MP4
|
||
перекодированный кусок и скопированный уживаются не всегда, а MKV
|
||
к смене параметров потока терпимее. }
|
||
HasPrecise := False;
|
||
for T := 0 to FProject.TrackCount - 1 do
|
||
for C := 0 to FProject.Tracks[T].Count - 1 do
|
||
if (FProject.Tracks[T][C].EdgeIn = edPrecise) or
|
||
(FProject.Tracks[T][C].EdgeOut = edPrecise) then
|
||
HasPrecise := True;
|
||
|
||
if HasPrecise then
|
||
begin
|
||
SaveExportDialog.DefaultExt := '.mkv';
|
||
SaveExportDialog.FileName := 'ролик.mkv';
|
||
end
|
||
else
|
||
begin
|
||
SaveExportDialog.DefaultExt := '.mp4';
|
||
SaveExportDialog.FileName := 'ролик.mp4';
|
||
end;
|
||
|
||
if not SaveExportDialog.Execute then
|
||
Exit;
|
||
FSettings.LastExportDir := ExtractFilePath(SaveExportDialog.FileName);
|
||
|
||
if HasPrecise and (LowerCase(ExtractFileExt(SaveExportDialog.FileName)) <> '.mkv') then
|
||
if ThemedMessageDlg('nlve',
|
||
'В монтаже есть точные резы. В MP4 перекодированный стык может ' +
|
||
'воспроизводиться неправильно — надёжнее MKV.' + LineEnding +
|
||
LineEnding + 'Всё равно собрать в выбранный контейнер?',
|
||
mtWarning, [mbYes, mbNo], 0) <> mrYes then
|
||
Exit;
|
||
|
||
Log('Сборка в ' + SaveExportDialog.FileName);
|
||
Log(Format('%d %s, длительность %s с',
|
||
[Length(Segments), Plural(Length(Segments), 'кусок', 'куска', 'кусков'),
|
||
SecondsToStr(TotalDuration(Segments))]));
|
||
|
||
FExport := TExportThread.Create(Segments, AudioSegs,
|
||
SaveExportDialog.FileName, True, FProject.Master);
|
||
FExport.OnProgress := @ExportProgress;
|
||
FExport.OnLog := @ExportLog;
|
||
FExport.OnTerminate := @ExportDone;
|
||
|
||
FExportUi := TProgressForm.Create(Self);
|
||
try
|
||
FExportUi.Caption := 'Сборка ролика';
|
||
FExportUi.OnCancelRequest := @ExportCancel;
|
||
FExport.Start;
|
||
FExportUi.ShowModal;
|
||
finally
|
||
FreeAndNil(FExportUi);
|
||
end;
|
||
|
||
if Assigned(FExport) then
|
||
begin
|
||
FExport.WaitFor;
|
||
ShowExportReport(FExport.Report);
|
||
FreeAndNil(FExport);
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.ExportProgress(Sender: TObject);
|
||
begin
|
||
if Assigned(FExportUi) then
|
||
begin
|
||
FExportUi.SetStage(FExport.StageText);
|
||
FExportUi.SetFraction(FExport.Fraction);
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.ExportLog(Sender: TObject);
|
||
begin
|
||
if Assigned(FExportUi) then
|
||
FExportUi.AddLog(FExport.PendingLog);
|
||
end;
|
||
|
||
procedure TMainForm.ExportCancel(Sender: TObject);
|
||
begin
|
||
if Assigned(FExport) then
|
||
FExport.RequestCancel;
|
||
end;
|
||
|
||
procedure TMainForm.ExportDone(Sender: TObject);
|
||
var
|
||
Rep: TExportReport;
|
||
begin
|
||
if not Assigned(FExportUi) then
|
||
Exit;
|
||
Rep := FExport.Report;
|
||
FExportUi.Finish(Rep.Succeeded, Rep.Message);
|
||
if Rep.Succeeded then
|
||
FExportUi.AddLog('Файл: ' + Rep.OutputPath);
|
||
end;
|
||
|
||
procedure TMainForm.ShowExportReport(const AReport: TExportReport);
|
||
var
|
||
I, Encoded: Integer;
|
||
Shift: Double;
|
||
begin
|
||
if AReport.Cancelled then
|
||
begin
|
||
Log('Сборка отменена.');
|
||
Exit;
|
||
end;
|
||
|
||
if not AReport.Succeeded then
|
||
begin
|
||
Log('Сборка не удалась: ' + AReport.Message);
|
||
Exit;
|
||
end;
|
||
|
||
Log('--- Отчёт о сборке ---');
|
||
Encoded := 0;
|
||
for I := 0 to High(AReport.Segments) do
|
||
begin
|
||
Shift := AReport.Segments[I].ActualStart - AReport.Segments[I].RequestedStart;
|
||
if AReport.Segments[I].Encoded then
|
||
begin
|
||
Inc(Encoded);
|
||
Log(Format(' часть %d (кусок %d, ПЕРЕКОДИРОВАНА): старт %s, длина %s, пакетов %d',
|
||
[I + 1, AReport.Segments[I].Index + 1,
|
||
SecondsToStr(AReport.Segments[I].ActualStart),
|
||
SecondsToStr(AReport.Segments[I].Duration),
|
||
AReport.Segments[I].Packets]));
|
||
end
|
||
else
|
||
Log(Format(' часть %d (кусок %d): старт %s (просили %s, сдвиг %s), длина %s, пакетов %d',
|
||
[I + 1, AReport.Segments[I].Index + 1,
|
||
SecondsToStr(AReport.Segments[I].ActualStart),
|
||
SecondsToStr(AReport.Segments[I].RequestedStart),
|
||
SecondsToStr(Shift),
|
||
SecondsToStr(AReport.Segments[I].Duration),
|
||
AReport.Segments[I].Packets]));
|
||
end;
|
||
if Encoded > 0 then
|
||
Log(Format(' перекодировано частей: %d, остальное скопировано без потерь',
|
||
[Encoded]));
|
||
|
||
Log(Format(' сумма пакетов кусков: %d', [AReport.ExpectedPackets]));
|
||
Log(Format(' пакетов в готовом файле: %d', [AReport.ActualPackets]));
|
||
if AReport.ExpectedPackets = AReport.ActualPackets then
|
||
Log(' СВЕРКА ПРОЙДЕНА: склейка не потеряла и не продублировала ни одного кадра.')
|
||
else
|
||
Log(Format(' РАСХОЖДЕНИЕ на %d кадров.',
|
||
[AReport.ActualPackets - AReport.ExpectedPackets]));
|
||
Log(' файл: ' + AReport.OutputPath);
|
||
SetStatus('Готово: ' + AReport.OutputPath);
|
||
end;
|
||
|
||
end.
|