From d55b624560903e2102fcb5fd48a576526b07639b Mon Sep 17 00:00:00 2001 From: 4aiman Date: Sun, 30 Aug 2026 15:30:02 +0300 Subject: [PATCH] =?UTF-8?q?=D0=A2=D0=B5=D0=BA=D1=81=D1=82=20=D0=BD=D0=B0?= =?UTF-8?q?=20=D0=B2=D0=B8=D0=B4=D0=B5=D0=BE:=20=D0=BC=D0=BE=D0=B4=D0=B5?= =?UTF-8?q?=D0=BB=D1=8C,=20=D1=80=D0=B0=D0=B7=D0=BC=D0=B5=D1=82=D0=BA?= =?UTF-8?q?=D0=B0=20ASS,=20=D0=BF=D1=80=D0=B5=D0=B4=D0=BF=D1=80=D0=BE?= =?UTF-8?q?=D1=81=D0=BC=D0=BE=D1=82=D1=80=20=D0=B8=20=D1=80=D0=B5=D0=B4?= =?UTF-8?q?=D0=B0=D0=BA=D1=82=D0=BE=D1=80?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ffmpeg умеет рисовать текст, но не тем фильтром, о котором думают. drawtext в местной сборке отсутствует: с версии 7.1 ему нужен harfbuzz. Зато есть libass — и он для задачи лучше. Проверено отрисовкой: цвет, обводка, тень, шрифт по имени, размер, поля и девять положений. Девять положений — родное понятие ASS, ровно та сетка, которую просили. Чего libass не делает — не уменьшает шрифт, чтобы текст влез. Это считаем мы: сами переносим по словам и сами подбираем размер, а libass получает готовые переводы строк, чтобы нарисовать ровно то, что мы померили. Размер ищется делением отрезка пополам. Прикидка «уменьшить во столько же раз, во сколько не влезли» давала слишком мелко: после переноса строк становится меньше, и места остаётся вдоволь — на длинной надписи вместо 29 помещался 37. Замер готового блока: ровно 144 точки при разрешённых 144, то есть пятая часть кадра 720p. Текст живёт на своей дорожке, как звук: правило «верхний клип побеждает» на него не распространяется, он лежит поверх и ничего не закрывает. Предпросмотр ничего не стоит. mpv рисует внешний файл ASS поверх нашего виртуального списка кусков — правка текста видна сразу, без пересборки участка, в отличие от прозрачности. Подключение сделано в двух местах: при смене файла и при загрузке нового списка кусков, потому что тогда mpv забывает все внешние дорожки. Редактор: текст, шрифт из установленных в системе, размер, три цвета образцами, толщина обводки и тени, сетка три на три, доля высоты. Рядом сказано, во что превратится надпись, — считает тот же код, что и сборка разметки. Замер ширины подключается снаружи: точный требует холста, а холст — оконного набора. Служебная программа без экрана обходится оценкой, окно ставит точный. Из-за этого же из модели убран TColor: она не должна тянуть за собой оконную библиотеку. Сборки ролика с текстом пока нет — это следующий этап, он расписан в IMPLEMENTATION_PLAN.md. --- src/uAppTypes.pas | 8 + src/uMainForm.pas | 126 +++++++++++- src/uMpvPlayer.pas | 33 +++- src/uProject.pas | 134 ++++++++++++- src/uSubtitles.pas | 444 ++++++++++++++++++++++++++++++++++++++++++ src/uTextForm.pas | 372 +++++++++++++++++++++++++++++++++++ src/uTextMeasure.pas | 62 ++++++ src/uTheme.pas | 24 +++ src/uTimelineCtrl.pas | 24 ++- tests/nlvetool.lpr | 37 +++- 10 files changed, 1251 insertions(+), 13 deletions(-) create mode 100644 src/uSubtitles.pas create mode 100644 src/uTextForm.pas create mode 100644 src/uTextMeasure.pas diff --git a/src/uAppTypes.pas b/src/uAppTypes.pas index 86e6da1..feef1dd 100644 --- a/src/uAppTypes.pas +++ b/src/uAppTypes.pas @@ -15,6 +15,14 @@ uses {$IFDEF UNIX}, BaseUnix{$ENDIF}; type + { Цвет в записи, принятой в LCL: $00BBGGRR. + + Свой тип, а не TColor из Graphics: модель не должна тянуть за собой + оконную библиотеку. Стоило один раз потянуть — и консольная проверка + перестала собираться. Значения совпадают, окно приводит одно к + другому без пересчёта. } + TRgb = LongInt; + { Чем заполнен сегмент готового ряда. skVideo — кусок настоящего исходного файла, копируется без перекодирования. diff --git a/src/uMainForm.pas b/src/uMainForm.pas index 233fb8a..ead47b0 100644 --- a/src/uMainForm.pas +++ b/src/uMainForm.pas @@ -29,7 +29,7 @@ uses uRemuxForm, uMismatchForm, uFfmpegJob, uSettings, uThumbs, uTransform, uPanCropForm, uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm, uWaveform, - uIconData; + uIconData, uSubtitles, uTextMeasure, uTextForm; const { Номера системных сообщений о перерисовке рамки окна. Берём числами, а @@ -171,6 +171,8 @@ type FSeekWaitTicks: Integer; procedure ApplyVolumeAt(const ATime: Double); + { Переписывает файл субтитров и отдаёт его плееру. } + procedure UpdateSubtitles; procedure UpdateRippleButton; procedure UpdateSnapButton; procedure RippleModeChosen(Sender: TObject); @@ -215,6 +217,9 @@ type procedure LogButtonClick(Sender: TObject); procedure MenuToggleLog(Sender: TObject); procedure MenuAbout(Sender: TObject); + procedure MenuAddText(Sender: TObject); + { Открывает редактор текста для клипа. True — что-то изменилось. } + function EditTextOf(AClip: TClip): Boolean; procedure ApplyLogVisible(AVisible: Boolean); procedure BuildTimeline; procedure StartPlayer; @@ -581,6 +586,10 @@ begin Application.HintPause := 100; Application.HintHidePause := 15000; + { Точный замер текста ставится до первой сборки субтитров: без него + размер подбирался бы по грубой оценке. } + InstallTextMeasure; + ApplyWindowIcon; BuildJobIndicator; @@ -640,6 +649,8 @@ begin MProject := AddTop('Проект'); AddItem(MProject, 'Сведения о проекте...', @MenuProjectInfo); AddSep(MProject); + AddItem(MProject, 'Добавить текст', @MenuAddText, ShortCut(VK_T, [ssCtrl])); + AddSep(MProject); AddItem(MProject, 'Добавить дорожку', @MenuAddTrack); AddItem(MProject, 'Удалить последнюю дорожку', @MenuRemoveTrack); @@ -757,6 +768,86 @@ 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; @@ -1731,6 +1822,10 @@ begin Exit; end; + { Текст поверх картинки рисует сам плеер: ему отдаётся файл разметки, + а не пересобранный кусок. Поэтому правка текста видна сразу. } + UpdateSubtitles; + { Участки с прозрачностью и переходами плееру не по зубам: список кусков накладывать не умеет. Подставляем вместо них заранее посчитанные файлы, а чего ещё нет — заказываем. } @@ -2172,6 +2267,19 @@ var 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; @@ -2321,6 +2429,22 @@ 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; diff --git a/src/uMpvPlayer.pas b/src/uMpvPlayer.pas index 8ab1d51..4c3e42e 100644 --- a/src/uMpvPlayer.pas +++ b/src/uMpvPlayer.pas @@ -63,6 +63,7 @@ type { Номера подключённых звуковых дорожек, в порядке подключения. } FAudioIds: array of string; FLastGraph: string; + FSubtitlePath: string; { Что произошло с выбором звуковой дорожки. Читается окном для журнала: без этого понять, откуда взялся звук, нечем. } FAudioTrackNote: string; @@ -195,6 +196,11 @@ type { Цепочка смешивания, отданная mpv. Нужна журналу: по ней видно, какая дорожка какую громкость получила на самом деле. } property AudioGraph: string read FLastGraph; + { Файл субтитров поверх картинки. Пустая строка снимает его. + + Держится отдельно от списка кусков: текст правится чаще, чем + монтаж, и перезагружать из-за него картинку незачем. } + procedure SetSubtitleFile(const APath: string); end; implementation @@ -899,6 +905,25 @@ begin mpv_set_property_string(FHandle, 'lavfi-complex', PAnsiChar(Graph)); end; +{ Субтитры подключаются двумя путями, и оба нужны. + + Здесь — когда файл поменялся, а картинка та же: снимаем прежние и + подключаем новые, не трогая воспроизведение. При загрузке нового списка + кусков mpv забывает все внешние дорожки, поэтому там подключение + повторяется — см. SelectExternalAudio. } +procedure TMpvPlayer.SetSubtitleFile(const APath: string); +begin + if FSubtitlePath = APath then + Exit; + FSubtitlePath := APath; + if FHandle = nil then + Exit; + + Command(['sub-remove']); + if APath <> '' then + Command(['sub-add', APath, 'select']); +end; + procedure TMpvPlayer.SelectExternalAudio; var Count, I, Found: Integer; @@ -1001,7 +1026,13 @@ begin MPV_EVENT_LOG_MESSAGE: HandleLogMessage(Pmpv_event_log_message(Ev^.data)); MPV_EVENT_FILE_LOADED: - SelectExternalAudio; + begin + SelectExternalAudio; + { Загрузка нового списка кусков сбрасывает все внешние дорожки, + в том числе субтитры. Подключаем заново. } + if FSubtitlePath <> '' then + Command(['sub-add', FSubtitlePath, 'select']); + end; MPV_EVENT_SHUTDOWN: begin FPump.Enabled := False; diff --git a/src/uProject.pas b/src/uProject.pas index 8262766..0fc4640 100644 --- a/src/uProject.pas +++ b/src/uProject.pas @@ -38,7 +38,37 @@ type Отдельный вид, а не признак дорожки, потому что решение принимается по клипу: сборка спрашивает у куска, что из него доставать. } - TClipKind = (ckVideo, ckImage, ckBlack, ckAudio); + TClipKind = (ckVideo, ckImage, ckBlack, ckAudio, ckText); + + { Положение текста в кадре: девять клеток, как на цифровой клавиатуре. + Числа совпадают с полем Alignment в ASS — переводить не приходится. } + TTextPlace = ( + tpBottomLeft = 1, tpBottomCenter = 2, tpBottomRight = 3, + tpMiddleLeft = 4, tpMiddleCenter = 5, tpMiddleRight = 6, + tpTopLeft = 7, tpTopCenter = 8, tpTopRight = 9 + ); + + { Оформление текстового клипа. + + Цвета хранятся как TColor, а в ASS переводятся: там свой порядок + составляющих и своя запись прозрачности. } + TTextStyle = record + FontName: string; + { Размер в точках кадра проекта, а не экрана. Он же верхняя граница: + если текст не влезает в отведённую полосу, размер уменьшается. } + FontSize: Integer; + Color: TRgb; + OutlineColor: TRgb; + { Толщина обводки и смещение тени в точках. Ноль — нет вовсе. } + Outline: Integer; + Shadow: Integer; + ShadowColor: TRgb; + Place: TTextPlace; + { Какую долю высоты кадра тексту позволено занять. 0.2 — пятую часть. } + MaxHeight: Double; + Bold: Boolean; + Italic: Boolean; + end; { На какие дорожки действует схлопывание. @@ -89,6 +119,8 @@ type FOpacity: Double; FFadeIn: Double; FFadeOut: Double; + FText: string; + FTextStyle: TTextStyle; public constructor Create; function TlEnd: Double; @@ -131,6 +163,10 @@ type удаляются вместе. По умолчанию так связаны картинка и её звук; Ctrl+G связывает и развязывает что угодно. } property GroupId: string read FGroupId write FGroupId; + { Текст и его оформление. Имеют смысл только у клипа вида ckText; + у остальных лежат пустыми и в файл проекта не пишутся. } + property Text: string read FText write FText; + property TextStyle: TTextStyle read FTextStyle write FTextStyle; { Выделение живёт только в памяти и в файл проекта не пишется. } property Selected: Boolean read FSelected write FSelected; end; @@ -138,7 +174,7 @@ type { Что живёт на дорожке. Картинка и звук разделены, потому что их можно двигать порознь: звук из одного места монтажа под картинкой из другого — обычное дело. } - TTrackKind = (tkVideo, tkAudio); + TTrackKind = (tkVideo, tkAudio, tkText); TTrack = class private @@ -188,10 +224,12 @@ type function GetPoolCount: Integer; function GetTrack(AIndex: Integer): TTrack; function GetTrackCount: Integer; - function NewId(const APrefix: string): string; function Serialize: string; procedure Deserialize(const AText: string); public + { Неповторимый номер для нового клипа или дорожки. Публичный: клипы + заводит не только сам проект — например, надпись создаёт окно. } + function NewId(const APrefix: string): string; constructor Create; destructor Destroy; override; @@ -298,6 +336,15 @@ const { Сколько длится картинка, пока её не растянули. } DefaultImageDuration = 5.0; +{ Оформление текста по умолчанию: белые буквы с тёмной обводкой внизу по + центру — то, что читается на любой картинке. } +function DefaultTextStyle: TTextStyle; + +{ Шрифт по умолчанию. Разный по системам: одинаковых имён у них нет. } +const + DefaultTextFont = + {$IFDEF WINDOWS}'Arial'{$ELSE}'DejaVu Sans'{$ENDIF}; + implementation uses @@ -332,6 +379,7 @@ begin FVolume := 1; FOpacity := 1; FTransform := DefaultTransform; + FTextStyle := DefaultTextStyle; end; function TClip.TlEnd: Double; @@ -594,6 +642,19 @@ begin if AKind = tkVideo then begin Pos := FTracks.Count; + for I := 0 to FTracks.Count - 1 do + if TTrack(FTracks[I]).Kind in [tkAudio, tkText] then + begin + Pos := I; + Break; + end; + FTracks.Insert(Pos, Result); + end + else if AKind = tkText then + begin + { Текст выше звука, но ниже картинки: на монтаже он читается как + надстройка над видеорядом, а не как ещё одна дорожка звука. } + Pos := FTracks.Count; for I := 0 to FTracks.Count - 1 do if TTrack(FTracks[I]).Kind = tkAudio then begin @@ -1053,18 +1114,59 @@ begin Result := edSnap; end; +{ Оформление текста по умолчанию: белые буквы с тёмной обводкой внизу по + центру — то, что читается на любой картинке. } +function DefaultTextStyle: TTextStyle; +begin + Result.FontName := DefaultTextFont; + Result.FontSize := 48; + Result.Color := TRgb($FFFFFF); + Result.OutlineColor := TRgb($202020); + Result.Outline := 3; + Result.Shadow := 2; + Result.ShadowColor := TRgb($000000); + Result.Place := tpBottomCenter; + Result.MaxHeight := 0.2; + Result.Bold := False; + Result.Italic := False; +end; + +function JsonToTextStyle(AObj: TJSONObject): TTextStyle; +begin + Result := DefaultTextStyle; + if AObj = nil then + Exit; + Result.FontName := AObj.Get('font', Result.FontName); + Result.FontSize := AObj.Get('size', Result.FontSize); + Result.Color := TRgb(AObj.Get('color', Integer(Result.Color))); + Result.OutlineColor := TRgb(AObj.Get('outline_color', + Integer(Result.OutlineColor))); + Result.Outline := AObj.Get('outline', Result.Outline); + Result.Shadow := AObj.Get('shadow', Result.Shadow); + Result.ShadowColor := TRgb(AObj.Get('shadow_color', + Integer(Result.ShadowColor))); + Result.Place := TTextPlace(AObj.Get('place', Integer(Ord(Result.Place)))); + Result.MaxHeight := AObj.Get('max_height', Result.MaxHeight); + Result.Bold := AObj.Get('bold', Result.Bold); + Result.Italic := AObj.Get('italic', Result.Italic); +end; + function TrackKindToStr(AKind: TTrackKind): string; begin - if AKind = tkAudio then - Result := 'audio' + case AKind of + tkAudio: Result := 'audio'; + tkText: Result := 'text'; else Result := 'video'; + end; end; function StrToTrackKind(const AValue: string): TTrackKind; begin if AValue = 'audio' then Result := tkAudio + else if AValue = 'text' then + Result := tkText else Result := tkVideo; end; @@ -1075,6 +1177,7 @@ begin ckImage: Result := 'image'; ckBlack: Result := 'black'; ckAudio: Result := 'audio'; + ckText: Result := 'text'; else Result := 'video'; end; @@ -1088,6 +1191,8 @@ begin Result := ckBlack else if AValue = 'audio' then Result := ckAudio + else if AValue = 'text' then + Result := ckText else Result := ckVideo; end; @@ -1238,6 +1343,22 @@ begin 'zoom', Clip.Transform.Zoom, 'offset_x', Clip.Transform.OffsetX, 'offset_y', Clip.Transform.OffsetY + ]), + { Оформление пишется только у текстовых клипов: у остальных оно + пустое, и таскать его в файле незачем. } + 'text', Clip.Text, + 'text_style', TJSONObject.Create([ + 'font', Clip.TextStyle.FontName, + 'size', Clip.TextStyle.FontSize, + 'color', Integer(Clip.TextStyle.Color), + 'outline_color', Integer(Clip.TextStyle.OutlineColor), + 'outline', Clip.TextStyle.Outline, + 'shadow', Clip.TextStyle.Shadow, + 'shadow_color', Integer(Clip.TextStyle.ShadowColor), + 'place', Integer(Ord(Clip.TextStyle.Place)), + 'max_height', Clip.TextStyle.MaxHeight, + 'bold', Clip.TextStyle.Bold, + 'italic', Clip.TextStyle.Italic ]) ])); end; @@ -1353,6 +1474,9 @@ begin if Media <> nil then Clip.Transform := Media.Transform; end; + Clip.Text := ClipObj.Get('text', ''); + Clip.TextStyle := JsonToTextStyle( + ClipObj.Get('text_style', TJSONObject(nil))); Track.Add(Clip); end; Track.Sort; diff --git a/src/uSubtitles.pas b/src/uSubtitles.pas new file mode 100644 index 0000000..57dd183 --- /dev/null +++ b/src/uSubtitles.pas @@ -0,0 +1,444 @@ +{ + uSubtitles — текст поверх картинки. + + Рисует не эта программа, а libass: он есть и внутри mpv, и внутри + ffmpeg, поэтому предпросмотр и готовый ролик показывают одно и то же. + Наше дело — собрать для него файл ASS. + + Почему переносы считаем сами. libass умеет переносить, но тогда + неизвестно, сколько выйдет строк, и подобрать размер под отведённую + полосу нечем. Поэтому меряем и переносим здесь, а в файл отдаём готовые + переводы строк: что померили, то и нарисуется. + + Чем меряем. Тем же шрифтом, что уйдёт в libass, через холст LCL — за + обоими стоит FreeType, и ширины сходятся. Небольшой запас всё равно + берём: настройки сглаживания у них разные. + + Замер, на котором держится подбор размера (DejaVu Sans, кадр 1280x720): + шаг строк почти равен размеру шрифта, высота блока из N строк ≈ + размер × (N − 0.16). В полосу 20% высоты влезает три строки размером до + 50, четыре до 37, пять до 30. +} +unit uSubtitles; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, uAppTypes, uProject; + +type + { Как померить ширину строки. Возвращает ширину в точках кадра. } + TTextMeasure = function(const AText: string; const AStyle: TTextStyle; + ASize: Integer): Integer; + +var + { Замерщик ширины текста. + + Подключается снаружи: точный замер требует холста, а холст — + работающего оконного набора. Служебной программе без экрана он + недоступен, и она обходится оценкой (см. EstimateWidth) — для + проверки самого файла ASS этого хватает. + + Окно ставит сюда замер тем же шрифтом, каким libass будет рисовать. } + TextMeasure: TTextMeasure = nil; + +{ Собирает ASS из всех текстовых клипов проекта. + + Возвращает пустую строку, если текста нет вовсе — тогда и файл писать + незачем. } +function BuildAss(AProject: TProject): string; + +{ Пишет ASS в файл. False — писать было нечего или не вышло. } +function WriteAssFile(AProject: TProject; const APath: string): Boolean; + +{ Есть ли в проекте хоть один текстовый клип. } +function HasText(AProject: TProject): Boolean; + +{ Подбор размера и переносов — для окна редактора: оно показывает, во что + превратится надпись, ещё до сборки разметки. Тот же код, что и в самой + сборке, поэтому расхождения быть не может. } +function FitTextForPreview(const AText: string; const AStyle: TTextStyle; + AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer; + +{ Занят ли текстом этот отрезок монтажа. Нужно сборке: вжигать текст + приходится только в те куски, которые он покрывает. } +function TextCovers(AProject: TProject; const AFrom, ATo: Double): Boolean; + +implementation + +uses + Math, LazUTF8; + +const + { Запас по ширине: наши мерки и мерки libass расходятся на проценты. } + WidthSafety = 0.95; + { Поля от краёв кадра в долях ширины и высоты. } + MarginShare = 0.05; + { Ниже этого размер не опускаем: дальше текст всё равно не прочесть, + и лучше показать его крупным с выходом за полосу, чем нечитаемым. } + MinFontSize = 14; + +{ Время в записи ASS: часы:минуты:секунды.сотые. } +function AssTime(const ASeconds: Double): string; +var + T: Double; + H, M: Integer; + S: Double; +begin + T := Max(0, ASeconds); + H := Trunc(T) div 3600; + M := (Trunc(T) mod 3600) div 60; + S := T - H * 3600 - M * 60; + { Дробную часть добиваем нулём вручную: %05.2f у Паскаля дополняет + пробелом, а ASS с пробелом внутри времени не читается. } + Result := Format('%d:%.2d:%.2d.%.2d', + [H, M, Trunc(S), Round(Frac(S) * 100)]); +end; + +{ Цвет в записи ASS: &HAABBGGRR. Порядок обратный привычному, а первым + идёт не прозрачность, а её отсутствие — ноль значит «непрозрачно». } +function AssColor(AColor: TRgb; ATransparent: Boolean = False): string; +var + Alpha: Integer; +begin + if ATransparent then + Alpha := $FF + else + Alpha := 0; + Result := Format('&H%.2X%.2X%.2X%.2X', + [Alpha, (AColor shr 16) and $FF, (AColor shr 8) and $FF, AColor and $FF]); +end; + +{ Внутри строки ASS перевод строки записывается как \N, а фигурные скобки + начинают команду — их надо обезвредить. } +function AssEscape(const AText: string): string; +begin + Result := StringReplace(AText, '\', '\\', [rfReplaceAll]); + Result := StringReplace(Result, '{', '(', [rfReplaceAll]); + Result := StringReplace(Result, '}', ')', [rfReplaceAll]); + Result := StringReplace(Result, LineEnding, '\N', [rfReplaceAll]); + Result := StringReplace(Result, #10, '\N', [rfReplaceAll]); + Result := StringReplace(Result, #13, '\N', [rfReplaceAll]); +end; + +{ Оценка ширины, когда точного замера нет. + + Множитель взят из замера: DejaVu Sans, размер 54, строка из двадцати + знаков кириллицы заняла 530 точек — это 0.49 размера на знак. Оценка + грубая, но для проверки самой разметки годится, а окно всегда ставит + точный замер. } +function EstimateWidth(const AText: string; ASize: Integer): Integer; +begin + Result := Round(UTF8Length(AText) * ASize * 0.49); +end; + +function MeasureWidth(const AText: string; const AStyle: TTextStyle; + ASize: Integer): Integer; +begin + if Assigned(TextMeasure) then + Result := TextMeasure(AText, AStyle, ASize) + else + Result := EstimateWidth(AText, ASize); +end; + +{ Перенос по словам под заданную ширину. Возвращает число строк, сами + строки складывает в ALines. } +function WrapText(const AText: string; const AStyle: TTextStyle; + ASize, AMaxWidth: Integer; ALines: TStringList): Integer; +var + Src: TStringList; + I: Integer; + Rest, Word, Line: string; + Space: Integer; +begin + ALines.Clear; + Src := TStringList.Create; + try + { Свои переводы строк человек ставил не зря — они остаются. } + Src.Text := AText; + for I := 0 to Src.Count - 1 do + begin + Rest := Src[I]; + if Trim(Rest) = '' then + begin + ALines.Add(''); + Continue; + end; + + Line := ''; + while Rest <> '' do + begin + Space := Pos(' ', Rest); + if Space = 0 then + begin + Word := Rest; + Rest := ''; + end + else + begin + Word := Copy(Rest, 1, Space - 1); + Rest := Copy(Rest, Space + 1, Length(Rest)); + end; + + if Line = '' then + Line := Word + else if MeasureWidth(Line + ' ' + Word, AStyle, ASize) <= AMaxWidth then + Line := Line + ' ' + Word + else + begin + ALines.Add(Line); + Line := Word; + end; + end; + if Line <> '' then + ALines.Add(Line); + end; + finally + Src.Free; + end; + Result := ALines.Count; +end; + +{ Подбор размера и переносов под отведённую полосу. + + Идём от заданного размера вниз: он же и верхняя граница. Уменьшаем, + пока блок не влезет по высоте — по ширине перенос справляется сам. } +function FitText(const AText: string; const AStyle: TTextStyle; + AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer; +var + MaxWidth, MaxHeight, Size, BlockHeight: Integer; + Lo, Hi, Mid, Best, Count: Integer; +begin + MaxWidth := Round(AFrameWidth * (1 - MarginShare * 2) * WidthSafety); + MaxHeight := Round(AFrameHeight * AStyle.MaxHeight); + Size := AStyle.FontSize; + if Size < MinFontSize then + Size := MinFontSize; + + { Ищем наибольший размер, при котором блок влезает, делением отрезка + пополам. + + Прикидка «уменьшить во столько же раз, во сколько не влезли» даёт + слишком мелкий шрифт: после переноса строк становится меньше, и + места остаётся вдоволь. Проверено на длинной надписи — вместо 29 + помещался 40. Десятка кругов хватает на любой разумный размер. } + Lo := MinFontSize; + Hi := Size; + Best := MinFontSize; + + while Lo <= Hi do + begin + Mid := (Lo + Hi) div 2; + Count := WrapText(AText, AStyle, Mid, MaxWidth, ALines); + if Count < 1 then + Count := 1; + { Высота блока по замеру: шаг строк равен размеру, последняя строка + занимает чуть меньше. } + BlockHeight := Round(Mid * (Count - 0.16)); + if BlockHeight <= MaxHeight then + begin + Best := Mid; + Lo := Mid + 1; + end + else + Hi := Mid - 1; + end; + + { Последний перенос должен соответствовать выбранному размеру: во время + поиска он мог остаться от неподошедшей примерки. } + WrapText(AText, AStyle, Best, MaxWidth, ALines); + Result := Best; +end; + +function FitTextForPreview(const AText: string; const AStyle: TTextStyle; + AFrameWidth, AFrameHeight: Integer; ALines: TStringList): Integer; +begin + Result := FitText(AText, AStyle, AFrameWidth, AFrameHeight, ALines); +end; + +function HasText(AProject: TProject): Boolean; +var + T, C: Integer; +begin + Result := False; + if AProject = nil then + Exit; + for T := 0 to AProject.TrackCount - 1 do + begin + if AProject.Tracks[T].Kind <> tkText then + Continue; + if not AProject.TrackAudible(AProject.Tracks[T]) then + Continue; + for C := 0 to AProject.Tracks[T].Count - 1 do + if Trim(AProject.Tracks[T][C].Text) <> '' then + Exit(True); + end; +end; + +function TextCovers(AProject: TProject; const AFrom, ATo: Double): Boolean; +var + T, C: Integer; + Clip: TClip; +begin + Result := False; + if AProject = nil then + Exit; + for T := 0 to AProject.TrackCount - 1 do + begin + if AProject.Tracks[T].Kind <> tkText then + Continue; + if not AProject.TrackAudible(AProject.Tracks[T]) then + Continue; + for C := 0 to AProject.Tracks[T].Count - 1 do + begin + Clip := AProject.Tracks[T][C]; + if Trim(Clip.Text) = '' then + Continue; + { Пересечение отрезков, а не попадание точки: кусок может быть + длиннее надписи и наоборот. } + if (Clip.TlStart < ATo - 0.0005) and (Clip.TlEnd > AFrom + 0.0005) then + Exit(True); + end; + end; +end; + +function BuildAss(AProject: TProject): string; +var + Lines: TStringList; + Styles, Events: TStringList; + T, C, I, Size: Integer; + Clip: TClip; + Track: TTrack; + Name, Body: string; + W, H, MarginH, MarginV: Integer; +begin + Result := ''; + if (AProject = nil) or (not HasText(AProject)) then + Exit; + + W := AProject.Master.Width; + H := AProject.Master.Height; + if (W < 2) or (H < 2) then + begin + W := 1920; + H := 1080; + end; + MarginH := Round(W * MarginShare); + MarginV := Round(H * MarginShare); + + Lines := TStringList.Create; + Styles := TStringList.Create; + Events := TStringList.Create; + try + for T := 0 to AProject.TrackCount - 1 do + begin + Track := AProject.Tracks[T]; + if Track.Kind <> tkText then + Continue; + if not AProject.TrackAudible(Track) then + Continue; + + for C := 0 to Track.Count - 1 do + begin + Clip := Track[C]; + if Trim(Clip.Text) = '' then + Continue; + + Size := FitText(Clip.Text, Clip.TextStyle, W, H, Lines); + + { У каждого клипа своё оформление, поэтому и свой стиль. Имя + выводим из номера дорожки и клипа — оно должно быть + неповторимым и не содержать запятых. } + Name := Format('s%d_%d', [T, C]); + Styles.Add(Format( + 'Style: %s,%s,%d,%s,%s,%s,%s,%d,%d,0,0,100,100,0,0,1,%d,%d,%d,' + + '%d,%d,%d,1', + [Name, Clip.TextStyle.FontName, Size, + AssColor(Clip.TextStyle.Color), + AssColor(Clip.TextStyle.Color), + AssColor(Clip.TextStyle.OutlineColor), + AssColor(Clip.TextStyle.ShadowColor, + Clip.TextStyle.Shadow <= 0), + Ord(Clip.TextStyle.Bold) * -1, Ord(Clip.TextStyle.Italic) * -1, + Clip.TextStyle.Outline, Clip.TextStyle.Shadow, + Ord(Clip.TextStyle.Place), + MarginH, MarginH, MarginV])); + + Body := ''; + for I := 0 to Lines.Count - 1 do + begin + if Body <> '' then + Body := Body + '\N'; + Body := Body + AssEscape(Lines[I]); + end; + + Events.Add(Format('Dialogue: 0,%s,%s,%s,,0,0,0,,%s', + [AssTime(Clip.TlStart), AssTime(Clip.TlEnd), Name, Body])); + end; + end; + + if Events.Count = 0 then + Exit; + + Result := + '[Script Info]' + LineEnding + + 'ScriptType: v4.00+' + LineEnding + + Format('PlayResX: %d', [W]) + LineEnding + + Format('PlayResY: %d', [H]) + LineEnding + + { Переносы мы уже расставили, libass переносить нечего. } + 'WrapStyle: 2' + LineEnding + + 'ScaledBorderAndShadow: yes' + LineEnding + + 'YCbCr Matrix: None' + LineEnding + + LineEnding + + '[V4+ Styles]' + LineEnding + + 'Format: Name,Fontname,Fontsize,PrimaryColour,SecondaryColour,' + + 'OutlineColour,BackColour,Bold,Italic,Underline,StrikeOut,ScaleX,' + + 'ScaleY,Spacing,Angle,BorderStyle,Outline,Shadow,Alignment,' + + 'MarginL,MarginR,MarginV,Encoding' + LineEnding + + Styles.Text + + LineEnding + + '[Events]' + LineEnding + + 'Format: Layer,Start,End,Style,Name,MarginL,MarginR,MarginV,' + + 'Effect,Text' + LineEnding + + Events.Text; + finally + Events.Free; + Styles.Free; + Lines.Free; + end; +end; + +function WriteAssFile(AProject: TProject; const APath: string): Boolean; +var + Text: string; + Stream: TFileStream; +begin + Result := False; + Text := BuildAss(AProject); + if Text = '' then + begin + { Текста не стало — старый файл убираем, иначе плеер покажет то, + чего на монтаже уже нет. } + if FileExists(APath) then + SysUtils.DeleteFile(APath); + Exit; + end; + + try + ForceDirectories(ExtractFilePath(APath)); + Stream := TFileStream.Create(APath, fmCreate); + try + if Length(Text) > 0 then + Stream.WriteBuffer(Text[1], Length(Text)); + finally + Stream.Free; + end; + Result := True; + except + Result := False; + end; +end; + +end. diff --git a/src/uTextForm.pas b/src/uTextForm.pas new file mode 100644 index 0000000..87a789c --- /dev/null +++ b/src/uTextForm.pas @@ -0,0 +1,372 @@ +{ + uTextForm — окно текстового клипа. + + Всё, что можно задать надписи: сам текст, шрифт, размер, три цвета, + толщина обводки, тень, место в кадре и доля высоты, которую тексту + позволено занять. + + Место выбирается сеткой три на три — это девять положений ASS, ровно + тех, что понимает libass. Кнопки сетки хранят номер положения прямо в + Tag: перекладывать его в отдельный список незачем. + + Размер шрифта здесь — верхняя граница, а не приказ. Если текст не + влезает в отведённую полосу, при сборке разметки он уменьшится; здесь + же рядом показано, до чего именно. +} +unit uTextForm; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, ExtCtrls, + uAppTypes, uTheme, uProject; + +{ Показывает окно. True — человек нажал «Готово», и в AText с AStyle лежит + изменённое. } +function EditTextClip(var AText: string; var AStyle: TTextStyle; + AFrameWidth, AFrameHeight: Integer): Boolean; + +implementation + +uses + uSubtitles; + +type + TTextDialog = class(TComponent) + public + Form: TForm; + Memo: TMemo; + cbFont: TComboBox; + edSize: TEdit; + edOutline: TEdit; + edShadow: TEdit; + edHeight: TEdit; + cbBold: TCheckBox; + cbItalic: TCheckBox; + BtnColor: TThemedButton; + BtnOutlineColor: TThemedButton; + BtnShadowColor: TThemedButton; + Places: array[1..9] of TThemedButton; + lblFit: TLabel; + Style: TTextStyle; + FrameW: Integer; + FrameH: Integer; + procedure PlaceClick(Sender: TObject); + procedure ColorClick(Sender: TObject); + procedure AnyChange(Sender: TObject); + procedure ReadControls; + procedure UpdateFit; + end; + +{ Кнопка цвета показывает сам цвет: подпись «выбрать» ничего не сообщает, + а образец нужного цвета сообщает всё. } +procedure PaintColorButton(ABtn: TThemedButton; AColor: TRgb); +begin + ABtn.Swatch := TColor(AColor); +end; + +procedure TTextDialog.PlaceClick(Sender: TObject); +var + I: Integer; +begin + Style.Place := TTextPlace((Sender as TThemedButton).Tag); + for I := 1 to 9 do + Places[I].Down := Places[I].Tag = Ord(Style.Place); + UpdateFit; +end; + +procedure TTextDialog.ColorClick(Sender: TObject); +var + Dlg: TColorDialog; + Btn: TThemedButton; +begin + Btn := Sender as TThemedButton; + Dlg := TColorDialog.Create(nil); + try + if Btn = BtnColor then + Dlg.Color := TColor(Style.Color) + else if Btn = BtnOutlineColor then + Dlg.Color := TColor(Style.OutlineColor) + else + Dlg.Color := TColor(Style.ShadowColor); + + if not Dlg.Execute then + Exit; + + if Btn = BtnColor then + Style.Color := TRgb(Dlg.Color) + else if Btn = BtnOutlineColor then + Style.OutlineColor := TRgb(Dlg.Color) + else + Style.ShadowColor := TRgb(Dlg.Color); + PaintColorButton(Btn, TRgb(Dlg.Color)); + finally + Dlg.Free; + end; +end; + +procedure TTextDialog.ReadControls; +var + V: Integer; + D: Double; +begin + if cbFont.ItemIndex >= 0 then + Style.FontName := cbFont.Items[cbFont.ItemIndex]; + + V := StrToIntDef(Trim(edSize.Text), Style.FontSize); + if (V >= 8) and (V <= 400) then + Style.FontSize := V; + + V := StrToIntDef(Trim(edOutline.Text), Style.Outline); + if (V >= 0) and (V <= 20) then + Style.Outline := V; + + V := StrToIntDef(Trim(edShadow.Text), Style.Shadow); + if (V >= 0) and (V <= 20) then + Style.Shadow := V; + + { Доля вводится процентами: «двадцать» понятнее, чем «ноль целых два». } + V := StrToIntDef(Trim(edHeight.Text), Round(Style.MaxHeight * 100)); + if (V >= 5) and (V <= 100) then + begin + D := V / 100; + Style.MaxHeight := D; + end; + + Style.Bold := cbBold.Checked; + Style.Italic := cbItalic.Checked; +end; + +{ Показывает, во что превратится надпись: сколько строк и каким размером. + Считает тот же код, что и сборка разметки, поэтому расхождения быть не + может. } +procedure TTextDialog.UpdateFit; +var + Lines: TStringList; + Size: Integer; +begin + ReadControls; + Lines := TStringList.Create; + try + Size := FitTextForPreview(Memo.Lines.Text, Style, FrameW, FrameH, Lines); + if Size < Style.FontSize then + lblFit.Caption := Format( + 'Не влезает: размер уменьшится с %d до %d, строк — %d', + [Style.FontSize, Size, Lines.Count]) + else + lblFit.Caption := Format('Влезает: размер %d, строк — %d', + [Size, Lines.Count]); + finally + Lines.Free; + end; +end; + +procedure TTextDialog.AnyChange(Sender: TObject); +begin + UpdateFit; +end; + +function EditTextClip(var AText: string; var AStyle: TTextStyle; + AFrameWidth, AFrameHeight: Integer): Boolean; +const + Rows: array[0..2] of Integer = (7, 4, 1); +var + Dlg: TTextDialog; + BtnOk, BtnCancel: TThemedButton; + Lbl: TLabel; + I, R, C, Place: Integer; + Grid: TPanel; +begin + Result := False; + Dlg := TTextDialog.Create(nil); + try + Dlg.Style := AStyle; + Dlg.FrameW := AFrameWidth; + Dlg.FrameH := AFrameHeight; + + Dlg.Form := TForm.CreateNew(nil); + Dlg.Form.Caption := 'Текст'; + Dlg.Form.Position := poScreenCenter; + Dlg.Form.ClientWidth := 640; + Dlg.Form.ClientHeight := 470; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 10, 200, 20); + Lbl.Caption := 'Текст надписи'; + + Dlg.Memo := TMemo.Create(Dlg.Form); + Dlg.Memo.Parent := Dlg.Form; + Dlg.Memo.SetBounds(12, 32, 616, 100); + Dlg.Memo.Anchors := [akTop, akLeft, akRight]; + Dlg.Memo.ScrollBars := ssAutoVertical; + Dlg.Memo.Text := AText; + Dlg.Memo.OnChange := @Dlg.AnyChange; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 146, 60, 20); + Lbl.Caption := 'Шрифт'; + + Dlg.cbFont := TComboBox.Create(Dlg.Form); + Dlg.cbFont.Parent := Dlg.Form; + Dlg.cbFont.SetBounds(80, 142, 260, 26); + Dlg.cbFont.Style := csDropDownList; + Dlg.cbFont.Items.Assign(Screen.Fonts); + Dlg.cbFont.ItemIndex := Dlg.cbFont.Items.IndexOf(AStyle.FontName); + if Dlg.cbFont.ItemIndex < 0 then + Dlg.cbFont.ItemIndex := Dlg.cbFont.Items.IndexOf(DefaultTextFont); + Dlg.cbFont.OnChange := @Dlg.AnyChange; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(356, 146, 60, 20); + Lbl.Caption := 'Размер'; + + Dlg.edSize := TEdit.Create(Dlg.Form); + Dlg.edSize.Parent := Dlg.Form; + Dlg.edSize.SetBounds(420, 142, 60, 26); + Dlg.edSize.Text := IntToStr(AStyle.FontSize); + Dlg.edSize.OnChange := @Dlg.AnyChange; + + Dlg.cbBold := TCheckBox.Create(Dlg.Form); + Dlg.cbBold.Parent := Dlg.Form; + Dlg.cbBold.SetBounds(492, 144, 76, 22); + Dlg.cbBold.Caption := 'Жирный'; + Dlg.cbBold.Checked := AStyle.Bold; + Dlg.cbBold.OnChange := @Dlg.AnyChange; + + Dlg.cbItalic := TCheckBox.Create(Dlg.Form); + Dlg.cbItalic.Parent := Dlg.Form; + Dlg.cbItalic.SetBounds(568, 144, 66, 22); + Dlg.cbItalic.Caption := 'Косой'; + Dlg.cbItalic.Checked := AStyle.Italic; + Dlg.cbItalic.OnChange := @Dlg.AnyChange; + + { --- Цвета --- } + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 186, 60, 20); + Lbl.Caption := 'Цвет'; + + Dlg.BtnColor := TThemedButton.Create(Dlg.Form); + Dlg.BtnColor.Parent := Dlg.Form; + Dlg.BtnColor.SetBounds(80, 182, 70, 26); + Dlg.BtnColor.OnClick := @Dlg.ColorClick; + PaintColorButton(Dlg.BtnColor, AStyle.Color); + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(160, 186, 70, 20); + Lbl.Caption := 'Обводка'; + + Dlg.BtnOutlineColor := TThemedButton.Create(Dlg.Form); + Dlg.BtnOutlineColor.Parent := Dlg.Form; + Dlg.BtnOutlineColor.SetBounds(232, 182, 70, 26); + Dlg.BtnOutlineColor.OnClick := @Dlg.ColorClick; + PaintColorButton(Dlg.BtnOutlineColor, AStyle.OutlineColor); + + Dlg.edOutline := TEdit.Create(Dlg.Form); + Dlg.edOutline.Parent := Dlg.Form; + Dlg.edOutline.SetBounds(310, 182, 40, 26); + Dlg.edOutline.Text := IntToStr(AStyle.Outline); + Dlg.edOutline.OnChange := @Dlg.AnyChange; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(360, 186, 50, 20); + Lbl.Caption := 'Тень'; + + Dlg.BtnShadowColor := TThemedButton.Create(Dlg.Form); + Dlg.BtnShadowColor.Parent := Dlg.Form; + Dlg.BtnShadowColor.SetBounds(412, 182, 70, 26); + Dlg.BtnShadowColor.OnClick := @Dlg.ColorClick; + PaintColorButton(Dlg.BtnShadowColor, AStyle.ShadowColor); + + Dlg.edShadow := TEdit.Create(Dlg.Form); + Dlg.edShadow.Parent := Dlg.Form; + Dlg.edShadow.SetBounds(490, 182, 40, 26); + Dlg.edShadow.Text := IntToStr(AStyle.Shadow); + Dlg.edShadow.OnChange := @Dlg.AnyChange; + + { --- Место в кадре --- } + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 224, 160, 20); + Lbl.Caption := 'Место в кадре'; + + Grid := TPanel.Create(Dlg.Form); + Grid.Parent := Dlg.Form; + Grid.SetBounds(12, 246, 130, 130); + Grid.BevelOuter := bvNone; + + for R := 0 to 2 do + for C := 0 to 2 do + begin + Place := Rows[R] + C; + Dlg.Places[Place] := TThemedButton.Create(Dlg.Form); + Dlg.Places[Place].Parent := Grid; + Dlg.Places[Place].SetBounds(C * 44, R * 44, 40, 40); + Dlg.Places[Place].Tag := Place; + Dlg.Places[Place].TabStop := False; + Dlg.Places[Place].Down := Place = Ord(AStyle.Place); + Dlg.Places[Place].OnClick := @Dlg.PlaceClick; + end; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(160, 250, 260, 20); + Lbl.Caption := 'Доля высоты кадра под текст, %'; + + Dlg.edHeight := TEdit.Create(Dlg.Form); + Dlg.edHeight.Parent := Dlg.Form; + Dlg.edHeight.SetBounds(420, 246, 60, 26); + Dlg.edHeight.Text := IntToStr(Round(AStyle.MaxHeight * 100)); + Dlg.edHeight.OnChange := @Dlg.AnyChange; + + Dlg.lblFit := TLabel.Create(Dlg.Form); + Dlg.lblFit.Parent := Dlg.Form; + Dlg.lblFit.SetBounds(160, 284, 460, 40); + Dlg.lblFit.AutoSize := False; + Dlg.lblFit.WordWrap := True; + + BtnOk := TThemedButton.Create(Dlg.Form); + BtnOk.Parent := Dlg.Form; + BtnOk.SetBounds(420, 424, 100, 30); + BtnOk.Anchors := [akRight, akBottom]; + BtnOk.Caption := 'Готово'; + BtnOk.ModalResult := mrOk; + BtnOk.Default := True; + + BtnCancel := TThemedButton.Create(Dlg.Form); + BtnCancel.Parent := Dlg.Form; + BtnCancel.SetBounds(528, 424, 100, 30); + BtnCancel.Anchors := [akRight, akBottom]; + BtnCancel.Caption := 'Отмена'; + BtnCancel.ModalResult := mrCancel; + BtnCancel.Cancel := True; + + ApplyDarkTheme(Dlg.Form); + { Цвета кнопок ставятся после раскраски: она сбрасывает цвет надписи + всем кнопкам разом. } + PaintColorButton(Dlg.BtnColor, Dlg.Style.Color); + PaintColorButton(Dlg.BtnOutlineColor, Dlg.Style.OutlineColor); + PaintColorButton(Dlg.BtnShadowColor, Dlg.Style.ShadowColor); + Dlg.UpdateFit; + + if Dlg.Form.ShowModal <> mrOk then + Exit; + + Dlg.ReadControls; + AText := TrimRight(Dlg.Memo.Lines.Text); + AStyle := Dlg.Style; + Result := True; + finally + Dlg.Form.Free; + Dlg.Free; + end; +end; + +end. diff --git a/src/uTextMeasure.pas b/src/uTextMeasure.pas new file mode 100644 index 0000000..273eca1 --- /dev/null +++ b/src/uTextMeasure.pas @@ -0,0 +1,62 @@ +{ + uTextMeasure — точный замер ширины текста для подбора размера. + + Живёт отдельно от uSubtitles нарочно: там модель, а здесь холст, то есть + оконная библиотека. Служебная программа собирает субтитры без окна и + обходится приблизительной оценкой; окно ставит сюда точный замер. + + Меряем тем же шрифтом и тем же движком, каким libass будет рисовать: за + обоими стоит FreeType. Полного совпадения нет — настройки сглаживания + разные, — поэтому в подборе размера заложен запас. +} +unit uTextMeasure; + +{$mode objfpc}{$H+} + +interface + +{ Ставит точный замер в uSubtitles. Вызывается один раз при запуске. } +procedure InstallTextMeasure; + +implementation + +uses + SysUtils, Graphics, uProject, uSubtitles; + +var + { Холст для замеров. Один на всё время работы: заводить растр на каждое + слово было бы расточительно, а слов бывают тысячи. } + Bitmap: TBitmap = nil; + +function MeasureText(const AText: string; const AStyle: TTextStyle; + ASize: Integer): Integer; +begin + if Bitmap = nil then + begin + Bitmap := TBitmap.Create; + Bitmap.SetSize(4, 4); + end; + + Bitmap.Canvas.Font.Name := AStyle.FontName; + { Height, а не Size: он задаётся в точках холста, и отношение к размеру + в кадре получается прямым. Size пересчитывался бы через разрешение + экрана, а оно к кадру проекта отношения не имеет. } + Bitmap.Canvas.Font.Height := ASize; + Bitmap.Canvas.Font.Style := []; + if AStyle.Bold then + Bitmap.Canvas.Font.Style := Bitmap.Canvas.Font.Style + [fsBold]; + if AStyle.Italic then + Bitmap.Canvas.Font.Style := Bitmap.Canvas.Font.Style + [fsItalic]; + + Result := Bitmap.Canvas.TextWidth(AText); +end; + +procedure InstallTextMeasure; +begin + uSubtitles.TextMeasure := @MeasureText; +end; + +finalization + Bitmap.Free; + +end. diff --git a/src/uTheme.pas b/src/uTheme.pas index a249fd0..2fd52ae 100644 --- a/src/uTheme.pas +++ b/src/uTheme.pas @@ -99,6 +99,7 @@ type TThemedButton = class(TCustomControl) private FArrow: Boolean; + FSwatch: TColor; FIcon: TThemedIcon; FFlat: Boolean; FDown: Boolean; @@ -109,6 +110,7 @@ type FModalResult: TModalResult; procedure SetArrow(AValue: Boolean); procedure SetIcon(AValue: TThemedIcon); + procedure SetSwatch(AValue: TColor); procedure DrawIcon(const ARect: TRect; AColor: TColor); procedure SetFlat(AValue: Boolean); procedure SetDown(AValue: Boolean); @@ -145,6 +147,9 @@ type { Значок вместо надписи. Надпись при этом не пропадает зря: её место — подсказка, которая всплывает по наведению. } property Icon: TThemedIcon read FIcon write SetIcon default tiNone; + { Образец цвета вместо надписи: кнопка выбора цвета должна показывать + сам цвет, а не слово «выбрать». clNone — обычная кнопка. } + property Swatch: TColor read FSwatch write SetSwatch default clNone; property Default: Boolean read FDefault write SetDefault default False; property Down: Boolean read FDown write SetDown default False; property Enabled; @@ -380,6 +385,9 @@ begin ControlStyle := ControlStyle + [csHasDefaultAction, csHasCancelAction]; TabStop := True; DoubleBuffered := True; + { Без явного значения образец был бы чёрным (ноль — это clBlack), и + чёрные прямоугольники полезли бы на все кнопки разом. } + FSwatch := clNone; with GetControlClassDefaultSize do SetInitialBounds(0, 0, cx, cy); end; @@ -390,6 +398,14 @@ begin Result.cy := 28; end; +procedure TThemedButton.SetSwatch(AValue: TColor); +begin + if FSwatch = AValue then + Exit; + FSwatch := AValue; + Invalidate; +end; + procedure TThemedButton.SetIcon(AValue: TThemedIcon); begin if FIcon = AValue then @@ -560,6 +576,14 @@ begin Canvas.Polygon([Point(CX - 5, CY - 2), Point(CX + 5, CY - 2), Point(CX, CY + 4)]); end + else if FSwatch <> clNone then + begin + { Образец с рамкой: без неё белый цвет на светлой кнопке сливается. } + Canvas.Brush.Color := FSwatch; + Canvas.Brush.Style := bsSolid; + Canvas.Pen.Color := ThemeBorder; + Canvas.Rectangle(R.Left + 5, R.Top + 5, R.Right - 5, R.Bottom - 5); + end else if FIcon <> tiNone then DrawIcon(R, Fore) else diff --git a/src/uTimelineCtrl.pas b/src/uTimelineCtrl.pas index 7ad49e3..16d8a15 100644 --- a/src/uTimelineCtrl.pas +++ b/src/uTimelineCtrl.pas @@ -698,7 +698,7 @@ end; procedure TTimelineControl.DrawClip(ACanvas: TCanvas; AClip: TClip; ATop: Integer); var - L, R, W: Integer; + L, R, W, I: Integer; Item: TMediaItem; { Не Caption и не Top: эти имена заняты свойствами TControl, и локальная переменная их перекроет. Компилятор ловит, но сообщение неочевидное. } @@ -760,8 +760,9 @@ begin нём рисуется. } DrawWaveform(ACanvas, AClip, Body); - { Кнопка кадрирования — только у картинки: звук кадрировать нечем. } - if AClip.Kind in [ckVideo, ckImage] then + { Кнопка на клипе: у картинки — кадрирование, у надписи — правка + текста. У звука нет ни того, ни другого. } + if AClip.Kind in [ckVideo, ckImage, ckText] then DrawCropButton(ACanvas, Body); { Затухания идут до громкости и подписей: срезанный угол не должен @@ -777,7 +778,18 @@ begin Item := nil; if FProject <> nil then Item := FProject.FindMedia(AClip.MediaId); - if Item <> nil then + if AClip.Kind = ckText then + begin + { У надписи имени файла нет — показываем её саму, первой строкой: + по ней клип и узнаётся. } + ClipCaption := AClip.Text; + I := Pos(#10, ClipCaption); + if I > 0 then + ClipCaption := Copy(ClipCaption, 1, I - 1) + '…'; + if Trim(ClipCaption) = '' then + ClipCaption := '(пустая надпись)'; + end + else if Item <> nil then ClipCaption := ExtractFileName(Item.Path) else ClipCaption := '(нет файла)'; @@ -1000,7 +1012,9 @@ var L, R: Integer; begin Result := Rect(0, 0, 0, 0); - if (AClip = nil) or (not (AClip.Kind in [ckVideo, ckImage])) then + { У надписи та же кнопка открывает правку текста — окно решает, что + именно показать. } + if (AClip = nil) or (not (AClip.Kind in [ckVideo, ckImage, ckText])) then Exit; L := TimeToX(AClip.TlStart); diff --git a/tests/nlvetool.lpr b/tests/nlvetool.lpr index 5d385ff..1bc68c1 100644 --- a/tests/nlvetool.lpr +++ b/tests/nlvetool.lpr @@ -23,6 +23,9 @@ render <проект.nlve> <выход> уплотить проект, создать вставки, собрать ролик и сверить число кадров + subs <проект.nlve> + собрать разметку субтитров из текстовых клипов + и напечатать её preview <проект.nlve> собрать список кусков так же, как это делает предпросмотр: с готовыми наложениями вместо @@ -44,7 +47,7 @@ uses {$ENDIF} Classes, SysUtils, DateUtils, Math, StrUtils, uAppTypes, uEdl, uKeyframeIndex, uFfmpegCmd, uExport, uRemuxQueue, - uMediaProbe, uProject, uFlatten, uGenerate; + uMediaProbe, uProject, uFlatten, uGenerate, uSubtitles; procedure PrintUsage; begin @@ -950,6 +953,36 @@ end; Отличается от сборки одним: участки с прозрачностью и переходами плеер показать не может, поэтому они заранее сводятся в отдельные файлы. Здесь видно, какие именно участки и во что превратились. } + +{ Разметка субтитров из текстовых клипов. + + Точного замера шрифта здесь нет — он требует холста, а холст оконного + набора. Поэтому ширины оцениваются приблизительно; для проверки самой + разметки этого хватает, а окно ставит точный замер. } +procedure CmdSubs; +var + Proj: TProject; + Err, Text: string; +begin + Proj := TProject.Create; + try + if not Proj.LoadFromFile(ExpandFileName(ParamStr(2)), Err) then + begin + WriteLn('Не удалось прочитать проект: ', Err); + Halt(1); + end; + Text := BuildAss(Proj); + if Text = '' then + begin + WriteLn('Текстовых клипов в проекте нет.'); + Halt(1); + end; + Write(Text); + finally + Proj.Free; + end; +end; + procedure CmdPreview; var Proj: TProject; @@ -1172,6 +1205,8 @@ begin CmdBuild else if (Cmd = 'buildcut') and (ParamCount >= 3) then CmdBuildCut + else if (Cmd = 'subs') and (ParamCount >= 2) then + CmdSubs else if (Cmd = 'preview') and (ParamCount >= 2) then CmdPreview else if (Cmd = 'audio') and (ParamCount >= 2) then