4aiman
96672341d2
Отметки участка стали видимыми уголками на линейке — жёлтые треугольники по краям, за них можно тянуть. Клавишами это выходило долго: поставил, посмотрел, промахнулся, ставь заново. Край прилипает к границам клипов, как и курсор, и края не пропускаются друг за друга. Клавиша \ и кнопка с целью переключают, держать ли курсор посередине монтажа при воспроизведении. Раньше монтаж ехал под курсором всегда, а это мешает, когда разглядываешь конкретное место. В окне сборки вместо надписи про участок появилась галка «только отмеченный участок». Надпись легко проглядеть, а вопрос из тех, где ошибка стоит часа работы: соберёшь кусок вместо ролика или наоборот. Снятая галка собирает весь монтаж, отметки при этом остаются. Журнал сборки пишется рядом с готовым файлом и под тем же именем. Общий журнал программы перезаписывается следующим запуском, а разбираться, почему в ролике не то, приходится потом. В журнале: время, проект, участок, кадр и битрейт, что с текстом, и полный список кусков — с пометками, где слои, где текст и что пересобирается. Строка пишется сразу, чтобы после падения осталась последняя.
3712 lines
140 KiB
ObjectPascal
3712 lines
140 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, uEncodeForm, uAboutForm, uProgressForm,
|
||
uRemuxForm, uMismatchForm,
|
||
uFfmpegJob, uSettings, uThumbs, uTransform, uPanCropForm,
|
||
uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm, uWaveform,
|
||
uIconData, uSubtitles, uTextMeasure, uTextForm, uExportForm,
|
||
uColorKeyForm;
|
||
|
||
const
|
||
{ Номера системных сообщений о перерисовке рамки окна. Берём числами, а
|
||
не из модуля Windows: тот переопределяет TRect и Point, и обычные
|
||
вызовы LCL начинают разбираться как системные. }
|
||
MsgNcPaint = $0085;
|
||
MsgNcActivate = $0086;
|
||
|
||
type
|
||
|
||
{ TMainForm }
|
||
|
||
TMainForm = class(TForm)
|
||
|
||
btnSnap: TThemedButton;
|
||
btnGlue: TThemedButton;
|
||
btnCenter: 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 btnGlueClick(Sender: TObject);
|
||
procedure btnCenterClick(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;
|
||
{ Наложение для плеера: список кусков оверлея и окна показа. }
|
||
{ Журнал текущей сборки: файл рядом с готовым роликом. }
|
||
FExportLogPath: string;
|
||
FPreviewOverlayUrl: string;
|
||
FPreviewOverlayWindows: TOverlayWindows;
|
||
{ Списки кусков звуковых дорожек для плеера. }
|
||
FPreviewAudioUrls: array of string;
|
||
{ Звуковые дорожки предпросмотра — их номера в проекте, а не сами
|
||
объекты.
|
||
|
||
Указатели здесь были ловушкой: отмена и открытие проекта
|
||
пересоздают все дорожки, а этот список продолжал показывать на
|
||
освобождённую память. Обращение к нему идёт на каждое обновление
|
||
времени при воспроизведении, то есть десятки раз в секунду. }
|
||
FPreviewAudioTracks: array of string;
|
||
FLastHwdec: string;
|
||
FLastAudioNote: string;
|
||
FLogFilePath: string;
|
||
FLogFileStarted: Boolean;
|
||
FLogFileBroken: Boolean;
|
||
FMenu: TMainMenu;
|
||
{ Отложенный показ списка меню. Номер списка и точка, где его
|
||
раскрыть; таймер срабатывает один раз. }
|
||
{ Показ фоновой работы. Пока что-то считается в стороне от окна,
|
||
здесь видно, что именно и сколько осталось. }
|
||
FJobLabel: TLabel;
|
||
FJobBar: TThemedProgress;
|
||
FJobTimer: TTimer;
|
||
{ Что выбрали в окне сборки в прошлый раз. Держится между вызовами,
|
||
чтобы не задавать один и тот же вопрос заново. }
|
||
FExportChoice: TExportChoice;
|
||
{ Сколько внутренних ошибок уже случилось. Окно показываем только на
|
||
первую. }
|
||
FErrorCount: Integer;
|
||
FLogButton: TThemedButton;
|
||
{ Пункт «Ключ и прозрачность в предпросмотре»: галку в нём приходится
|
||
держать за руку — она не следует за настройкой сама. }
|
||
FKeyPreviewItem: TMenuItem;
|
||
{ Показанная доля выполнения. Отдельно от настоящей, потому что растёт
|
||
она по своим правилам — см. AdvanceJobBar. }
|
||
FJobShown: Double;
|
||
{ Настоящая доля и доля следующей вехи. Между вехами полоска ползёт
|
||
сама, замедляясь. }
|
||
FJobReal: Double;
|
||
FJobNext: Double;
|
||
{ Какая именно работа идёт. При смене занятия полоска начинается
|
||
заново: иначе новая работа унаследовала бы почти полную полосу от
|
||
предыдущей и стояла бы на месте до самого конца. }
|
||
FJobKind: Integer;
|
||
{ Уплощённый монтаж, отданный плееру. Хранится, чтобы по времени
|
||
находить звучащий кусок и брать у него громкость. }
|
||
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 UpdateSubtitles;
|
||
procedure UpdateRippleButton;
|
||
procedure UpdateSnapButton;
|
||
procedure UpdateGlueButton;
|
||
procedure UpdateCenterButton;
|
||
procedure ToggleCenterPlayhead;
|
||
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 HandleException(Sender: TObject; E: Exception);
|
||
procedure ApplyWindowIcon;
|
||
procedure BuildJobIndicator;
|
||
procedure JobTimerTick(Sender: TObject);
|
||
procedure AdvanceJobBar;
|
||
procedure LogButtonClick(Sender: TObject);
|
||
procedure MenuToggleLog(Sender: TObject);
|
||
procedure MenuTogglePreviewKey(Sender: TObject);
|
||
procedure MenuAbout(Sender: TObject);
|
||
procedure MenuAddText(Sender: TObject);
|
||
{ Открывает редактор текста для клипа. True — что-то изменилось. }
|
||
function EditTextOf(AClip: TClip): Boolean;
|
||
procedure ApplyLogVisible(AVisible: Boolean);
|
||
procedure BuildTimeline;
|
||
procedure StartPlayer;
|
||
{ Чего не хватает для работы. Пустая строка — всё на месте. }
|
||
function MissingDeps: string;
|
||
procedure RemindAboutDeps;
|
||
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 BuildOverlayPreview(const AOverlays: TPreviewOverlays;
|
||
const ATotal: Double);
|
||
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 MenuExportEncode(Sender: TObject);
|
||
procedure DoExport(const AProfile: TEncodeProfile);
|
||
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 MenuColorKey(Sender: TObject);
|
||
procedure MenuRegionIn(Sender: TObject);
|
||
procedure MenuRegionOut(Sender: TObject);
|
||
procedure MenuRegionClear(Sender: TObject);
|
||
{ Что и откуда собирать: с учётом отмеченного участка. }
|
||
procedure DescribeRegion(out AFrom, ATo: Double);
|
||
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 LogExport(const AText: string);
|
||
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 := ProgramDir + '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;
|
||
UpdateGlueButton;
|
||
UpdateCenterButton;
|
||
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;
|
||
FTimeline.PlayheadSnap := FSettings.PlayheadSnap;
|
||
|
||
{ Каталоги подставляем в диалоги, чтобы не искать одно и то же место
|
||
заново при каждом запуске. }
|
||
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.LogVisible := memoLog.Visible;
|
||
FSettings.RippleAllTracks := FProject.RippleMode = rmAllTracks;
|
||
FSettings.RippleEnabled := FProject.RippleEnabled;
|
||
FSettings.PlayheadSnap := FTimeline.PlayheadSnap;
|
||
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;
|
||
|
||
{ Возвращает созданный пункт: у пунктов с галкой её потом надо ставить
|
||
и снимать, а искать пункт по названию — способ ненадёжный. }
|
||
function AddItem(AParent: TMenuItem; const ACaption: string;
|
||
AHandler: TNotifyEvent; AShortCut: TShortCut = 0): TMenuItem;
|
||
var
|
||
Item: TMenuItem;
|
||
begin
|
||
Item := TMenuItem.Create(Self);
|
||
Item.Caption := ACaption;
|
||
Item.OnClick := AHandler;
|
||
Item.ShortCut := AShortCut;
|
||
AParent.Add(Item);
|
||
Result := 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, MHelp: TMenuItem;
|
||
begin
|
||
{ Подсказки всплывают почти сразу: на кнопке со значком они не
|
||
украшение, а единственный способ узнать, что она делает. Держатся
|
||
долго — читать там больше, чем одно слово. }
|
||
Application.ShowHint := True;
|
||
Application.HintPause := 100;
|
||
Application.HintHidePause := 15000;
|
||
|
||
{ Точный замер текста ставится до первой сборки субтитров: без него
|
||
размер подбирался бы по грубой оценке. }
|
||
InstallTextMeasure;
|
||
Application.OnException := @HandleException;
|
||
|
||
ApplyWindowIcon;
|
||
|
||
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, 'Собрать с перекодированием...', @MenuExportEncode,
|
||
ShortCut(VK_E, [ssCtrl, ssShift]));
|
||
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]));
|
||
AddItem(MEdit, 'Цветовой ключ клипа...', @MenuColorKey);
|
||
AddSep(MEdit);
|
||
AddItem(MEdit, 'Отметить начало участка', @MenuRegionIn, ShortCut(VK_I, []));
|
||
AddItem(MEdit, 'Отметить конец участка', @MenuRegionOut, ShortCut(VK_O, []));
|
||
AddItem(MEdit, 'Снять отметки участка', @MenuRegionClear);
|
||
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]));
|
||
AddSep(MView);
|
||
AddItem(MView, 'Журнал сообщений', @MenuToggleLog, ShortCut(VK_L, [ssCtrl]));
|
||
AddSep(MView);
|
||
FKeyPreviewItem := AddItem(MView, 'Ключ и прозрачность в предпросмотре',
|
||
@MenuTogglePreviewKey);
|
||
FKeyPreviewItem.AutoCheck := False;
|
||
FKeyPreviewItem.Checked := FSettings.PreviewKey;
|
||
|
||
MProject := AddTop('Проект');
|
||
AddItem(MProject, 'Сведения о проекте...', @MenuProjectInfo);
|
||
AddSep(MProject);
|
||
AddItem(MProject, 'Добавить текст', @MenuAddText, ShortCut(VK_T, [ssCtrl]));
|
||
AddSep(MProject);
|
||
AddItem(MProject, 'Добавить дорожку', @MenuAddTrack);
|
||
AddItem(MProject, 'Удалить последнюю дорожку', @MenuRemoveTrack);
|
||
|
||
MHelp := AddTop('Справка');
|
||
AddItem(MHelp, 'О программе...', @MenuAbout);
|
||
|
||
{ Дважды, и оба раза нужны.
|
||
|
||
До присваивания — чтобы обработчики отрисовки стояли к первому показу.
|
||
После — чтобы задать подложку полосы: она задаётся через SetMenuInfo по
|
||
дескриптору меню, а дескриптор появляется только когда меню отдано
|
||
окну. Первый вызов до этого просто пропускал подложку, и справа от
|
||
последнего названия оставалась светлая полоса. }
|
||
ApplyDarkMenu(FMenu);
|
||
Menu := FMenu;
|
||
ApplyDarkMenu(FMenu);
|
||
end;
|
||
|
||
{ Показ фоновой работы.
|
||
|
||
Разбор звука читает файл целиком — на шести гигабайтах это больше
|
||
десяти секунд, и всё это время программа выглядит просто задумчивой.
|
||
Молчать об этом нельзя: непонятно, идёт ли что-то вообще.
|
||
|
||
Место справа в нижней полосе отводится сразу и насовсем, а надпись с
|
||
полоской показываются только когда работа есть. Так строка состояния и
|
||
показатель не наезжают друг на друга. }
|
||
{ Внутренняя ошибка не должна оставаться загадкой.
|
||
|
||
Окно «Access violation» без единого слова о том, где именно, не даёт
|
||
ничего: ошибка повторяется на каждый кадр воспроизведения, а найти её
|
||
негде. Поэтому мы перехватываем её сами и пишем в журнал разбор стека —
|
||
сборка идёт с отладочными сведениями, поэтому в нём видны имена файлов
|
||
и номера строк.
|
||
|
||
Окно показывается только на первую ошибку. Дальше они лишь считаются:
|
||
повторяющееся окно поверх воспроизведения невозможно закрыть. }
|
||
procedure TMainForm.HandleException(Sender: TObject; E: Exception);
|
||
var
|
||
Trace: string;
|
||
I: Integer;
|
||
Frames: PPointer;
|
||
begin
|
||
Inc(FErrorCount);
|
||
|
||
Trace := BackTraceStrFunc(ExceptAddr);
|
||
Frames := ExceptFrames;
|
||
for I := 0 to ExceptFrameCount - 1 do
|
||
Trace := Trace + LineEnding + ' ' + BackTraceStrFunc(Frames[I]);
|
||
|
||
Log(Format('ВНУТРЕННЯЯ ОШИБКА %d: %s: %s', [FErrorCount, E.ClassName,
|
||
E.Message]));
|
||
Log(' где: ' + Trace);
|
||
|
||
if FErrorCount = 1 then
|
||
ThemedMessageDlg('nlve',
|
||
E.ClassName + ': ' + E.Message + LineEnding + LineEnding +
|
||
'Разбор записан в журнал (nlve.log рядом с программой). ' +
|
||
'Следующие такие же ошибки будут только записываться.',
|
||
mtError, [mbOK], 0);
|
||
end;
|
||
|
||
{ Значок окна. Вшит в программу, потому что рядом с ней может ничего не
|
||
лежать. Значок самого файла программы под Windows задаётся не здесь, а
|
||
ресурсом при сборке — это отдельная история. }
|
||
procedure TMainForm.ApplyWindowIcon;
|
||
var
|
||
Stream: TMemoryStream;
|
||
begin
|
||
Stream := TMemoryStream.Create;
|
||
try
|
||
Stream.WriteBuffer(IconAppData[0], Length(IconAppData));
|
||
Stream.Position := 0;
|
||
try
|
||
Icon.LoadFromStream(Stream);
|
||
Application.Icon.Assign(Icon);
|
||
except
|
||
{ Со значком не вышло — работать это не мешает. }
|
||
end;
|
||
finally
|
||
Stream.Free;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.BuildJobIndicator;
|
||
const
|
||
JobWidth = 330;
|
||
LogButtonWidth = 28;
|
||
LogButtonLeft = 448;
|
||
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;
|
||
|
||
{ Переключатель журнала. Стоит рядом с показателем работы: это две
|
||
вещи про одно и то же — что программа делает и что она об этом
|
||
рассказала. }
|
||
FLogButton := TThemedButton.Create(Self);
|
||
FLogButton.Parent := pnlBottom;
|
||
{ Рядом с прилипанием и схлопыванием: три переключателя читаются как
|
||
один набор, а не как случайно разбросанные значки. }
|
||
FLogButton.SetBounds(LogButtonLeft, 6, LogButtonWidth, 28);
|
||
FLogButton.Icon := tiLog;
|
||
{ Фокус переключателям не нужен: по ним щёлкают, а обходить их клавишей
|
||
Tab при работе с монтажом только мешает. }
|
||
FLogButton.TabStop := False;
|
||
FLogButton.Down := True;
|
||
FLogButton.OnClick := @LogButtonClick;
|
||
FLogButton.ShowHint := True;
|
||
FLogButton.Hint := 'Журнал: спрятать или показать полосу с сообщениями';
|
||
|
||
{ Строка состояния ужимается, чтобы её длинные сообщения не залезали
|
||
под показатель и под кнопку. }
|
||
lblStatus.Width := pnlBottom.ClientWidth - lblStatus.Left - JobWidth - 24;
|
||
|
||
{ Сто миллисекунд, а не триста: полоска должна ползти, а не дёргаться
|
||
ступеньками. }
|
||
FJobTimer := TTimer.Create(Self);
|
||
FJobTimer.Interval := 100;
|
||
FJobTimer.OnTimer := @JobTimerTick;
|
||
FJobTimer.Enabled := True;
|
||
end;
|
||
|
||
{ Как растёт полоска — см. AdvanceProgress в uAppTypes: там же она и
|
||
проверяется числами. }
|
||
procedure TMainForm.AdvanceJobBar;
|
||
const
|
||
{ Доля оставшегося до вехи расстояния за один шаг таймера. При ста
|
||
миллисекундах на шаг это примерно половина расстояния за секунду. }
|
||
StepShare = 0.07;
|
||
begin
|
||
FJobShown := AdvanceProgress(FJobShown, FJobReal, FJobNext, StepShare);
|
||
end;
|
||
|
||
procedure TMainForm.LogButtonClick(Sender: TObject);
|
||
begin
|
||
ApplyLogVisible(not memoLog.Visible);
|
||
end;
|
||
|
||
{ Новая надпись.
|
||
|
||
Кладётся на текстовую дорожку в место курсора. Дорожки нет — заводится:
|
||
просить сначала создать дорожку, а потом положить на неё текст значило
|
||
бы заставлять человека знать наше устройство. }
|
||
procedure TMainForm.MenuAddText(Sender: TObject);
|
||
var
|
||
Track: TTrack;
|
||
Clip: TClip;
|
||
I: Integer;
|
||
begin
|
||
Track := nil;
|
||
for I := 0 to FProject.TrackCount - 1 do
|
||
if FProject.Tracks[I].Kind = tkText then
|
||
begin
|
||
Track := FProject.Tracks[I];
|
||
Break;
|
||
end;
|
||
|
||
FProject.BeginChange;
|
||
|
||
if Track = nil then
|
||
Track := FProject.AddTrackOfKind('Т1', tkText);
|
||
|
||
Clip := TClip.Create;
|
||
Clip.Id := FProject.NewId('c');
|
||
Clip.Kind := ckText;
|
||
Clip.TlStart := Max(0, FTimeline.Playhead);
|
||
{ Три секунды — столько держится короткая надпись, чтобы её успели
|
||
прочесть. Дальше человек растянет клип как захочет. }
|
||
Clip.Duration := 3;
|
||
Clip.Text := 'Надпись';
|
||
Clip.TextStyle := DefaultTextStyle;
|
||
Track.Add(Clip);
|
||
Track.Sort;
|
||
|
||
if not EditTextOf(Clip) then
|
||
begin
|
||
{ Передумал — клипа быть не должно, иначе на монтаже останется
|
||
пустая надпись, которую он не заказывал. }
|
||
Track.Remove(Clip);
|
||
FProject.CancelChange;
|
||
FTimeline.Invalidate;
|
||
Exit;
|
||
end;
|
||
|
||
FProject.ClearSelection;
|
||
Clip.Selected := True;
|
||
TimelineStructureChange(nil);
|
||
end;
|
||
|
||
function TMainForm.EditTextOf(AClip: TClip): Boolean;
|
||
var
|
||
{ Не Text: так называется свойство самой формы. }
|
||
Body: string;
|
||
Style: TTextStyle;
|
||
W, H: Integer;
|
||
begin
|
||
Result := False;
|
||
if AClip = nil then
|
||
Exit;
|
||
|
||
Body := AClip.Text;
|
||
Style := AClip.TextStyle;
|
||
W := FProject.Master.Width;
|
||
H := FProject.Master.Height;
|
||
if (W < 2) or (H < 2) then
|
||
begin
|
||
W := 1920;
|
||
H := 1080;
|
||
end;
|
||
|
||
if not EditTextClip(Body, Style, W, H) then
|
||
Exit;
|
||
|
||
AClip.Text := Body;
|
||
AClip.TextStyle := Style;
|
||
Result := True;
|
||
end;
|
||
|
||
procedure TMainForm.MenuAbout(Sender: TObject);
|
||
begin
|
||
ShowAboutForm;
|
||
end;
|
||
|
||
procedure TMainForm.MenuToggleLog(Sender: TObject);
|
||
begin
|
||
ApplyLogVisible(not memoLog.Visible);
|
||
end;
|
||
|
||
procedure TMainForm.ApplyLogVisible(AVisible: Boolean);
|
||
begin
|
||
memoLog.Visible := AVisible;
|
||
if not Assigned(FLogButton) then
|
||
Exit;
|
||
FLogButton.Down := AVisible;
|
||
if AVisible then
|
||
FLogButton.Hint := 'Журнал виден. Нажмите, чтобы спрятать.'
|
||
else
|
||
FLogButton.Hint := 'Журнал спрятан. Нажмите, чтобы показать.';
|
||
end;
|
||
|
||
{ Как растёт полоска.
|
||
|
||
Настоящая доля известна только вехами: файл разобран, вставка готова.
|
||
Между вехами не происходит ничего видимого, и полоска, стоящая на месте,
|
||
выглядит как зависшая программа.
|
||
|
||
Поэтому она ползёт сама — к следующей вехе, но никогда её не достигая:
|
||
каждый шаг покрывает малую долю оставшегося расстояния. Пока работа идёт
|
||
как задумано, веха приходит быстро и полоска прыгает к ней. Если работа
|
||
затянулась, шаги становятся всё мельче, и заполнение само собой
|
||
замедляется — ровно то поведение, которого ждут от такой полоски.
|
||
|
||
Назад она не идёт никогда: доля, единожды показанная, остаётся. }
|
||
|
||
|
||
{ Опрос по таймеру, а не уведомления из потоков: поток сообщает о готовом
|
||
файле, а не о ходе внутри файла, и на шестигигабайтном файле между
|
||
сообщениями проходят десятки секунд. Опрос показывает движение и там. }
|
||
procedure TMainForm.JobTimerTick(Sender: TObject);
|
||
var
|
||
{ Не Text: так называется свойство самой формы, а имена в Паскале
|
||
нечувствительны к регистру. }
|
||
Note: string;
|
||
Frac: Double;
|
||
Total, Done, Kind: Integer;
|
||
begin
|
||
{$IFDEF LCLWIN32}
|
||
{ Заодно подновляем закраску остатка полосы меню.
|
||
|
||
Обработчика перерисовки рамки может не хватить: система трогает
|
||
полосу и по другим поводам, а рисуем мы поверх неё. Прямоугольник тот
|
||
же и цвет тот же, поэтому подновление не видно. }
|
||
PaintMenuBarTail(Self);
|
||
{$ENDIF}
|
||
|
||
Note := '';
|
||
Total := 0;
|
||
Done := 0;
|
||
Kind := 0;
|
||
|
||
{ Порядок важен: показываем то, чего человек ждёт прямо сейчас.
|
||
|
||
Сборка вставок держит предпросмотр — до её конца монтаж играет
|
||
по-старому. Разбор звука и миниатюры не держат ничего, они лишь
|
||
дорисовывают то, что уже видно. }
|
||
if FGenerateBusy and Assigned(FGenerate) then
|
||
begin
|
||
Kind := 1;
|
||
Total := FGenerate.Total;
|
||
Done := FGenerate.Done;
|
||
Note := FGenerate.StageText;
|
||
if Note = '' then
|
||
Note := 'Готовлю участки монтажа';
|
||
{ Заодно показываем на монтаже, какой именно участок пересобирается. }
|
||
FTimeline.SetBusyRange(FGenerate.BusyFrom, FGenerate.BusyTo);
|
||
end
|
||
else if Assigned(FPeaksThread) and (not FPeaksFinished) then
|
||
begin
|
||
Kind := 2;
|
||
Total := FPeaksThread.Total;
|
||
Done := FPeaksThread.Done;
|
||
if Total > 0 then
|
||
Note := Format('Разбор звука: %d из %d', [Min(Done + 1, Total), Total]);
|
||
end
|
||
else if Assigned(FThumbThread) then
|
||
begin
|
||
Kind := 3;
|
||
Total := FThumbThread.Total;
|
||
Done := FThumbThread.Done;
|
||
if (Total > 0) and (Done < Total) then
|
||
Note := Format('Миниатюры: %d из %d', [Min(Done + 1, Total), Total]);
|
||
end;
|
||
|
||
if Note = '' then
|
||
begin
|
||
if FJobLabel.Visible then
|
||
begin
|
||
FJobLabel.Visible := False;
|
||
FJobBar.Visible := False;
|
||
end;
|
||
{ Следующая работа начинается с пустой полоски, а не с того места, где
|
||
кончилась прошлая. }
|
||
FJobShown := 0;
|
||
FJobReal := 0;
|
||
FJobNext := 0;
|
||
FJobKind := 0;
|
||
FTimeline.SetBusyRange(0, 0);
|
||
Exit;
|
||
end;
|
||
|
||
if Kind <> FJobKind then
|
||
begin
|
||
FJobKind := Kind;
|
||
FJobShown := 0;
|
||
end;
|
||
|
||
if Total > 0 then
|
||
begin
|
||
FJobReal := Done / Total;
|
||
FJobNext := (Done + 1) / Total;
|
||
end
|
||
else
|
||
begin
|
||
{ Работа без счёта: ползём к концу, никогда его не достигая. }
|
||
FJobReal := 0;
|
||
FJobNext := 1;
|
||
end;
|
||
AdvanceJobBar;
|
||
Frac := FJobShown;
|
||
|
||
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;
|
||
|
||
{ Журнал прячется здесь, а не при чтении настроек.
|
||
|
||
Спрятанный до первого показа окна, он не получает своего виджета
|
||
вовсе, и вернуть его потом уже нечем: свойство переключается,
|
||
а на экране ничего не меняется. Проверено на невидимом экране:
|
||
щелчок по кнопке журнала не менял ни пикселя, при том что запись в
|
||
журнале показывала Visible=True, высоту 135 и верх 743.
|
||
|
||
HandleNeeded — на случай, если до этого места дескриптор всё же не
|
||
создан: прятать можно только то, что уже существует. }
|
||
memoLog.HandleNeeded;
|
||
ApplyLogVisible(FSettings.LogVisible);
|
||
|
||
{ Подложка полосы меню задаётся здесь, а не при создании формы.
|
||
|
||
Она задаётся через SetMenuInfo по дескриптору меню, а тот появляется
|
||
вместе с дескриптором окна — то есть уже после создания формы. Вызов
|
||
из BuildMenu поэтому попадал на несозданный дескриптор и молча ничего
|
||
не делал: пункты рисовались нашими руками, а полоса правее последнего
|
||
названия оставалась светлой. }
|
||
ApplyDarkMenu(Menu);
|
||
PaintMenuBarTail(Self);
|
||
{$IFDEF LCLWIN32}
|
||
Log(MenuBarTailNote);
|
||
{$ENDIF}
|
||
|
||
StartPlayer;
|
||
RemindAboutDeps;
|
||
|
||
{ Файлы из командной строки попадают в список проекта. Так на программу
|
||
можно перетащить файлы из файлового менеджера.
|
||
|
||
Файл проекта — особый случай: его надо открыть, а не пытаться
|
||
разобрать как видео. }
|
||
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;
|
||
|
||
{ Проверка не по одному месту, а разом: человеку нужен ответ «чего не
|
||
хватает», а не «на чём именно споткнулись первым». }
|
||
function TMainForm.MissingDeps: string;
|
||
var
|
||
Err: string;
|
||
begin
|
||
Result := '';
|
||
if not MpvLibLoaded then
|
||
Result := 'libmpv — без неё нет предпросмотра';
|
||
if not ToolsAvailable(Err) then
|
||
begin
|
||
if Result <> '' then
|
||
Result := Result + LineEnding;
|
||
Result := Result + 'ffmpeg — без него не собрать ролик';
|
||
end;
|
||
end;
|
||
|
||
{ Напоминание при запуске.
|
||
|
||
Программа без ffmpeg и libmpv открывается и даже даёт разложить клипы,
|
||
но ничего не покажет и ничего не соберёт. Молча об этом сообщать в
|
||
журнал мало: журнал можно и спрятать.
|
||
|
||
Три кнопки: открыть окно зависимостей, отложить, больше не напоминать.
|
||
Последняя запоминается в настройках. }
|
||
procedure TMainForm.RemindAboutDeps;
|
||
var
|
||
Missing: string;
|
||
Choice: Integer;
|
||
begin
|
||
if not FSettings.DepsReminder then
|
||
Exit;
|
||
Missing := MissingDeps;
|
||
if Missing = '' then
|
||
Exit;
|
||
|
||
Choice := ThemedChoiceDlg('nlve',
|
||
'Не хватает того, на чём программа работает:' + LineEnding +
|
||
LineEnding + Missing + LineEnding + LineEnding +
|
||
'Окно «Зависимости» умеет скачать недостающее с официальных сайтов.' +
|
||
LineEnding + 'Открыть его сейчас?',
|
||
['Открыть', 'Потом', 'Не напоминать']);
|
||
|
||
case Choice of
|
||
0: MenuDeps(nil);
|
||
2: FSettings.DepsReminder := False;
|
||
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;
|
||
Overlays: TPreviewOverlays;
|
||
GenMaster: TMediaInfo;
|
||
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 FlattenPreview(FProject, Segments, AudioSegs, Overlays, Missing,
|
||
FSettings.PreviewKey) then
|
||
begin
|
||
FPlayer.Stop;
|
||
FLastLoadedEdl := '';
|
||
FPreviewOverlayUrl := '';
|
||
FPreviewOverlayWindows := nil;
|
||
UpdateTimeLabel;
|
||
Exit;
|
||
end;
|
||
|
||
BuildOverlayPreview(Overlays, TotalDuration(Segments));
|
||
|
||
{ Текст поверх картинки рисует сам плеер: ему отдаётся файл разметки,
|
||
а не пересобранный кусок. Поэтому правка текста видна сразу. }
|
||
UpdateSubtitles;
|
||
|
||
{ Участки с прозрачностью и переходами плееру не по зубам: список
|
||
кусков накладывать не умеет. Подставляем вместо них заранее
|
||
посчитанные файлы, а чего ещё нет — заказываем. }
|
||
ResolveLayers(FProject, Segments, Missing);
|
||
|
||
{ Каждая звуковая дорожка идёт своим списком кусков: они смешиваются, а
|
||
не побеждают друг друга. Дыры в каждой дорожке свои, и вставки тишины
|
||
под них нужны свои — без этого список ссылается на несуществующий
|
||
файл, плеер его не открывает, и дорожка молчит целиком. }
|
||
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].Id;
|
||
end;
|
||
|
||
if Length(Missing) > 0 then
|
||
begin
|
||
FGenerateBusy := True;
|
||
SetStatus('Готовлю вставки для предпросмотра...');
|
||
{ Вставки — картинки и связки — попадают в ролик наравне со съёмкой,
|
||
поэтому целятся в тот же битрейт. }
|
||
GenMaster := FProject.Master;
|
||
GenMaster.VideoBitrate := FProject.MaxVideoBitrate;
|
||
FGenerate := TGenerateThread.Create(Missing, GenMaster);
|
||
FGenerate.OnProgress := @GenerateProgress;
|
||
FGenerate.OnLog := @GenerateLog;
|
||
FGenerate.OnTerminate := @GenerateDone;
|
||
FGenerate.Start;
|
||
Exit;
|
||
end;
|
||
|
||
LoadPreviewEdl(Segments, AudioSegs);
|
||
end;
|
||
|
||
{ Список кусков оверлея и окна его показа.
|
||
|
||
Список должен покрывать монтаж от начала и без разрывов: плеер
|
||
выравнивает дорожки по времени, и дыра сдвинула бы всё, что после неё.
|
||
Промежутки заполняются тем же файлом — показывать его там всё равно
|
||
никто не будет, за это отвечают окна. }
|
||
procedure TMainForm.BuildOverlayPreview(const AOverlays: TPreviewOverlays;
|
||
const ATotal: Double);
|
||
var
|
||
Segs: TFlatSegmentArray;
|
||
Win: TOverlayWindow;
|
||
I, N: Integer;
|
||
At: Double;
|
||
|
||
procedure Push(const APath: string; const AStart, ADuration: Double);
|
||
begin
|
||
if ADuration <= 0.001 then
|
||
Exit;
|
||
SetLength(Segs, N + 1);
|
||
Segs[N] := Default(TFlatSegment);
|
||
Segs[N].FilePath := APath;
|
||
Segs[N].SrcStart := AStart;
|
||
Segs[N].Duration := ADuration;
|
||
Inc(N);
|
||
end;
|
||
|
||
begin
|
||
FPreviewOverlayUrl := '';
|
||
FPreviewOverlayWindows := nil;
|
||
if Length(AOverlays) = 0 then
|
||
Exit;
|
||
|
||
N := 0;
|
||
At := 0;
|
||
for I := 0 to High(AOverlays) do
|
||
begin
|
||
{ Промежуток до этого куска — заполнитель из того же файла. }
|
||
if AOverlays[I].TlStart > At + 0.001 then
|
||
Push(AOverlays[I].FilePath, 0, AOverlays[I].TlStart - At);
|
||
Push(AOverlays[I].FilePath, AOverlays[I].SrcStart,
|
||
AOverlays[I].TlEnd - AOverlays[I].TlStart);
|
||
At := AOverlays[I].TlEnd;
|
||
|
||
Win := Default(TOverlayWindow);
|
||
Win.TlStart := AOverlays[I].TlStart;
|
||
Win.TlEnd := AOverlays[I].TlEnd;
|
||
Win.Filter := AOverlays[I].Filter;
|
||
Win.X := AOverlays[I].X;
|
||
Win.Y := AOverlays[I].Y;
|
||
Win.Width := AOverlays[I].Width;
|
||
Win.Height := AOverlays[I].Height;
|
||
SetLength(FPreviewOverlayWindows, Length(FPreviewOverlayWindows) + 1);
|
||
FPreviewOverlayWindows[High(FPreviewOverlayWindows)] := Win;
|
||
end;
|
||
|
||
{ Хвост после последнего куска не нужен: наложение там выключено, а
|
||
плеер спокойно доигрывает основу без второй дорожки. }
|
||
if N = 0 then
|
||
begin
|
||
FPreviewOverlayWindows := nil;
|
||
Exit;
|
||
end;
|
||
FPreviewOverlayUrl := BuildEdlUri(Segs);
|
||
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] + '|';
|
||
{ Наложение входит в сравнение наравне со звуком: сдвинули оверлей —
|
||
список кусков основы мог не измениться, а показывать надо иначе. }
|
||
AudioEdl := AudioEdl + '#' + FPreviewOverlayUrl;
|
||
for I := 0 to High(FPreviewOverlayWindows) do
|
||
AudioEdl := AudioEdl + Format('|%s@%d:%d:%s-%s',
|
||
[FPreviewOverlayWindows[I].Filter,
|
||
FPreviewOverlayWindows[I].X, FPreviewOverlayWindows[I].Y,
|
||
SecondsToStr(FPreviewOverlayWindows[I].TlStart),
|
||
SecondsToStr(FPreviewOverlayWindows[I].TlEnd)]);
|
||
|
||
{ Список кусков запоминаем всегда, даже если строка не изменилась:
|
||
громкость в неё не входит, а брать её потом неоткуда. }
|
||
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.SetVideoOverlay(FPreviewOverlayUrl, FPreviewOverlayWindows);
|
||
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.Down := FProject.RippleEnabled;
|
||
if FProject.RippleEnabled then
|
||
btnRipple.Hint := 'Автосхлопывание включено, режим: ' + ModeText + '.'
|
||
else
|
||
btnRipple.Hint := 'Автосхлопывание выключено, режим: ' + ModeText + '.';
|
||
btnRipple.Hint := btnRipple.Hint + LineEnding +
|
||
'Ctrl+K — включить или выключить. Режим действует и при выключенном ' +
|
||
'автосхлопывании: по нему работает Ctrl+Shift+R.';
|
||
btnRippleMenu.Hint := 'Выбрать режим схлопывания';
|
||
end;
|
||
|
||
{ Прилипание краёв клипов друг к другу.
|
||
|
||
Shift работает как переключатель наоборот: при включённом прилипании
|
||
временно отключает его, при выключенном — временно включает. Так одна
|
||
клавиша полезна в обоих режимах, и не нужно помнить, какой сейчас. }
|
||
{ Кнопка со значком не может сказать словами, что она делает и в каком
|
||
она состоянии. Слова переезжают в подсказку — целиком, вместе с
|
||
состоянием: иначе о состоянии пришлось бы догадываться по цвету. }
|
||
procedure TMainForm.UpdateSnapButton;
|
||
var
|
||
State: string;
|
||
begin
|
||
btnSnap.Down := FTimeline.SnapEnabled;
|
||
if FTimeline.SnapEnabled then
|
||
State := 'включено'
|
||
else
|
||
State := 'выключено';
|
||
btnSnap.Hint := 'Прилипание: ' + State + '.' + LineEnding +
|
||
'Shift во время перетаскивания меняет решение на противоположное.';
|
||
end;
|
||
|
||
procedure TMainForm.btnSnapClick(Sender: TObject);
|
||
begin
|
||
FTimeline.SnapEnabled := not FTimeline.SnapEnabled;
|
||
UpdateSnapButton;
|
||
end;
|
||
|
||
{ Прилипание курсора — отдельный переключатель, а не общий с клипами.
|
||
|
||
Это разные привычки: клипы прилипают при перетаскивании, курсор — при
|
||
щелчке. Одному нужно одно, другому другое, и объединять их в один
|
||
выключатель значило бы навязывать связь, которой нет. }
|
||
procedure TMainForm.UpdateGlueButton;
|
||
var
|
||
State: string;
|
||
begin
|
||
btnGlue.Down := FTimeline.PlayheadSnap;
|
||
if FTimeline.PlayheadSnap then
|
||
State := 'включено'
|
||
else
|
||
State := 'выключено';
|
||
btnGlue.Hint := 'Прилипание курсора к границам клипов: ' + State + '.' +
|
||
LineEnding + 'Shift при щелчке меняет решение на противоположное.';
|
||
end;
|
||
|
||
procedure TMainForm.btnGlueClick(Sender: TObject);
|
||
begin
|
||
FTimeline.PlayheadSnap := not FTimeline.PlayheadSnap;
|
||
UpdateGlueButton;
|
||
end;
|
||
|
||
{ Держать ли курсор посередине при воспроизведении.
|
||
|
||
Включено — монтаж едет под курсором, и всегда видно, что будет дальше.
|
||
Выключено — картинка стоит на месте, пока курсор не уйдёт за край; так
|
||
спокойнее, когда разглядываешь конкретное место, а ролик при этом
|
||
играет. }
|
||
procedure TMainForm.UpdateCenterButton;
|
||
var
|
||
State: string;
|
||
begin
|
||
btnCenter.Down := FSettings.CenterPlayhead;
|
||
if FSettings.CenterPlayhead then
|
||
State := 'включено'
|
||
else
|
||
State := 'выключено';
|
||
btnCenter.Hint := 'Курсор посередине при воспроизведении: ' + State + '.' +
|
||
LineEnding + 'Клавиша \ переключает.';
|
||
end;
|
||
|
||
procedure TMainForm.ToggleCenterPlayhead;
|
||
begin
|
||
FSettings.CenterPlayhead := not FSettings.CenterPlayhead;
|
||
UpdateCenterButton;
|
||
if FSettings.CenterPlayhead then
|
||
begin
|
||
FTimeline.ScrollToPlayhead(True);
|
||
SetStatus('Курсор держится посередине монтажа.');
|
||
end
|
||
else
|
||
SetStatus('Монтаж стоит на месте, курсор идёт по нему.');
|
||
end;
|
||
|
||
procedure TMainForm.btnCenterClick(Sender: TObject);
|
||
begin
|
||
ToggleCenterPlayhead;
|
||
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;
|
||
Key: TColorKey;
|
||
Applied: Boolean;
|
||
begin
|
||
if AClip = nil then
|
||
Exit;
|
||
|
||
{ У надписи кнопка на клипе открывает не кадрирование, а правку текста:
|
||
кадрировать там нечего. }
|
||
if AClip.Kind = ckText then
|
||
begin
|
||
FProject.BeginChange;
|
||
if EditTextOf(AClip) then
|
||
TimelineStructureChange(nil)
|
||
else
|
||
FProject.CancelChange;
|
||
Exit;
|
||
end;
|
||
|
||
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;
|
||
{ Ключ отдаётся окну по ссылке: правку он подтверждает сам, и «Отмена»
|
||
кадрирования её не отменяет. }
|
||
Key := AClip.ColorKey;
|
||
Applied := EditTransform(Self, Item.EffectivePath, Item.Info,
|
||
FProject.Master.Width, FProject.Master.Height, T,
|
||
FProject.CacheDir + 'pancrop.png', @Key);
|
||
if (not Applied) and SameColorKey(Key, AClip.ColorKey) then
|
||
Exit;
|
||
|
||
FProject.BeginChange;
|
||
if Applied then
|
||
AClip.Transform := T;
|
||
AClip.ColorKey := Key;
|
||
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.UpdateSubtitles;
|
||
var
|
||
Path: string;
|
||
begin
|
||
if (FProject = nil) or (FPlayer = nil) then
|
||
Exit;
|
||
if FProject.CacheDir = '' then
|
||
Exit;
|
||
|
||
Path := IncludeTrailingPathDelimiter(FProject.CacheDir) + 'subs.ass';
|
||
if WriteAssFile(FProject, Path) then
|
||
FPlayer.SetSubtitleFile(Path)
|
||
else
|
||
FPlayer.SetSubtitleFile('');
|
||
end;
|
||
|
||
procedure TMainForm.ApplyVolumeAt(const ATime: Double);
|
||
var
|
||
I: Integer;
|
||
Clip: TClip;
|
||
Track: TTrack;
|
||
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
|
||
Track := FProject.FindTrack(FPreviewAudioTracks[I]);
|
||
SetLength(Vols, Length(Vols) + 1);
|
||
Vols[High(Vols)] := 1;
|
||
if Track <> nil then
|
||
begin
|
||
Clip := Track.ClipAt(ATime);
|
||
if Clip <> nil then
|
||
Vols[High(Vols)] := Clip.Volume;
|
||
end;
|
||
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 + ', ';
|
||
Track := FProject.FindTrack(FPreviewAudioTracks[I]);
|
||
if Track <> nil then
|
||
Key := Key + Track.Name + '='
|
||
else
|
||
Key := Key + '?=';
|
||
Key := Key + 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(FSettings.CenterPlayhead);
|
||
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;
|
||
Exit;
|
||
end;
|
||
|
||
{ Обратная косая: пункта меню для неё нет намеренно — сочетание из
|
||
одной такой клавиши в меню выглядит как опечатка, а работать должно. }
|
||
if (Key = VK_OEM_5) and (Shift = []) then
|
||
begin
|
||
Key := 0;
|
||
ToggleCenterPlayhead;
|
||
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.MenuColorKey(Sender: TObject);
|
||
var
|
||
T, C: Integer;
|
||
Track: TTrack;
|
||
Found: TClip;
|
||
Item: TMediaItem;
|
||
Key: TColorKey;
|
||
begin
|
||
Found := nil;
|
||
for T := 0 to FProject.TrackCount - 1 do
|
||
begin
|
||
Track := FProject.Tracks[T];
|
||
for C := 0 to Track.Count - 1 do
|
||
if Track[C].Selected and (Track[C].Kind in [ckVideo, ckImage]) then
|
||
begin
|
||
Found := Track[C];
|
||
Break;
|
||
end;
|
||
if Found <> nil then
|
||
Break;
|
||
end;
|
||
|
||
if Found = nil then
|
||
begin
|
||
SetStatus('Выделите клип с картинкой: ключ выбивает цвет из неё.');
|
||
Exit;
|
||
end;
|
||
|
||
Item := FProject.FindMedia(Found.MediaId);
|
||
if Item = nil then
|
||
Exit;
|
||
|
||
Key := Found.ColorKey;
|
||
if not EditColorKey(Key, Item.EffectivePath,
|
||
Found.SrcIn + Found.Duration / 2, FProject.CacheDir + 'colorkey.png') then
|
||
Exit;
|
||
|
||
FProject.BeginChange;
|
||
Found.ColorKey := Key;
|
||
FTimeline.Invalidate;
|
||
FLastLoadedEdl := '';
|
||
SchedulePreview;
|
||
UpdateCaption;
|
||
if Key.Enabled then
|
||
SetStatus('Цветовой ключ включён: участок будет пересобран.')
|
||
else
|
||
SetStatus('Цветовой ключ выключен.');
|
||
end;
|
||
|
||
{ Отметки участка.
|
||
|
||
Участок нужен, чтобы собрать кусок монтажа, а не весь ролик: на длинном
|
||
материале проверить правку иначе почти невозможно — сборка занимает
|
||
столько же, сколько сам ролик, а то и больше.
|
||
|
||
Отметки ставятся по курсору, как в монтажных программах. Перепутанные
|
||
местами меняются сами: требовать от человека помнить порядок — лишняя
|
||
строгость там, где всё однозначно. }
|
||
procedure TMainForm.MenuRegionIn(Sender: TObject);
|
||
begin
|
||
FProject.RegionStart := FTimeline.Playhead;
|
||
if FProject.RegionEnd <= FProject.RegionStart then
|
||
FProject.RegionEnd := FProject.EndTime;
|
||
FTimeline.Invalidate;
|
||
UpdateCaption;
|
||
SetStatus(Format('Участок: %s — %s',
|
||
[SecondsToStr(FProject.RegionStart), SecondsToStr(FProject.RegionEnd)]));
|
||
end;
|
||
|
||
procedure TMainForm.MenuRegionOut(Sender: TObject);
|
||
var
|
||
Tmp: Double;
|
||
begin
|
||
FProject.RegionEnd := FTimeline.Playhead;
|
||
if FProject.RegionEnd < FProject.RegionStart then
|
||
begin
|
||
Tmp := FProject.RegionStart;
|
||
FProject.RegionStart := FProject.RegionEnd;
|
||
FProject.RegionEnd := Tmp;
|
||
end;
|
||
FTimeline.Invalidate;
|
||
UpdateCaption;
|
||
SetStatus(Format('Участок: %s — %s',
|
||
[SecondsToStr(FProject.RegionStart), SecondsToStr(FProject.RegionEnd)]));
|
||
end;
|
||
|
||
procedure TMainForm.MenuRegionClear(Sender: TObject);
|
||
begin
|
||
FProject.RegionStart := 0;
|
||
FProject.RegionEnd := 0;
|
||
FTimeline.Invalidate;
|
||
UpdateCaption;
|
||
SetStatus('Отметки участка сняты: собирается весь монтаж.');
|
||
end;
|
||
|
||
{ Границы того, что собираем. Без отметок — весь монтаж. }
|
||
procedure TMainForm.DescribeRegion(out AFrom, ATo: Double);
|
||
begin
|
||
if FProject.HasRegion then
|
||
begin
|
||
AFrom := Max(0, FProject.RegionStart);
|
||
ATo := FProject.RegionEnd;
|
||
end
|
||
else
|
||
begin
|
||
AFrom := 0;
|
||
ATo := FProject.EndTime;
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.MenuSelectAll(Sender: TObject);
|
||
begin
|
||
FTimeline.SelectAll;
|
||
end;
|
||
|
||
procedure TMainForm.MenuRipple(Sender: TObject);
|
||
begin
|
||
FTimeline.RippleCloseGap;
|
||
end;
|
||
|
||
{ К началу самого раннего клипа по всем дорожкам. Если монтаж начинается
|
||
с пятой секунды, ноль — не то место, куда хотят попасть. }
|
||
{ Показывать ли в предпросмотре то, что даст сборка.
|
||
|
||
Выключено — оверлей виден целиком, со своим фоном: так понятно, куда он
|
||
встал и где его края. Включено — выбитый цвет и прозрачность считаются
|
||
на лету, и окно совпадает с готовым роликом.
|
||
|
||
Считается это не бесплатно, хотя и недорого: фильтр работает по площади
|
||
оверлея, а не всего кадра. Замерено на 2688x1512: наложение стоит 0.36 с
|
||
на десять секунд материала, ключ добавляет ещё 0.23 с. }
|
||
procedure TMainForm.MenuTogglePreviewKey(Sender: TObject);
|
||
begin
|
||
FSettings.PreviewKey := not FSettings.PreviewKey;
|
||
FKeyPreviewItem.Checked := FSettings.PreviewKey;
|
||
{ Список кусков не изменился, а показывать надо иначе — заставляем
|
||
пересобрать цепочку. }
|
||
FLastLoadedEdl := '';
|
||
SchedulePreview;
|
||
if FSettings.PreviewKey then
|
||
SetStatus('Предпросмотр показывает ключ и прозрачность.')
|
||
else
|
||
SetStatus('Предпросмотр показывает оверлей как есть.');
|
||
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);
|
||
begin
|
||
DoExport(Default(TEncodeProfile));
|
||
end;
|
||
|
||
{ Сборка с перекодированием: отдельный пункт, потому что это осознанный
|
||
выбор — ролик пересобирается целиком, и быстрым это уже не будет. }
|
||
procedure TMainForm.MenuExportEncode(Sender: TObject);
|
||
var
|
||
Profile: TEncodeProfile;
|
||
begin
|
||
if not AskEncodeProfile(Profile, FProject.Master.VideoCodec) then
|
||
Exit;
|
||
DoExport(Profile);
|
||
end;
|
||
|
||
procedure TMainForm.DoExport(const AProfile: TEncodeProfile);
|
||
var
|
||
Segments, AudioSegs: TFlatSegmentArray;
|
||
Missing: TGenRequests;
|
||
HasPrecise: Boolean;
|
||
T, C: Integer;
|
||
Rebuilt, RegionFrom, RegionTo: Double;
|
||
SubsPath, RegionCaption, Extra: string;
|
||
Master: TMediaInfo;
|
||
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;
|
||
|
||
DescribeRegion(RegionFrom, RegionTo);
|
||
RegionCaption := '';
|
||
if FProject.HasRegion then
|
||
RegionCaption := SecondsToStr(RegionFrom) + ' — ' + SecondsToStr(RegionTo);
|
||
|
||
{ Сколько материала придётся пересобрать. Наложение, переход,
|
||
полупрозрачность и чужие параметры файла — всё это перекодирование, и
|
||
человек должен знать цену заранее, а не обнаружить её по времени
|
||
сборки. }
|
||
Rebuilt := 0;
|
||
|
||
{ Если есть хоть один точный рез, предупреждаем про контейнер: в 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 not AskExport(FExportChoice, HasText(FProject), HasPrecise,
|
||
FSettings.LastExportDir, RegionCaption) then
|
||
Exit;
|
||
FSettings.LastExportDir := ExtractFilePath(FExportChoice.Path);
|
||
|
||
{ Участок режется после вопроса: человек мог снять галку и собрать всё.
|
||
Картинка и звук подрезаются по одному времени, иначе они разъедутся. }
|
||
if not (FProject.HasRegion and FExportChoice.RegionOnly) then
|
||
begin
|
||
RegionFrom := 0;
|
||
RegionTo := TotalDuration(Segments);
|
||
end
|
||
else
|
||
begin
|
||
ClipSegmentsToRange(Segments, RegionFrom, RegionTo);
|
||
ClipSegmentsToRange(AudioSegs, RegionFrom, RegionTo);
|
||
if Length(Segments) = 0 then
|
||
begin
|
||
ThemedMessageDlg('nlve',
|
||
'В отмеченном участке нечего собирать.', mtInformation, [mbOK], 0);
|
||
Exit;
|
||
end;
|
||
end;
|
||
|
||
if HasPrecise and
|
||
(LowerCase(ExtractFileExt(FExportChoice.Path)) <> '.mkv') then
|
||
if ThemedMessageDlg('nlve',
|
||
'В монтаже есть точные резы. В MP4 перекодированный стык может ' +
|
||
'воспроизводиться неправильно — надёжнее MKV.' + LineEnding +
|
||
LineEnding + 'Всё равно собрать в выбранный контейнер?',
|
||
mtWarning, [mbYes, mbNo], 0) <> mrYes then
|
||
Exit;
|
||
|
||
{ Сколько материала придётся пересобрать — считаем уже по тому списку,
|
||
который пойдёт в сборку: с участком он короче, и обещать человеку
|
||
работу на весь ролик было бы неправдой. }
|
||
for T := 0 to High(Segments) do
|
||
if Segments[T].Transcode or (Length(Segments[T].Layers) > 0) then
|
||
Rebuilt := Rebuilt + Segments[T].Duration;
|
||
|
||
{ Вжигание меняет расклад: куски с текстом перестают копироваться.
|
||
Готовим их до подсчёта того, сколько придётся пересобрать. }
|
||
SubsPath := '';
|
||
if HasText(FProject) then
|
||
begin
|
||
if FExportChoice.BurnText then
|
||
{ Начало списка — не обязательно начало монтажа: при отмеченном
|
||
участке текст надо брать с его начала. }
|
||
Rebuilt := Rebuilt +
|
||
BurnTextIntoSegments(FProject, Segments, FProject.CacheDir, RegionFrom)
|
||
else
|
||
begin
|
||
SubsPath := IncludeTrailingPathDelimiter(FProject.CacheDir) +
|
||
'export.ass';
|
||
{ Разметка тоже по участку: иначе субтитры в готовом файле
|
||
появлялись бы со сдвигом на его начало. }
|
||
if not WriteAssForRange(FProject, RegionFrom, RegionTo, SubsPath) then
|
||
SubsPath := '';
|
||
end;
|
||
end;
|
||
|
||
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;
|
||
|
||
{ Пересобираемые куски целятся в битрейт самого щедрого исходника, а не
|
||
в то, что кодировщик выберет сам: его выбор скромнее в разы, и
|
||
пересобранный кусок оказывается заметно хуже соседних скопированных. }
|
||
Master := FProject.Master;
|
||
Master.VideoBitrate := FProject.MaxVideoBitrate;
|
||
|
||
{ Журнал этой сборки: рядом с готовым файлом, под тем же именем.
|
||
Прежний одноимённый убираем — иначе две сборки слиплись бы в один
|
||
файл, и разобрать, где чья, было бы нельзя. }
|
||
FExportLogPath := ChangeFileExt(FExportChoice.Path, '.log');
|
||
if FileExists(FExportLogPath) then
|
||
SysUtils.DeleteFile(FExportLogPath);
|
||
|
||
LogExport(Format('nlve, сборка от %s',
|
||
[FormatDateTime('yyyy-mm-dd hh:nn:ss', Now)]));
|
||
LogExport('Проект: ' + FProject.FileName);
|
||
LogExport('Готовый файл: ' + FExportChoice.Path);
|
||
if FProject.HasRegion and FExportChoice.RegionOnly then
|
||
LogExport(Format('Собирается отмеченный участок: %s — %s',
|
||
[SecondsToStr(RegionFrom), SecondsToStr(RegionTo)]))
|
||
else
|
||
LogExport('Собирается весь монтаж.');
|
||
LogExport(Format('Кадр проекта: %dx%d, %d/%d к/с, %s, %s',
|
||
[Master.Width, Master.Height, Master.FpsNum, Master.FpsDen,
|
||
Master.VideoCodec, Master.PixFmt]));
|
||
LogExport(Format('Целевой битрейт: %d кбит/с (наибольший среди файлов проекта)',
|
||
[Master.VideoBitrate div 1000]));
|
||
if FExportChoice.BurnText then
|
||
LogExport('Текст вжигается в картинку.')
|
||
else if SubsPath <> '' then
|
||
LogExport('Текст идёт отдельной дорожкой субтитров.')
|
||
else if HasText(FProject) then
|
||
LogExport('ВНИМАНИЕ: текст в проекте есть, но в сборку не попадает.');
|
||
LogExport(Format('%d %s, длительность %s с',
|
||
[Length(Segments), Plural(Length(Segments), 'кусок', 'куска', 'кусков'),
|
||
SecondsToStr(TotalDuration(Segments))]));
|
||
|
||
{ Что именно собирается — по кускам. Без этого списка по журналу нельзя
|
||
понять, попал ли в сборку тот клип, которого потом не нашли в ролике. }
|
||
for T := 0 to High(Segments) do
|
||
begin
|
||
Extra := '';
|
||
if Length(Segments[T].Layers) > 0 then
|
||
Extra := Extra + ', слоёв ' + IntToStr(Length(Segments[T].Layers));
|
||
if Segments[T].SubFile <> '' then
|
||
Extra := Extra + ', с текстом';
|
||
if Segments[T].Transcode then
|
||
Extra := Extra + ', пересобирается';
|
||
LogExport(Format(' кусок %d: %s, из %s, длина %s%s',
|
||
[T + 1, ExtractFileName(Segments[T].FilePath),
|
||
SecondsToStr(Segments[T].SrcStart), SecondsToStr(Segments[T].Duration),
|
||
Extra]));
|
||
end;
|
||
|
||
FExport := TExportThread.Create(Segments, AudioSegs,
|
||
FExportChoice.Path, True, Master, AProfile);
|
||
FExport.SubtitlePath := SubsPath;
|
||
FExport.LogPath := FExportLogPath;
|
||
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.LogExport(const AText: string);
|
||
var
|
||
F: TextFile;
|
||
begin
|
||
Log(AText);
|
||
if FExportLogPath = '' then
|
||
Exit;
|
||
try
|
||
AssignFile(F, FExportLogPath);
|
||
if FileExists(FExportLogPath) then
|
||
Append(F)
|
||
else
|
||
Rewrite(F);
|
||
try
|
||
WriteLn(F, AText);
|
||
finally
|
||
CloseFile(F);
|
||
end;
|
||
except
|
||
on E: Exception do
|
||
FExportLogPath := '';
|
||
end;
|
||
end;
|
||
|
||
procedure TMainForm.ShowExportReport(const AReport: TExportReport);
|
||
var
|
||
I, Encoded: Integer;
|
||
Shift: Double;
|
||
begin
|
||
if AReport.Cancelled then
|
||
begin
|
||
LogExport('Сборка отменена.');
|
||
Exit;
|
||
end;
|
||
|
||
if not AReport.Succeeded then
|
||
begin
|
||
LogExport('Сборка не удалась: ' + AReport.Message);
|
||
Exit;
|
||
end;
|
||
|
||
LogExport('--- Отчёт о сборке ---');
|
||
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);
|
||
LogExport(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
|
||
LogExport(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
|
||
LogExport(Format(' перекодировано частей: %d, остальное скопировано без потерь',
|
||
[Encoded]));
|
||
|
||
LogExport(Format(' сумма пакетов кусков: %d', [AReport.ExpectedPackets]));
|
||
LogExport(Format(' пакетов в готовом файле: %d', [AReport.ActualPackets]));
|
||
if AReport.ExpectedPackets = AReport.ActualPackets then
|
||
LogExport(' СВЕРКА ПРОЙДЕНА: склейка не потеряла и не продублировала ни одного кадра.')
|
||
else
|
||
LogExport(Format(' РАСХОЖДЕНИЕ на %d кадров.',
|
||
[AReport.ActualPackets - AReport.ExpectedPackets]));
|
||
LogExport(' файл: ' + AReport.OutputPath);
|
||
SetStatus('Готово: ' + AReport.OutputPath);
|
||
end;
|
||
|
||
end.
|