diff --git a/.gitignore b/.gitignore index e60625a..a13d191 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,11 @@ # Результаты сборки /lib/ +# Обёртка для macOS: её создаёт lazbuild при сборке под darwin. +/nlve.app/ /nlve /nlve.exe +/nlve_intel +/nlve_arm /nlve.dbg /nlve.res /tests/lib/ @@ -42,3 +46,46 @@ shot*.png # Журнал последнего запуска /nlve.log + +# Проверка свойств из файлов форм. +/tests/lfmcheck/lfmcheck +/tests/lfmcheck/units/ + +# Проверка хода полоски: двоичный файл и промежуточные модули. +/tests/progress/progtest +/tests/progress/*.o +/tests/progress/*.ppu + +# Сборка пробников. Сами исходники нужны: они и есть запись замера. +/probe/*/units/ +/probe/menu/menuprobe +/probe/menu/menuprobe.exe + +# --- Тому, что ниже, в репозитории не место --- + +# Готовые ролики и журналы сборки, которые ложатся рядом с ними. +*.mkv +*.mp4 +*.log + +# Скачанные зависимости и подопытная сборка под Windows: сотни мегабайт, +# у каждого свои и добываются меню «Зависимости». +/test/ + +# Отладочные символы macOS: их делает компоновщик. +/nlve.dSYM/ +/nlve.app/ + +# Пробники замеров — отдельные программки, к самому редактору отношения +# не имеют. +/probe/ + +# Рабочие бумаги: планы, логи сессий, изначальная постановка. Нужны в +# работе, но это не исходники. +/docs/plans/ +/docs/session-logs/ +/IMPLEMENTATION_PLAN.md +/изначальная постановка.txt + +# Мусор компоновщика Lazarus. +link*.res diff --git a/BACKLOG.md b/BACKLOG.md new file mode 100644 index 0000000..07a84cf --- /dev/null +++ b/BACKLOG.md @@ -0,0 +1,142 @@ +# Что отложено + +Список того, что известно и сознательно не сделано. Не «когда-нибудь +починим», а «знаем, чего это стоит, и решили пока не платить». + +## macOS: собирается, но работает наполовину + +Сборка проверена. В тулчейне fpcupdeluxe уже стоит всё нужное: +кросс-компиляторы, Apple SDK (10.13, 11.0, 12.3) и виджетсет cocoa для +обеих архитектур. Обе цели собираются с первого раза: + + ./build.sh macos → nlve_intel (Mach-O x86_64) + nlve_arm (Mach-O arm64) + +Чего не будет, пока не сделано: + +**Предпросмотра нет.** Встраивание mpv написано под два случая: X11 (под +gtk2 создаётся своё дочернее окно и его номер отдаётся mpv в `wid`) и +Windows (там у панели есть настоящий HWND). Под cocoa нужен третий путь — +отдать mpv указатель на NSView. Это не правка на десять строк: нужно +разобраться, как LCL под cocoa отдаёт NSView панели, и проверить, что mpv +рисует именно в неё. + +**Окно зависимостей врёт.** Списки в `uDeps.pas` разделены на два случая: +Windows и всё остальное. Мак попадает во второй и получает совет +`sudo apt install ffmpeg`. Нужен свой список: `brew install ffmpeg mpv` +или готовые сборки. + +**Проверить нечем.** У нас нет мака. Собранный, но ни разу не запущенный +файл — это предположение, а не сборка. Всё, что можно утверждать сейчас: +компилятор и компоновщик отработали без ошибок. + +**Двух файлов может оказаться мало.** Intel и Apple Silicon сейчас +раздаются отдельно. Склеить их в один универсальный умеет `lipo`, но в +тулчейне он есть только для powerpc — для x86_64 и arm64 его надо +доставить. + +**Обёртка .app не настроена.** lazbuild её создаёт, но внутри лежит +ссылка на файл с именем `nlve`, которого после переименования нет. +Сейчас она просто удаляется. Настоящему приложению нужны свой Info.plist, +значок и, для раздачи, подпись и нотаризация у Apple. + +## Лицензия не выбрана + +libmpv грузится в наш процесс, а её сборки — GPL (в Ubuntu GPL-3+ из-за +libsmbclient, у shinchiro тоже GPL). По толкованию FSF это делает +совместную работу производной, и при раздаче программа должна быть под +GPL-3+ или совместимой. + +Пока ничего не раздаётся — вопрос не стоит. Решать его перед первой +раздачей сборок. Возможный обход: отказаться от libmpv в пользу своего +вывода кадров через ffmpeg, но это большая работа и заметно хуже по +плавности. + +ffmpeg проблемой не является: он запускается отдельной программой. + +## Настоящая прозрачность в исходном файле + +Цветовой ключ выбивает цвет, но бывает и прозрачность, записанная в самом +файле: WebM с VP8/VP9, ProRes 4444, QuickTime Animation. ffmpeg их +распаковывает в кадр с альфа-каналом, и ключ таким файлам не нужен — +достаточно не выбрасывать альфу по дороге. + +Что для этого потребуется, когда дойдут руки: + +- при добавлении файла запоминать, есть ли у него альфа (`pix_fmt` с + буквой «a»: yuva420p, yuva444p10le, argb); +- такой клип считать несплошным так же, как клип с ключом, — то есть + собирать участок слоями; +- в цепочке фильтров следить, чтобы альфа не терялась: `scale` её + сохраняет, а `pad` — только с прозрачным цветом полей; +- аппаратное декодирование к таким файлам не применять: альфа в VP9 + лежит отдельным потоком, и видеокарта его не отдаёт. + +Чего не будет в любом случае: раздать готовый ролик с прозрачностью в +MP4/H.264 нельзя — контейнер и кодек альфу не хранят. Для этого нужен +отдельный вывод в VP9 или ProRes 4444. + +## Предпросмотр не показывает кадрирование обычного клипа + +Кадрирование и поворот видны в окне только у клипов с ключом или +прозрачностью: их плеер кладёт поверх основы сам и применяет к ним +цепочку фильтров. Обычный клип идёт списком кусков, а список фильтровать +нечем — он играется как есть, во весь кадр. В готовом ролике при этом всё +верно: такой кусок помечен на пересборку и обкладывается полями. + +Проверено опытом: у клипа выключен только ключ, кадрирование оставлено — +окно показывает его во весь кадр. + +Как это делается тем же механизмом, что и наложение: провести такой клип +через ту же дорожку наложения, а под ним заставить основу быть чёрной — +непрозрачный клип с полями в готовом ролике именно так и закрывает всё, +что ниже. Значит, уплощению нужно понятие «здесь дыра, даже если ниже +что-то есть». + +Чего это стоит: ветка масштабирования в цепочке работает на каждом кадре, +а не только там, где клип виден. Для накладки в 512 точек это пустяк, для +куска 2688x1512 — уже нет. Поэтому сначала замер, потом решение. + +## Окно настроек программы + +Переключателей, которые стоят машинного времени, становится больше, а +живут они кто где: прилипание и схлопывание — кнопками внизу, ключ в +предпросмотре — в меню «Вид», выбор кодировщика вообще нигде (берётся +NVENC, если он есть). Это разрозненно и не даёт увидеть общую цену. + +Нужно одно окно, где собрано всё, что можно выключить ради скорости: + +- ключ и прозрачность в предпросмотре (сейчас в меню «Вид»); +- наложение в предпросмотре вообще — на слабой машине может не хватать и + его, тогда честнее показывать одну основу; +- кодировщик для пересборки: аппаратный или процессорный, и какой + именно; +- где держать кэш и когда его убирать; +- прилипание клипов и курсора (сейчас кнопками, но им место и здесь). + +Почему это важно: разработка идёт на машине с быстрой видеокартой, и +всё, что здесь считается «недорогим», на другой может оказаться +неподъёмным. Пока цифры замеряны только на одной машине, у человека +должна быть возможность выключить любую из этих трат. + +## Мелочи, до которых не дошли руки + +**Вид дорожки не виден в её заголовке.** Дорожки картинки, звука и текста +подписаны V1, A1, Т1, и по букве вид угадывается, но не более того. +Клип, попавший на дорожку чужого вида, теперь не принимается и не +теряется, но само различие стоило бы показать явно — значком или цветом +полосы заголовка. + +**Значок файла программы под Windows.** Значок окна задаётся из +`uIconData`, а значок самого `.exe` в проводнике берётся из ресурса при +сборке — там он до сих пор стандартный. + +**Кэш наложений не убирается.** Каждая правка наплыва создаёт в кэше +проекта новый файл; старые остаются лежать. Клипы с ключом и +прозрачностью сюда больше не попадают — их показывает сам плеер, — так +что расти кэшу теперь почти не с чего. + +**Окно кадрирования открывается около четырёх секунд.** Оно синхронно +достаёт два кадра ffmpeg-ом (по 2.2 с каждый на шестигигабайтном файле) и +только потом показывается. Лечится показом окна сразу и дорисовкой кадра +по готовности, либо одним кадром вместо двух. diff --git a/README.md b/README.md index 9ce520f..ea009dc 100644 --- a/README.md +++ b/README.md @@ -46,6 +46,30 @@ Lazarus другой версии, и собранные им модули LCL `./nlve remux <файл>...` — в коде этого нет и не было: слово `remux` не является именем файла и молча пропускалось. +### Встраивание в рабочий стол + +``` +tools/install-desktop.sh # берёт ./nlve рядом с репозиторием +tools/install-desktop.sh /путь/к/nlve +``` + +Скрипт кладёт пункт меню, значки и описание типа файла — всё в домашний +каталог, без прав администратора. После этого `*.nlve` перестают быть +просто текстом: у них своё имя типа (`application/x-nlve-project`), свой +значок и открытие двойным щелчком. Проверяется так: + +``` +xdg-mime query filetype проект.nlve # application/x-nlve-project +xdg-mime query default application/x-nlve-project +``` + +Внутри проект — обычный JSON, и тип объявлен наследником +`application/json`. Наследником простого текста делать не стали: тогда +файл снова открывался бы редактором по умолчанию. + +Файловый менеджер может показать новый значок не сразу — ему нужно +перечитать базу. + ## Управление | Действие | Клавиши | @@ -62,9 +86,11 @@ Lazarus другой версии, и собранные им модули LCL | Прокрутка по дорожкам | колесо мыши | | Прокрутка по времени | Shift + колесо, средняя кнопка | | Прокрутка журнала вбок | Shift + колесо над журналом | +| Растянуть форму звука по высоте | Shift + стрелки вверх и вниз | | Выключить дорожку / оставить только её | кнопки М и С в заголовке | | Громкость клипа | тянуть ручку на клипе вверх-вниз | | Автосхлопывание вкл/выкл | Ctrl+K | +| Связать или развязать клипы | Ctrl+G | | Отменить прилипание на время | Shift при перетаскивании | | Вписать проект целиком | Ctrl+0 | | Новый, открыть, сохранить проект | Ctrl+N, Ctrl+O, Ctrl+S | @@ -99,11 +125,61 @@ Lazarus другой версии, и собранные им модули LCL если кнопку нажали и потянули, курсор остаётся на месте, в том числе во время воспроизведения. -**Прилипание.** Края клипов притягиваются друг к другу и к курсору. -Кнопка внизу включает и выключает его, а Shift во время перетаскивания -меняет решение на противоположное: при включённом прилипании временно -отключает, при выключенном — временно включает. Так одна клавиша полезна -в обоих режимах, и не нужно помнить, какой сейчас. +**Прилипание клипов** (кнопка с магнитом). Края клипов притягиваются +друг к другу и к курсору. Shift во время перетаскивания меняет решение на +противоположное: при включённом прилипании временно отключает, при +выключенном — временно включает. Так одна клавиша полезна в обоих +режимах, и не нужно помнить, какой сейчас. + +**Прилипание курсора** (кнопка с клеем). Курсор, поставленный щелчком, +притягивается к границам клипов на любой дорожке. Без этого в стык не +попасть: на общем плане одна точка экрана — это секунды материала, а +ставят курсор чаще всего именно на стык. Shift при щелчке работает так +же — меняет решение на противоположное. + +Переключателя два, а не один, потому что это разные привычки: клипы +липнут при перетаскивании, курсор — при щелчке, и одно бывает нужно без +другого. + +**Ключ и прозрачность в предпросмотре** (меню «Вид»). Включено — окно +показывает то же, что даст сборка: выбитый цвет и приглушение считаются +на лету. Выключено — оверлей виден целиком, со своим фоном: так понятно, +куда он встал и где его края. + +Считается это по площади самого оверлея, а не всего кадра. Замер на +2688x1512 (600 кадров, десять секунд материала): основа 2.07 с, с +наложением 2.43 с, с ключом и прозрачностью 2.66 с. То есть наложение +стоит 0.36 с, ключ добавляет ещё 0.23 с — вчетверо быстрее реального +времени. На слабой машине это может быть заметнее, потому выключатель и +есть. + +**Отмеченный участок.** У линейки два этажа. Верхний, в двенадцать точек, +— про отметки: протяжка по нему отмечает участок, даже если отметок не +было, а щелчок без движения их снимает. По краям участка стоят жёлтые +уголки, за них тянут. Нижний этаж — про курсор, как и раньше. + +Клавиши тоже остались: `I` ставит начало по курсору, `O` — конец; оба +пункта есть в меню «Правка», там же снятие отметок. Пока он отмечен, сборка +собирает только его — это единственный способ проверить правку на длинном +монтаже, не тратя на каждую проверку столько же времени, сколько идёт сам +ролик. Отметки живут в файле проекта: участок относится к монтажу, а не к +привычкам человека. + +**Дорожки.** Слева в заголовке две стрелки: поднять и опустить. У верхней +дорожки некуда вверх, у нижней вниз — такая стрелка нарисована тускло и +не нажимается. Заголовок можно и просто потащить мышью. Двойной щелчок по +названию переименовывает дорожку: на монтаже из десятка дорожек «карта», +«звук мотора» и «титры» читаются несравнимо лучше, чем V1, A2 и Т1. + +Правый щелчок по заголовку открывает меню: поднять, опустить, +переименовать, удалить. Удаление дорожки с клипами спрашивает +подтверждение и называет число клипов. + +**Копирование свойств клипа.** Ctrl+Shift+C берёт с выделенного клипа всё +оформление — кадрирование, поворот, увеличение, смещение, прозрачность, +цветовой ключ, затухания, громкость, — Ctrl+Shift+V применяет их ко всем +выделенным. Вид клипа и его текст при этом не переносятся: свойства +копируют между разными клипами, и превращать картинку в надпись незачем. **Схлопывание.** Кнопка внизу показывает и режим, и состояние: утоплена — автосхлопывание включено, и тогда при перетаскивании клипа всё, что @@ -137,6 +213,20 @@ Ctrl+Shift+R, который схлопывает дыру под курсоро В списке файлов слева показывается кадр из каждого файла, его параметры и длительность. Кадры делаются в фоне и запоминаются в кэше проекта. +На клипах видна форма звука. Считается она по заранее разобранным пикам — +сто значений в секунду, каждое есть наибольший модуль отсчёта за свои +десять миллисекунд. Рисовать по настоящим отсчётам нельзя: в секунде их +48 тысяч, а в клипе на экране сотни пикселей. + +Разбор идёт в фоне и запоминается в кэше проекта. Для записи на 892 с это +около 13 секунд — столько занимает чтение шести гигабайт с диска, и +быстрее не выйдет; при следующем открытии проекта пики берутся готовыми. + +**Shift со стрелками вверх и вниз растягивает форму по высоте.** Звук +бывает тихим, и угадывать за человека, во сколько раз растянуть картинку, +неправильно. Усиление меняет только рисунок, самого звука не касается, и +запоминается между запусками. + ## Файл не совпадает с проектом Проект имеет одно разрешение и один набор кодеков на всё — иначе куски не @@ -146,11 +236,23 @@ Ctrl+Shift+R, который схлопывает дыру под курсоро Пересобираются **только они**. Остальной материал по-прежнему копируется без потерь и почти мгновенно. Ролик целиком не перекодируется никогда. -Как именно кадр такого файла ложится в кадр проекта, решает окно -«Кадрирование и поворот» из контекстного меню библиотеки: вписать целиком -с полями, заполнить кадр с обрезкой или растянуть, плюс поворот на 90, -отражение, увеличение и смещение. Показывается настоящий кадр, пропущенный -через ту же цепочку фильтров, что пойдёт в дело. +Как именно кадр ложится в кадр проекта, решает окно «Кадрирование и +поворот»: вписать целиком с полями, заполнить кадр с обрезкой или +растянуть, плюс поворот на 90, отражение, увеличение и смещение. + +Слева в окне — кадр источника с рамкой: её тянут мышью за середину и за +правый нижний угол, и она держит пропорции кадра проекта. Справа — +настоящий результат, пропущенный через ту же цепочку фильтров, что пойдёт +в дело. + +**Настройка принадлежит клипу**, а открывается кнопкой в правом нижнем +видимом углу самого клипа. Именно видимом: у клипа длиной в час настоящий +угол почти всегда за краем экрана. Два куска одного файла можно +кадрировать по-разному. + +У файла в библиотеке хранится такая же настройка, но она лишь заготовка: +её берёт новый клип при добавлении. Правится она из контекстного меню +библиотеки. По умолчанию кадр вписывается целиком. Растяжение надо выбрать руками: раньше оно применялось молча, и вертикальное видео размазывалось по ширине. @@ -258,6 +360,98 @@ Linux потом искала по нему `.dll`. случая, когда программа падает до появления окна: иначе всё, что она о себе рассказала, пропадает вместе с окном. +## Наложение, переходы и прозрачность + +Ползунок на клипе картинки задаёт **непрозрачность**, на звуковом — +громкость. Клип с непрозрачностью меньше единицы смешивается с тем, что +под ним. + +**Звуковые дорожки смешиваются.** Правило «верхний побеждает» придумано +для картинки — оно и делает возможной сборку копированием. Для звука оно +бессмысленно: без смешивания нельзя положить фоновую музыку под голос. И +стоит оно ничего, потому что звук всё равно перекодируется. + +Плеер играет одну звуковую дорожку за раз, поэтому в предпросмотре смесь +собирается его же цепочкой фильтров: каждая дорожка монтажа подаётся +своим списком кусков, дальше `amix`. Громкость клипов подставляется в ту +же цепочку — иначе предпросмотр врал бы про баланс. Проверено: в +предпросмотре и в готовом ролике уровни совпадают до десятой доли +децибела. + +Два клипа **на одной дорожке**, наползшие друг на друга, дают переход: +один плавно перетекает в другой. На разных дорожках перекрытие означает +не переход, а наложение — там по-прежнему побеждает верхний, если он +непрозрачен. + +Различие не косметическое. Если бы кроссфейдом считалось любое +перекрытие, то в проекте, где клипы на разных дорожках перекрываются +постоянно, каждое такое место пришлось бы пересобирать. + +У клипа есть плавное появление и уход. Для картинки это затемнение, для +звука — нарастание громкости. + +**Всё это стоит перекодирования** — но только своего участка. Перед +сборкой программа сообщает, сколько секунд из скольких придётся +пересобрать, и даёт отказаться. + +Звук при наложении сводится прямо в отсчётах, без фильтров ffmpeg: доля +каждого слоя считается на каждый отсчёт, и длина результата получается +ровно такой, какая нужна. + +## Качество пересобираемых кусков + +Куски, которые нельзя скопировать, целятся в наибольший битрейт среди +файлов проекта. Без этого кодировщик берёт своё значение по умолчанию, и +оно скромное: на съёмке 2688x1512 с 56 Мбит/с NVENC выдавал 5.9 Мбит/с — +пересобранный кусок бросался в глаза среди скопированных соседей. + +Кроме среднего задаётся потолок в полтора раза выше и буфер вдвое: без +них кодировщик разгоняется на сложных кадрах ровно настолько, насколько +позволит средний, и мелкие детали всё равно теряются. + +Берётся именно наибольший, а не средний: пересобранный кусок стоит рядом +со скопированными, и если он окажется хуже их, разница видна именно на +нём. Лишнее место дешевле. + +## Место на диске + +Куски весят примерно столько же, сколько готовый ролик, а на длинном +материале и больше: на часовой съёмке набралось 110 ГБ. Поэтому: + +- **картинка не собирается в промежуточный файл.** Звук собирается + раньше, и склейка сразу кладёт всё вместе в конечный файл. Раньше + получалось два полных ролика на диске одновременно — 91 ГБ в кэше и 91 + ГБ рядом — и лишний проход копирования ради одной звуковой дорожки; +- **после удачной сборки куски удаляются,** и в журнале сказано, сколько + места освободилось. После неудачной — остаются: с них продолжают. + +Оставить их можно настройкой `keep_parts` в файле настроек: пригодится, +когда разбираешься, из чего собрался ролик. + +## Прерванная сборка + +Каждый доведённый до конца кусок помечается в списке рядом с самими +кусками (`готово.txt` в кэше). Если сборка не дошла до конца — упала, +была отменена или программу закрыли, — при следующей сборке в тот же файл +программа предложит продолжить с готовых кусков. + +Проверяется не только наличие файла: сборку могли прервать посреди +записи, и файл оказался бы обрезанным. Поэтому куском считается только +тот, который успел попасть в список. + +Первая строка списка — отпечаток плана: пути, места и длины всех кусков. +Не совпал — значит монтаж с тех пор менялся, и готовые куски не подойдут; +программа скажет об этом и соберёт заново. + +## Сколько осталось + +Окно сборки показывает, сколько прошло и сколько примерно осталось. +Оценка простая: если четверть пути заняла минуту, весь путь займёт +четыре. На деле скорость меняется — копируемые куски идут мгновенно, +пересобираемые медленно, — поэтому число называется «примерно» и +пересчитывается на каждом шаге. Даже такая оценка отвечает на главный +вопрос: успею ли я сходить за чаем. + ## Как собирается ролик 1. Монтаж уплощается в последовательность непересекающихся кусков. @@ -367,6 +561,30 @@ mpv сам выбрал `nvdec-copy`, всё работало, и ошибки «Invalid floating point operation», и предпросмотр не запускался. Лечится `SetExceptionMask` после загрузки библиотеки. +**Цепочку смешивания надо снимать до загрузки.** Она ссылается на дорожки +по номерам, и оставшаяся от прошлого раза не даёт открыть новый файл +вовсе: проверено на живом mpv — после такой загрузки дорожек ноль, кадра +нет, не играет ничего. Выглядит это как чёрное окно и полная тишина, и +на плеер не похоже совсем. + +Снимать её после загрузки поздно: ломается сама загрузка. + +**Внешняя звуковая дорожка не подключается свойством.** Задать +`audio-files` перед загрузкой недостаточно: список дорожек после +загрузки остаётся прежним, внешний файл не подключается вовсе, и играет +звук, встроенный в саму картинку. Проверено на живом mpv через его канал +управления: после установки свойства дорожек по-прежнему две, обе не +внешние. + +Из-за этого звук был слышен там, где на монтаже его нет. Попытка +защититься, отключая звук при ненайденной внешней дорожке, сделала +хуже — звука не стало нигде. + +Правильный способ — команда `audio-add` с признаком `select` после +загрузки: она добавляет дорожку, выбирает её и снимает выбор с +внутренней. Проверено: дорожек становится четыре, внутренняя звуковая +помечается невыбранной. + **Аргументы loadfile.** В mpv 0.38 у команды появился четвёртый аргумент — номер позиции в списке, и настройки файла сдвинулись на пятое место. Прежний вызов стал ошибкой «The loadfile option must be an integer», и под @@ -433,6 +651,7 @@ Wine с новой библиотекой не грузилось ничего. | `src/uPanCropForm.pas` | Окно кадрирования и поворота | | `src/uProjectInfoForm.pas` | Сведения о проекте и ответ ffprobe | | `src/uThumbs.pas` | Кадры-миниатюры для списка файлов | +| `src/uWaveform.pas` | Пики звука для формы волны на клипах | | `src/uTheme.pas` | Цвета окна, своя кнопка, своё окно сообщения | | `src/uLogView.pas` | Журнал: своя отрисовка, свои полосы прокрутки | | `src/uThemedScroll.pas` | Полоса прокрутки и обвязка для таблиц | diff --git a/build.sh b/build.sh index 7d8b474..2c2d87d 100755 --- a/build.sh +++ b/build.sh @@ -6,6 +6,7 @@ # ./build.sh current то же самое # ./build.sh windows редактор под Windows (кросс-сборка) # ./build.sh tool консольный инструмент проверок +# ./build.sh macos две сборки под macOS: nlve_intel и nlve_arm # ./build.sh test инструмент плюс прогон проверок # ./build.sh all всё перечисленное # ./build.sh run собрать под эту систему и запустить @@ -22,6 +23,8 @@ HERE=$(cd "$(dirname "$0")" && pwd) FPCUP=${FPCUP:-/home/chaiman/fpcupdeluxe} LAZBUILD="$FPCUP/lazarus/lazbuild" LAZCONF="$FPCUP/config_lazarus" +# Компилятор нужен напрямую для консольных проверок без формы. +FPC="$FPCUP/fpc/bin/x86_64-linux/fpc.sh" # Собранный виджетсет только один — gtk2. Ни qt5, ни gtk3 в этом # тулчейне нет, подставлять их бессмысленно. @@ -99,6 +102,48 @@ build_windows() { rm -rf "$HERE/lib/x86_64-win64" } +build_macos() { + check_toolchain + + # Сборка под macOS кладёт файл туда же, куда и сборка под Linux, и + # затирает её: имя цели в проекте одно на все системы. Поэтому каждый + # файл переименовывается сразу, а линуксовая сборка в конце делается + # заново. + if run_lazbuild "Редактор под macOS (Intel)" \ + --cpu=x86_64 --os=darwin --ws=cocoa "$HERE/nlve.lpi"; then + mv -f "$HERE/nlve" "$HERE/nlve_intel" + echo "готово: $HERE/nlve_intel" + file "$HERE/nlve_intel" 2>/dev/null | cut -d: -f2- | sed 's/^/ /' + else + echo "не собралось" >&2 + status=1 + fi + + if run_lazbuild "Редактор под macOS (Apple Silicon)" \ + --cpu=aarch64 --os=darwin --ws=cocoa "$HERE/nlve.lpi"; then + mv -f "$HERE/nlve" "$HERE/nlve_arm" + echo "готово: $HERE/nlve_arm" + file "$HERE/nlve_arm" 2>/dev/null | cut -d: -f2- | sed 's/^/ /' + else + echo "не собралось" >&2 + status=1 + fi + + # Обёртку .app делает lazbuild, и внутри неё ссылка на файл с именем + # nlve, которого после переименования уже нет. Обманчивая пустышка не + # нужна. + rm -rf "$HERE/nlve.app" + + # Модули под darwin лежат отдельно, но сборку под Linux мы затёрли — + # возвращаем её на место. + note "Возвращаю сборку под эту систему" + build_current + + echo + echo "ВНИМАНИЕ: под macOS предпросмотра не будет — встраивание mpv" + echo "написано под X11 и Windows. Подробности в BACKLOG.md." +} + build_tool() { note "Консольный инструмент проверок" if "$HERE/tests/build.sh"; then @@ -120,6 +165,42 @@ run_tests() { echo "проверки не пройдены" >&2 status=1 fi + + # Свойства, записанные в файлах форм, проверяются по сведениям о типах. + # Файл формы разбирается при запуске, а не при сборке: опечатка в имени + # свойства даёт не ошибку компиляции, а падение окна на старте. + note "Проверка свойств из файлов форм" + if "$LAZBUILD" --primary-config-path="$LAZCONF" \ + "$HERE/tests/lfmcheck/lfmcheck.lpi" >/dev/null 2>&1; then + if "$HERE/tests/lfmcheck/lfmcheck"; then + : + else + status=1 + fi + # Окно зависимостей при создании записывает рядом с собой список + # пакетов по умолчанию. Проверке это не мешает, а в дереве исходников + # такому файлу не место. + rm -f "$HERE/tests/lfmcheck/deps-linux.json" + else + echo "не собралось" >&2 + status=1 + fi + + # Ход полоски выполнения проверяется отдельной программой: расчёт вынесен + # в uAppTypes именно затем, чтобы его можно было прогнать числами. + note "Проверка хода полоски выполнения" + if "$FPC" -Fu"$HERE/src" -FE"$HERE/tests/progress" \ + -o"$HERE/tests/progress/progtest" \ + "$HERE/tests/progress/progtest.lpr" >/dev/null 2>&1; then + if "$HERE/tests/progress/progtest"; then + : + else + status=1 + fi + else + echo "не собралось" >&2 + status=1 + fi } do_clean() { @@ -137,6 +218,9 @@ case "${1:-current}" in windows|win|win64) build_windows ;; + macos|mac|darwin) + build_macos + ;; tool) build_tool ;; @@ -163,7 +247,7 @@ case "${1:-current}" in ;; *) fail "неизвестная цель: $1 -Доступны: current, windows, tool, test, all, run, clean" +Доступны: current, windows, macos, tool, test, all, run, clean" ;; esac diff --git a/icons_online/attribution.txt b/icons_online/attribution.txt new file mode 100644 index 0000000..0f3b577 --- /dev/null +++ b/icons_online/attribution.txt @@ -0,0 +1,5 @@ +Log panel: Property icon by Icons8 +Ripple gaps: Merge Vertical icon by Icons8 +Magnet: Magnet icon by Icons8 +Playhead snapping: Клей icon by Icons8 +App icon: Showing Video Frames icon by Icons8 \ No newline at end of file diff --git a/icons_online/icons8-merge-vertical-64.png b/icons_online/icons8-merge-vertical-64.png new file mode 100644 index 0000000..d03c248 Binary files /dev/null and b/icons_online/icons8-merge-vertical-64.png differ diff --git a/icons_online/icons8-property-30.png b/icons_online/icons8-property-30.png new file mode 100644 index 0000000..f37634c Binary files /dev/null and b/icons_online/icons8-property-30.png differ diff --git a/icons_online/icons8-клей-30.png b/icons_online/icons8-клей-30.png new file mode 100644 index 0000000..0c9e053 Binary files /dev/null and b/icons_online/icons8-клей-30.png differ diff --git a/icons_online/icons8-магнит-30.png b/icons_online/icons8-магнит-30.png new file mode 100644 index 0000000..aae491a Binary files /dev/null and b/icons_online/icons8-магнит-30.png differ diff --git a/icons_online/icons8-объединение-по-вертикали-30.png b/icons_online/icons8-объединение-по-вертикали-30.png new file mode 100644 index 0000000..0bcfe98 Binary files /dev/null and b/icons_online/icons8-объединение-по-вертикали-30.png differ diff --git a/icons_online/icons8-показ-видеокадров-30.png b/icons_online/icons8-показ-видеокадров-30.png new file mode 100644 index 0000000..28ea570 Binary files /dev/null and b/icons_online/icons8-показ-видеокадров-30.png differ diff --git a/icons_online/icons8-цель-30.png b/icons_online/icons8-цель-30.png new file mode 100644 index 0000000..274e00c Binary files /dev/null and b/icons_online/icons8-цель-30.png differ diff --git a/nlve.lpr b/nlve.lpr index a03aaab..abec454 100644 --- a/nlve.lpr +++ b/nlve.lpr @@ -18,6 +18,9 @@ begin Application.Title := 'nlve'; Application.Scaled := True; Application.Initialize; + { Цвета меню задаются до создания окон: под gtk2 это строка стиля, а её + разбирают один раз — уже созданные виджеты о ней не узнают. } + ApplyMenuStyle; { Подписка на появление окон: своим окнам цвета задаются в их же обработчике создания, а это подстраховка на случай окна, созданного самой библиотекой. } diff --git a/packaging/application-x-nlve-project.png b/packaging/application-x-nlve-project.png new file mode 100644 index 0000000..c9cd245 Binary files /dev/null and b/packaging/application-x-nlve-project.png differ diff --git a/packaging/application-x-nlve-project.xml b/packaging/application-x-nlve-project.xml new file mode 100644 index 0000000..567c6e8 --- /dev/null +++ b/packaging/application-x-nlve-project.xml @@ -0,0 +1,22 @@ + + + + + nlve project + Проект nlve + + + + + + diff --git a/packaging/nlve.desktop.in b/packaging/nlve.desktop.in new file mode 100644 index 0000000..c9550bc --- /dev/null +++ b/packaging/nlve.desktop.in @@ -0,0 +1,17 @@ +[Desktop Entry] +Type=Application +Version=1.0 +Name=nlve +GenericName=Video editor +GenericName[ru]=Видеоредактор +Comment=Non-linear video editing without re-encoding +Comment[ru]=Монтаж видео без перекодирования +Exec=@BIN@ %f +Path=@DIR@ +Icon=nlve +Terminal=false +StartupNotify=true +Categories=AudioVideo;Video;AudioVideoEditing; +MimeType=application/x-nlve-project;video/mp4;video/x-matroska; +Keywords=video;editor;montage; +Keywords[ru]=видео;монтаж;редактор; diff --git a/packaging/nlve.png b/packaging/nlve.png new file mode 100644 index 0000000..4736678 Binary files /dev/null and b/packaging/nlve.png differ diff --git a/src/uAboutForm.pas b/src/uAboutForm.pas new file mode 100644 index 0000000..f2714c9 --- /dev/null +++ b/src/uAboutForm.pas @@ -0,0 +1,235 @@ +{ + uAboutForm — окно «О программе». + + Две вкладки. «Ресурсы» — на чём программа держится и чьи значки + использует: бесплатная лицензия Icons8 требует ссылку на каждый значок. + «Возможности» — что программа умеет. + + Вкладки свои, а не TPageControl: системные под Windows остались бы + светлой полосой поверх тёмного окна. + + Текст показывает uArticleView: он сам переносит строки по ширине окна и + делает ссылки нажимаемыми. +} +unit uAboutForm; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, + uTheme, uArticleView; + +procedure ShowAboutForm; + +implementation + +type + { Обработчики живут в объекте: событиям нужны методы. } + TAboutDialog = class(TComponent) + public + Form: TForm; + BtnResources: TThemedButton; + BtnFeatures: TThemedButton; + ViewResources: TArticleView; + ViewFeatures: TArticleView; + procedure ShowResources(Sender: TObject); + procedure ShowFeatures(Sender: TObject); + procedure Select(AResources: Boolean); + end; + +procedure TAboutDialog.Select(AResources: Boolean); +begin + BtnResources.Down := AResources; + BtnFeatures.Down := not AResources; + ViewResources.Visible := AResources; + ViewFeatures.Visible := not AResources; +end; + +procedure TAboutDialog.ShowResources(Sender: TObject); +begin + Select(True); +end; + +procedure TAboutDialog.ShowFeatures(Sender: TObject); +begin + Select(False); +end; + +{ Списки под Windows и под Linux разные: там сборки скачивает сама + программа, здесь их ставит пакетный менеджер. } +function ResourcesText: string; +begin + Result := + '# nlve' + LineEnding + + 'Монтаж без перекодирования: куски вырезаются и склеиваются ' + + 'копированием потока.' + LineEnding + + 'Автор: 4aiman' + LineEnding + + LineEnding + + '# Значки' + LineEnding + + 'Icons8. Нужна ссылка на каждый значок.' + LineEnding + + 'Прилипание — Magnet' + LineEnding + + ' https://icons8.com/icon/79942/magnet' + LineEnding + + 'Схлопывание — Merge Vertical' + LineEnding + + ' https://icons8.com/icon/2EQegp8tbR6Q/merge-vertical' + LineEnding + + 'Журнал — Property' + LineEnding + + ' https://icons8.com/icon/79872/property' + LineEnding + + 'Прилипание курсора — Клей' + LineEnding + + ' https://icons8.com/icon/111296/glue' + LineEnding + + 'Значок программы — Showing Video Frames' + LineEnding + + ' https://icons8.com/icon/69093/showing-video-frames' + LineEnding + + 'Сам Icons8' + LineEnding + + ' https://icons8.com' + LineEnding + + LineEnding + + '# Видео и звук' + LineEnding + + {$IFDEF WINDOWS} + 'ffmpeg — нарезка, склейка, перекодирование. Сборка BtbN, GPL.' + + LineEnding + + ' https://github.com/BtbN/FFmpeg-Builds' + LineEnding + + ' https://ffmpeg.org' + LineEnding + + 'libmpv — предпросмотр. Сборка shinchiro, GPL.' + LineEnding + + ' https://github.com/shinchiro/mpv-winbuild-cmake' + LineEnding + + ' https://mpv.io' + LineEnding + + '7-Zip — распаковка сборок libmpv. LGPL-2.1.' + LineEnding + + ' https://www.7-zip.org' + LineEnding + + {$ELSE} + 'ffmpeg — нарезка, склейка, перекодирование. GPL-2 и новее.' + + LineEnding + + ' sudo apt install ffmpeg' + LineEnding + + ' https://ffmpeg.org' + LineEnding + + 'libmpv — предпросмотр. GPL-3 и новее.' + LineEnding + + ' sudo apt install mpv' + LineEnding + + ' https://mpv.io' + LineEnding + + {$ENDIF} + LineEnding + + '# Инструменты' + LineEnding + + 'Free Pascal' + LineEnding + + ' https://www.freepascal.org' + LineEnding + + 'Lazarus LCL' + LineEnding + + ' https://www.lazarus-ide.org' + LineEnding + + LineEnding + + 'ffmpeg и libmpv в состав программы не входят: ffmpeg запускается ' + + 'отдельной программой, libmpv ставится отдельно.'; +end; + +function FeaturesText: string; +begin + Result := + '# Монтаж' + LineEnding + + 'Дорожки для картинки и для звука.' + LineEnding + + 'При перекрытии картинку даёт верхняя дорожка, звук всех дорожек ' + + 'смешивается.' + LineEnding + + 'Перенос, растягивание за края, рез по курсору (S), удаление.' + + LineEnding + + 'Прилипание к соседям и к курсору. Shift отменяет его.' + LineEnding + + 'Связки: видео и его звук ходят вместе. Ctrl+G связывает и ' + + 'развязывает.' + LineEnding + + 'Схлопывание дыр: Ctrl+Shift+R или само при перетаскивании.' + + LineEnding + + 'Отмена и повтор: Ctrl+Z, Ctrl+Y.' + LineEnding + + LineEnding + + '# На дорожках' + LineEnding + + 'Форма звука. Shift со стрелками усиливает её на тихих записях.' + + LineEnding + + 'Громкость и прозрачность — ручкой на клипе.' + LineEnding + + 'Появление и уход — за верхние углы клипа.' + LineEnding + + 'Перекрытие на одной дорожке помечено крестом: там переход.' + + LineEnding + + 'Цвет краёв показывает, потребует ли рез перекодирования.' + LineEnding + + LineEnding + + '# Предпросмотр' + LineEnding + + 'Играет монтаж целиком, не собирая файлов.' + LineEnding + + 'Показывает кадр проекта, а не кадр исходника.' + LineEnding + + 'Прозрачность и переходы видны.' + LineEnding + + LineEnding + + '# Кадрирование' + LineEnding + + 'Вписать, заполнить или растянуть. Увеличение, смещение, поворот, ' + + 'отражение.' + LineEnding + + 'Рамку можно тянуть мышью.' + LineEnding + + 'У каждого клипа своё.' + LineEnding + + LineEnding + + '# Сборка' + LineEnding + + 'Обычная — копированием потоков, за время копирования файла.' + + LineEnding + + 'Заранее сказано, сколько секунд придётся пересобрать и почему.' + + LineEnding + + 'Точный рез перекодирует только огрызок до опорного кадра.' + + LineEnding + + 'С перекодированием: от 720p до 4K, свой поток, HEVC или H.264, ' + + 'на видеокарте.' + LineEnding + + 'Перепаковка в другой контейнер без пересчёта.' + LineEnding + + LineEnding + + '# Прочее' + LineEnding + + 'Индекс опорных кадров читается из заголовка: 20 мс вместо 12 секунд.' + + LineEnding + + 'Фоновая работа видна полоской внизу и штриховкой на монтаже.' + + LineEnding + + 'Свои цвета во всех окнах.' + LineEnding + + 'Настройки и недавние проекты переживают перезапуск.'; +end; + +procedure ShowAboutForm; +var + Dlg: TAboutDialog; + BtnClose: TThemedButton; +begin + Dlg := TAboutDialog.Create(nil); + try + Dlg.Form := TForm.CreateNew(nil); + Dlg.Form.Caption := 'О программе'; + Dlg.Form.Position := poScreenCenter; + Dlg.Form.ClientWidth := 720; + Dlg.Form.ClientHeight := 560; + Dlg.Form.Constraints.MinWidth := 420; + Dlg.Form.Constraints.MinHeight := 300; + + Dlg.BtnResources := TThemedButton.Create(Dlg.Form); + Dlg.BtnResources.Parent := Dlg.Form; + Dlg.BtnResources.SetBounds(12, 12, 140, 28); + Dlg.BtnResources.Caption := 'Ресурсы'; + Dlg.BtnResources.TabStop := False; + Dlg.BtnResources.OnClick := @Dlg.ShowResources; + + Dlg.BtnFeatures := TThemedButton.Create(Dlg.Form); + Dlg.BtnFeatures.Parent := Dlg.Form; + Dlg.BtnFeatures.SetBounds(158, 12, 140, 28); + Dlg.BtnFeatures.Caption := 'Возможности'; + Dlg.BtnFeatures.TabStop := False; + Dlg.BtnFeatures.OnClick := @Dlg.ShowFeatures; + + Dlg.ViewResources := TArticleView.Create(Dlg.Form); + Dlg.ViewResources.Parent := Dlg.Form; + Dlg.ViewResources.SetBounds(12, 48, 696, 460); + Dlg.ViewResources.Anchors := [akTop, akLeft, akRight, akBottom]; + + Dlg.ViewFeatures := TArticleView.Create(Dlg.Form); + Dlg.ViewFeatures.Parent := Dlg.Form; + Dlg.ViewFeatures.SetBounds(12, 48, 696, 460); + Dlg.ViewFeatures.Anchors := [akTop, akLeft, akRight, akBottom]; + + BtnClose := TThemedButton.Create(Dlg.Form); + BtnClose.Parent := Dlg.Form; + BtnClose.SetBounds(608, 520, 100, 28); + BtnClose.Anchors := [akRight, akBottom]; + BtnClose.Caption := 'Закрыть'; + BtnClose.ModalResult := mrOk; + BtnClose.Default := True; + BtnClose.Cancel := True; + + ApplyDarkTheme(Dlg.Form); + + { Текст задаётся после раскраски: раскладка считается по тому шрифту, + которым он будет нарисован. } + Dlg.ViewResources.SetText(ResourcesText); + Dlg.ViewFeatures.SetText(FeaturesText); + Dlg.Select(True); + + Dlg.Form.ShowModal; + finally + Dlg.Form.Free; + Dlg.Free; + end; +end; + +end. diff --git a/src/uAppTypes.pas b/src/uAppTypes.pas index 060570e..c7b9144 100644 --- a/src/uAppTypes.pas +++ b/src/uAppTypes.pas @@ -11,9 +11,18 @@ unit uAppTypes; interface uses - SysUtils; + SysUtils + {$IFDEF UNIX}, BaseUnix{$ENDIF}; type + { Цвет в записи, принятой в LCL: $00BBGGRR. + + Свой тип, а не TColor из Graphics: модель не должна тянуть за собой + оконную библиотеку. Стоило один раз потянуть — и консольная проверка + перестала собираться. Значения совпадают, окно приводит одно к + другому без пересчёта. } + TRgb = LongInt; + { Чем заполнен сегмент готового ряда. skVideo — кусок настоящего исходного файла, копируется без перекодирования. @@ -26,6 +35,67 @@ type показа. Позиция на таймлайне здесь не хранится намеренно — она равна сумме длительностей предыдущих сегментов, дублировать её значит завести источник рассогласования. } + { Один слой наложения. + + Появляется там, где кусок нельзя описать одним источником: клип + полупрозрачен и сквозь него видно нижний, либо два клипа на одной + дорожке наползли друг на друга и должны перетечь один в другой. + + Слои перечислены снизу вверх. } + TSegmentLayer = record + FilePath: string; + SrcStart: Double; + { Цепочка кадрирования этого слоя: с полями до кадра проекта. Годится + там, где слой сам по себе занимает весь кадр. } + Filter: string; + { Та же цепочка без полей и место, куда слой встаёт в кадре. + + Верхний слой полями обкладывать нельзя: поле чёрное и непрозрачное, + и уменьшенный клип закрывал бы им всё нижнее видео вместо того, + чтобы лечь в свой угол. } + FitFilter: string; + X: Integer; + Y: Integer; + { Постоянная непрозрачность слоя. } + Opacity: Double; + { Слой — неподвижная картинка, а не видео. + + Её надо повторять: одиночный файл даёт ffmpeg ровно один кадр, и + кусок с наложением схлопывался в одну шестидесятую секунды — + фотография из ролика просто пропадала. } + IsImage: Boolean; + { Цветовой ключ слоя: этот цвет становится прозрачным. Ключ выключен, + если KeyEnabled равно False. } + KeyEnabled: Boolean; + KeyColor: TRgb; + KeySimilarity: Integer; + KeyBlend: Integer; + { Переход: непрозрачность меняется от начала куска к концу. Если оба + значения равны Opacity, перехода нет. } + FadeFrom: Double; + FadeTo: Double; + end; + + TSegmentLayers = array of TSegmentLayer; + + { Окно наложения для плеера: когда, куда и каким фильтром класть + оверлей поверх основы. + + Живёт в базовых типах, а не в уплощении, потому что плеер про + уплощение знать не должен: ему отдают готовое описание. } + TOverlayWindow = record + TlStart: Double; + TlEnd: Double; + { Цепочка фильтров для самого оверлея: размер, поворот. Без полей — + поля закрыли бы нижнее видео. } + Filter: string; + X: Integer; + Y: Integer; + Width: Integer; + Height: Integer; + end; + TOverlayWindows = array of TOverlayWindow; + TFlatSegment = record FilePath: string; SrcStart: Double; @@ -53,6 +123,16 @@ type { Готовая цепочка фильтров ffmpeg: как кадр этого исходника ложится в кадр проекта. Считается один раз при уплощении. } Filter: string; + { Разметка субтитров для этого куска: времена уже сдвинуты к его + началу. Пусто — текста здесь нет. Заполняется только при сборке с + вжиганием. } + SubFile: string; + { Слои наложения. Пусто — обычный кусок с одним источником, который + можно скопировать. Непусто — участок придётся собрать заново. + + Ради этого и заведено: наложение и переходы стоят перекодирования, + но только своего участка, а не всего ролика. } + Layers: TSegmentLayers; end; TFlatSegmentArray = array of TFlatSegment; @@ -77,6 +157,30 @@ function TotalDuration(const Segments: TFlatSegmentArray): Double; «куска», для 5 — «кусков». Без этого в интерфейсе появляется «1 кусков». } function Plural(ACount: Integer; const AOne, AFew, AMany: string): string; +{ Как двигается показанная доля выполнения. + + Настоящая доля известна только вехами: файл разобран, вставка готова. + Между вехами не происходит ничего видимого, и полоска, стоящая на месте, + выглядит как зависшая программа. + + Поэтому между вехами она ползёт сама — к следующей вехе, но никогда её + не достигая: каждый шаг покрывает малую долю оставшегося расстояния. + Пока работа идёт как задумано, веха приходит быстро и полоска прыгает к + ней. Затянулась — шаги мельчают, и заполнение само собой замедляется. + + Назад полоска не идёт никогда. } +function AdvanceProgress(AShown, AReal, ANext, AStepShare: Double): Double; + +{ Каталог, в котором лежит сама программа. + + Не ExtractFilePath(ParamStr(0)): если программу запустили через + символьную ссылку — а так она и попадает в PATH и в меню, — то путь + укажет на ссылку, и рядом с ней окажутся и журнал, и файл зависимостей, + и поиск ffmpeg. Ссылки раскрываются, пока не кончатся. + + Под Windows ссылок такого рода нет, и путь берётся как есть. } +function ProgramDir: string; + implementation var @@ -127,4 +231,44 @@ begin Result := AMany; end; +function AdvanceProgress(AShown, AReal, ANext, AStepShare: Double): Double; +begin + Result := AShown; + if AReal > Result then + Result := AReal; + if ANext > Result then + Result := Result + (ANext - Result) * AStepShare; + { До самого конца полоска не доходит: конец наступает тогда, когда + работа кончилась, а не когда мы досчитали. } + if Result > 0.999 then + Result := 0.999; +end; + +function ProgramDir: string; +var + Path, Target: string; + {$IFDEF UNIX} + Guard: Integer; + {$ENDIF} +begin + Path := ExpandFileName(ParamStr(0)); + {$IFDEF UNIX} + { Ограничение на число переходов — от закольцованных ссылок. } + Guard := 0; + while Guard < 16 do + begin + Target := fpReadLink(Path); + if Target = '' then + Break; + { Ссылка может указывать и относительным путём — считаем его от + каталога самой ссылки. } + if (Length(Target) > 0) and (Target[1] <> '/') then + Target := ExpandFileName(ExtractFilePath(Path) + Target); + Path := Target; + Inc(Guard); + end; + {$ENDIF} + Result := ExtractFilePath(Path); +end; + end. diff --git a/src/uArticleView.pas b/src/uArticleView.pas new file mode 100644 index 0000000..fae9e0b --- /dev/null +++ b/src/uArticleView.pas @@ -0,0 +1,414 @@ +{ + uArticleView — страница текста со ссылками. + + Журнал (uLogView) для этого не годится: он показывает сообщения + программы, где перенос сбил бы выравнивание, и строки там не + переносятся принципиально. Здесь наоборот — сплошной текст, который + должен сам ложиться по ширине окна и переливаться заново при его + изменении. Считать переносы заранее нельзя ещё и потому, что текст + когда-нибудь поедет в переводы: длина строки в другом языке будет иной. + + Разметка нарочно бедная, вся в одну строку: + + «# заголовок» — заголовок раздела + пустая строка — отступ между абзацами + ведущие пробелы — отступ, сохраняется при переносе + http:// и https:// — ссылка, её можно нажать + + Больше ничего не нужно: это окно «О программе», а не браузер. +} +unit uArticleView; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, Controls, Graphics, LCLType, LCLIntf, Types, + uTheme, uThemedScroll; + +type + { Кусок строки: либо обычный текст, либо ссылка. } + TRun = record + Text: string; + Url: string; + Left: Integer; + Width: Integer; + end; + + TVisualLine = record + Runs: array of TRun; + Top: Integer; + Height: Integer; + Heading: Boolean; + end; + + TArticleView = class(TCustomControl) + private + FLines: TStringList; + FVisual: array of TVisualLine; + FContentHeight: Integer; + FScroll: Integer; + FBar: TThemedScrollBar; + FHotLine: Integer; + FHotRun: Integer; + procedure BarChange(Sender: TObject); + procedure Relayout; + procedure SyncBar; + { Ссылка под указателем. Возвращает пустую строку, если её там нет. } + function UrlAt(X, Y: Integer; out ALine, ARun: Integer): string; + function LineHeight(AHeading: Boolean): Integer; + protected + procedure Paint; override; + procedure Resize; override; + procedure MouseMove(Shift: TShiftState; X, Y: Integer); override; + procedure MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); override; + procedure MouseLeave; override; + function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; override; + public + constructor Create(AOwner: TComponent); override; + destructor Destroy; override; + procedure SetText(const AText: string); + published + property Align; + property Anchors; + property Font; + property ParentFont; + property Visible; + end; + +implementation + +const + PadLeft = 10; + PadTop = 8; + BarWidth = 12; + { Отступ между абзацами и после заголовка — доли высоты строки. } + ParaGap = 6; + +constructor TArticleView.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + DoubleBuffered := True; + Color := ThemeSurface; + ParentColor := False; + FLines := TStringList.Create; + FHotLine := -1; + FHotRun := -1; + + FBar := TThemedScrollBar.Create(Self); + FBar.Parent := Self; + FBar.Setup(True); + FBar.OnChange := @BarChange; + FBar.Visible := False; +end; + +destructor TArticleView.Destroy; +begin + FLines.Free; + inherited Destroy; +end; + +function TArticleView.LineHeight(AHeading: Boolean): Integer; +begin + Canvas.Font.Assign(Font); + if AHeading then + Canvas.Font.Style := [fsBold]; + Result := Canvas.TextHeight('Wg') + 3; + Canvas.Font.Style := []; +end; + +procedure TArticleView.SetText(const AText: string); +begin + FLines.Text := AText; + FScroll := 0; + Relayout; + Invalidate; +end; + +{ Раскладка: каждая строка исходника режется на слова и укладывается по + ширине. Ссылка не режется никогда — из двух половин её не собрать. } +procedure TArticleView.Relayout; +var + I, N, Indent, X, MaxX, W, Start: Integer; + Src, Word, Rest: string; + Heading: Boolean; + Line: TVisualLine; + Y: Integer; + + procedure PushLine; + begin + if Length(Line.Runs) = 0 then + Exit; + Line.Top := Y; + Line.Height := LineHeight(Line.Heading); + Inc(Y, Line.Height); + SetLength(FVisual, Length(FVisual) + 1); + FVisual[High(FVisual)] := Line; + Line.Runs := nil; + X := Indent; + end; + + procedure PushWord(const AWord: string; const AUrl: string); + var + Wid: Integer; + begin + Canvas.Font.Assign(Font); + if Line.Heading then + Canvas.Font.Style := [fsBold]; + Wid := Canvas.TextWidth(AWord); + Canvas.Font.Style := []; + + { Не влезло — переносим, но только если на строке уже что-то есть: + иначе слово шире окна ушло бы в бесконечный перенос. } + if (X + Wid > MaxX) and (Length(Line.Runs) > 0) then + PushLine; + + N := Length(Line.Runs); + SetLength(Line.Runs, N + 1); + Line.Runs[N].Text := AWord; + Line.Runs[N].Url := AUrl; + Line.Runs[N].Left := X; + Line.Runs[N].Width := Wid; + Inc(X, Wid); + end; + +begin + FVisual := nil; + FContentHeight := 0; + if FLines = nil then + Exit; + + MaxX := ClientWidth - PadLeft - BarWidth - 6; + if MaxX < 80 then + MaxX := 80; + + Y := PadTop; + Line.Runs := nil; + Line.Heading := False; + + for I := 0 to FLines.Count - 1 do + begin + Src := FLines[I]; + + if Trim(Src) = '' then + begin + Inc(Y, ParaGap + LineHeight(False) div 2); + Continue; + end; + + Heading := Copy(Src, 1, 2) = '# '; + if Heading then + begin + Src := Copy(Src, 3, Length(Src)); + Inc(Y, ParaGap); + end; + + Indent := PadLeft; + while (Length(Src) > 0) and (Src[1] = ' ') do + begin + Inc(Indent, 12); + Delete(Src, 1, 1); + end; + + Line.Heading := Heading; + X := Indent; + Rest := Src; + + while Rest <> '' do + begin + Start := Pos(' ', Rest); + if Start = 0 then + begin + Word := Rest; + Rest := ''; + end + else + begin + Word := Copy(Rest, 1, Start); + Rest := Copy(Rest, Start + 1, Length(Rest)); + end; + + if (Pos('http://', Word) = 1) or (Pos('https://', Word) = 1) then + PushWord(Word, TrimRight(Word)) + else + PushWord(Word, ''); + end; + PushLine; + + if Heading then + Inc(Y, 2); + end; + + FContentHeight := Y + PadTop; + SyncBar; +end; + +procedure TArticleView.SyncBar; +var + Page: Integer; +begin + if FBar = nil then + Exit; + Page := ClientHeight; + FBar.SetBounds(ClientWidth - BarWidth, 0, BarWidth, ClientHeight); + FBar.SetRange(FContentHeight, Page); + FBar.Visible := FBar.Needed; + if FScroll > FContentHeight - Page then + FScroll := Max(0, FContentHeight - Page); + FBar.Position := FScroll; +end; + +procedure TArticleView.BarChange(Sender: TObject); +begin + if FScroll = FBar.Position then + Exit; + FScroll := FBar.Position; + Invalidate; +end; + +procedure TArticleView.Resize; +begin + inherited Resize; + Relayout; + Invalidate; +end; + +function TArticleView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; + MousePos: TPoint): Boolean; +var + Step: Integer; +begin + Step := LineHeight(False) * 3; + if WheelDelta > 0 then + FScroll := Max(0, FScroll - Step) + else + FScroll := Min(Max(0, FContentHeight - ClientHeight), FScroll + Step); + if FBar <> nil then + FBar.Position := FScroll; + Invalidate; + Result := True; +end; + +function TArticleView.UrlAt(X, Y: Integer; out ALine, ARun: Integer): string; +var + { Не Top: так называется свойство самого элемента. } + I, J, LineTop: Integer; +begin + Result := ''; + ALine := -1; + ARun := -1; + for I := 0 to High(FVisual) do + begin + LineTop := FVisual[I].Top - FScroll; + if (Y < LineTop) or (Y >= LineTop + FVisual[I].Height) then + Continue; + for J := 0 to High(FVisual[I].Runs) do + if (FVisual[I].Runs[J].Url <> '') and + (X >= FVisual[I].Runs[J].Left) and + (X < FVisual[I].Runs[J].Left + FVisual[I].Runs[J].Width) then + begin + ALine := I; + ARun := J; + Exit(FVisual[I].Runs[J].Url); + end; + Exit; + end; +end; + +procedure TArticleView.MouseMove(Shift: TShiftState; X, Y: Integer); +var + L, R: Integer; +begin + inherited MouseMove(Shift, X, Y); + UrlAt(X, Y, L, R); + if (L <> FHotLine) or (R <> FHotRun) then + begin + FHotLine := L; + FHotRun := R; + if L >= 0 then + Cursor := crHandPoint + else + Cursor := crDefault; + Invalidate; + end; +end; + +procedure TArticleView.MouseLeave; +begin + inherited MouseLeave; + if FHotLine >= 0 then + begin + FHotLine := -1; + FHotRun := -1; + Cursor := crDefault; + Invalidate; + end; +end; + +procedure TArticleView.MouseUp(Button: TMouseButton; Shift: TShiftState; + X, Y: Integer); +var + Url: string; + L, R: Integer; +begin + inherited MouseUp(Button, Shift, X, Y); + if Button <> mbLeft then + Exit; + Url := UrlAt(X, Y, L, R); + if Url <> '' then + OpenURL(Url); +end; + +procedure TArticleView.Paint; +var + I, J, LineTop: Integer; + Run: TRun; + Hot: Boolean; +begin + Canvas.Brush.Color := ThemeSurface; + Canvas.Brush.Style := bsSolid; + Canvas.FillRect(ClientRect); + + Canvas.Brush.Style := bsClear; + for I := 0 to High(FVisual) do + begin + LineTop := FVisual[I].Top - FScroll; + if LineTop + FVisual[I].Height < 0 then + Continue; + if LineTop > ClientHeight then + Break; + + Canvas.Font.Assign(Font); + if FVisual[I].Heading then + Canvas.Font.Style := [fsBold]; + + for J := 0 to High(FVisual[I].Runs) do + begin + Run := FVisual[I].Runs[J]; + Hot := (I = FHotLine) and (J = FHotRun); + + if Run.Url <> '' then + begin + if Hot then + Canvas.Font.Color := ThemeAccent + else + Canvas.Font.Color := ThemeLink; + Canvas.Font.Style := Canvas.Font.Style + [fsUnderline]; + end + else if FVisual[I].Heading then + Canvas.Font.Color := ThemeText + else + Canvas.Font.Color := ThemeText; + + Canvas.TextOut(Run.Left, LineTop, Run.Text); + + Canvas.Font.Style := Canvas.Font.Style - [fsUnderline]; + end; + Canvas.Font.Style := []; + end; +end; + +end. diff --git a/src/uColorKeyForm.pas b/src/uColorKeyForm.pas new file mode 100644 index 0000000..ae2de3e --- /dev/null +++ b/src/uColorKeyForm.pas @@ -0,0 +1,397 @@ +{ + uColorKeyForm — окно цветового ключа. + + Цветовой ключ выбивает из клипа один цвет: всё, что достаточно на него + похоже, становится прозрачным, и сквозь клип видно то, что лежит под + ним. Так работает «зелёный экран» в кино, только цвет выбираем мы. + + Главное в этом окне — не поля, а картинка. Цвет берут щелчком прямо по + кадру: назвать пурпурный числом человек не сможет, а ткнуть в него + мышью — сможет. Выбитое показывается клеткой, как в редакторах + изображений: клетка видна там, где будет видно нижний клип. + + Порог считается тем же способом, что и в ffmpeg: расстояние между + цветом точки и заданным цветом в пространстве RGB, поделённое на + наибольшее возможное. Иначе картинка в окне обещала бы одно, а сборка + давала другое. +} +unit uColorKeyForm; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, ExtCtrls, + ComCtrls, uAppTypes, uProject, uTheme; + +{ Показывает окно. True — человек нажал «Готово», и в AKey лежит + изменённое. + + APath — файл клипа, ATime — время внутри файла, откуда брать кадр для + показа. } +function EditColorKey(var AKey: TColorKey; const APath: string; + const ATime: Double; const ATempFile: string): Boolean; + +implementation + +uses + Math, FPimage, IntfGraphics, uFfmpegCmd, uProcRunner; + +const + { Клетка под выбитым: две краски и размер квадратика. } + ColorCheckA = TColor($4A4A4A); + ColorCheckB = TColor($5E5E5E); + CheckSize = 8; + +type + TColorKeyDialog = class(TComponent) + public + Form: TForm; + pbFrame: TPaintBox; + cbOn: TCheckBox; + BtnColor: TThemedButton; + tbSimilar: TTrackBar; + tbBlend: TTrackBar; + lblSimilar: TLabel; + lblBlend: TLabel; + lblHint: TLabel; + Key: TColorKey; + { Кадр как он есть и кадр с уже выбитым цветом. Первый нужен, чтобы + брать из него цвет по щелчку: во втором выбитое уже заменено + клеткой, и попасть по исходному цвету было бы нельзя. } + Source: TBitmap; + Shown: TBitmap; + procedure AnyChange(Sender: TObject); + procedure ColorClick(Sender: TObject); + procedure FramePaint(Sender: TObject); + procedure FrameMouseDown(Sender: TObject; AButton: TMouseButton; + AShift: TShiftState; AX, AY: Integer); + { Прямоугольник, в который вписан кадр. } + function FrameRect: TRect; + procedure Rebuild; + procedure UpdateLabels; + end; + +{ Насколько точка отличается от заданного цвета: 0 — тот же цвет, 1 — + наибольшее возможное расхождение. Повторяет расчёт фильтра colorkey. } +function ColorDistance(AR, AG, AB: Integer; AKey: TRgb): Double; +var + DR, DG, DB: Integer; +begin + DR := AR - (AKey and $FF); + DG := AG - ((AKey shr 8) and $FF); + DB := AB - ((AKey shr 16) and $FF); + Result := Sqrt((DR * DR + DG * DG + DB * DB) / (255.0 * 255.0 * 3.0)); +end; + +{ Прозрачность точки после ключа: 0 — выбита совсем, 1 — осталась. } +function KeyAlpha(const ADist, ASimilar, ABlend: Double): Double; +begin + if ABlend > 0.0001 then + Result := Max(0, Min(1, (ADist - ASimilar) / ABlend)) + else if ADist > ASimilar then + Result := 1 + else + Result := 0; +end; + +{ Кадр с выбитым цветом: где выбито — клетка, где нет — исходная точка, + а на смягчённом крае они смешаны. + + Точки берутся через промежуточное изображение, а не через Canvas.Pixels: + каждое обращение к Pixels под gtk2 идёт через оконную систему, и на + кадре в четверть миллиона точек окно бы просто встало. } +procedure ApplyKey(ASrc, ADst: TBitmap; const AKey: TColorKey); +var + Img: TLazIntfImage; + X, Y, R, G, B: Integer; + A, Similar, Blend: Double; + C: TFPColor; + Check: TColor; +begin + Similar := AKey.Similarity / 100; + Blend := AKey.Blend / 100; + Img := ASrc.CreateIntfImage; + try + if AKey.Enabled then + for Y := 0 to Img.Height - 1 do + for X := 0 to Img.Width - 1 do + begin + C := Img.Colors[X, Y]; + R := C.Red shr 8; + G := C.Green shr 8; + B := C.Blue shr 8; + A := KeyAlpha(ColorDistance(R, G, B, AKey.Color), Similar, Blend); + if A >= 0.999 then + Continue; + + if ((X div CheckSize) + (Y div CheckSize)) and 1 = 0 then + Check := ColorCheckA + else + Check := ColorCheckB; + C.Red := Round(R * A + (Check and $FF) * (1 - A)) * 257; + C.Green := Round(G * A + ((Check shr 8) and $FF) * (1 - A)) * 257; + C.Blue := Round(B * A + ((Check shr 16) and $FF) * (1 - A)) * 257; + Img.Colors[X, Y] := C; + end; + ADst.LoadFromIntfImage(Img); + finally + Img.Free; + end; +end; + +function TColorKeyDialog.FrameRect: TRect; +var + W, H: Integer; + Scale: Double; +begin + Result := Rect(0, 0, 0, 0); + if (Source = nil) or (Source.Width = 0) or (Source.Height = 0) then + Exit; + Scale := Min(pbFrame.Width / Source.Width, pbFrame.Height / Source.Height); + W := Max(1, Round(Source.Width * Scale)); + H := Max(1, Round(Source.Height * Scale)); + Result := Bounds((pbFrame.Width - W) div 2, (pbFrame.Height - H) div 2, W, H); +end; + +procedure TColorKeyDialog.FramePaint(Sender: TObject); +var + R: TRect; +begin + pbFrame.Canvas.Brush.Color := ThemeSurface; + pbFrame.Canvas.FillRect(0, 0, pbFrame.Width, pbFrame.Height); + if Shown = nil then + begin + pbFrame.Canvas.Font.Color := ThemeText; + pbFrame.Canvas.TextOut(8, 8, 'Кадр получить не удалось'); + Exit; + end; + R := FrameRect; + pbFrame.Canvas.StretchDraw(R, Shown); +end; + +procedure TColorKeyDialog.FrameMouseDown(Sender: TObject; + AButton: TMouseButton; AShift: TShiftState; AX, AY: Integer); +var + R: TRect; + SX, SY: Integer; +begin + if Source = nil then + Exit; + R := FrameRect; + if (AX < R.Left) or (AX >= R.Right) or (AY < R.Top) or (AY >= R.Bottom) then + Exit; + + SX := Round((AX - R.Left) / (R.Right - R.Left) * Source.Width); + SY := Round((AY - R.Top) / (R.Bottom - R.Top) * Source.Height); + SX := Max(0, Min(Source.Width - 1, SX)); + SY := Max(0, Min(Source.Height - 1, SY)); + + Key.Color := TRgb(Source.Canvas.Pixels[SX, SY]); + BtnColor.Swatch := TColor(Key.Color); + { Ткнули в цвет — значит, его и хотят выбить. Требовать после этого + отдельно поставить галку было бы издевательством. } + if not cbOn.Checked then + cbOn.Checked := True; + Rebuild; +end; + +procedure TColorKeyDialog.ColorClick(Sender: TObject); +var + Dlg: TColorDialog; +begin + Dlg := TColorDialog.Create(nil); + try + Dlg.Color := TColor(Key.Color); + if not Dlg.Execute then + Exit; + Key.Color := TRgb(Dlg.Color); + BtnColor.Swatch := Dlg.Color; + Rebuild; + finally + Dlg.Free; + end; +end; + +procedure TColorKeyDialog.UpdateLabels; +begin + lblSimilar.Caption := Format('Допуск: %d%%', [tbSimilar.Position]); + lblBlend.Caption := Format('Смягчение края: %d%%', [tbBlend.Position]); +end; + +procedure TColorKeyDialog.AnyChange(Sender: TObject); +begin + Key.Enabled := cbOn.Checked; + Key.Similarity := tbSimilar.Position; + Key.Blend := tbBlend.Position; + UpdateLabels; + Rebuild; +end; + +procedure TColorKeyDialog.Rebuild; +begin + if Source = nil then + Exit; + if Shown = nil then + Shown := TBitmap.Create; + ApplyKey(Source, Shown, Key); + pbFrame.Invalidate; +end; + +{ Кадр из середины куска. Первый кадр часто чёрный, и выбирать по нему + цвет не по чему. } +function GrabFrame(const APath: string; const ATime: Double; + const ATempFile: string): TBitmap; +var + Res: TProcResult; + Png: TPortableNetworkGraphic; +begin + Result := nil; + if APath = '' then + Exit; + Res := RunProcess(FfmpegExe, + ArgsPreviewFrame(APath, ATempFile, ATime, ''), nil, nil, nil); + if (not Res.Started) or (Res.ExitCode <> 0) or (not FileExists(ATempFile)) then + Exit; + + Png := TPortableNetworkGraphic.Create; + try + try + Png.LoadFromFile(ATempFile); + Result := TBitmap.Create; + { Формат точек не трогаем. Присвоение ему пересоздаёт хранилище + картинки, и только что положенный кадр пропадает — окно + показывало ровный чёрный прямоугольник вместо кадра. } + Result.Assign(Png); + except + FreeAndNil(Result); + end; + finally + Png.Free; + end; + SysUtils.DeleteFile(ATempFile); +end; + +function EditColorKey(var AKey: TColorKey; const APath: string; + const ATime: Double; const ATempFile: string): Boolean; +var + Dlg: TColorKeyDialog; + BtnOk, BtnCancel: TThemedButton; + Lbl: TLabel; +begin + Result := False; + Dlg := TColorKeyDialog.Create(nil); + try + Dlg.Key := AKey; + Dlg.Source := GrabFrame(APath, ATime, ATempFile); + + Dlg.Form := TForm.CreateNew(nil); + Dlg.Form.Caption := 'Цветовой ключ'; + Dlg.Form.Position := poScreenCenter; + Dlg.Form.ClientWidth := 760; + Dlg.Form.ClientHeight := 560; + + Dlg.pbFrame := TPaintBox.Create(Dlg.Form); + Dlg.pbFrame.Parent := Dlg.Form; + Dlg.pbFrame.SetBounds(12, 12, 736, 360); + Dlg.pbFrame.Anchors := [akLeft, akTop, akRight, akBottom]; + Dlg.pbFrame.OnPaint := @Dlg.FramePaint; + Dlg.pbFrame.OnMouseDown := @Dlg.FrameMouseDown; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 380, 736, 20); + Lbl.Anchors := [akLeft, akRight, akBottom]; + Lbl.Caption := 'Щёлкните по кадру, чтобы взять цвет. Клетка — то, ' + + 'что станет прозрачным.'; + + Dlg.cbOn := TCheckBox.Create(Dlg.Form); + Dlg.cbOn.Parent := Dlg.Form; + Dlg.cbOn.SetBounds(12, 408, 220, 22); + Dlg.cbOn.Anchors := [akLeft, akBottom]; + Dlg.cbOn.Caption := 'Выбивать цвет'; + Dlg.cbOn.Checked := AKey.Enabled; + Dlg.cbOn.OnClick := @Dlg.AnyChange; + + Dlg.BtnColor := TThemedButton.Create(Dlg.Form); + Dlg.BtnColor.Parent := Dlg.Form; + Dlg.BtnColor.SetBounds(240, 404, 120, 28); + Dlg.BtnColor.Anchors := [akLeft, akBottom]; + Dlg.BtnColor.Caption := 'Цвет'; + Dlg.BtnColor.Swatch := TColor(AKey.Color); + Dlg.BtnColor.OnClick := @Dlg.ColorClick; + + Dlg.lblSimilar := TLabel.Create(Dlg.Form); + Dlg.lblSimilar.Parent := Dlg.Form; + Dlg.lblSimilar.SetBounds(12, 442, 200, 20); + Dlg.lblSimilar.Anchors := [akLeft, akBottom]; + + Dlg.tbSimilar := TTrackBar.Create(Dlg.Form); + Dlg.tbSimilar.Parent := Dlg.Form; + Dlg.tbSimilar.SetBounds(210, 438, 538, 30); + Dlg.tbSimilar.Anchors := [akLeft, akRight, akBottom]; + Dlg.tbSimilar.Min := 1; + Dlg.tbSimilar.Max := 60; + Dlg.tbSimilar.TickStyle := tsNone; + Dlg.tbSimilar.Position := Max(1, Min(60, AKey.Similarity)); + Dlg.tbSimilar.OnChange := @Dlg.AnyChange; + + Dlg.lblBlend := TLabel.Create(Dlg.Form); + Dlg.lblBlend.Parent := Dlg.Form; + Dlg.lblBlend.SetBounds(12, 478, 200, 20); + Dlg.lblBlend.Anchors := [akLeft, akBottom]; + + Dlg.tbBlend := TTrackBar.Create(Dlg.Form); + Dlg.tbBlend.Parent := Dlg.Form; + Dlg.tbBlend.SetBounds(210, 474, 538, 30); + Dlg.tbBlend.Anchors := [akLeft, akRight, akBottom]; + Dlg.tbBlend.Min := 0; + Dlg.tbBlend.Max := 40; + Dlg.tbBlend.TickStyle := tsNone; + Dlg.tbBlend.Position := Max(0, Min(40, AKey.Blend)); + Dlg.tbBlend.OnChange := @Dlg.AnyChange; + + Dlg.lblHint := TLabel.Create(Dlg.Form); + Dlg.lblHint.Parent := Dlg.Form; + Dlg.lblHint.SetBounds(12, 512, 480, 36); + Dlg.lblHint.Anchors := [akLeft, akRight, akBottom]; + Dlg.lblHint.AutoSize := False; + Dlg.lblHint.WordWrap := True; + Dlg.lblHint.Caption := 'Участки с ключом придётся пересобрать: ' + + 'копированием прозрачность не делается.'; + + BtnOk := TThemedButton.Create(Dlg.Form); + BtnOk.Parent := Dlg.Form; + BtnOk.SetBounds(540, 518, 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(648, 518, 100, 30); + BtnCancel.Anchors := [akRight, akBottom]; + BtnCancel.Caption := 'Отмена'; + BtnCancel.ModalResult := mrCancel; + BtnCancel.Cancel := True; + + ApplyDarkTheme(Dlg.Form); + Dlg.UpdateLabels; + Dlg.Rebuild; + + if Dlg.Form.ShowModal <> mrOk then + Exit; + + AKey := Dlg.Key; + Result := True; + finally + Dlg.Source.Free; + Dlg.Shown.Free; + Dlg.Form.Free; + Dlg.Free; + end; +end; + +end. diff --git a/src/uDeps.pas b/src/uDeps.pas index 55cb020..48ff2ed 100644 --- a/src/uDeps.pas +++ b/src/uDeps.pas @@ -24,7 +24,7 @@ unit uDeps; interface uses - Classes, SysUtils; + Classes, SysUtils, uAppTypes; type TStringArray = array of string; @@ -89,7 +89,7 @@ uses function DepTargetDir: string; begin - Result := ExtractFilePath(ExpandFileName(ParamStr(0))); + Result := ProgramDir; end; function DepsConfigPath: string; diff --git a/src/uEncodeForm.pas b/src/uEncodeForm.pas new file mode 100644 index 0000000..3880db7 --- /dev/null +++ b/src/uEncodeForm.pas @@ -0,0 +1,224 @@ +{ + uEncodeForm — окно настроек сборки с перекодированием. + + Зачем оно нужно. Обычная сборка копирует потоки и потому мгновенна, но + отдаёт ролик ровно в том виде, в каком снят исходник. Когда ролик надо + отдать под площадку — в 1080p с определённым потоком, — приходится + перекодировать, и это уже осознанный выбор, а не поведение по + умолчанию. Поэтому отдельный пункт меню и отдельное окно. + + Окно собирается кодом, без файла формы: элементов в нём меньше десятка, + и описание заняло бы больше места, чем сам код. Так же сделано окно + сообщения в uTheme. + + Перекодирование идёт на видеокарте. Процессорный кодировщик на + 2688x1512 работает медленнее реального времени, и часовой ролик считал + бы часами; выбор кодировщика делает uFfmpegCmd, предпочитая NVENC. + Если аппаратного кодировщика нет, окно об этом честно предупреждает. +} +unit uEncodeForm; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, + uTheme, uExport; + +{ Спрашивает настройки. Возвращает False, если человек передумал. + + ADefaultCodec — кодек проекта: с него разумно начинать, иначе первый же + выбор менял бы формат без спроса. } +function AskEncodeProfile(out AProfile: TEncodeProfile; + const ADefaultCodec: string): Boolean; + +implementation + +uses + uFfmpegCmd; + +type + TPreset = record + Caption: string; + Width: Integer; + Height: Integer; + { Поток в килобитах в секунду. Значения взяты как обычная рабочая + середина для съёмки с движением: меньше — заметны квадраты на + траве и воде, больше — файл растёт без видимой пользы. } + Bitrate: Integer; + end; + +const + Presets: array[0..3] of TPreset = ( + (Caption: '1280x720 (720p)'; Width: 1280; Height: 720; Bitrate: 8000), + (Caption: '1920x1080 (1080p)'; Width: 1920; Height: 1080; Bitrate: 16000), + (Caption: '2560x1440 (1440p)'; Width: 2560; Height: 1440; Bitrate: 28000), + (Caption: '3840x2160 (4K)'; Width: 3840; Height: 2160; Bitrate: 50000) + ); + +type + { Обработчики живут в объекте: событиям нужны методы. } + TEncodeDialog = class(TComponent) + public + Form: TForm; + cbPreset: TComboBox; + cbCodec: TComboBox; + edBitrate: TEdit; + lblEncoder: TLabel; + procedure PresetChange(Sender: TObject); + procedure CodecChange(Sender: TObject); + procedure UpdateEncoderNote; + end; + +procedure TEncodeDialog.PresetChange(Sender: TObject); +begin + if (cbPreset.ItemIndex >= 0) and (cbPreset.ItemIndex <= High(Presets)) then + edBitrate.Text := IntToStr(Presets[cbPreset.ItemIndex].Bitrate); +end; + +procedure TEncodeDialog.CodecChange(Sender: TObject); +begin + UpdateEncoderNote; +end; + +procedure TEncodeDialog.UpdateEncoderNote; +var + Codec, Enc: string; +begin + if cbCodec.ItemIndex = 0 then + Codec := 'hevc' + else + Codec := 'h264'; + Enc := PreferredEncoder(Codec); + + if Pos('nvenc', Enc) > 0 then + begin + lblEncoder.Font.Color := ThemeTextDim; + lblEncoder.Caption := 'Кодировщик: ' + Enc + ' — на видеокарте.'; + end + else + begin + { Предупреждение, а не запрет: пусть человек сам решит, готов ли + ждать. Молча уйти на процессор нельзя — разница в разы. } + lblEncoder.Font.Color := ThemeAccent; + lblEncoder.Caption := 'Кодировщик: ' + Enc + + ' — аппаратного не нашлось, сборка будет очень долгой.'; + end; +end; + +function AskEncodeProfile(out AProfile: TEncodeProfile; + const ADefaultCodec: string): Boolean; +var + Dlg: TEncodeDialog; + Lbl: TLabel; + BtnOk, BtnCancel: TThemedButton; + I, Bitrate: Integer; +begin + Result := False; + AProfile := Default(TEncodeProfile); + + Dlg := TEncodeDialog.Create(nil); + try + Dlg.Form := TForm.CreateNew(nil); + Dlg.Form.Caption := 'Сборка с перекодированием'; + Dlg.Form.BorderStyle := bsDialog; + Dlg.Form.Position := poScreenCenter; + Dlg.Form.ClientWidth := 460; + Dlg.Form.ClientHeight := 220; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(16, 16, 120, 20); + Lbl.Caption := 'Размер кадра'; + + Dlg.cbPreset := TComboBox.Create(Dlg.Form); + Dlg.cbPreset.Parent := Dlg.Form; + Dlg.cbPreset.SetBounds(160, 12, 280, 26); + Dlg.cbPreset.Style := csDropDownList; + for I := 0 to High(Presets) do + Dlg.cbPreset.Items.Add(Presets[I].Caption); + Dlg.cbPreset.ItemIndex := 1; + Dlg.cbPreset.OnChange := @Dlg.PresetChange; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(16, 56, 140, 20); + Lbl.Caption := 'Поток, кбит/с'; + + Dlg.edBitrate := TEdit.Create(Dlg.Form); + Dlg.edBitrate.Parent := Dlg.Form; + Dlg.edBitrate.SetBounds(160, 52, 120, 26); + Dlg.edBitrate.Text := IntToStr(Presets[1].Bitrate); + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(16, 96, 140, 20); + Lbl.Caption := 'Кодек'; + + Dlg.cbCodec := TComboBox.Create(Dlg.Form); + Dlg.cbCodec.Parent := Dlg.Form; + Dlg.cbCodec.SetBounds(160, 92, 280, 26); + Dlg.cbCodec.Style := csDropDownList; + Dlg.cbCodec.Items.Add('HEVC (H.265) — меньше файл'); + Dlg.cbCodec.Items.Add('H.264 — совместимее'); + if LowerCase(ADefaultCodec) = 'h264' then + Dlg.cbCodec.ItemIndex := 1 + else + Dlg.cbCodec.ItemIndex := 0; + Dlg.cbCodec.OnChange := @Dlg.CodecChange; + + Dlg.lblEncoder := TLabel.Create(Dlg.Form); + Dlg.lblEncoder.Parent := Dlg.Form; + Dlg.lblEncoder.SetBounds(16, 132, 424, 36); + Dlg.lblEncoder.WordWrap := True; + Dlg.lblEncoder.AutoSize := False; + Dlg.lblEncoder.ParentColor := False; + + BtnOk := TThemedButton.Create(Dlg.Form); + BtnOk.Parent := Dlg.Form; + BtnOk.SetBounds(240, 180, 100, 28); + BtnOk.Caption := 'Собрать'; + BtnOk.ModalResult := mrOk; + BtnOk.Default := True; + + BtnCancel := TThemedButton.Create(Dlg.Form); + BtnCancel.Parent := Dlg.Form; + BtnCancel.SetBounds(348, 180, 100, 28); + BtnCancel.Caption := 'Отмена'; + BtnCancel.ModalResult := mrCancel; + BtnCancel.Cancel := True; + + { Цвета задаются до первого показа, как и во всех остальных окнах. } + ApplyDarkTheme(Dlg.Form); + Dlg.UpdateEncoderNote; + + if Dlg.Form.ShowModal <> mrOk then + Exit; + + I := Dlg.cbPreset.ItemIndex; + if (I < 0) or (I > High(Presets)) then + I := 1; + + Bitrate := StrToIntDef(Trim(Dlg.edBitrate.Text), Presets[I].Bitrate); + { Ноль и отрицательное — не поток, а описка. Верхняя граница выбрана + с запасом: выше него кодировщики уже отказываются работать. } + if (Bitrate < 100) or (Bitrate > 400000) then + Bitrate := Presets[I].Bitrate; + + AProfile.Enabled := True; + AProfile.Width := Presets[I].Width; + AProfile.Height := Presets[I].Height; + AProfile.BitrateKbps := Bitrate; + if Dlg.cbCodec.ItemIndex = 1 then + AProfile.Codec := 'h264' + else + AProfile.Codec := 'hevc'; + Result := True; + finally + Dlg.Form.Free; + Dlg.Free; + end; +end; + +end. diff --git a/src/uExport.pas b/src/uExport.pas index c71fc69..d7f4beb 100644 --- a/src/uExport.pas +++ b/src/uExport.pas @@ -51,6 +51,20 @@ uses Classes, SysUtils, uAppTypes, uKeyframeIndex, uMediaProbe; type + { Настройки сборки с перекодированием. + + Enabled = False означает обычную сборку копированием — то, ради чего + редактор и делался. Всё остальное имеет смысл только при True. } + TEncodeProfile = record + Enabled: Boolean; + Width: Integer; + Height: Integer; + BitrateKbps: Integer; + { Кодек в привычных именах: h264 или hevc. Кодировщик под него + подбирается сам, с предпочтением аппаратного. } + Codec: string; + end; + { Что получилось с одной частью. Кусок монтажа обычно даёт одну часть, но при точном резе — две: @@ -87,6 +101,12 @@ type TExportThread = class(TThread) private FSegments: TFlatSegmentArray; + { Куски звука. Отдельный список: звук можно двигать независимо от + картинки, и точки реза у них разные. } + FAudio: TFlatSegmentArray; + { Собранная звуковая дорожка и картинка без звука. } + FAudioPath: string; + FVideoPath: string; FOutputPath: string; FCacheDir: string; FKeepIntermediate: Boolean; @@ -95,6 +115,13 @@ type FStageText: string; FFraction: Double; FPendingLog: string; + FLogPath: string; + FResume: Boolean; + FReusedParts: Integer; + { Имена кусков, доведённых до конца в этой или прошлой сборке. } + FDone: TStringList; + { Признак того, что готовые куски относятся к этому же монтажу. } + FPlanKey: string; FReport: TExportReport; FOnProgress: TNotifyEvent; @@ -110,6 +137,8 @@ type FPacketCount: Int64; FMaster: TMediaInfo; + FProfile: TEncodeProfile; + FSubtitlePath: string; { Формат промежуточных кусков: 'matroska' или 'mpegts'. } FIntermediateFormat: string; FIntermediateExt: string; @@ -120,6 +149,16 @@ type procedure SyncProgress; procedure SyncLog; procedure Log(const AText: string); + procedure WriteLogLine(const AText: string); + { Отпечаток плана сборки: пути, места и длины кусков. По нему видно, + что готовые куски сделаны из того же монтажа, а не от прошлой + правки. } + function PlanKey: string; + procedure LoadDoneList; + function IsDone(const AName: string): Boolean; + procedure MarkDone(const AName: string); + { Готов ли кусок с прошлого раза. Заполняет отчёт по нему. } + function TakeReadyPart(AIndex: Integer; out ARep: TSegmentReport): Boolean; procedure SetStage(const AText: string); procedure PublishProgress; @@ -134,15 +173,23 @@ type function WriteConcatList(out AListPath: string): Boolean; function ConcatAll(const AListPath: string): Boolean; procedure Verify; + { Сборка звука: куски сводятся в сырой поток и сжимаются одним + проходом. Сырой поток нужен для точности — стык получается с + точностью до отсчёта, а не до звукового кадра. } + function BuildAudio: Boolean; + function MixLayers(const ASeg: TFlatSegment; ADest: TStream; + ANeed: Int64; ARate, AChannels: Integer): Boolean; + function MuxFinal: Boolean; protected procedure Execute; override; public { AMaster нужен, чтобы понять, влезут ли кодеки проекта в MPEG-TS. Можно передать пустую запись — тогда способ склейки выберется по одному лишь числу источников. } - constructor Create(const ASegments: TFlatSegmentArray; + destructor Destroy; override; + constructor Create(const ASegments, AAudio: TFlatSegmentArray; const AOutputPath: string; AKeepIntermediate: Boolean; - const AMaster: TMediaInfo); + const AMaster: TMediaInfo; const AProfile: TEncodeProfile); procedure RequestCancel; @@ -154,6 +201,27 @@ type property OnProgress: TNotifyEvent read FOnProgress write FOnProgress; property OnLog: TNotifyEvent read FOnLog write FOnLog; + { Разметка субтитров, которую надо вложить в готовый файл отдельной + дорожкой. Пусто — либо текста нет, либо он вжигается в картинку. + Годится только для Matroska: MP4 хранит субтитры без оформления. } + property SubtitlePath: string read FSubtitlePath write FSubtitlePath; + { Куда писать журнал сборки. Пусто — никуда. + + Журнал кладётся рядом с готовым файлом и под тем же именем: когда + через неделю выяснится, что в ролике не то, разбираться придётся + именно по нему, а общий журнал программы к тому времени перезапишется + следующим запуском. Строка пишется сразу, а не копится в памяти: + если сборка упадёт, важна как раз последняя строка. } + property LogPath: string read FLogPath write FLogPath; + { Продолжать прерванную сборку: готовые куски берутся с диска, а не + считаются заново. + + Что считается готовым, помечено в списке рядом с самими кусками. + Проверять по одному только наличию файла нельзя: сборку могли + прервать посреди записи, и файл окажется обрезанным. } + property Resume: Boolean read FResume write FResume; + { Сколько кусков взято готовыми. Для отчёта. } + property ReusedParts: Integer read FReusedParts; end; { Каталог для временных кусков рядом с готовым файлом. } @@ -162,7 +230,33 @@ function CacheDirFor(const AOutputPath: string): string; implementation uses - Math, uFfmpegCmd, uProcRunner; + Math, md5, FileUtil, uFfmpegCmd, uProcRunner; + +{ Размер файла или ноль, если его нет. } +function FileSizeOf(const APath: string): Int64; +var + F: TSearchRec; +begin + Result := 0; + if APath = '' then + Exit; + if FindFirst(APath, faAnyFile, F) = 0 then + begin + Result := F.Size; + FindClose(F); + end; +end; + +{ Размер по-человечески: гигабайты, если их много. } +function SizeText(ABytes: Int64): string; +begin + if ABytes >= Int64(1024) * 1024 * 1024 then + Result := Format('%.1f ГБ', [ABytes / (1024 * 1024 * 1024)]) + else if ABytes >= 1024 * 1024 then + Result := Format('%.0f МБ', [ABytes / (1024 * 1024)]) + else + Result := Format('%d КБ', [ABytes div 1024]); +end; function CacheDirFor(const AOutputPath: string): string; begin @@ -171,13 +265,20 @@ begin PathDelim; end; -constructor TExportThread.Create(const ASegments: TFlatSegmentArray; +destructor TExportThread.Destroy; +begin + FDone.Free; + inherited Destroy; +end; + +constructor TExportThread.Create(const ASegments, AAudio: TFlatSegmentArray; const AOutputPath: string; AKeepIntermediate: Boolean; - const AMaster: TMediaInfo); + const AMaster: TMediaInfo; const AProfile: TEncodeProfile); var I: Integer; begin FMaster := AMaster; + FProfile := AProfile; inherited Create(True); FreeOnTerminate := False; @@ -195,6 +296,14 @@ begin FSegments[I].FilePath := ExpandFileName(FSegments[I].FilePath); end; + SetLength(FAudio, Length(AAudio)); + for I := 0 to High(AAudio) do + begin + FAudio[I] := AAudio[I]; + if FAudio[I].FilePath <> '' then + FAudio[I].FilePath := ExpandFileName(FAudio[I].FilePath); + end; + FOutputPath := ExpandFileName(AOutputPath); FCacheDir := CacheDirFor(FOutputPath); FKeepIntermediate := AKeepIntermediate; @@ -230,8 +339,148 @@ begin FOnLog(Self); end; +{ Строка в журнал сборки рядом с готовым файлом. + + Файл открывается и закрывается на каждой строке. Это медленно, но строк + за сборку десятки, а взамен журнал остаётся целым даже если программа + упадёт на следующем шаге — ради этого он и заводится. } +procedure TExportThread.WriteLogLine(const AText: string); +var + F: TextFile; +begin + if FLogPath = '' then + Exit; + try + AssignFile(F, FLogPath); + if FileExists(FLogPath) then + Append(F) + else + Rewrite(F); + try + WriteLn(F, AText); + finally + CloseFile(F); + end; + except + { Журнал не должен ронять сборку: не записалось — и ладно. } + on E: Exception do + FLogPath := ''; + end; +end; + +function TExportThread.PlanKey: string; +var + I: Integer; +begin + Result := Format('%dx%d %d/%d %s %s|', [FMaster.Width, FMaster.Height, + FMaster.FpsNum, FMaster.FpsDen, FMaster.VideoCodec, FMaster.PixFmt]); + for I := 0 to High(FSegments) do + Result := Result + Format('%s@%s+%s#%d%s;', + [ExtractFileName(FSegments[I].FilePath), + SecondsToStr(FSegments[I].SrcStart), + SecondsToStr(FSegments[I].Duration), + Length(FSegments[I].Layers), + FSegments[I].SubFile]); + Result := MD5Print(MD5String(Result)); +end; + +{ Список готовых кусков рядом с ними самими. Первая строка — отпечаток + плана: не совпал, значит куски от другого монтажа и брать их нельзя. } +procedure TExportThread.LoadDoneList; +var + Path: string; +begin + FDone := TStringList.Create; + FPlanKey := PlanKey; + Path := FCacheDir + 'готово.txt'; + + if not FResume then + begin + if FileExists(Path) then + SysUtils.DeleteFile(Path); + Exit; + end; + + if not FileExists(Path) then + Exit; + try + FDone.LoadFromFile(Path); + except + FDone.Clear; + end; + + if (FDone.Count = 0) or (FDone[0] <> FPlanKey) then + begin + Log('Готовые куски от другой расстановки — собираю заново.'); + FDone.Clear; + end; +end; + +function TExportThread.IsDone(const AName: string): Boolean; +begin + Result := (FDone <> nil) and (FDone.IndexOf(AName) > 0) and + (FileExists(FCacheDir + AName)) and (FileSize(FCacheDir + AName) > 0); +end; + +procedure TExportThread.MarkDone(const AName: string); +var + Path: string; +begin + if FDone = nil then + Exit; + if FDone.Count = 0 then + FDone.Add(FPlanKey); + if FDone.IndexOf(AName) < 0 then + FDone.Add(AName); + Path := FCacheDir + 'готово.txt'; + try + { Записываем сразу: список нужен именно на случай, когда сборка не + доживёт до конца. } + FDone.SaveToFile(Path); + except + { Не записалось — просто соберём заново в следующий раз. } + end; +end; + +function TExportThread.TakeReadyPart(AIndex: Integer; + out ARep: TSegmentReport): Boolean; +var + Names: array[0..2] of string; + I: Integer; +begin + Result := False; + ARep := Default(TSegmentReport); + if (FDone = nil) or (FDone.Count = 0) then + Exit; + + { Имя куска зависит от того, каким путём он делался: обычный, с + наложением, с точным резом. Проверяем все три. } + Names[0] := Format('part_%.3d_a%s', [AIndex, FIntermediateExt]); + Names[1] := Format('part_%.3d_x%s', [AIndex, FIntermediateExt]); + Names[2] := Format('part_%.3d_b%s', [AIndex, FIntermediateExt]); + + for I := 0 to 1 do + if IsDone(Names[I]) then + begin + { Кусок с точным резом состоит из двух частей; если вторая тоже + готова, её возьмёт следующий заход — здесь достаточно первой. } + ARep.Index := AIndex; + ARep.SourcePath := FSegments[AIndex].FilePath; + ARep.RequestedStart := FSegments[AIndex].SrcStart; + ARep.ActualStart := FSegments[AIndex].SrcStart; + ARep.Duration := FSegments[AIndex].Duration; + ARep.Packets := -1; + ARep.Encoded := I = 1; + ARep.TempPath := FCacheDir + Names[I]; + Inc(FReusedParts); + Log(Format('Кусок %d уже собран — беру готовый.', [AIndex + 1])); + Exit(True); + end; +end; + procedure TExportThread.Log(const AText: string); begin + WriteLogLine(AText); FPendingLog := AText; Synchronize(@SyncLog); end; @@ -445,13 +694,23 @@ begin Exit; end; + { Кусок, доведённый до конца в прошлый раз, берём готовым. На длинном + ролике это разница между «собрать заново всё» и «доделать хвост». } + if TakeReadyPart(I, Rep) then + begin + AddPart(Rep); + FDoneWork := FDoneWork + FSegments[I].Duration; + PublishProgress; + Continue; + end; + SetStage(Format('Вырезаю кусок %d из %d', [I + 1, Length(FSegments)])); { Сгенерированные вставки берутся из файла, который заведомо длиннее нужного: так одна и та же чёрная вставка годится для дыр любой длины. Значит вырезать надо и из них, но притягивать к опорному кадру нечего — они начинаются с нуля, а ноль всегда опорный. } - if FSegments[I].Kind <> skVideo then + if (FSegments[I].Kind <> skVideo) and (FSegments[I].SubFile = '') then begin Dst := FCacheDir + Format('part_%.3d_a%s', [I, FIntermediateExt]); Rep.Index := I; @@ -470,14 +729,56 @@ begin Exit; Rep.TempPath := Dst; + + MarkDone(ExtractFileName(Dst)); AddPart(Rep); Continue; end; - { Кусок от файла, не совпадающего с параметрами проекта. Скопировать - его нельзя — пересобираем. Но только его: соседние куски, снятые тем - же оборудованием, что и весь проект, по-прежнему копируются. } - if FSegments[I].Transcode then + { Участок с наложением: полупрозрачный клип поверх нижнего либо + переход между двумя клипами одной дорожки. Собирается из двух + входов сразу, копированием такое не получить. } + if Length(FSegments[I].Layers) > 0 then + begin + SetStage(Format('Собираю наложение, кусок %d из %d', + [I + 1, Length(FSegments)])); + Dst := FCacheDir + Format('part_%.3d_x%s', [I, FIntermediateExt]); + Rep.Index := I; + Rep.SourcePath := FSegments[I].Layers[0].FilePath; + Rep.RequestedStart := FSegments[I].Layers[0].SrcStart; + Rep.ActualStart := Rep.RequestedStart; + Rep.Duration := FSegments[I].Duration; + Rep.Packets := -1; + Rep.Encoded := True; + + FStepWork := FSegments[I].Duration; + if not RunFfmpeg(ArgsRenderLayers(FSegments[I].Layers, Dst, + FSegments[I].Duration, FMaster.Width, FMaster.Height, + FMaster.FpsNum, FMaster.FpsDen, FMaster.PixFmt, + PreferredEncoder(FMaster.VideoCodec), + FIntermediateFormat = 'mpegts', FMaster.VideoBitrate, + FSegments[I].SubFile), + 'Наложение в куске ' + IntToStr(I + 1)) then + Exit; + + Rep.TempPath := Dst; + + MarkDone(ExtractFileName(Dst)); + AddPart(Rep); + Continue; + end; + + { Кусок от файла, не совпадающего с параметрами проекта, или с + вжигаемым текстом. Скопировать его нельзя — пересобираем. Но только + его: соседние куски, снятые тем же оборудованием, что и весь + проект, по-прежнему копируются. + + Сгенерированные вставки — картинки и чёрное — сюда попадают только + с текстом: без него их незачем перекодировать, они и так в + параметрах проекта. Раньше они уходили в ветку выше и копировались + вместе с текстом мимо: галка вжигания стояла, а надписи на + фотографии не появлялось. } + if FSegments[I].Transcode or (FSegments[I].SubFile <> '') then begin SetStage(Format('Пересобираю кусок %d из %d (файл не совпадает с проектом)', [I + 1, Length(FSegments)])); @@ -491,16 +792,27 @@ begin Rep.Encoded := True; FStepWork := FSegments[I].Duration; + { У сгенерированной вставки время своё: она начинается с нуля, и + просить у неё кусок с середины монтажа бессмысленно. } + if FSegments[I].Kind <> skVideo then + Rep.RequestedStart := 0 + else + Rep.RequestedStart := FSegments[I].SrcStart; + Rep.ActualStart := Rep.RequestedStart; + if not RunFfmpeg(ArgsTranscodeSegment(FSegments[I].FilePath, Dst, - FSegments[I].SrcStart, FSegments[I].SrcStart + FSegments[I].Duration, + Rep.RequestedStart, Rep.RequestedStart + FSegments[I].Duration, FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen, FMaster.VideoCodec, FMaster.PixFmt, FMaster.AudioCodec, FMaster.SampleRate, FMaster.Channels, FSegments[I].Volume, - FIntermediateFormat, FSegments[I].Filter), + FIntermediateFormat, FSegments[I].Filter, FSegments[I].SubFile, + FMaster.VideoBitrate), 'Пересборка куска ' + IntToStr(I + 1)) then Exit; Rep.TempPath := Dst; + + MarkDone(ExtractFileName(Dst)); AddPart(Rep); Continue; end; @@ -548,6 +860,7 @@ begin Rep.Duration := EncodeUntil - FSegments[I].SrcStart; Rep.TempPath := Dst; Rep.Encoded := True; + MarkDone(ExtractFileName(Dst)); AddPart(Rep); if EncodeUntil < SegEnd - 0.0005 then @@ -564,6 +877,7 @@ begin Rep.Duration := SegEnd - EncodeUntil; Rep.TempPath := Dst; Rep.Encoded := False; + MarkDone(ExtractFileName(Dst)); AddPart(Rep); end; @@ -595,6 +909,7 @@ begin Rep.Duration := FSegments[I].Duration; Rep.TempPath := Dst; Rep.Encoded := False; + MarkDone(ExtractFileName(Dst)); AddPart(Rep); end; @@ -632,9 +947,39 @@ end; function TExportThread.ConcatAll(const AListPath: string): Boolean; begin - SetStage('Склеиваю'); FStepWork := FReport.TotalDuration; - Result := RunFfmpeg(ArgsConcat(AListPath, FOutputPath), 'Склейка'); + + if FProfile.Enabled then + begin + { Перекодирование всего ролика одним проходом. Так весь результат + выходит из одного кодировщика с одними настройками: пересобирать + куски по отдельности здесь нельзя, на стыках была бы видна смена + качества. } + SetStage('Склеиваю и перекодирую'); + if RunFfmpeg(ArgsConcatEncode(AListPath, FOutputPath, + FProfile.Width, FProfile.Height, FMaster.FpsNum, FMaster.FpsDen, + FProfile.BitrateKbps, FProfile.Codec, FMaster.PixFmt, True, FAudioPath), + 'Склейка с перекодированием') then + Exit(True); + + if Terminated then + Exit(False); + + { Аппаратная распаковка не пошла — повторяем без неё. + + Она даёт впятеро, но зависит от драйвера и от того, знаком ли + видеокарте кодек исходника. Отказываться из-за неё от сборки + нельзя: медленно лучше, чем никак. } + Log('Аппаратная распаковка не пошла, повторяю на процессоре.'); + Exit(RunFfmpeg(ArgsConcatEncode(AListPath, FOutputPath, + FProfile.Width, FProfile.Height, FMaster.FpsNum, FMaster.FpsDen, + FProfile.BitrateKbps, FProfile.Codec, FMaster.PixFmt, False, FAudioPath), + 'Склейка с перекодированием без аппаратной распаковки')); + end; + + SetStage('Склеиваю'); + Result := RunFfmpeg(ArgsConcatMux(AListPath, FAudioPath, FSubtitlePath, + FOutputPath), 'Склейка'); end; procedure TExportThread.Verify; @@ -658,10 +1003,235 @@ begin FReport.ActualPackets := Actual; end; + +{ --- Звук --- } + +function TExportThread.BuildAudio: Boolean; +var + RawPath, PartPath: string; + All, Part: TFileStream; + I: Integer; + Need: Int64; + Zero: array[0..65535] of Byte; + Res: TProcResult; + Chunk: Int64; + Rate, Channels: Integer; +begin + Result := False; + FAudioPath := ''; + if Length(FAudio) = 0 then + Exit; + + Rate := FMaster.SampleRate; + if Rate <= 0 then + Rate := 48000; + Channels := FMaster.Channels; + if Channels <= 0 then + Channels := 2; + + RawPath := FCacheDir + 'audio.raw'; + PartPath := FCacheDir + 'audio_part.raw'; + FillChar(Zero, SizeOf(Zero), 0); + + SetStage('Собираю звук'); + + try + All := TFileStream.Create(RawPath, fmCreate); + try + for I := 0 to High(FAudio) do + begin + if Terminated then + Exit; + + { Сколько байт должен занять кусок. Считается из длительности, а + не берётся у ffmpeg: тогда длина всей дорожки совпадает с + монтажом до отсчёта, и звук не уезжает от картинки. } + Need := Round(FAudio[I].Duration * Rate) * Channels * 2; + + if Length(FAudio[I].Layers) > 0 then + begin + { Переход или наложение: слои сводятся прямо в отсчётах. Здесь + это проще и точнее, чем через фильтры ffmpeg — доля каждого + слоя считается на каждый отсчёт, без округлений по кадрам. } + if MixLayers(FAudio[I], All, Need, Rate, Channels) then + Need := 0; + end + else if FAudio[I].FilePath <> '' then + begin + Res := RunProcess(FfmpegExe, + ArgsExtractAudioRaw(FAudio[I].FilePath, PartPath, + FAudio[I].SrcStart, FAudio[I].Duration, Rate, Channels, + FAudio[I].Volume), + nil, @ErrorLine, @CancelQuery); + if Res.Cancelled then + Exit; + if Res.Started and (Res.ExitCode = 0) and FileExists(PartPath) then + begin + Part := TFileStream.Create(PartPath, fmOpenRead or fmShareDenyNone); + try + Chunk := Part.Size; + if Chunk > Need then + Chunk := Need; + if Chunk > 0 then + All.CopyFrom(Part, Chunk); + Dec(Need, Chunk); + finally + Part.Free; + end; + SysUtils.DeleteFile(PartPath); + end; + end; + + { Чего не хватило — дополняем тишиной. Так же заполняются дыры и + куски файлов без звука. } + while Need > 0 do + begin + Chunk := SizeOf(Zero); + if Chunk > Need then + Chunk := Need; + All.WriteBuffer(Zero, Chunk); + Dec(Need, Chunk); + end; + + { Учёт работы: секунда звука весит столько же, сколько секунда + картинки на вырезании. } + FDoneWork := FDoneWork + FAudio[I].Duration; + PublishProgress; + end; + finally + All.Free; + end; + + SetStage('Сжимаю звук'); + FAudioPath := FCacheDir + 'audio.m4a'; + Res := RunProcess(FfmpegExe, + ArgsEncodeAudio(RawPath, FAudioPath, Rate, Channels, FMaster.AudioCodec), + @ProgressLine, @ErrorLine, @CancelQuery); + if Res.Cancelled then + Exit; + if (not Res.Started) or (Res.ExitCode <> 0) or (not FileExists(FAudioPath)) then + begin + FReport.Message := 'Не удалось сжать звук.'; + Exit; + end; + + Result := True; + finally + SysUtils.DeleteFile(RawPath); + SysUtils.DeleteFile(PartPath); + end; +end; + +{ Сведение слоёв звука в один поток. + + Доля каждого слоя меняется от начала куска к концу: так получается + переход. Смешивание идёт по отсчётам, поэтому длина результата ровно + такая, какая нужна. } +function TExportThread.MixLayers(const ASeg: TFlatSegment; ADest: TStream; + ANeed: Int64; ARate, AChannels: Integer): Boolean; +var + L, I, N: Integer; + Parts: array of TMemoryStream; + PartPath: string; + Res: TProcResult; + Src: TFileStream; + Samples, S, Ch: Integer; + Acc: Double; + K: Double; + V: SmallInt; + Out16: SmallInt; + Buf: array of SmallInt; +begin + Result := False; + SetLength(Parts, Length(ASeg.Layers)); + for I := 0 to High(Parts) do + Parts[I] := nil; + + try + for L := 0 to High(ASeg.Layers) do + begin + PartPath := FCacheDir + Format('mix_%d.raw', [L]); + Res := RunProcess(FfmpegExe, + ArgsExtractAudioRaw(ASeg.Layers[L].FilePath, PartPath, + ASeg.Layers[L].SrcStart, ASeg.Duration, ARate, AChannels, 1), + nil, @ErrorLine, @CancelQuery); + Parts[L] := TMemoryStream.Create; + if Res.Started and (Res.ExitCode = 0) and FileExists(PartPath) then + begin + Src := TFileStream.Create(PartPath, fmOpenRead or fmShareDenyNone); + try + Parts[L].CopyFrom(Src, Src.Size); + finally + Src.Free; + end; + SysUtils.DeleteFile(PartPath); + end; + Parts[L].Position := 0; + end; + + Samples := ANeed div (AChannels * 2); + if Samples <= 0 then + Exit; + SetLength(Buf, AChannels); + + for S := 0 to Samples - 1 do + begin + for Ch := 0 to AChannels - 1 do + begin + Acc := 0; + for L := 0 to High(ASeg.Layers) do + begin + { Доля слоя меняется линейно по ходу куска. } + if Samples > 1 then + K := ASeg.Layers[L].FadeFrom + + (ASeg.Layers[L].FadeTo - ASeg.Layers[L].FadeFrom) * S / (Samples - 1) + else + K := ASeg.Layers[L].FadeFrom; + + N := (S * AChannels + Ch) * 2; + if N + 1 < Parts[L].Size then + begin + Move(PByte(Parts[L].Memory)[N], V, 2); + Acc := Acc + V * K; + end; + end; + if Acc > 32767 then + Acc := 32767; + if Acc < -32768 then + Acc := -32768; + Out16 := Round(Acc); + Buf[Ch] := Out16; + end; + ADest.WriteBuffer(Buf[0], AChannels * 2); + end; + + Result := True; + finally + for I := 0 to High(Parts) do + Parts[I].Free; + end; +end; + +function TExportThread.MuxFinal: Boolean; +var + Res: TProcResult; +begin + SetStage('Сшиваю'); + Res := RunProcess(FfmpegExe, + ArgsMux(FVideoPath, FAudioPath, FOutputPath, FSubtitlePath), + @ProgressLine, @ErrorLine, @CancelQuery); + Result := Res.Started and (Res.ExitCode = 0) and FileExists(FOutputPath); + if Res.Cancelled then + Result := False + else if not Result then + FReport.Message := 'Не удалось сшить картинку со звуком.'; +end; + procedure TExportThread.Execute; var ListPath: string; I: Integer; + Freed: Int64; ToolError: string; begin try @@ -688,16 +1258,40 @@ begin Log('Временные куски: ' + FCacheDir); ChooseIntermediateFormat; + { Список готовых кусков — после выбора промежуточного формата: от него + зависят их имена. } + LoadDoneList; + if FResume and (FDone.Count > 1) then + Log(Format('Продолжаю прерванную сборку: готовых кусков %d.', + [FDone.Count - 1])); { Единица учёта работы — секунда материала. Каждая секунда проходит - через вырезание и через склейку, отсюда двойной вес. } - FTotalWork := FReport.TotalDuration * 2; + через вырезание, склейку и сборку звука, отсюда тройной вес. } + FTotalWork := FReport.TotalDuration * 3; FDoneWork := 0; if not ExtractSegments then Exit; if not WriteConcatList(ListPath) then Exit; + + { Звук собирается раньше картинки, и склейка сразу кладёт всё вместе в + конечный файл. + + Так было не всегда: сперва картинка собиралась в отдельный файл, а + потом сшивалась со звуком. На часовом ролике это 91 ГБ + промежуточного файла и лишний полный проход копирования — места + требовалось вдвое больше готового ролика. } + FVideoPath := ''; + if not BuildAudio then + begin + if FReport.Cancelled then + Exit; + { Без звука ролик всё равно лучше, чем ничего. } + Log('Звук собрать не удалось, собираю картинку без него.'); + FAudioPath := ''; + end; + if not ConcatAll(ListPath) then Exit; @@ -712,18 +1306,38 @@ begin FReport.Succeeded := True; FReport.Message := 'Готово.'; + { Уборка после удачной сборки. + + Куски весят столько же, сколько готовый ролик, а на длинном + материале и больше: на часовой съёмке набралось 110 ГБ. Держать их + после того, как ролик собран, незачем — продолжать больше нечего. + После неудачи, наоборот, не трогаем: с них и продолжим. + + Считаем освобождённое: цифра говорит человеку, сколько места было + занято, лучше любого объяснения. } if not FKeepIntermediate then begin + Freed := 0; for I := 0 to High(FReport.Segments) do { Удаляем только то, что сами создали в своём каталоге. Части, указывающие на общий кэш сгенерированных вставок, трогать нельзя: они нужны и предпросмотру, и следующей сборке. } if Copy(FReport.Segments[I].TempPath, 1, Length(FCacheDir)) = FCacheDir then + begin + Inc(Freed, FileSizeOf(FReport.Segments[I].TempPath)); DeleteFile(FReport.Segments[I].TempPath); + end; + + Inc(Freed, FileSizeOf(FAudioPath)); + DeleteFile(FAudioPath); DeleteFile(ListPath); + DeleteFile(FCacheDir + 'готово.txt'); RemoveDir(FCacheDir); - Log('Временные куски удалены.'); - end; + Log(Format('Временные куски удалены, освободилось %s.', + [SizeText(Freed)])); + end + else + Log('Временные куски оставлены: ' + FCacheDir); except on E: Exception do begin diff --git a/src/uExportForm.pas b/src/uExportForm.pas new file mode 100644 index 0000000..72c5c97 --- /dev/null +++ b/src/uExportForm.pas @@ -0,0 +1,322 @@ +{ + uExportForm — окно сборки ролика. + + Здесь выбирается не только имя файла, но и то, что от него зависит: + контейнер и способ попадания текста в ролик. Разделять их нельзя — + выбор одного меняет допустимое в другом. + + Почему при MP4 вжигание становится обязательным. Отдельной дорожкой + субтитров со всем оформлением умеет только Matroska. В MP4 их кладут + как mov_text, а он не хранит ни цвета, ни обводки, ни положения — от + надписи остаётся голый текст в углу, и это хуже, чем ничего. Поэтому + при MP4 галка ставится и запирается: выбора всё равно нет. + + Запертой она остаётся ровно пока выбран MP4. Переключение на MKV + возвращает и галку, и прежний ответ человека — тот, что он давал до + того, как MP4 всё за него решил. +} +unit uExportForm; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, + uTheme; + +type + { Что человек выбрал в окне. } + TExportChoice = record + Path: string; + { Вжигать ли текст в картинку. При MP4 всегда True. } + BurnText: Boolean; + { Собирать только отмеченный участок. Имеет смысл, только когда + участок отмечен. } + RegionOnly: Boolean; + end; + +{ Показывает окно. + + AHasText — есть ли в проекте надписи: без них про текст и спрашивать + незачем. APreferMkv — в монтаже есть точные резы, и MKV надёжнее. + ABurnDefault — ответ, данный в прошлый раз. + + ARegion — описание отмеченного участка. Не пусто — в окне появляется + галка «только отмеченный участок». Галка, а не надпись: надпись легко + проглядеть, а тут вопрос из тех, где ошибка стоит часа работы — соберёшь + кусок вместо ролика или наоборот. } +function AskExport(var AChoice: TExportChoice; AHasText, APreferMkv: Boolean; + const ADefaultDir: string; const ARegion: string = ''): Boolean; + +implementation + +type + TExportDialog = class(TComponent) + public + Form: TForm; + edPath: TEdit; + BtnMp4: TThemedButton; + BtnMkv: TThemedButton; + cbBurn: TCheckBox; + cbRegion: TCheckBox; + lblNote: TLabel; + HasText: Boolean; + { Ответ человека про вжигание, сохранённый до того, как MP4 навязал + своё. К нему возвращаемся при переходе на MKV. } + BurnWanted: Boolean; + { Идёт ли согласование: пока идёт, ответы человека не запоминаются. + Установка галки кодом вызывает тот же обработчик, что и щелчок, и + без этого признака навязанное при MP4 значение записывалось бы как + осознанный выбор — при возврате на MKV галка так и оставалась + стоять. } + Applying: Boolean; + procedure FormatClick(Sender: TObject); + procedure BrowseClick(Sender: TObject); + procedure BurnClick(Sender: TObject); + procedure RegionClick(Sender: TObject); + function IsMp4: Boolean; + procedure ApplyFormat; + end; + +function TExportDialog.IsMp4: Boolean; +begin + Result := BtnMp4.Down; +end; + +{ Приводит имя файла и галку в согласие с выбранным контейнером. } +procedure TExportDialog.ApplyFormat; +var + Ext: string; +begin + Applying := True; + try + if IsMp4 then + Ext := '.mp4' + else + Ext := '.mkv'; + if Trim(edPath.Text) <> '' then + edPath.Text := ChangeFileExt(edPath.Text, Ext); + + if not HasText then + begin + lblNote.Caption := ''; + Exit; + end; + + if IsMp4 then + begin + { Сначала запираем, потом ставим: наоборот обработчик успел бы счесть + навязанное значение осознанным. } + cbBurn.Enabled := False; + cbBurn.Checked := True; + lblNote.Caption := 'В MP4 отдельная дорожка субтитров теряет цвет, ' + + 'обводку и положение, поэтому текст вжигается. Участки с текстом ' + + 'придётся пересобрать.'; + end + else + begin + cbBurn.Enabled := True; + cbBurn.Checked := BurnWanted; + if cbBurn.Checked then + lblNote.Caption := 'Участки с текстом придётся пересобрать. ' + + 'Текст будет виден в любом проигрывателе.' + else + lblNote.Caption := 'Текст ляжет отдельной дорожкой субтитров: ' + + 'сборка останется мгновенной, но показывать его будет не всякий ' + + 'проигрыватель.'; + end; + finally + Applying := False; + end; +end; + +procedure TExportDialog.FormatClick(Sender: TObject); +begin + BtnMp4.Down := Sender = BtnMp4; + BtnMkv.Down := Sender = BtnMkv; + ApplyFormat; +end; + +procedure TExportDialog.BurnClick(Sender: TObject); +begin + if Applying then + Exit; + { Запоминаем только осознанный ответ: при MP4 галка стоит не по воле + человека, и запоминать её значило бы соврать ему в следующий раз. } + if cbBurn.Enabled then + BurnWanted := cbBurn.Checked; + ApplyFormat; +end; + +{ Галка участка ничего не пересчитывает: она только запоминает ответ. + Всё, что от неё зависит, решается уже после закрытия окна. } +procedure TExportDialog.RegionClick(Sender: TObject); +begin +end; + +procedure TExportDialog.BrowseClick(Sender: TObject); +var + Dlg: TSaveDialog; +begin + Dlg := TSaveDialog.Create(nil); + try + Dlg.Title := 'Куда собрать ролик'; + Dlg.Options := Dlg.Options + [ofOverwritePrompt, ofPathMustExist]; + if IsMp4 then + begin + Dlg.DefaultExt := '.mp4'; + Dlg.Filter := 'MP4|*.mp4'; + end + else + begin + Dlg.DefaultExt := '.mkv'; + Dlg.Filter := 'Matroska|*.mkv'; + end; + Dlg.FileName := edPath.Text; + if Dlg.Execute then + edPath.Text := Dlg.FileName; + finally + Dlg.Free; + end; +end; + +function AskExport(var AChoice: TExportChoice; AHasText, APreferMkv: Boolean; + const ADefaultDir: string; const ARegion: string): Boolean; +var + Dlg: TExportDialog; + Lbl: TLabel; + BtnBrowse, BtnOk, BtnCancel: TThemedButton; + Dir: string; +begin + Result := False; + Dlg := TExportDialog.Create(nil); + try + Dlg.HasText := AHasText; + Dlg.BurnWanted := AChoice.BurnText; + + Dlg.Form := TForm.CreateNew(nil); + Dlg.Form.Caption := 'Сборка ролика'; + Dlg.Form.Position := poScreenCenter; + Dlg.Form.ClientWidth := 620; + Dlg.Form.ClientHeight := 272; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 12, 200, 20); + Lbl.Caption := 'Куда собрать'; + + Dlg.edPath := TEdit.Create(Dlg.Form); + Dlg.edPath.Parent := Dlg.Form; + Dlg.edPath.SetBounds(12, 34, 490, 26); + Dlg.edPath.Anchors := [akTop, akLeft, akRight]; + + BtnBrowse := TThemedButton.Create(Dlg.Form); + BtnBrowse.Parent := Dlg.Form; + BtnBrowse.SetBounds(510, 33, 96, 28); + BtnBrowse.Anchors := [akTop, akRight]; + BtnBrowse.Caption := 'Обзор...'; + BtnBrowse.OnClick := @Dlg.BrowseClick; + + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(12, 76, 100, 20); + Lbl.Caption := 'Контейнер'; + + Dlg.BtnMp4 := TThemedButton.Create(Dlg.Form); + Dlg.BtnMp4.Parent := Dlg.Form; + Dlg.BtnMp4.SetBounds(110, 72, 90, 28); + Dlg.BtnMp4.Caption := 'MP4'; + Dlg.BtnMp4.TabStop := False; + Dlg.BtnMp4.OnClick := @Dlg.FormatClick; + + Dlg.BtnMkv := TThemedButton.Create(Dlg.Form); + Dlg.BtnMkv.Parent := Dlg.Form; + Dlg.BtnMkv.SetBounds(206, 72, 90, 28); + Dlg.BtnMkv.Caption := 'MKV'; + Dlg.BtnMkv.TabStop := False; + Dlg.BtnMkv.OnClick := @Dlg.FormatClick; + + if ARegion <> '' then + begin + Lbl := TLabel.Create(Dlg.Form); + Lbl.Parent := Dlg.Form; + Lbl.SetBounds(310, 76, 300, 20); + Lbl.Anchors := [akTop, akLeft, akRight]; + Lbl.Caption := 'Только участок: ' + ARegion; + Lbl.Font.Color := TColor($30A0D0); + end; + + Dlg.cbRegion := TCheckBox.Create(Dlg.Form); + Dlg.cbRegion.Parent := Dlg.Form; + Dlg.cbRegion.SetBounds(12, 112, 596, 22); + Dlg.cbRegion.Anchors := [akTop, akLeft, akRight]; + Dlg.cbRegion.Caption := 'Только отмеченный участок: ' + ARegion; + Dlg.cbRegion.Visible := ARegion <> ''; + Dlg.cbRegion.Checked := ARegion <> ''; + Dlg.cbRegion.OnClick := @Dlg.RegionClick; + + Dlg.cbBurn := TCheckBox.Create(Dlg.Form); + Dlg.cbBurn.Parent := Dlg.Form; + Dlg.cbBurn.SetBounds(12, 138, 300, 22); + Dlg.cbBurn.Caption := 'Вжечь текст в картинку'; + Dlg.cbBurn.Visible := AHasText; + Dlg.cbBurn.OnClick := @Dlg.BurnClick; + + Dlg.lblNote := TLabel.Create(Dlg.Form); + Dlg.lblNote.Parent := Dlg.Form; + Dlg.lblNote.SetBounds(12, 164, 596, 52); + Dlg.lblNote.Anchors := [akTop, akLeft, akRight]; + Dlg.lblNote.AutoSize := False; + Dlg.lblNote.WordWrap := True; + + BtnOk := TThemedButton.Create(Dlg.Form); + BtnOk.Parent := Dlg.Form; + BtnOk.SetBounds(400, 230, 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(508, 230, 100, 30); + BtnCancel.Anchors := [akRight, akBottom]; + BtnCancel.Caption := 'Отмена'; + BtnCancel.ModalResult := mrCancel; + BtnCancel.Cancel := True; + + ApplyDarkTheme(Dlg.Form); + + { Начальное имя: где были в прошлый раз, с расширением по контейнеру. } + Dir := ADefaultDir; + if Dir = '' then + Dir := GetCurrentDir; + if AChoice.Path <> '' then + Dlg.edPath.Text := AChoice.Path + else + Dlg.edPath.Text := IncludeTrailingPathDelimiter(Dir) + 'ролик.mkv'; + + { Точные резы просят Matroska: в MP4 перекодированный стык может + воспроизводиться неправильно. } + Dlg.BtnMkv.Down := APreferMkv or + (LowerCase(ExtractFileExt(Dlg.edPath.Text)) = '.mkv'); + Dlg.BtnMp4.Down := not Dlg.BtnMkv.Down; + Dlg.ApplyFormat; + + if Dlg.Form.ShowModal <> mrOk then + Exit; + + AChoice.Path := Trim(Dlg.edPath.Text); + if AChoice.Path = '' then + Exit; + AChoice.BurnText := AHasText and Dlg.cbBurn.Checked; + AChoice.RegionOnly := (ARegion <> '') and Dlg.cbRegion.Checked; + Result := True; + finally + Dlg.Form.Free; + Dlg.Free; + end; +end; + +end. diff --git a/src/uFfmpegCmd.pas b/src/uFfmpegCmd.pas index 13f4357..c01e39f 100644 --- a/src/uFfmpegCmd.pas +++ b/src/uFfmpegCmd.pas @@ -86,7 +86,13 @@ function ArgsTranscodeSegment(const ASrc, ADst: string; AStart, AEnd: Double; AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; ASampleRate, AChannels: Integer; AVolume: Double; - const AFormat: string; const AFilter: string = ''): TArgs; + const AFormat: string; const AFilter: string = ''; + const ASubFile: string = ''; ABitrate: Int64 = 0): TArgs; + +{ Путь внутри строки фильтра. Двоеточие там разделяет настройки, обратная + косая и кавычка имеют своё значение — всё это надо обезвредить, иначе + путь с пробелом или двоеточием развалит разбор. } +function EscapeFilterPath(const APath: string): string; { Кадр одиночной картинки для окна кадрирования. } function ArgsPreviewFrame(const ASrc, ADst: string; const ATime: Double; @@ -109,7 +115,68 @@ function TsSupportsCodecs(const AVideoCodec, AAudioCodec: string): Boolean; { Склеить куски по списку. Формат вывода ffmpeg определит по расширению. } function ArgsConcat(const AListFile, ADst: string): TArgs; +{ Склейка сразу с готовым звуком и разметкой — прямо в конечный файл. + + Зачем. Раньше картинка сначала собиралась в отдельный файл, а потом + сшивалась со звуком в конечный. На часовом ролике это означало 91 ГБ + промежуточного файла и лишний полный проход копирования: места нужно + вдвое больше готового ролика, и всё это ради того, чтобы приписать + звуковую дорожку. + + Звук собирается раньше картинки, и склейка сразу кладёт всё вместе куда + надо. Пусто в AAudio — значит звука нет, тогда это обычная склейка. } +function ArgsConcatMux(const AListFile, AAudio, ASubFile, ADst: string): TArgs; + +{ Склеить куски и сразу перекодировать картинку в заданный размер и поток. + + Нужно для сборки «под площадку»: когда ролик надо отдать в 1080p с + определённым битрейтом, а исходники сняты в 2688x1512. Отдельный путь, а + не пересборка каждого куска по отдельности: здесь важно, чтобы весь + ролик получился одним кодировщиком с одними настройками — иначе на + стыках видно смену качества. + + Кодировщик выбирается аппаратный: перекодирование целого ролика на + процессоре идёт медленнее реального времени, и смысл теряется. } +function ArgsConcatEncode(const AListFile, ADst: string; + AWidth, AHeight, AFpsNum, AFpsDen, ABitrateKbps: Integer; + const AVideoCodec, APixFmt: string; AHwDecode: Boolean = True; + const AAudio: string = ''): TArgs; + { Перепаковать файл в другой контейнер без перекодирования. } +{ Звук куска в сыром виде: 16 бит со знаком, частота и число каналов + проекта. Сырой поток нужен потому, что куски потом просто дописываются + друг за другом байтами — так стык получается с точностью до отсчёта, а + не до звукового кадра. } +function ArgsExtractAudioRaw(const ASource, ATarget: string; + const AStart, ADuration: Double; ARate, AChannels: Integer; + const AVolume: Double): TArgs; + +{ Сжатие собранного сырого звука. Один проход на весь ролик. } +function ArgsEncodeAudio(const ASource, ATarget: string; + ARate, AChannels: Integer; const ACodec: string): TArgs; + +{ Пересборка участка с наложением: два слоя сводятся в один кадр. + + Постоянная непрозрачность делается наложением с приглушённым альфа- + каналом, переход — фильтром xfade. Их нельзя перепутать: xfade умеет + плавно менять долю во времени, а простое наложение — нет. + + ASubFile — разметка текста, которую надо вжечь в этот кусок. Пусто — не + вжигать. Без этого текст пропадал везде, где есть наложение: кусок шёл + этой веткой, а она про субтитры не знала. } +function ArgsRenderLayers(const ALayers: array of TSegmentLayer; + const ATarget: string; const ADuration: Double; + AWidth, AHeight, AFpsNum, AFpsDen: Integer; + const APixFmt, ACodec: string; AIsTs: Boolean; + ABitrate: Int64 = 0; const ASubFile: string = ''): TArgs; + +{ Сшивание готовой картинки с готовым звуком. Оба потока копируются. + + ASubFile — разметка субтитров, которую надо вложить отдельной дорожкой. + Пусто — не вкладывать. } +function ArgsMux(const AVideo, AAudio, ATarget: string; + const ASubFile: string = ''): TArgs; + function ArgsRemux(const ASrc, ADst: string): TArgs; { Сведения о файле в JSON. } @@ -148,7 +215,7 @@ function ArgsNormalize(const ASrc, ADst: string; function ArgsImageClip(const ASrc, ADst: string; ADuration: Double; AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; - ASampleRate, AChannels: Integer): TArgs; + ASampleRate, AChannels: Integer; ABitrate: Int64 = 0): TArgs; { Сделать чёрный клип с тишиной заданной длины. @@ -159,6 +226,13 @@ function ArgsBlackClip(const ADst: string; ADuration: Double; const AVideoCodec, APixFmt, AAudioCodec: string; ASampleRate, AChannels: Integer): TArgs; +{ Вставка тишины для звуковой дорожки: только звук, без картинки. + + Отдельно от чёрного клипа, потому что перемотка внутри видео + откатывается к опорному кадру, а в звуке опорным является каждый. } +function ArgsSilenceClip(const ADst: string; ADuration: Double; + const AAudioCodec: string; ASampleRate, AChannels: Integer): TArgs; + { Кадр-миниатюра для списка файлов проекта. Кадр берётся не с нуля: у многих съёмок первые секунды это крышка @@ -179,13 +253,204 @@ function ParseProgressLine(const ALine: string; var ASeconds: Double; implementation uses - StrUtils; + StrUtils, uTransform; + +{ Ключи качества. Объявлено в самом начале: ими пользуется отрисовка + слоёв, а она по тексту раньше самой функции. } +function BitrateArgs(ABitrate: Int64): TArgs; forward; { Общие параметры вывода в формате проекта. Объявлено заранее, потому что используется выше по тексту, чем определено. } +function ArgsExtractAudioRaw(const ASource, ATarget: string; + const AStart, ADuration: Double; ARate, AChannels: Integer; + const AVolume: Double): TArgs; +var + Filter: string; +begin + Result := ['-hide_banner', '-nostdin', '-loglevel', 'error', '-y', + '-ss', SecondsToStr(AStart), '-t', SecondsToStr(ADuration), + '-i', ASource, '-vn', '-map', '0:a:0?']; + + { Громкость применяется здесь же: звук всё равно перекодируется, второго + прохода ради неё не нужно. } + if Abs(AVolume - 1) > 0.001 then + begin + Filter := 'volume=' + SecondsToStr(AVolume); + Result := Concat(Result, ['-af', Filter]); + end; + + Result := Concat(Result, + ['-ac', IntToStr(AChannels), '-ar', IntToStr(ARate), + '-f', 's16le', ATarget]); +end; + +function ArgsEncodeAudio(const ASource, ATarget: string; + ARate, AChannels: Integer; const ACodec: string): TArgs; +var + Codec: string; +begin + Codec := ACodec; + if Codec = '' then + Codec := 'aac'; + Result := ['-hide_banner', '-nostdin', '-loglevel', 'error', '-y', + '-f', 's16le', '-ar', IntToStr(ARate), '-ac', IntToStr(AChannels), + '-i', ASource, '-c:a', Codec, '-b:a', '192k', + '-progress', 'pipe:1', '-nostats', ATarget]; +end; + +function ArgsRenderLayers(const ALayers: array of TSegmentLayer; + const ATarget: string; const ADuration: Double; + AWidth, AHeight, AFpsNum, AFpsDen: Integer; + const APixFmt, ACodec: string; AIsTs: Boolean; + ABitrate: Int64; const ASubFile: string): TArgs; +var + I: Integer; + Graph, Fit, Src, OutLabel: string; + Crossfade: Boolean; +begin + Result := ['-hide_banner', '-nostdin', '-loglevel', 'warning', '-y']; + + { Каждый слой — отдельный вход, вырезанный ровно по длине участка. + + Неподвижная картинка — случай особый: её надо повторять ключом -loop, + иначе ffmpeg отдаёт один-единственный кадр, и весь кусок с наложением + схлопывается в одну шестидесятую секунды. Перематывать её тоже + незачем: у картинки нет времени. } + for I := 0 to High(ALayers) do + if ALayers[I].IsImage then + Result := Concat(Result, + ['-loop', '1', + '-framerate', Format('%d/%d', [AFpsNum, AFpsDen]), + '-t', SecondsToStr(ADuration), + '-i', ALayers[I].FilePath]) + else + Result := Concat(Result, + ['-ss', SecondsToStr(ALayers[I].SrcStart), + '-t', SecondsToStr(ADuration), + '-i', ALayers[I].FilePath]); + + { Переход отличается от наложения тем, что доля меняется во времени. } + Crossfade := (Length(ALayers) = 2) and + ((Abs(ALayers[1].FadeFrom - ALayers[1].FadeTo) > 0.001) or + (Abs(ALayers[0].FadeFrom - ALayers[0].FadeTo) > 0.001)); + + Graph := ''; + for I := 0 to High(ALayers) do + begin + { Нижний слой — холст, он занимает весь кадр, и поля ему нужны. + Верхнему поля вредны: чёрное поле непрозрачно и закрыло бы холст, + поэтому верхний кладётся на своё место как есть. Переход — случай + особый: xfade смешивает два кадра целиком, и оба должны быть в + размер проекта. } + if (I > 0) and (not Crossfade) and (ALayers[I].FitFilter <> '') then + Fit := ALayers[I].FitFilter + else + Fit := ALayers[I].Filter; + if Fit = '' then + Fit := Format('scale=%d:%d,setsar=1', [AWidth, AHeight]); + { Цветовой ключ ставится после вписывания и до наложения: он должен + работать по кадру проекта, иначе смягчение края разъедется вместе с + масштабом. Цвет записывается как 0xRRGGBB — порядок обратный тому, + в каком он хранится у нас. } + if ALayers[I].KeyEnabled then + Fit := Fit + ',' + ColorKeyFilter(ALayers[I].KeyColor, + ALayers[I].KeySimilarity, ALayers[I].KeyBlend); + Graph := Graph + Format('[%d:v]%s,format=yuva420p[v%d];', [I, Fit, I]); + end; + + if Length(ALayers) = 1 then + begin + Src := 'v0'; + { Ключ без нижнего слоя: выбитое надо чем-то заполнить, иначе при + переводе в кадр без прозрачности вернётся исходный цвет — тот + самый, который выбивали. Кладём на чёрное поле. } + if ALayers[0].KeyEnabled then + begin + Graph := Graph + Format('color=c=black:s=%dx%d:r=%d/%d:d=%s[bg];' + + '[bg][v0]overlay=0:0[k0];', + [AWidth, AHeight, AFpsNum, AFpsDen, SecondsToStr(ADuration)]); + Src := 'k0'; + end; + if Abs(ALayers[0].FadeTo - ALayers[0].FadeFrom) < 0.001 then + Graph := Graph + Format('[%s]null[out]', [Src]) + { Один слой с меняющейся долей — это затухание в чёрное или из него. } + else if ALayers[0].FadeTo >= ALayers[0].FadeFrom then + Graph := Graph + Format('[%s]fade=t=in:st=0:d=%s:alpha=0[out]', + [Src, SecondsToStr(ADuration)]) + else + Graph := Graph + Format('[%s]fade=t=out:st=0:d=%s:alpha=0[out]', + [Src, SecondsToStr(ADuration)]); + end + else if Crossfade then + Graph := Graph + Format('[v0][v1]xfade=transition=fade:duration=%s:offset=0[out]', + [SecondsToStr(ADuration)]) + else + begin + { Верхний слой приглушается по альфа-каналу и кладётся на нижний — + на своё место в кадре, теми же координатами, по которым его + показывает предпросмотр. } + Graph := Graph + Format('[v1]colorchannelmixer=aa=%s[t];' + + '[v0][t]overlay=%d:%d[out]', + [SecondsToStr(ALayers[High(ALayers)].Opacity), + ALayers[High(ALayers)].X, ALayers[High(ALayers)].Y]); + end; + + { Текст вжигается последним: он ложится поверх уже сведённой картинки, + как и в куске без наложения. Разметка приходит со сдвигом под этот + кусок, поэтому время в ней считается от его начала. } + if ASubFile <> '' then + Graph := Graph + Format(';[out]subtitles=filename=''%s''[outs]', + [EscapeFilterPath(ASubFile)]); + + { Кодировщик выбирается предпочтительный, а не тот, что ffmpeg возьмёт + по имени кодека. Имя «hevc» уводит его на процессорный x265, и участок + наложения считался медленнее реального времени: замерено 9.6 с + материала за 11.2 с работы. } + if ASubFile <> '' then + OutLabel := '[outs]' + else + OutLabel := '[out]'; + Result := Concat(Result, + ['-filter_complex', Graph, '-map', OutLabel, + '-t', SecondsToStr(ADuration), + '-c:v', PreferredEncoder(ACodec), '-r', Format('%d/%d', [AFpsNum, AFpsDen]), + '-pix_fmt', APixFmt]); + Result := Concat(Result, BitrateArgs(ABitrate)); + Result := Concat(Result, + ['-bf', '0', '-an', '-avoid_negative_ts', 'make_zero', + '-progress', 'pipe:1', '-nostats']); + if AIsTs then + Result := Concat(Result, ['-f', 'mpegts']); + Result := Concat(Result, [ATarget]); +end; + +function ArgsMux(const AVideo, AAudio, ATarget: string; + const ASubFile: string): TArgs; +begin + Result := ['-hide_banner', '-nostdin', '-loglevel', 'warning', '-y', + '-i', AVideo, '-i', AAudio]; + + { Субтитры отдельной дорожкой: ничего не перекодируется, проигрыватель + может их включить или выключить. Кодек ass сохраняет всё оформление — + в MP4 такого нет, там субтитры кладутся голым текстом, поэтому туда + их и не предлагают. } + if ASubFile <> '' then + Result := Concat(Result, ['-i', ASubFile]); + + Result := Concat(Result, ['-map', '0:v:0', '-map', '1:a:0']); + if ASubFile <> '' then + Result := Concat(Result, ['-map', '2:s:0', '-c:s', 'ass', + '-metadata:s:s:0', 'title=Надписи', + '-metadata:s:s:0', 'language=rus']); + + Result := Concat(Result, ['-c:v', 'copy', '-c:a', 'copy', + '-avoid_negative_ts', 'make_zero', + '-progress', 'pipe:1', '-nostats', ATarget]); +end; + function MasterOutputArgs(AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; - ASampleRate, AChannels: Integer): TArgs; forward; + ASampleRate, AChannels: Integer; ABitrate: Int64 = 0): TArgs; forward; { Запрет двунаправленных кадров. Объявлено заранее по той же причине. } function NoBFramesArgs: TArgs; forward; @@ -201,7 +466,7 @@ function LocateTool(const AName: string): string; var Own: string; begin - Own := ExtractFilePath(ExpandFileName(ParamStr(0))) + AName + Own := ProgramDir + AName {$IFDEF WINDOWS} + '.exe'{$ENDIF}; if FileExists(Own) then Exit(Own); @@ -387,11 +652,21 @@ begin Result := Concat(Result, ['-f', AFormat, ADst]); end; +function EscapeFilterPath(const APath: string): string; +begin + Result := StringReplace(APath, '\', '/', [rfReplaceAll]); + Result := StringReplace(Result, '''', '\''', [rfReplaceAll]); + Result := StringReplace(Result, ':', '\:', [rfReplaceAll]); +end; + function ArgsTranscodeSegment(const ASrc, ADst: string; AStart, AEnd: Double; AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; ASampleRate, AChannels: Integer; AVolume: Double; - const AFormat: string; const AFilter: string): TArgs; + const AFormat: string; const AFilter: string; + const ASubFile: string; ABitrate: Int64): TArgs; +var + Chain: string; begin Result := Concat(CommonFfmpegPrefix, [ '-ss', SecondsToStr(AStart), @@ -404,17 +679,26 @@ begin { Как именно кадр ложится в кадр проекта, решено заранее и передано готовой цепочкой фильтров. } if AFilter <> '' then - Result := Concat(Result, ['-vf', AFilter]) + Chain := AFilter else - Result := Concat(Result, ['-vf', Format( - 'scale=%d:%d:force_original_aspect_ratio=decrease,pad=%d:%d:(ow-iw)/2:(oh-ih)/2,setsar=1', - [AWidth, AHeight, AWidth, AHeight])]); + Chain := Format( + 'scale=%d:%d:force_original_aspect_ratio=decrease,' + + 'pad=%d:%d:(ow-iw)/2:(oh-ih)/2,setsar=1', + [AWidth, AHeight, AWidth, AHeight]); + + { Текст рисуется последним — уже по кадру проекта. Раньше он попал бы + под масштабирование и уехал бы вместе с картинкой. } + if ASubFile <> '' then + Chain := Chain + ',subtitles=filename=''' + + EscapeFilterPath(ASubFile) + ''''; + + Result := Concat(Result, ['-vf', Chain]); if Abs(AVolume - 1) >= 0.001 then Result := Concat(Result, ['-af', 'volume=' + SecondsToStr(AVolume)]); Result := Concat(Result, MasterOutputArgs(0, 0, AFpsNum, AFpsDen, - AVideoCodec, APixFmt, AAudioCodec, ASampleRate, AChannels)); + AVideoCodec, APixFmt, AAudioCodec, ASampleRate, AChannels, ABitrate)); Result := Concat(Result, NoBFramesArgs); Result := Concat(Result, ['-avoid_negative_ts', 'make_zero']); Result := Concat(Result, ProgressArgs); @@ -436,6 +720,72 @@ begin (AAudioCodec = 'ac3') or (AAudioCodec = 'mp2'); end; +function ArgsConcatEncode(const AListFile, ADst: string; + AWidth, AHeight, AFpsNum, AFpsDen, ABitrateKbps: Integer; + const AVideoCodec, APixFmt: string; AHwDecode: Boolean; + const AAudio: string): TArgs; +var + Fps, Enc: string; +begin + Enc := PreferredEncoder(AVideoCodec); + + Result := Concat(CommonFfmpegPrefix, []); + + { Распаковка тоже на видеокарте. Замерено на паре кусков 2688x1512: + 9.18 с без неё против 1.77 с с ней, впятеро. + + Кадры при этом всё равно возвращаются в обычную память, а масштаб + считает процессор. Полностью карточный путь через scale_cuda в том же + замере оказался медленнее (5.74 с) — видимо, из-за преобразований + формата, и городить его незачем. + + Признак необязательный: если распаковка не пойдёт, вызывающий + повторит без неё. } + if AHwDecode and (Pos('nvenc', Enc) > 0) then + Result := Concat(Result, ['-hwaccel', 'cuda']); + + Result := Concat(Result, ['-f', 'concat', '-safe', '0', '-i', AListFile]); + { Готовый звук подмешивается прямо здесь, чтобы не собирать картинку в + промежуточный файл ради одной звуковой дорожки. } + if AAudio <> '' then + Result := Concat(Result, ['-i', AAudio, '-map', '0:v:0', '-map', '1:a:0']) + else + Result := Concat(Result, ['-map', '0:v:0', '-map', '0:a:0?']); + + { Вписываем целиком и добиваем полями: соотношение сторон менять нельзя, + иначе кадр растянется. } + if (AWidth > 0) and (AHeight > 0) then + Result := Concat(Result, ['-vf', Format( + 'scale=%d:%d:force_original_aspect_ratio=decrease,' + + 'pad=%d:%d:(ow-iw)/2:(oh-ih)/2,setsar=1', + [AWidth, AHeight, AWidth, AHeight])]); + + Result := Concat(Result, ['-c:v', Enc]); + if ABitrateKbps > 0 then + { Верхняя граница и запас буфера задаются вместе со средним потоком: + без них кодировщик волен выдать всплеск вдвое выше заказанного. } + Result := Concat(Result, [ + '-b:v', IntToStr(ABitrateKbps) + 'k', + '-maxrate', IntToStr(Round(ABitrateKbps * 1.5)) + 'k', + '-bufsize', IntToStr(ABitrateKbps * 2) + 'k']); + + Fps := ''; + if (AFpsNum > 0) and (AFpsDen > 0) then + Fps := IntToStr(AFpsNum) + '/' + IntToStr(AFpsDen); + if Fps <> '' then + Result := Concat(Result, ['-r', Fps]); + if APixFmt <> '' then + Result := Concat(Result, ['-pix_fmt', APixFmt]); + + { Звук уже собран и сжат отдельным проходом — трогать его незачем. } + Result := Concat(Result, ['-c:a', 'copy']); + + Result := Concat(Result, ProgressArgs); + if WantsFaststart(ADst) then + Result := Concat(Result, ['-movflags', '+faststart']); + Result := Concat(Result, [ADst]); +end; + function ArgsConcat(const AListFile, ADst: string): TArgs; begin Result := Concat(CommonFfmpegPrefix, [ @@ -453,6 +803,46 @@ begin Result := Concat(Result, [ADst]); end; +function ArgsConcatMux(const AListFile, AAudio, ASubFile, ADst: string): TArgs; +var + Next: Integer; +begin + Result := Concat(CommonFfmpegPrefix, [ + '-f', 'concat', + { Без -safe 0 демультиплексор откажется брать абсолютные пути. } + '-safe', '0', + '-i', AListFile + ]); + + Next := 1; + if AAudio <> '' then + Result := Concat(Result, ['-i', AAudio]); + if ASubFile <> '' then + Result := Concat(Result, ['-i', ASubFile]); + + Result := Concat(Result, ['-map', '0:v:0']); + if AAudio <> '' then + begin + Result := Concat(Result, ['-map', IntToStr(Next) + ':a:0']); + Inc(Next); + end + else + { Звука своего нет — берём тот, что пришёл с кусками, если он там есть. } + Result := Concat(Result, ['-map', '0:a:0?']); + + if ASubFile <> '' then + Result := Concat(Result, ['-map', IntToStr(Next) + ':s:0', '-c:s', 'ass', + '-metadata:s:s:0', 'title=Надписи', + '-metadata:s:s:0', 'language=rus']); + + Result := Concat(Result, ['-c:v', 'copy', '-c:a', 'copy', + '-avoid_negative_ts', 'make_zero']); + Result := Concat(Result, ProgressArgs); + if WantsFaststart(ADst) then + Result := Concat(Result, ['-movflags', '+faststart']); + Result := Concat(Result, [ADst]); +end; + function ArgsRemux(const ASrc, ADst: string): TArgs; begin Result := Concat(CommonFfmpegPrefix, [ @@ -623,9 +1013,31 @@ begin end; { Реализация объявленной выше функции. } +{ Ключи качества для пересобираемых кусков. + + Без них кодировщик берёт своё значение по умолчанию, а оно скромное: на + съёмке 2688x1512 с 56 Мбит/с NVENC выдавал 5.9 Мбит/с, и пересобранный + кусок бросался в глаза среди скопированных. Поэтому целимся в тот же + битрейт, что у исходного материала. + + Кроме среднего задаётся потолок и размер буфера: без них кодировщик + разгоняется на сложных кадрах ровно настолько, насколько ему позволит + средний, и мелкие детали всё равно пропадают. } +function BitrateArgs(ABitrate: Int64): TArgs; +begin + Result := []; + { Ниже ста килобит в секунду — это не битрейт, а неизвестность: ffprobe + не всегда его сообщает. Тогда оставляем решение кодировщику. } + if ABitrate < 100000 then + Exit; + Result := ['-b:v', IntToStr(ABitrate div 1000) + 'k', + '-maxrate', IntToStr(ABitrate * 3 div 2000) + 'k', + '-bufsize', IntToStr(ABitrate div 500) + 'k']; +end; + function MasterOutputArgs(AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; - ASampleRate, AChannels: Integer): TArgs; + ASampleRate, AChannels: Integer; ABitrate: Int64): TArgs; var Fps: string; begin @@ -641,6 +1053,7 @@ begin Result := Concat(Result, ['-r', Fps]); if APixFmt <> '' then Result := Concat(Result, ['-pix_fmt', APixFmt]); + Result := Concat(Result, BitrateArgs(ABitrate)); if AAudioCodec <> '' then begin @@ -673,7 +1086,7 @@ end; function ArgsImageClip(const ASrc, ADst: string; ADuration: Double; AWidth, AHeight, AFpsNum, AFpsDen: Integer; const AVideoCodec, APixFmt, AAudioCodec: string; - ASampleRate, AChannels: Integer): TArgs; + ASampleRate, AChannels: Integer; ABitrate: Int64): TArgs; begin { -loop 1 повторяет единственный кадр, -t задаёт длину. Картинка вписывается в кадр целиком с чёрными полями по краям: @@ -696,7 +1109,7 @@ begin [AWidth, AHeight, AWidth, AHeight])]); Result := Concat(Result, MasterOutputArgs(0, 0, AFpsNum, AFpsDen, - AVideoCodec, APixFmt, AAudioCodec, ASampleRate, AChannels)); + AVideoCodec, APixFmt, AAudioCodec, ASampleRate, AChannels, ABitrate)); Result := Concat(Result, NoBFramesArgs); Result := Concat(Result, ['-shortest']); Result := Concat(Result, ProgressArgs); @@ -733,6 +1146,32 @@ begin Result := Concat(Result, [ADst]); end; +function ArgsSilenceClip(const ADst: string; ADuration: Double; + const AAudioCodec: string; ASampleRate, AChannels: Integer): TArgs; +var + Codec: string; + Ch: Integer; +begin + Codec := AAudioCodec; + if Codec = '' then + Codec := 'aac'; + Ch := AChannels; + if Ch < 1 then + Ch := 2; + + Result := Concat(CommonFfmpegPrefix, [ + '-f', 'lavfi', + '-i', Format('anullsrc=channel_layout=%s:sample_rate=%d', + [IfThen(Ch = 1, 'mono', 'stereo'), ASampleRate]), + '-c:a', Codec, + '-ac', IntToStr(Ch), + '-ar', IntToStr(ASampleRate), + '-t', SecondsToStr(ADuration) + ]); + Result := Concat(Result, ProgressArgs); + Result := Concat(Result, [ADst]); +end; + function ArgsThumbnail(const ASrc, ADst: string; const ATime: Double; AWidth, AHeight: Integer): TArgs; begin diff --git a/src/uFlatten.pas b/src/uFlatten.pas index 8dfcbb2..e97a318 100644 --- a/src/uFlatten.pas +++ b/src/uFlatten.pas @@ -38,14 +38,54 @@ uses Classes, SysUtils, uAppTypes, uProject, uMediaProbe, uTransform; type + { Набор отрезков времени: им описывают, где оверлей виден. } + TDoubleArray = array of Double; + + { Клип, который в предпросмотре кладётся поверх основы. + + Место в кадре — то же самое, по чему сборка обкладывает картинку + полями: считается одним кодом (см. OverlayFilter). } + TPreviewOverlay = record + TlStart: Double; + TlEnd: Double; + FilePath: string; + SrcStart: Double; + { Цепочка фильтров для плеера: без полей, только приведение к нужному + размеру и повороту. } + Filter: string; + X: Integer; + Y: Integer; + Width: Integer; + Height: Integer; + end; + TPreviewOverlays = array of TPreviewOverlay; + { Что нужно создать, чтобы кусок стал воспроизводимым файлом. } - TGenKind = (gkNone, gkBlack, gkImage); + { gkSilence — вставка тишины без картинки, только для звуковых дорожек. + + Отдельный вид, а не чёрный клип, потому что перемотка внутри чёрного + клипа откатывается к ближайшему опорному кадру, а те стоят через + четыре секунды. Дорожка после этого отдаёт звук на несколько секунд + раньше соседних, смешивание равняется по ней, и содержимое соседней + дорожки в это окно не попадает — звук пропадал целыми кусками. + Замерено: на 24-й секунде смешивание трёх дорожек давало -91 dB, то + есть полную тишину, при том что каждая дорожка по отдельности звучала. + Со звуковой вставкой в той же точке -11.7 dB. + + В звуковом файле опорным является каждый кадр, и такой беды нет. } + TGenKind = (gkNone, gkBlack, gkImage, gkSilence, gkLayers); TGenRequest = record Kind: TGenKind; SourcePath: string; Duration: Double; TargetPath: string; + { Только для gkLayers: что с чем смешивать. } + Layers: TSegmentLayers; + { Место на монтаже, ради которого всё затевается. Нужно только для + показа: пока участок пересобирается, монтаж помечает его полосой. } + TlStart: Double; + TlEnd: Double; end; TGenRequests = array of TGenRequest; @@ -55,20 +95,109 @@ type У кусков, требующих генерации, FilePath указывает на будущий файл в кэше; сам файл может ещё не существовать. Список того, что надо создать, возвращается в AMissing. } -function FlattenProject(AProject: TProject; out ASegments: TFlatSegmentArray; +{ Уплощение одного потока: либо картинки, либо звука. + + Проходов два, потому что звук можно двигать отдельно от картинки: в один + и тот же момент картинка берётся с одной дорожки, а звук с другой. При + одном общем проходе такое не выразить. + + Дорожки другого вида в проходе не участвуют вовсе — ни как источники, + ни как границы кусков. } +{ AMinLength — до какой длины дотянуть поток. Нужно, чтобы картинка и звук + всегда были одной длины: если выключить все дорожки картинки, поток + картинки опустеет, и без этого предпросмотр погас бы вместе со звуком. + Недостающее заполняется чёрным и тишиной. } +function FlattenStream(AProject: TProject; AKind: TTrackKind; + const AMinLength: Double; + out ASegments: TFlatSegmentArray; out AMissing: TGenRequests; + AHidden: TFPList = nil): Boolean; + +{ Уплощение одной звуковой дорожки — для предпросмотра. + + Плеер умеет играть только одну звуковую дорожку за раз, поэтому смесь + ему приходится собирать самому: каждая дорожка монтажа подаётся своим + списком кусков, а дальше они складываются его же средствами. } +function FlattenAudioTrack(AProject: TProject; ATrack: TTrack; + const ATotal: Double; + out ASegments: TFlatSegmentArray; out AMissing: TGenRequests): Boolean; + +{ Длина слышимого материала одного вида дорожек. } +function AudibleEnd(AProject: TProject; AKind: TTrackKind): Double; + +{ Оба потока разом. Список того, что надо создать, общий: чёрные вставки + годятся и картинке, и звуку — в них есть и то, и другое. } +function FlattenProject(AProject: TProject; + out AVideo, AAudio: TFlatSegmentArray; out AMissing: TGenRequests): Boolean; +{ То же для предпросмотра, но клипы, которые кладутся поверх, вынесены + отдельно. + + Зачем. Клип с ключом или прозрачностью не сплошной, и в готовом ролике + участок под ним приходится сводить. Оверлей во весь ролик — компас или + карта поверх всего материала — заставил бы сводить весь фильм на каждую + правку, ради картинки, которую всё равно надо перепроверять сборкой. + + Плееру сводить не нужно: он умеет играть две дорожки одна поверх + другой. Поэтому такие клипы здесь не участвуют в отборе победителя — + под ними видно то, что лежит ниже, — а выдаются отдельным списком со + временем и местом в кадре. + + AWithKey — применять ли к оверлею цветовой ключ и прозрачность прямо в + плеере. Тогда окно показывает то же, что даст сборка. Стоит это + недорого: фильтр работает по площади самого оверлея, а не всего кадра, + но на слабой машине лишним не будет, поэтому решает вызывающий. + + Для сборки ролика это не применяется: там всё сводится по-настоящему. } +function FlattenPreview(AProject: TProject; + out AVideo, AAudio: TFlatSegmentArray; + out AOverlays: TPreviewOverlays; + out AMissing: TGenRequests; + AWithKey: Boolean = False): Boolean; + +{ Оставляет от списка кусков только то, что попадает в участок. + + Куски, задетые краем, подрезаются: у начального сдвигается точка входа в + исходник, у конечного укорачивается длина. Слои внутри куска сдвигаются + вместе с ним — иначе наложение поехало бы относительно картинки. + + Зачем: собрать кусок монтажа, не собирая весь ролик. На длинном + материале это разница между минутой и часом, и без этого проверить + правку в готовом файле почти невозможно. + + Возвращает, сколько секунд осталось. } +function ClipSegmentsToRange(var ASegments: TFlatSegmentArray; + const AFrom, ATo: Double): Double; + { Путь к сгенерированному клипу. Имя выводится из содержимого запроса, поэтому одинаковые запросы дают один и тот же файл, и он делается один раз. } function GeneratedPath(const ACacheDir: string; const AReq: TGenRequest): string; +{ Заменяет куски с наложением готовыми файлами — для предпросмотра. + + Плеер играет список кусков, а список накладывать не умеет: там побеждает + верхний клип целиком. Поэтому участки с прозрачностью и переходами + заранее собираются в отдельные файлы, и предпросмотр играет уже их. Файл + один раз посчитан и лежит в кэше, так что при следующем открытии ждать + нечего. + + Чего ещё не готово — уходит в AMissing тем же путём, что чёрные вставки: + окно их закажет и повторит сборку списка. + + Для сборки ролика это не применяется: там наложение считается заново с + параметрами вывода, и промежуточный файл был бы лишней потерей + качества. } +procedure ResolveLayers(AProject: TProject; var ASegments: TFlatSegmentArray; + var AMissing: TGenRequests); + { Заготовка чёрной вставки самой ходовой длины. Делается заранее, сразу после того как стали известны параметры проекта. Иначе первая же дыра на монтаже ждала бы генерации, и в это время предпросмотр играл бы прежнюю расстановку — выглядело бы так, будто удаление клипа или выключение дорожки не действуют. } + function PrewarmRequests(const ACacheDir: string): TGenRequests; implementation @@ -119,6 +248,13 @@ begin case AReq.Kind of gkBlack: Name := Format('black_%d.mkv', [Ms]); + gkSilence: + Name := Format('silence_%d.m4a', [Ms]); + gkLayers: + { Имя выводится из описания слоёв: одно и то же наложение даёт один + и тот же файл, и пересчитывать его второй раз не приходится. } + Name := Format('mix_%s_%d.mkv', + [Copy(MD5Print(MD5String(AReq.SourcePath)), 1, 12), Ms]); gkImage: begin Key := AReq.SourcePath + '|' + IntToStr(Ms); @@ -134,6 +270,118 @@ begin Result := IncludeTrailingPathDelimiter(ACacheDir) + 'gen' + PathDelim + Name; end; +{ Описание слоёв одной строкой. Из неё выводится имя файла, поэтому в неё + входит всё, что влияет на картинку: исходник, место в нём, кадрирование + и доли прозрачности. } +function LayersKey(const ALayers: TSegmentLayers; + const ADuration: Double): string; +var + I: Integer; +begin + Result := SecondsToStr(ADuration); + for I := 0 to High(ALayers) do + Result := Result + '|' + ALayers[I].FilePath + + '@' + SecondsToStr(ALayers[I].SrcStart) + + '#' + ALayers[I].Filter + + '*' + SecondsToStr(ALayers[I].Opacity) + + '>' + SecondsToStr(ALayers[I].FadeFrom) + + '<' + SecondsToStr(ALayers[I].FadeTo); + { Ключ входит в имя готового файла: иначе после правки цвета или + допуска подставился бы прежний, сведённый по старым числам. } + if ALayers[I].KeyEnabled then + Result := Result + Format('~%.6x/%d/%d', + [ALayers[I].KeyColor and $FFFFFF, + ALayers[I].KeySimilarity, ALayers[I].KeyBlend]); +end; + +function ClipSegmentsToRange(var ASegments: TFlatSegmentArray; + const AFrom, ATo: Double): Double; +var + I, J, N: Integer; + At, SegStart, SegEnd, NewStart, NewEnd, Shift: Double; + Kept: TFlatSegmentArray; + Seg: TFlatSegment; +begin + Result := 0; + if ATo <= AFrom then + Exit; + + N := 0; + At := 0; + SetLength(Kept, Length(ASegments)); + for I := 0 to High(ASegments) do + begin + SegStart := At; + SegEnd := At + ASegments[I].Duration; + At := SegEnd; + + NewStart := Max(SegStart, AFrom); + NewEnd := Min(SegEnd, ATo); + if NewEnd <= NewStart + 0.0005 then + Continue; + + Seg := ASegments[I]; + Shift := NewStart - SegStart; + Seg.SrcStart := Seg.SrcStart + Shift; + Seg.Duration := NewEnd - NewStart; + for J := 0 to High(Seg.Layers) do + Seg.Layers[J].SrcStart := Seg.Layers[J].SrcStart + Shift; + + Kept[N] := Seg; + Inc(N); + Result := Result + Seg.Duration; + end; + + SetLength(Kept, N); + ASegments := Kept; +end; + +procedure ResolveLayers(AProject: TProject; var ASegments: TFlatSegmentArray; + var AMissing: TGenRequests); +var + I: Integer; + Req: TGenRequest; + At: Double; +begin + if AProject = nil then + Exit; + At := 0; + for I := 0 to High(ASegments) do + begin + if Length(ASegments[I].Layers) = 0 then + begin + At := At + ASegments[I].Duration; + Continue; + end; + + Req := Default(TGenRequest); + Req.Kind := gkLayers; + Req.Duration := ASegments[I].Duration; + Req.SourcePath := LayersKey(ASegments[I].Layers, ASegments[I].Duration); + Req.Layers := ASegments[I].Layers; + Req.TargetPath := GeneratedPath(AProject.CacheDir, Req); + Req.TlStart := At; + Req.TlEnd := At + ASegments[I].Duration; + At := Req.TlEnd; + + if not FileExists(Req.TargetPath) then + begin + SetLength(AMissing, Length(AMissing) + 1); + AMissing[High(AMissing)] := Req; + Continue; + end; + + { Готовый файл встаёт на место куска целиком: слои в нём уже сведены, + кадрировать и пересобирать больше нечего. } + ASegments[I].FilePath := Req.TargetPath; + ASegments[I].SrcStart := 0; + ASegments[I].Filter := ''; + ASegments[I].Transcode := False; + ASegments[I].Layers := nil; + end; +end; + + function PrewarmRequests(const ACacheDir: string): TGenRequests; var Req: TGenRequest; @@ -189,8 +437,33 @@ begin end; end; -function FlattenProject(AProject: TProject; out ASegments: TFlatSegmentArray; - out AMissing: TGenRequests): Boolean; +function AudibleEnd(AProject: TProject; AKind: TTrackKind): Double; +var + T: Integer; + Track: TTrack; +begin + Result := 0; + if AProject = nil then + Exit; + for T := 0 to AProject.TrackCount - 1 do + begin + Track := AProject.Tracks[T]; + if Track.Kind <> AKind then + Continue; + if not AProject.TrackAudible(Track) then + Continue; + if Track.EndTime > Result then + Result := Track.EndTime; + end; +end; + +{ AHidden — клипы, которых для этого прохода как бы нет. Через них видно + то, что лежит ниже. Нужны предпросмотру: клип, который плеер положит + поверх сам, не должен ничего закрывать в основе. } +function FlattenStream(AProject: TProject; AKind: TTrackKind; + const AMinLength: Double; + out ASegments: TFlatSegmentArray; out AMissing: TGenRequests; + AHidden: TFPList = nil): Boolean; var Bounds: array of Double; BoundCount: Integer; @@ -205,6 +478,125 @@ var Req: TGenRequest; Path: string; Seen: TStringList; + Partner, Under: TClip; + + { Слой из клипа: где в исходнике брать картинку и с какой + непрозрачностью её накладывать. } + function LayerOf(AClip: TClip; const AAt: Double; + const AFrom, ATo: Double): TSegmentLayer; + var + It: TMediaItem; + W, H: Integer; + begin + Result := Default(TSegmentLayer); + Result.FadeFrom := AFrom; + Result.FadeTo := ATo; + Result.Opacity := AFrom; + It := AProject.FindMedia(AClip.MediaId); + if It = nil then + Exit; + Result.FilePath := It.EffectivePath; + Result.IsImage := (AClip.Kind = ckImage) or (It.Info.Kind = mkImage); + Result.SrcStart := AClip.SrcIn + (AAt - AClip.TlStart); + Result.KeyEnabled := AClip.ColorKey.Enabled; + Result.KeyColor := AClip.ColorKey.Color; + Result.KeySimilarity := AClip.ColorKey.Similarity; + Result.KeyBlend := AClip.ColorKey.Blend; + Result.Filter := TransformFilter(AClip.Transform, + It.Info.Width, It.Info.Height, + AProject.Master.Width, AProject.Master.Height); + Result.FitFilter := OverlayFilter(AClip.Transform, + It.Info.Width, It.Info.Height, + AProject.Master.Width, AProject.Master.Height, + Result.X, Result.Y, W, H); + if Result.Filter = '' then + Result.Filter := PreviewFitFilter(AProject.Master.Width, + AProject.Master.Height); + end; + + { Все звучащие клипы в этот момент, со всех слышимых звуковых дорожек. + + Если звучит ровно один и без перехода, слои не нужны — кусок описан + обычным способом. } + procedure CollectAudioLayers(AWinner, APartner: TClip; + const AAt, ASegStart: Double; var ASeg: TFlatSegment); + var + Ti, C, N: Integer; + Track: TTrack; + Cl: TClip; + + procedure Push(const ALayer: TSegmentLayer); + begin + SetLength(ASeg.Layers, N + 1); + ASeg.Layers[N] := ALayer; + Inc(N); + end; + + begin + N := 0; + ASeg.Layers := nil; + + if APartner <> nil then + begin + { Переход на дорожке победителя: один уходит, другой приходит. } + if APartner.TlStart < AWinner.TlStart then + begin + Push(LayerOf(APartner, ASegStart, APartner.Volume, 0)); + Push(LayerOf(AWinner, ASegStart, 0, AWinner.Volume)); + end + else + begin + Push(LayerOf(AWinner, ASegStart, AWinner.Volume, 0)); + Push(LayerOf(APartner, ASegStart, 0, APartner.Volume)); + end; + end + else + Push(LayerOf(AWinner, ASegStart, AWinner.Volume, AWinner.Volume)); + + { Всё, что звучит одновременно на других звуковых дорожках. } + for Ti := 0 to AProject.TrackCount - 1 do + begin + Track := AProject.Tracks[Ti]; + if Track.Kind <> tkAudio then + Continue; + if not AProject.TrackAudible(Track) then + Continue; + for C := 0 to Track.Count - 1 do + begin + Cl := Track[C]; + if not Cl.Covers(AAt) then + Continue; + if (Cl = AWinner) or (Cl = APartner) then + Continue; + Push(LayerOf(Cl, ASegStart, Cl.Volume, Cl.Volume)); + end; + end; + + { Звучит ровно один клип и без перехода — смешивать нечего, кусок + описывается обычным способом и обходится без пересборки. } + if N < 2 then + ASeg.Layers := nil; + end; + + function IsHidden(AClip: TClip): Boolean; + begin + Result := (AHidden <> nil) and (AHidden.IndexOf(AClip) >= 0); + end; + + { Клип дорожки в этот момент, не считая спрятанных. } + function VisibleClipAt(ATrack: TTrack; const ATime: Double): TClip; + var + C: Integer; + Cl: TClip; + begin + Result := nil; + for C := 0 to ATrack.Count - 1 do + begin + Cl := ATrack[C]; + if Cl.Covers(ATime) and (not IsHidden(Cl)) then + Exit(Cl); + end; + end; { Клип, побеждающий в указанный момент: с самой верхней дорожки. } function WinnerAt(const ATime: Double): TClip; @@ -215,11 +607,70 @@ var Result := nil; for Ti := 0 to AProject.TrackCount - 1 do begin + if AProject.Tracks[Ti].Kind <> AKind then + Continue; { Выключенные дорожки пропускаются, а если где-то включено «соло» — то и все несолирующие. } if not AProject.TrackAudible(AProject.Tracks[Ti]) then Continue; - Cl := AProject.Tracks[Ti].ClipAt(ATime); + Cl := VisibleClipAt(AProject.Tracks[Ti], ATime); + if Cl <> nil then + Exit(Cl); + end; + end; + + { Номер дорожки, на которой стоит клип. } + function TrackIndexOfClip(AClip: TClip): Integer; + var + Ti: Integer; + begin + Result := -1; + for Ti := 0 to AProject.TrackCount - 1 do + if AProject.Tracks[Ti].IndexOf(AClip) >= 0 then + Exit(Ti); + end; + + { Второй клип, покрывающий тот же момент на той же дорожке. + + Два клипа на одной дорожке, наползшие друг на друга, — это переход: + один перетекает в другой. На разных дорожках такое означает не + переход, а наложение, и разбирается отдельно. } + function OverlapPartner(AClip: TClip; const ATime: Double): TClip; + var + Ti, C: Integer; + Track: TTrack; + Cl: TClip; + begin + Result := nil; + Ti := TrackIndexOfClip(AClip); + if Ti < 0 then + Exit; + Track := AProject.Tracks[Ti]; + for C := 0 to Track.Count - 1 do + begin + Cl := Track[C]; + if (Cl <> AClip) and Cl.Covers(ATime) and (not IsHidden(Cl)) then + Exit(Cl); + end; + end; + + { Клип под победителем: нужен, когда победитель полупрозрачен. } + function BelowAt(AClip: TClip; const ATime: Double): TClip; + var + Ti, Start: Integer; + Cl: TClip; + begin + Result := nil; + Start := TrackIndexOfClip(AClip); + if Start < 0 then + Exit; + for Ti := Start + 1 to AProject.TrackCount - 1 do + begin + if AProject.Tracks[Ti].Kind <> AKind then + Continue; + if not AProject.TrackAudible(AProject.Tracks[Ti]) then + Continue; + Cl := VisibleClipAt(AProject.Tracks[Ti], ATime); if Cl <> nil then Exit(Cl); end; @@ -236,19 +687,32 @@ begin N := 0; for T := 0 to AProject.TrackCount - 1 do Inc(N, AProject.Tracks[T].Count * 2); - SetLength(Bounds, N + 2); + SetLength(Bounds, N + 3); BoundCount := 0; AddBoundary(Bounds, BoundCount, 0); + { Конец задан снаружи: оба потока должны быть одной длины. } + if AMinLength > 0 then + AddBoundary(Bounds, BoundCount, AMinLength); for T := 0 to AProject.TrackCount - 1 do begin Track := AProject.Tracks[T]; + if Track.Kind <> AKind then + Continue; if not AProject.TrackAudible(Track) then Continue; for C := 0 to Track.Count - 1 do begin AddBoundary(Bounds, BoundCount, Track[C].TlStart); AddBoundary(Bounds, BoundCount, Track[C].TlEnd); + { Границы затуханий: внутри них доля меняется, снаружи нет, значит + это разные куски. } + if Track[C].FadeIn > 0 then + AddBoundary(Bounds, BoundCount, + Track[C].TlStart + Min(Track[C].FadeIn, Track[C].Duration)); + if Track[C].FadeOut > 0 then + AddBoundary(Bounds, BoundCount, + Track[C].TlEnd - Min(Track[C].FadeOut, Track[C].Duration)); end; end; @@ -332,12 +796,16 @@ begin Seg.PreciseIn := (Winner.EdgeIn = edPrecise) and (Abs(SegStart - Winner.TlStart) < 0.0005); - { Файл, не совпадающий с параметрами проекта, скопировать нельзя: - придётся пересобрать. Но только его куски — всё остальное + { Кусок нельзя скопировать по двум причинам: файл не совпадает с + параметрами проекта, либо у клипа своё кадрирование. И то, и + другое требует пересборки — но только этого куска, всё остальное по-прежнему копируется. } - Seg.Transcode := HasBlocking(CompareToMaster(AProject.Master, Item.Info)); + Seg.Transcode := HasBlocking(CompareToMaster(AProject.Master, Item.Info)) + or (not TransformIsIdentity(Winner.Transform, + Item.Info.Width, Item.Info.Height, + AProject.Master.Width, AProject.Master.Height)); if Seg.Transcode then - Seg.Filter := TransformFilter(Item.Transform, + Seg.Filter := TransformFilter(Winner.Transform, Item.Info.Width, Item.Info.Height, AProject.Master.Width, AProject.Master.Height); @@ -355,6 +823,97 @@ begin if (MaxLen > 0) and (Seg.Duration > MaxLen - 0.001) then Seg.Duration := Max(0.001, MaxLen - 0.001); end; + + { --- Наложение --- } + + Partner := OverlapPartner(Winner, Mid); + Under := nil; + { Ключ работает так же, как полупрозрачность: клип перестаёт быть + сплошным, и участок приходится собирать вместе с тем, что под + ним. } + if (Partner = nil) and + ((Winner.Opacity < 0.999) or Winner.ColorKey.Enabled) then + Under := BelowAt(Winner, Mid); + + { Ручное затухание: кусок попал в зону появления или ухода. Слой + один, но с меняющейся долей — дальше это обрабатывается тем же + путём, что и переход между двумя клипами. } + if (Partner = nil) and (Under = nil) and Winner.ColorKey.Enabled then + begin + { Ключ есть, а класть не на что — всё равно пересобираем. } + SetLength(Seg.Layers, 1); + Seg.Layers[0] := LayerOf(Winner, SegStart, 1, 1); + Seg.Transcode := True; + end + else if (Partner = nil) and (Under = nil) then + begin + if (Winner.FadeIn > 0) and (SegEnd <= Winner.TlStart + Winner.FadeIn + 0.0005) then + begin + SetLength(Seg.Layers, 1); + Seg.Layers[0] := LayerOf(Winner, SegStart, + (SegStart - Winner.TlStart) / Winner.FadeIn, + (SegEnd - Winner.TlStart) / Winner.FadeIn); + Seg.Transcode := True; + end + else if (Winner.FadeOut > 0) and + (SegStart >= Winner.TlEnd - Winner.FadeOut - 0.0005) then + begin + SetLength(Seg.Layers, 1); + Seg.Layers[0] := LayerOf(Winner, SegStart, + (Winner.TlEnd - SegStart) / Winner.FadeOut, + (Winner.TlEnd - SegEnd) / Winner.FadeOut); + Seg.Transcode := True; + end; + end; + + { Звуковые дорожки смешиваются, а не побеждают друг друга. + + Правило «верхний побеждает» придумано для картинки: оно и делает + возможной сборку копированием. Для звука оно бессмысленно — без + смешивания нельзя положить фоновую музыку под голос. И стоит оно + ничего: звук у нас всё равно перекодируется. } + if AKind = tkAudio then + begin + CollectAudioLayers(Winner, Partner, Mid, SegStart, Seg); + if Length(Seg.Layers) > 0 then + Seg.Transcode := True; + end + else if (Partner <> nil) or (Under <> nil) then + begin + SetLength(Seg.Layers, 2); + if Partner <> nil then + begin + { Переход на одной дорожке: кто начался раньше, тот уходит. + Нижним слоем идёт уходящий, верхним приходящий. } + if Partner.TlStart < Winner.TlStart then + begin + Seg.Layers[0] := LayerOf(Partner, SegStart, 1, 0); + Seg.Layers[1] := LayerOf(Winner, SegStart, 0, 1); + end + else + begin + Seg.Layers[0] := LayerOf(Winner, SegStart, 1, 0); + Seg.Layers[1] := LayerOf(Partner, SegStart, 0, 1); + end; + end + else if Under <> nil then + begin + { Полупрозрачный клип или клип с ключом поверх нижнего. } + Seg.Layers[0] := LayerOf(Under, SegStart, 1, 1); + Seg.Layers[1] := LayerOf(Winner, SegStart, + Winner.Opacity, Winner.Opacity); + end + else + begin + { Под клипом ничего нет, но ключ всё равно надо применить: + вырезанное станет чёрным. } + SetLength(Seg.Layers, 1); + Seg.Layers[0] := LayerOf(Winner, SegStart, + Winner.Opacity, Winner.Opacity); + end; + { Собрать такой участок копированием нельзя. } + Seg.Transcode := True; + end; end; Raw[RawCount] := Seg; @@ -373,6 +932,9 @@ begin if (Raw[I].Kind = ASegments[N].Kind) and (Raw[I].FilePath = ASegments[N].FilePath) and (Raw[I].Kind = skVideo) and + { Участок с наложением склеивать с соседним нельзя: у него свой + набор слоёв, и в объединённом куске он потерялся бы. } + (Length(Raw[I].Layers) = 0) and (Length(ASegments[N].Layers) = 0) and (Abs(Raw[I].Volume - ASegments[N].Volume) < 0.001) and (Abs((ASegments[N].SrcStart + ASegments[N].Duration) - Raw[I].SrcStart) < 0.0005) then { Идут подряд в одном файле — это один кусок, а не два. } @@ -419,4 +981,329 @@ begin Result := True; end; +function FlattenAudioTrack(AProject: TProject; ATrack: TTrack; + const ATotal: Double; + out ASegments: TFlatSegmentArray; out AMissing: TGenRequests): Boolean; +var + C, N: Integer; + At: Double; + Clip: TClip; + Item: TMediaItem; + Seg: TFlatSegment; + Req: TGenRequest; + Path: string; + + procedure PushSilence(const ALen: Double); + begin + if ALen <= 0.0005 then + Exit; + Seg := Default(TFlatSegment); + Seg.Volume := 1; + Seg.Kind := skBlack; + Seg.Duration := ALen; + { Тишина без картинки: см. пояснение у gkSilence. } + Req.Kind := gkSilence; + Req.SourcePath := ''; + Req.Duration := BucketFor(ALen); + Req.TargetPath := GeneratedPath(AProject.CacheDir, Req); + Seg.FilePath := Req.TargetPath; + if not FileExists(Req.TargetPath) then + begin + SetLength(AMissing, Length(AMissing) + 1); + AMissing[High(AMissing)] := Req; + end; + SetLength(ASegments, N + 1); + ASegments[N] := Seg; + Inc(N); + end; + +begin + ASegments := nil; + AMissing := nil; + Result := False; + if (AProject = nil) or (ATrack = nil) then + Exit; + + N := 0; + At := 0; + ATrack.Sort; + for C := 0 to ATrack.Count - 1 do + begin + Clip := ATrack[C]; + { Клипы на дорожке могут наползать друг на друга. В предпросмотре это + разбирается проще некуда: наползший кусок начинается там, где + кончился предыдущий. Переход в предпросмотре не показывается — он + виден в готовом ролике. } + if Clip.TlEnd <= At + 0.0005 then + Continue; + if Clip.TlStart > At then + PushSilence(Clip.TlStart - At); + + Item := AProject.FindMedia(Clip.MediaId); + if Item = nil then + Continue; + + Seg := Default(TFlatSegment); + Seg.Kind := skVideo; + Seg.Volume := Clip.Volume; + Seg.FilePath := Item.EffectivePath; + Seg.SrcStart := Clip.SrcIn + Max(0, At - Clip.TlStart); + Seg.Duration := Clip.TlEnd - Max(At, Clip.TlStart); + SetLength(ASegments, N + 1); + ASegments[N] := Seg; + Inc(N); + At := Clip.TlEnd; + end; + + if ATotal > At then + PushSilence(ATotal - At); + + Result := N > 0; +end; + +function FlattenProject(AProject: TProject; + out AVideo, AAudio: TFlatSegmentArray; + out AMissing: TGenRequests): Boolean; +var + MissA: TGenRequests; + I: Integer; + Total: Double; +begin + AAudio := nil; + MissA := nil; + { Длина берётся по обоим видам дорожек сразу: иначе выключенная + картинка укоротила бы ролик, хотя звук ещё идёт. } + Total := Max(AudibleEnd(AProject, tkVideo), AudibleEnd(AProject, tkAudio)); + if Total <= 0 then + Exit; + + Result := FlattenStream(AProject, tkVideo, Total, AVideo, AMissing); + if not Result then + Exit; + FlattenStream(AProject, tkAudio, Total, AAudio, MissA); + + for I := 0 to High(MissA) do + begin + SetLength(AMissing, Length(AMissing) + 1); + AMissing[High(AMissing)] := MissA[I]; + end; +end; + +{ Вырезает из набора отрезков указанный. Отрезок посередине делит тот, в + который попал, надвое: оверлей, закрытый в середине, показывается двумя + окнами. } +procedure CutRange(var AFrom, ATo: TDoubleArray; var ACount: Integer; + const ACutFrom, ACutTo: Double); +var + I, N: Integer; + NewFrom, NewTo: array of Double; + + procedure Push(const A, B: Double); + begin + if B <= A + 0.001 then + Exit; + NewFrom[N] := A; + NewTo[N] := B; + Inc(N); + end; + +begin + if ACutTo <= ACutFrom then + Exit; + SetLength(NewFrom, ACount * 2 + 2); + SetLength(NewTo, ACount * 2 + 2); + N := 0; + for I := 0 to ACount - 1 do + begin + { Не пересекаются — отрезок остаётся как был. } + if (ACutTo <= AFrom[I] + 0.001) or (ACutFrom >= ATo[I] - 0.001) then + Push(AFrom[I], ATo[I]) + else + begin + Push(AFrom[I], ACutFrom); + Push(ACutTo, ATo[I]); + end; + end; + + ACount := N; + SetLength(AFrom, N); + SetLength(ATo, N); + for I := 0 to N - 1 do + begin + AFrom[I] := NewFrom[I]; + ATo[I] := NewTo[I]; + end; +end; + +{ Клип кладётся поверх, а не побеждает целиком, если он не сплошной: + с выбитым цветом или полупрозрачный. } +function IsOverlayClip(AClip: TClip): Boolean; +begin + Result := (AClip <> nil) and (AClip.Kind in [ckVideo, ckImage]) and + (AClip.ColorKey.Enabled or (AClip.Opacity < 0.999)); +end; + +function FlattenPreview(AProject: TProject; + out AVideo, AAudio: TFlatSegmentArray; + out AOverlays: TPreviewOverlays; + out AMissing: TGenRequests; + AWithKey: Boolean): Boolean; +var + Hidden: TFPList; + MissA: TGenRequests; + T, C, I, J, K, N: Integer; + Track, Above: TTrack; + Clip: TClip; + Item: TMediaItem; + Total: Double; + RangeA, RangeB: TDoubleArray; + RangeCount: Integer; + Ov: TPreviewOverlay; + + { Занято ли это время другим оверлеем. } + function OverlapsTaken(const AFrom, ATo: Double): Boolean; + var + K: Integer; + begin + Result := False; + for K := 0 to High(AOverlays) do + if (AFrom < AOverlays[K].TlEnd - 0.001) and + (ATo > AOverlays[K].TlStart + 0.001) then + Exit(True); + end; + +begin + AVideo := nil; + AAudio := nil; + AOverlays := nil; + AMissing := nil; + MissA := nil; + Result := False; + if AProject = nil then + Exit; + + Total := Max(AudibleEnd(AProject, tkVideo), AudibleEnd(AProject, tkAudio)); + if Total <= 0 then + Exit; + + Hidden := TFPList.Create; + try + N := 0; + for T := 0 to AProject.TrackCount - 1 do + begin + Track := AProject.Tracks[T]; + if Track.Kind <> tkVideo then + Continue; + if not AProject.TrackAudible(Track) then + Continue; + for C := 0 to Track.Count - 1 do + begin + Clip := Track[C]; + if not IsOverlayClip(Clip) then + Continue; + Item := AProject.FindMedia(Clip.MediaId); + if Item = nil then + Continue; + + { Оверлей играется одной дорожкой поверх основы, а одна дорожка + не может показывать два куска разом. Если такой клип наложился + на уже взятый, он остаётся в основе и сводится по-старому: + потерять его было бы хуже. } + if OverlapsTaken(Clip.TlStart, Clip.TlEnd) then + Continue; + + Hidden.Add(Clip); + + { Оверлей виден не всюду, где лежит: сверху его может закрывать + сплошной клип, и в готовом ролике его там не будет — побеждает + верхняя дорожка целиком. Показывать в окне то, чего не будет в + ролике, нельзя: именно из-за такого расхождения человек собирает + ролик и не находит в нём миникарты. + + Закрывать могут и посередине — тогда от оверлея остаётся + несколько отрезков, и каждый становится своим окном показа. } + RangeCount := 1; + SetLength(RangeA, 1); + SetLength(RangeB, 1); + RangeA[0] := Clip.TlStart; + RangeB[0] := Clip.TlEnd; + + for K := 0 to T - 1 do + begin + Above := AProject.Tracks[K]; + if Above.Kind <> tkVideo then + Continue; + if not AProject.TrackAudible(Above) then + Continue; + for J := 0 to Above.Count - 1 do + { Клип с ключом или прозрачностью сам ничего не закрывает. } + if not IsOverlayClip(Above[J]) then + CutRange(RangeA, RangeB, RangeCount, + Above[J].TlStart, Above[J].TlEnd); + end; + + for J := 0 to RangeCount - 1 do + begin + if RangeB[J] <= RangeA[J] + 0.001 then + Continue; + if OverlapsTaken(RangeA[J], RangeB[J]) then + Continue; + + Ov := Default(TPreviewOverlay); + Ov.TlStart := RangeA[J]; + Ov.TlEnd := RangeB[J]; + Ov.FilePath := Item.EffectivePath; + Ov.SrcStart := Clip.SrcIn + (RangeA[J] - Clip.TlStart); + Ov.Filter := OverlayFilter(Clip.Transform, + Item.Info.Width, Item.Info.Height, + AProject.Master.Width, AProject.Master.Height, + Ov.X, Ov.Y, Ov.Width, Ov.Height); + { Порядок тот же, что при сборке: сперва вписали в кадр, потом + выбили цвет, потом приглушили. Иначе смягчение края разошлось + бы с тем, что даст готовый ролик. } + if AWithKey then + begin + if Clip.ColorKey.Enabled then + Ov.Filter := Ov.Filter + ',' + ColorKeyFilter(Clip.ColorKey.Color, + Clip.ColorKey.Similarity, Clip.ColorKey.Blend); + if OpacityFilter(Clip.Opacity) <> '' then + Ov.Filter := Ov.Filter + ',' + OpacityFilter(Clip.Opacity); + end; + + SetLength(AOverlays, N + 1); + AOverlays[N] := Ov; + Inc(N); + end; + end; + end; + + { По времени: список кусков оверлея строится подряд, дырами между + ними. } + for I := 1 to High(AOverlays) do + begin + Ov := AOverlays[I]; + C := I - 1; + while (C >= 0) and (AOverlays[C].TlStart > Ov.TlStart) do + begin + AOverlays[C + 1] := AOverlays[C]; + Dec(C); + end; + AOverlays[C + 1] := Ov; + end; + + Result := FlattenStream(AProject, tkVideo, Total, AVideo, AMissing, Hidden); + if not Result then + Exit; + FlattenStream(AProject, tkAudio, Total, AAudio, MissA); + finally + Hidden.Free; + end; + + for I := 0 to High(MissA) do + begin + SetLength(AMissing, Length(AMissing) + 1); + AMissing[High(AMissing)] := MissA[I]; + end; +end; + end. diff --git a/src/uGenerate.pas b/src/uGenerate.pas index 6042bd3..75b3fdb 100644 --- a/src/uGenerate.pas +++ b/src/uGenerate.pas @@ -53,6 +53,14 @@ type property StageText: string read FStageText; property Fraction: Double read FFraction; + { Сколько всего заказано и сколько уже сделано. Нужно показателю + работы: по ним он знает, докуда ползти до следующей вехи. } + function Total: Integer; + property Done: Integer read FCurrent; + { Место на монтаже, которое считается прямо сейчас. Ноль в обоих — + значит, к монтажу это отношения не имеет. } + function BusyFrom: Double; + function BusyTo: Double; property PendingLog: string read FPendingLog; property Succeeded: Boolean read FSucceeded; property Cancelled: Boolean read FCancelled; @@ -113,6 +121,27 @@ begin Log('ffmpeg: ' + ALine); end; +function TGenerateThread.Total: Integer; +begin + Result := Length(FRequests); +end; + +function TGenerateThread.BusyFrom: Double; +begin + if (FCurrent >= 0) and (FCurrent <= High(FRequests)) then + Result := FRequests[FCurrent].TlStart + else + Result := 0; +end; + +function TGenerateThread.BusyTo: Double; +begin + if (FCurrent >= 0) and (FCurrent <= High(FRequests)) then + Result := FRequests[FCurrent].TlEnd + else + Result := 0; +end; + procedure TGenerateThread.Publish; begin if Length(FRequests) > 0 then @@ -175,6 +204,12 @@ begin gkImage: FStageText := Format('Делаю клип из картинки %d из %d', [I + 1, Length(FRequests)]); + gkSilence: + FStageText := Format('Делаю вставку тишины %d из %d', + [I + 1, Length(FRequests)]); + gkLayers: + FStageText := Format('Собираю наложение %d из %d', + [I + 1, Length(FRequests)]); end; Publish; @@ -191,11 +226,26 @@ begin FMaster.VideoCodec, FMaster.PixFmt, AudioCodec, FMaster.SampleRate, FMaster.Channels); gkImage: + { Фотография попадает в ролик наравне со съёмкой, и жать её + сильнее, чем её соседей, незачем. } Args := ArgsImageClip(FRequests[I].SourcePath, FRequests[I].TargetPath, FRequests[I].Duration, FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen, FMaster.VideoCodec, FMaster.PixFmt, AudioCodec, + FMaster.SampleRate, FMaster.Channels, FMaster.VideoBitrate); + gkSilence: + Args := ArgsSilenceClip(FRequests[I].TargetPath, + FRequests[I].Duration, AudioCodec, FMaster.SampleRate, FMaster.Channels); + gkLayers: + { Тот же расчёт, что и при сборке ролика: прозрачность — + наложением с приглушённым альфа-каналом, переход — фильтром + xfade. Разными путями считать одно и то же нельзя, иначе + предпросмотр разойдётся с готовым роликом. } + Args := ArgsRenderLayers(FRequests[I].Layers, + FRequests[I].TargetPath, FRequests[I].Duration, + FMaster.Width, FMaster.Height, FMaster.FpsNum, FMaster.FpsDen, + FMaster.PixFmt, FMaster.VideoCodec, False, FMaster.VideoBitrate); else Continue; end; diff --git a/src/uIconData.pas b/src/uIconData.pas new file mode 100644 index 0000000..2487924 --- /dev/null +++ b/src/uIconData.pas @@ -0,0 +1,488 @@ +{ + uIconData — значки, вшитые в программу. + + Собран из файлов в icons_online командой: + + python3 tools/make_icons.py + + Правится не он, а исходные картинки: этот файл переписывается целиком. + + Значки взяты у Icons8 и требуют указания авторства — оно есть в окне + «О программе», вкладка «Библиотеки и авторство». Ссылки на каждый значок + лежат в icons_online/attribution.txt. + + Картинки чёрные на прозрачном фоне. Цвет им задаётся при отрисовке: + берётся прозрачность точки, а цвет — тот, каким сейчас рисуется кнопка. + Поэтому один и тот же значок годится и для тёмной кнопки, и для + оранжевой. +} +unit uIconData; + +{$mode objfpc}{$H+} + +interface + +const + { icons8-магнит-30.png, 24 на 24 точек } + IconSnapData: array[0..472] of Byte = ( + $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52, + $00, $00, $00, $18, $00, $00, $00, $18, $08, $04, $00, $00, $00, $4A, $7E, $F5, + $73, $00, $00, $00, $20, $63, $48, $52, $4D, $00, $00, $7A, $26, $00, $00, $80, + $84, $00, $00, $FA, $00, $00, $00, $80, $E8, $00, $00, $75, $30, $00, $00, $EA, + $60, $00, $00, $3A, $98, $00, $00, $17, $70, $9C, $BA, $51, $3C, $00, $00, $00, + $02, $62, $4B, $47, $44, $00, $00, $AA, $8D, $23, $32, $00, $00, $00, $09, $70, + $48, $59, $73, $00, $00, $0B, $13, $00, $00, $0B, $13, $01, $00, $9A, $9C, $18, + $00, $00, $00, $07, $74, $49, $4D, $45, $07, $EA, $08, $1F, $07, $2E, $1B, $C7, + $2C, $48, $09, $00, $00, $01, $3E, $49, $44, $41, $54, $38, $CB, $BD, $92, $31, + $4B, $C3, $40, $14, $C7, $7F, $97, $44, $29, $68, $03, $5A, $45, $EA, $D0, $A5, + $6B, $41, $44, $5C, $0A, $0E, $3A, $15, $DC, $1D, $DD, $FB, $51, $74, $71, $29, + $F8, $39, $EC, $62, $06, $17, $5D, $EA, $22, $D2, $88, $93, $E0, $22, $68, $A1, + $AD, $14, $AA, $A0, $B6, $E6, $39, $24, $17, $AE, $69, $32, $88, $D4, $77, $4B, + $EE, $DD, $EF, $7F, $EF, $DD, $FB, $07, $66, $1D, $6A, $6A, $EF, $B2, $4D, $85, + $22, $F3, $74, $B9, $E3, $9A, $1E, $92, $2D, $5F, $E0, $80, $0B, $9E, $78, $27, + $40, $F8, $E4, $85, $4B, $0E, $71, $B3, $F0, $35, $4E, $78, $45, $12, $6B, $40, + $83, $62, $1A, $BE, $44, $83, $AF, $29, $5C, $10, $46, $9C, $B2, $9C, $C4, $1D, + $EA, $0C, $53, $71, $41, $78, $A3, $8E, $33, $29, $28, $E1, $67, $E2, $82, $E0, + $53, $0A, $41, $2B, $9A, $CD, $1E, $65, $43, $3E, $C0, $C7, $67, $60, $64, $CA, + $EC, $86, $13, $D5, $82, $2A, $B9, $F8, $B0, $C7, $11, $35, $6A, $1C, $D3, $8F, + $73, $39, $AA, $A6, $05, $16, $9E, $51, $BE, $49, $01, $80, $02, $4D, $23, $EB, + $85, $97, $EB, $0A, $E6, $AC, $3B, $D1, $CD, $7D, $3A, $46, $D6, $35, $5B, $9A, + $74, $5C, $52, $BE, $62, $C2, $E2, $97, $31, $7B, $81, $F6, $4F, $F1, $41, $1B, + $61, $8E, $AD, $04, $71, $C3, $08, $C5, $86, $7E, $83, $16, $D8, $DC, $B3, $C3, + $37, $AB, $3C, $18, $03, $50, $0C, $D9, $A7, $8B, $4D, $0B, $FB, $8F, $2D, $8D, + $D9, $A4, $85, $E0, $90, $27, $88, $4F, $03, $F2, $78, $8C, $51, $54, $B8, $D5, + $AD, $84, $A5, $D7, $59, $C4, $02, $84, $47, $CE, $68, $47, $82, $02, $2B, $11, + $F1, $CC, $39, $57, $88, $B6, $43, $A1, $8C, $CE, $83, $D8, $30, $65, $B4, $1C, + $FE, $20, $FF, $10, $3F, $90, $74, $7D, $D8, $DF, $AB, $6B, $DD, $00, $00, $00, + $00, $49, $45, $4E, $44, $AE, $42, $60, $82 + ); + + { icons8-merge-vertical-64.png, 24 на 24 точек } + IconRippleData: array[0..457] of Byte = ( + $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52, + $00, $00, $00, $18, $00, $00, $00, $18, $08, $04, $00, $00, $00, $4A, $7E, $F5, + $73, $00, $00, $00, $20, $63, $48, $52, $4D, $00, $00, $7A, $26, $00, $00, $80, + $84, $00, $00, $FA, $00, $00, $00, $80, $E8, $00, $00, $75, $30, $00, $00, $EA, + $60, $00, $00, $3A, $98, $00, $00, $17, $70, $9C, $BA, $51, $3C, $00, $00, $00, + $02, $62, $4B, $47, $44, $00, $00, $AA, $8D, $23, $32, $00, $00, $00, $09, $70, + $48, $59, $73, $00, $00, $0B, $13, $00, $00, $0B, $13, $01, $00, $9A, $9C, $18, + $00, $00, $00, $07, $74, $49, $4D, $45, $07, $EA, $08, $1F, $07, $2E, $1B, $C7, + $2C, $48, $09, $00, $00, $01, $2F, $49, $44, $41, $54, $38, $CB, $CD, $D2, $3D, + $2F, $83, $51, $18, $C6, $F1, $DF, $C3, $63, $31, $34, $11, $B5, $35, $D1, $A9, + $C1, $E0, $25, $4C, $66, $49, $F9, $16, $24, $96, $C6, $37, $A8, $18, $7D, $02, + $31, $98, $18, $99, $25, $44, $F8, $02, $26, $B1, $30, $30, $78, $D9, $90, $18, + $24, $35, $F4, $B4, $8F, $A1, $8A, $7A, $5A, $D2, $45, $FC, $C7, $73, $DF, $D7, + $7D, $AE, $EB, $3E, $87, $2E, $89, $52, $27, $3D, $7A, $50, $43, $2F, $EA, $EA, + $BF, $8D, $28, $3A, $B6, $A9, $5F, $BF, $4D, $C7, $8A, $DF, $CB, $71, $4A, $90, + $33, $27, $2B, $C6, $AC, $49, $BB, $69, $03, $5D, $F2, $77, $82, $A8, $CD, $BE, + $BE, $F2, $51, $6F, $0A, $46, $2D, $E8, $EB, $D8, $1E, $2B, $1A, $69, $15, $0C, + $DB, $B6, $66, $A8, $6D, $7B, $D6, $AA, $1D, $F9, $A6, $B6, $60, $40, $50, $90, + $55, $36, $A3, $FC, $CD, $5A, $64, $C2, $BA, $79, $91, $82, $07, $B1, $67, $F6, + $54, $BC, $78, $95, $48, $24, $AE, $1D, $49, $9C, $C9, $C8, $38, $93, $38, $74, + $F5, $5E, $79, $F5, $A2, $62, $2F, $16, $54, $D5, $BE, $CC, $4C, $3A, $E4, $08, + $AA, $EA, $02, $79, $E3, $C6, $94, $D4, $04, $07, $26, $2D, $B7, $DC, $B0, $6C, + $C2, $BE, $A0, $A6, $64, $CC, $B8, $7C, $EC, $E6, $3D, $F4, $93, $2D, $1B, $1E, + $4D, $B7, $CC, $4D, $9C, $5B, $B2, $A2, $E4, $C6, $45, $23, $74, $83, $5B, $8B, + $4E, $54, $DB, $9A, $79, $B2, $EE, $D4, $5D, $73, $4B, $0D, $2E, $5D, $76, $74, + $4F, $70, $F4, $F9, $24, $3F, $47, $4D, $AD, $E2, $1F, $FF, $D6, $4F, $AA, $2A, + $EE, $05, $C1, $BD, $4A, $87, $BD, $B5, $30, $68, $4A, $4E, $24, $92, $33, $65, + $B0, $5B, $07, $29, $DE, $00, $F6, $77, $56, $B3, $E2, $94, $4B, $80, $00, $00, + $00, $00, $49, $45, $4E, $44, $AE, $42, $60, $82 + ); + + { icons8-property-30.png, 24 на 24 точек } + IconLogData: array[0..425] of Byte = ( + $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52, + $00, $00, $00, $18, $00, $00, $00, $18, $08, $04, $00, $00, $00, $4A, $7E, $F5, + $73, $00, $00, $00, $20, $63, $48, $52, $4D, $00, $00, $7A, $26, $00, $00, $80, + $84, $00, $00, $FA, $00, $00, $00, $80, $E8, $00, $00, $75, $30, $00, $00, $EA, + $60, $00, $00, $3A, $98, $00, $00, $17, $70, $9C, $BA, $51, $3C, $00, $00, $00, + $02, $62, $4B, $47, $44, $00, $00, $AA, $8D, $23, $32, $00, $00, $00, $09, $70, + $48, $59, $73, $00, $00, $0B, $13, $00, $00, $0B, $13, $01, $00, $9A, $9C, $18, + $00, $00, $00, $07, $74, $49, $4D, $45, $07, $EA, $08, $1F, $07, $2E, $1B, $C7, + $2C, $48, $09, $00, $00, $01, $0F, $49, $44, $41, $54, $38, $CB, $B5, $D3, $BF, + $2E, $83, $51, $18, $C7, $F1, $CF, $5B, $15, $0C, $74, $93, $88, $91, $0B, $E8, + $68, $60, $33, $34, $B1, $1A, $F4, $1E, $0C, $66, $8B, $C5, $05, $B8, $01, $89, + $2B, $30, $18, $24, $4C, $0D, $8B, $41, $13, $46, $62, $90, $18, $A4, $4B, $55, + $3A, $28, $AD, $F7, $18, $AA, $F5, $36, $DA, $B7, $25, $3C, $67, $38, $27, $4F, + $9E, $EF, $79, $FE, $9C, $F3, $E3, $BF, $2D, $42, $24, $12, $8D, $10, $1B, $04, + $21, $8B, $39, $5B, $96, $65, $84, $D4, $8B, $63, $E7, $F6, $3C, $42, $51, $A3, + $4D, $0F, $59, $2F, $36, $C8, $60, $C6, $C4, $48, $E5, $4F, $CA, $B5, $81, $1F, + $59, $F6, $73, $7F, $D6, $1C, $12, $39, $2E, $97, $04, $8A, $2E, $BA, $E7, $7E, + $D6, $B2, $E4, $38, $09, $D4, $3C, $0D, $C9, $50, $EB, $2D, $09, $F2, $0A, $0E, + $B0, $69, $36, $E1, $6D, $3A, $72, $F2, $BD, $07, $98, $B7, $EA, $50, $B0, $66, + $B1, $FB, $26, $91, $86, $DB, $41, $C0, $A9, $92, $86, $60, $A5, $67, $76, $C1, + $5B, $BF, $29, $B5, $33, $E4, $95, $50, $90, $4B, $64, $68, $B9, $74, $DD, $1F, + $C8, $DB, $76, $23, $D8, $B5, $90, $F0, $BE, $DA, $19, $04, $9C, $B9, $73, $8F, + $75, $53, $09, $6F, $EC, $61, $50, $49, $55, $55, $70, $95, $36, $DD, $5F, $7F, + $8D, $08, $63, $29, $71, $EF, $1D, $C5, $74, $80, $7D, $F5, $54, $11, $05, $D3, + $5F, $40, $45, $59, $3C, $44, $73, $91, $BA, $B2, $4A, $47, $A2, $A3, $76, $12, + $A7, $AA, $F2, $8F, $EC, $03, $0F, $C8, $51, $5A, $EC, $EA, $63, $7C, $00, $00, + $00, $00, $49, $45, $4E, $44, $AE, $42, $60, $82 + ); + + { icons8-клей-30.png, 24 на 24 точек } + IconGlueData: array[0..513] of Byte = ( + $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52, + $00, $00, $00, $18, $00, $00, $00, $18, $08, $04, $00, $00, $00, $4A, $7E, $F5, + $73, $00, $00, $00, $20, $63, $48, $52, $4D, $00, $00, $7A, $26, $00, $00, $80, + $84, $00, $00, $FA, $00, $00, $00, $80, $E8, $00, $00, $75, $30, $00, $00, $EA, + $60, $00, $00, $3A, $98, $00, $00, $17, $70, $9C, $BA, $51, $3C, $00, $00, $00, + $02, $62, $4B, $47, $44, $00, $00, $AA, $8D, $23, $32, $00, $00, $00, $09, $70, + $48, $59, $73, $00, $00, $0B, $13, $00, $00, $0B, $13, $01, $00, $9A, $9C, $18, + $00, $00, $00, $07, $74, $49, $4D, $45, $07, $EA, $08, $1F, $07, $2E, $1B, $C7, + $2C, $48, $09, $00, $00, $01, $67, $49, $44, $41, $54, $38, $CB, $B5, $D3, $3D, + $4F, $93, $61, $14, $C6, $F1, $5F, $AB, $80, $9D, $A8, $A1, $71, $95, $08, $14, + $3F, $80, $71, $D2, $8D, $C5, $D8, $A4, $A6, $61, $31, $74, $32, $31, $1A, $99, + $89, $B3, $8B, $71, $B0, $7C, $0F, $37, $42, $4B, $07, $07, $D0, $98, $30, $E0, + $0E, $62, $59, $1C, $24, $18, $35, $61, $50, $04, $C2, $F3, $DC, $0E, $DE, $9A, + $96, $C2, $23, $0B, $67, $3D, $D7, $FF, $3A, $D7, $FD, $72, $38, $EF, $BA, $70, + $6A, $67, $D4, $23, $15, $87, $3E, $0B, $67, $31, $1A, $B7, $E8, $97, $D4, $86, + $AA, $8B, $FF, $97, $97, $2D, $49, $05, $41, $B0, $A5, $66, $20, $5B, $3E, $69, + $51, $12, $E5, $41, $F0, $31, $1B, $29, $47, $79, $DA, $85, $6C, $AA, $9D, $76, + $DA, $09, $6D, $89, $23, $0B, $66, $BC, $ED, $42, $3A, $AA, $27, $21, $A3, $9A, + $52, $41, $CB, $35, $DC, $F0, $A6, $6B, $CE, $86, $5B, $FD, $C0, $53, $FB, $82, + $A0, $A1, $00, $6E, $F6, $20, $CF, $21, $DF, $03, $14, $0D, $81, $FB, $1E, $18, + $C4, $7B, $73, $DE, $C5, $DE, $81, $DD, $FE, $09, $B7, $AD, $47, $B7, $1D, $4F, + $0C, $21, $A7, $2E, $15, $A4, $9A, $AE, $F6, $8A, $07, $8C, $B9, $A2, $A2, $13, + $91, $2F, $66, $15, $8C, $59, $10, $24, $DA, $26, $7A, $E5, $79, $53, $56, $CD, + $2B, $A9, $FA, $10, $91, $6D, $F3, $96, $1C, $49, $B4, $4C, $1E, $0F, $33, $6C, + $59, $F0, $43, $C3, $88, $7B, $36, $BB, $2E, $34, $D1, $72, $BD, $3F, $7D, $D1, + $9A, $20, $D8, $F3, $D2, $88, $EA, $BF, $60, $A9, $76, $BF, $FB, $9F, $48, $75, + $3F, $23, $D2, $50, $52, $B1, $2E, $B5, $A7, $79, $3C, $FB, $DF, $9F, $38, $A8, + $1C, $5F, $B2, $E0, $B1, $9C, $17, $1E, $BA, $6B, $D7, $2B, $9F, $4E, $F2, $CF, + $99, $F6, $4D, $B0, $1F, $A7, $AC, $1A, $97, $59, $25, $2B, $82, $AF, $9E, $A9, + $5B, $B3, $6C, $2A, $63, $B1, $C0, $8C, $8E, $15, $35, $97, $E4, $15, $0D, $67, + $C9, $73, $E0, $8E, $CB, $5E, $FB, $7E, $B6, $65, $3C, $EF, $FA, $0D, $91, $67, + $97, $14, $98, $55, $D3, $54, $00, $00, $00, $00, $49, $45, $4E, $44, $AE, $42, + $60, $82 + ); + + { icons8-цель-30.png, 24 на 24 точек } + IconTargetData: array[0..779] of Byte = ( + $89, $50, $4E, $47, $0D, $0A, $1A, $0A, $00, $00, $00, $0D, $49, $48, $44, $52, + $00, $00, $00, $18, $00, $00, $00, $18, $08, $04, $00, $00, $00, $4A, $7E, $F5, + $73, $00, $00, $00, $20, $63, $48, $52, $4D, $00, $00, $7A, $26, $00, $00, $80, + $84, $00, $00, $FA, $00, $00, $00, $80, $E8, $00, $00, $75, $30, $00, $00, $EA, + $60, $00, $00, $3A, $98, $00, $00, $17, $70, $9C, $BA, $51, $3C, $00, $00, $00, + $02, $62, $4B, $47, $44, $00, $00, $AA, $8D, $23, $32, $00, $00, $00, $09, $70, + $48, $59, $73, $00, $00, $0B, $13, $00, $00, $0B, $13, $01, $00, $9A, $9C, $18, + $00, $00, $00, $07, $74, $49, $4D, $45, $07, $EA, $08, $1F, $07, $2E, $1B, $C7, + $2C, $48, $09, $00, $00, $02, $71, $49, $44, $41, $54, $38, $CB, $95, $D4, $41, + $68, $DB, $65, $18, $06, $F0, $5F, $E2, $DA, $2A, $2E, $59, $B2, $65, $29, $4B, + $B4, $A7, $C9, $B0, $DB, $A0, $8C, $49, $63, $55, $50, $0F, $56, $31, $ED, $68, + $BA, $CB, $70, $3B, $C8, $F0, $24, $08, $0A, $1E, $44, $99, $4E, $AA, $B2, $5D, + $44, $86, $D9, $4D, $9B, $0E, $3C, $4D, $58, $87, $14, $75, $22, $C8, $DC, $9C, + $2B, $78, $4A, $D9, $84, $04, $6B, $93, $B5, $34, $15, $BB, $FE, $6B, $65, $5D, + $B5, $F1, $F0, $67, $AC, $DD, $40, $D8, $73, $FB, $E0, $7B, $78, $DF, $E7, $7D, + $DE, $E7, $E5, $1E, $11, $B9, $EB, $9D, $B0, $43, $46, $1C, $81, $69, $57, $2D, + $68, $AE, $FD, $B0, $01, $3C, $67, $97, $1F, $3C, $E1, $8C, $59, $AF, $3A, $20, + $23, $26, $22, $30, $E3, $8A, $AF, $9D, $31, $77, $9B, $70, $1F, $D8, $E7, $4D, + $3D, $0E, $DA, $62, $DC, $92, $55, $C3, $4E, $18, $71, $C1, $8A, $27, $E5, $ED, + $35, $A9, $BE, $9E, $70, $53, $8F, $9C, $16, $BB, $B4, $29, $B9, $EC, $2F, $AB, + $96, $D5, $7C, $67, $C4, $8A, $17, $F4, $FA, $5D, $65, $6D, $6B, $AF, $59, $D2, + $D4, $D4, $54, $13, $D7, $6F, $D2, $8A, $9B, $AA, $4E, $D9, $2F, $29, $AF, $6C, + $42, $4F, $A8, $37, $AC, $30, $23, $65, $B7, $28, $56, $7C, $26, $EA, $5F, $A3, + $CE, $F9, $D3, $D3, $06, $6D, $74, $DA, $55, $03, $1E, $F1, $AD, $BF, $43, $42, + $C4, $0D, $E3, $5A, $65, $FD, $E3, $41, $71, $A3, $C6, $FC, $EC, $8A, $F3, $C6, + $A4, $1C, $D2, $EA, $0B, $6D, $06, $5C, $F3, $4B, $D8, $50, $D2, $3B, $9E, $F1, + $80, $B8, $AC, $93, $16, $14, $6D, $B5, $DB, $59, $25, $DD, $D2, $4A, $1A, $06, + $75, $A8, $38, $2D, $11, $56, $E8, $F2, $B6, $55, $97, $3D, $25, $6A, $D4, $66, + $07, $6C, $31, $66, $D2, $CB, $FA, $9D, $F7, $A3, $7D, $36, $3A, $27, $E3, $31, + $17, $5C, $83, $82, $79, $07, $ED, $F4, $9B, $8F, $B4, $48, $F9, $D4, $BC, $A2, + $94, $01, $93, $86, $B5, $2B, $AA, $EA, $74, $C8, $BC, $42, $68, $5C, $4C, $4C, + $5D, $9B, $AC, $39, $4D, $DB, $BC, $2F, $E2, $25, $81, $0F, $8C, $7B, $D6, $B2, + $8A, $C3, $EE, $57, $17, $13, $BB, $E5, $74, $B8, $22, $4D, $4D, $31, $43, $4E, + $38, $22, $B0, $24, $22, $72, $F7, $F2, $6C, $C0, $A2, $45, $59, $B3, $EA, $B6, + $6B, $71, $DD, $C7, $8E, $18, $42, $C1, $5E, $DF, $6B, $B5, $5D, $CD, $0D, $3B, + $2D, $5A, $24, $8A, $69, $33, $72, $16, $5C, $D4, $2B, $A3, $88, $4F, $7C, $6E, + $D8, $90, $C0, $49, $DB, $F4, $BA, $E8, $BA, $9C, $E9, $50, $32, $09, $5F, $AA, + $78, $D8, $7E, $73, $4A, $D2, $BA, $95, $D4, $D4, $0C, $EB, $96, $36, $A2, $A1, + $A0, $43, $35, $1C, $6B, $88, $57, $34, $BC, $2B, $E9, $B8, $40, $49, $97, $B4, + $84, $A4, $B4, $2E, $25, $81, $63, $12, $8E, $9A, $75, $F8, $B6, $92, $AD, $BE, + $32, $25, $AF, $DD, $71, $0D, $55, $45, $AF, $7B, $43, $51, $55, $C3, $31, $ED, + $FA, $4C, $39, $2B, $B5, $36, $36, $3D, $26, $94, $F5, $49, $1A, $74, $4A, $C5, + $B2, $65, $15, $23, $0A, $12, $FA, $94, $95, $3D, $BE, $7E, $5E, $51, $79, $13, + $A6, $BC, $A7, $43, $46, $A7, $3D, $F6, $E8, $94, $D1, $E1, $A8, $9A, $B2, $17, + $45, $EF, $8C, $68, $44, $CE, $5B, $72, $02, $DF, $B8, $A4, $8E, $87, $E4, $3C, + $6F, $93, $9F, $7C, $E8, $D2, $AD, $34, $AC, $B7, $65, $B3, $7E, $79, $8F, $CA, + $88, $B1, $26, $A2, $7F, $FC, $DF, $11, $D8, $64, $87, $AC, $B8, $A6, $C0, $B4, + $5F, $EF, $3C, $02, $F7, $8C, $FF, $00, $D3, $AE, $CE, $9E, $6E, $47, $CD, $DC, + $00, $00, $00, $00, $49, $45, $4E, $44, $AE, $42, $60, $82 + ); + + { icons8-показ-видеокадров-30.png, значок окна, 32 на 32 точек, формат ico } + IconAppData: array[0..4285] of Byte = ( + $00, $00, $01, $00, $01, $00, $20, $20, $00, $00, $01, $00, $20, $00, $A8, $10, + $00, $00, $16, $00, $00, $00, $28, $00, $00, $00, $20, $00, $00, $00, $40, $00, + $00, $00, $01, $00, $20, $00, $00, $00, $00, $00, $00, $10, $00, $00, $13, $0B, + $00, $00, $13, $0B, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $37, $00, $00, $00, $A1, $00, $00, $00, $BB, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BB, $00, $00, $00, $A1, $00, $00, $00, $37, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $51, $00, $00, $00, $E5, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $E5, $00, $00, $00, $51, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $1E, $00, $00, $00, $58, $00, $00, $00, $66, $00, $00, + $00, $66, $00, $00, $00, $66, $00, $00, $00, $66, $00, $00, $00, $66, $00, $00, + $00, $66, $00, $00, $00, $66, $00, $00, $00, $66, $00, $00, $00, $66, $00, $00, + $00, $66, $00, $00, $00, $58, $00, $00, $00, $1E, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $15, $00, $00, + $00, $54, $00, $00, $00, $74, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, + $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, + $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, + $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, + $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, $00, $77, $00, $00, + $00, $77, $00, $00, $00, $77, $00, $00, $00, $74, $00, $00, $00, $54, $00, $00, + $00, $15, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $69, $00, $00, + $00, $DB, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $DA, $00, $00, + $00, $68, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $BE, $00, $00, + $00, $FF, $00, $00, $00, $C7, $00, $00, $00, $A4, $00, $00, $00, $D7, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $D7, $00, $00, $00, $A4, $00, $00, $00, $C7, $00, $00, $00, $FF, $00, $00, + $00, $BD, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $55, $00, $00, $00, $00, $00, $00, $00, $88, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $88, $00, $00, $00, $00, $00, $00, $00, $55, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $79, $00, $00, $00, $29, $00, $00, $00, $A1, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $A1, $00, $00, $00, $29, $00, $00, $00, $79, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $EC, $00, $00, $00, $E1, $00, $00, $00, $F2, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $F2, $00, $00, $00, $E1, $00, $00, $00, $EC, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $5C, $00, $00, $00, $00, $00, $00, $00, $8D, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $8D, $00, $00, $00, $00, $00, $00, $00, $5C, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $5C, $00, $00, $00, $00, $00, $00, $00, $8D, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $8D, $00, $00, $00, $00, $00, $00, $00, $5C, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $EC, $00, $00, $00, $E1, $00, $00, $00, $F2, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $F2, $00, $00, $00, $E1, $00, $00, $00, $EC, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $79, $00, $00, $00, $29, $00, $00, $00, $A1, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $A1, $00, $00, $00, $29, $00, $00, $00, $79, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $55, $00, $00, $00, $00, $00, $00, $00, $88, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $88, $00, $00, $00, $00, $00, $00, $00, $55, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $C6, $00, $00, $00, $A4, $00, $00, $00, $D7, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $D7, $00, $00, $00, $A4, $00, $00, $00, $C6, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $A4, $00, $00, $00, $6E, $00, $00, $00, $C0, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $C0, $00, $00, $00, $6E, $00, $00, $00, $A4, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C9, $00, $00, + $00, $FF, $00, $00, $00, $55, $00, $00, $00, $00, $00, $00, $00, $88, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $88, $00, $00, $00, $00, $00, $00, $00, $55, $00, $00, $00, $FF, $00, $00, + $00, $C9, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $C3, $00, $00, + $00, $FF, $00, $00, $00, $99, $00, $00, $00, $5C, $00, $00, $00, $B8, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $B8, $00, $00, $00, $5C, $00, $00, $00, $99, $00, $00, $00, $FF, $00, $00, + $00, $C3, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $8A, $00, $00, + $00, $EA, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, + $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $FF, $00, $00, $00, $EA, $00, $00, + $00, $89, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $26, $00, $00, + $00, $87, $00, $00, $00, $B6, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $BA, $00, $00, + $00, $BA, $00, $00, $00, $BA, $00, $00, $00, $B6, $00, $00, $00, $86, $00, $00, + $00, $24, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, + $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $FF, $FF, + $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $80, + $01, $FF, $FF, $80, $01, $FF, $FF, $80, $01, $FF, $FF, $FF, $FF, $FF, $E0, $00, + $00, $07, $E0, $00, $00, $07, $E0, $00, $00, $07, $E2, $00, $00, $47, $E0, $00, + $00, $07, $E0, $00, $00, $07, $E0, $00, $00, $07, $E2, $00, $00, $47, $E2, $00, + $00, $47, $E0, $00, $00, $07, $E0, $00, $00, $07, $E0, $00, $00, $07, $E2, $00, + $00, $47, $E0, $00, $00, $07, $E0, $00, $00, $07, $E0, $00, $00, $07, $E2, $00, + $00, $47, $E0, $00, $00, $07, $E0, $00, $00, $07, $E0, $00, $00, $07, $FF, $FF, + $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF, $FF + ); + +implementation + +end. diff --git a/src/uMainForm.lfm b/src/uMainForm.lfm index 3e41355..f9902ae 100644 --- a/src/uMainForm.lfm +++ b/src/uMainForm.lfm @@ -13,19 +13,10 @@ object MainForm: TMainForm OnKeyDown = FormKeyDown OnShow = FormShow LCLVersion = '4.6' - object pnlMenu: TPanel - Left = 0 - Height = 26 - Top = 0 - Width = 1600 - Align = alTop - BevelOuter = bvNone - TabOrder = 4 - end object memoLog: TLogView Left = 0 Height = 130 - Top = 770 + Top = 730 Width = 1600 Align = alBottom Font.Height = -11 @@ -36,7 +27,7 @@ object MainForm: TMainForm object pnlBottom: TPanel Left = 0 Height = 40 - Top = 730 + Top = 860 Width = 1600 Align = alBottom BevelOuter = bvNone @@ -58,34 +49,59 @@ object MainForm: TMainForm Left = 290 Height = 28 Top = 6 - Width = 170 + Width = 28 Down = True - Caption = 'Прилипание: вкл' + Icon = tiSnap OnClick = btnSnapClick ShowHint = True + TabStop = False + end + object btnGlue: TThemedButton + Left = 320 + Height = 28 + Top = 6 + Width = 28 + Down = True + Icon = tiGlue + OnClick = btnGlueClick + ShowHint = True + TabStop = False + end + object btnCenter: TThemedButton + Left = 350 + Height = 28 + Top = 6 + Width = 28 + Down = True + Icon = tiTarget + OnClick = btnCenterClick + ShowHint = True + TabStop = False end object btnRipple: TThemedButton - Left = 470 + Left = 386 Height = 28 Top = 6 - Width = 280 - Caption = 'Схлопывание: текущая дорожка' + Width = 28 + Icon = tiRipple OnClick = btnRippleClick ShowHint = True + TabStop = False end object btnRippleMenu: TThemedButton - Left = 752 + Left = 416 Height = 28 Top = 6 - Width = 26 + Width = 22 Arrow = True OnClick = btnRippleMenuClick + TabStop = False end object lblStatus: TLabel - Left = 790 + Left = 488 Height = 20 Top = 10 - Width = 840 + Width = 780 Anchors = [akTop, akLeft, akRight] AutoSize = False Caption = 'Готов.' @@ -110,6 +126,7 @@ object MainForm: TMainForm Align = alClient ItemHeight = 100 OnClick = lstPoolClick + OnMouseDown = lstPoolMouseDown OnDrawItem = lstPoolDrawItem Style = lbOwnerDrawFixed TabOrder = 0 diff --git a/src/uMainForm.pas b/src/uMainForm.pas index a62332e..57b24b6 100644 --- a/src/uMainForm.pas +++ b/src/uMainForm.pas @@ -25,9 +25,19 @@ uses Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, ComCtrls, Menus, Buttons, LCLType, LMessages, uAppTypes, uEdl, uMpvLib, uMpvPlayer, uProject, uMediaProbe, uTimelineCtrl, - uFlatten, uGenerate, uExport, uProgressForm, uRemuxForm, uMismatchForm, + uFlatten, uGenerate, uExport, uEncodeForm, uAboutForm, uProgressForm, + uRemuxForm, uMismatchForm, uFfmpegJob, uSettings, uThumbs, uTransform, uPanCropForm, - uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm; + uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm, uWaveform, + uIconData, uSubtitles, uTextMeasure, uTextForm, uExportForm, + uColorKeyForm; + +const + { Номера системных сообщений о перерисовке рамки окна. Берём числами, а + не из модуля Windows: тот переопределяет TRect и Point, и обычные + вызовы LCL начинают разбираться как системные. } + MsgNcPaint = $0085; + MsgNcActivate = $0086; type @@ -36,6 +46,8 @@ type TMainForm = class(TForm) btnSnap: TThemedButton; + btnGlue: TThemedButton; + btnCenter: TThemedButton; btnRipple: TThemedButton; btnRippleMenu: TThemedButton; lblPoolInfo: TLabel; @@ -47,7 +59,6 @@ type OpenMediaDialog: TOpenDialog; OpenProjectDialog: TOpenDialog; pnlBottom: TPanel; - pnlMenu: TPanel; pnlLeft: TPanel; pnlMain: TPanel; pnlTimelineHost: TPanel; @@ -56,6 +67,8 @@ type 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); @@ -63,7 +76,15 @@ type 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 @@ -76,18 +97,69 @@ type FPreviewDirty: Boolean; FUpdatingFromPlayer: Boolean; FLastLoadedEdl: string; + FLastLoadedAudioEdl: string; + { Наложение для плеера: список кусков оверлея и окна показа. } + { Журнал текущей сборки: файл рядом с готовым роликом. } + FExportLogPath: string; + { Разметка текста, отданная плееру в прошлый раз. } + FLastAss: string; + { Клип, с которого скопированы свойства. Хранится копией, а не + ссылкой: исходный клип могут удалить, а свойства должны остаться. } + FLookClip: TClip; + { Проект открыт из командной строки: спросить про клипы на чужих + дорожках можно только когда окно уже показано. } + FCheckMisplacedOnShow: Boolean; + FPreviewOverlayUrl: string; + FPreviewOverlayWindows: TOverlayWindows; + { Списки кусков звуковых дорожек для плеера. } + FPreviewAudioUrls: array of string; + { Звуковые дорожки предпросмотра — их номера в проекте, а не сами + объекты. + + Указатели здесь были ловушкой: отмена и открытие проекта + пересоздают все дорожки, а этот список продолжал показывать на + освобождённую память. Обращение к нему идёт на каждое обновление + времени при воспроизведении, то есть десятки раз в секунду. } + FPreviewAudioTracks: array of string; FLastHwdec: string; + FLastAudioNote: string; FLogFilePath: string; FLogFileStarted: Boolean; FLogFileBroken: Boolean; - { Списки полосы меню. Хранятся, чтобы искать по ним сочетания клавиш: - системной полосы меню нет, и форма сама их не найдёт. } - FMenus: TFPList; - FMenuX: Integer; + 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; @@ -102,6 +174,9 @@ type FThumbs: TImageList; FThumbThread: TThumbThread; + FPeaksThread: TPeaksThread; + FPeaksRestart: Boolean; + FPeaksFinished: Boolean; { Соответствие «путь к файлу -> номер картинки в списке изображений». По пути, а не по номеру в списке проекта: пока миниатюра делается, файлы могут добавиться или пропасть. Номер хранится увеличенным на @@ -112,6 +187,10 @@ type FPoolMenu: TPopupMenu; FPoolAddMenu: TMenuItem; FRippleMenu: TPopupMenu; + { Меню дорожки по правому щелчку в её заголовке. } + FTrackMenu: TPopupMenu; + { Дорожка, для которой открыто меню. } + FTrackMenuIndex: Integer; { Пункт «Недавние проекты» в меню «Файл». Его содержимое собирается заново при каждом изменении списка. } FRecentMenu: TMenuItem; @@ -130,8 +209,23 @@ type FSeekWaitTicks: Integer; procedure ApplyVolumeAt(const ATime: Double); + { Переписывает файл субтитров и отдаёт его плееру. } + procedure UpdateSubtitles; procedure UpdateRippleButton; + procedure CheckMisplacedClips; + procedure BuildTrackMenu; + procedure TimelineTrackMenu(Sender: TObject; ATrackIndex: Integer; + const AScreenPos: TPoint); + procedure TimelineRegionChange(Sender: TObject); + procedure TrackMenuDelete(Sender: TObject); + procedure TrackMenuRename(Sender: TObject); + procedure TimelineTrackRename(Sender: TObject; ATrackIndex: Integer); + procedure TrackMenuUp(Sender: TObject); + procedure TrackMenuDown(Sender: TObject); procedure UpdateSnapButton; + procedure UpdateGlueButton; + procedure UpdateCenterButton; + procedure ToggleCenterPlayhead; procedure RippleModeChosen(Sender: TObject); procedure ToggleRipple; procedure BuildPoolMenu; @@ -143,12 +237,16 @@ type 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); @@ -163,10 +261,25 @@ type { --- окно и меню --- } procedure BuildMenu; - procedure MenuBarClick(Sender: TObject); - procedure FormShortCut(var Msg: TLMKey; var Handled: Boolean); + { Разбор внутренней ошибки: пишет в журнал место, где она случилась. } + 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); @@ -185,7 +298,9 @@ type { Заставляет предпросмотр показывать кадр проекта, а не кадр исходника. } procedure ApplyPreviewFrame; procedure RebuildPreview; - procedure LoadPreviewEdl(const ASegments: TFlatSegmentArray); + 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); @@ -205,6 +320,8 @@ type 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); @@ -213,6 +330,15 @@ type procedure MenuSplit(Sender: TObject); procedure MenuSplitPrecise(Sender: TObject); procedure MenuDelete(Sender: TObject); + procedure MenuColorKey(Sender: TObject); + procedure MenuCopyLook(Sender: TObject); + procedure MenuPasteLook(Sender: TObject); + function FirstSelectedClip: TClip; + 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); @@ -235,6 +361,10 @@ type procedure ExportDone(Sender: TObject); procedure ExportCancel(Sender: TObject); procedure ShowExportReport(const AReport: TExportReport); + { Строка и в общий журнал программы, и в журнал этой сборки. } + procedure LogExport(const AText: string); + { Предлагает продолжить прерванную сборку с готовых кусков. } + function AskResume(const AOutputPath: string): Boolean; procedure NormalizeProgress(Sender: TObject); procedure NormalizeLog(Sender: TObject); procedure NormalizeDone(Sender: TObject); @@ -294,7 +424,7 @@ begin pnlVideo.Color := clBlack; memoLog.Clear; - FLogFilePath := ExtractFilePath(ExpandFileName(ParamStr(0))) + 'nlve.log'; + FLogFilePath := ProgramDir + 'nlve.log'; FPlayer := TMpvPlayer.Create(pnlVideo); FPlayer.OnLog := @PlayerLog; @@ -330,6 +460,7 @@ begin lstPool.DragMode := dmAutomatic; BuildPoolMenu; + BuildTrackMenu; RefreshRecentMenu; AllowDropFiles := True; OnDropFiles := @FormFilesDropped; @@ -337,6 +468,8 @@ begin RefreshPool; UpdateRippleButton; UpdateSnapButton; + UpdateGlueButton; + UpdateCenterButton; UpdateCaption; SetStatus('Готов. Добавьте файлы в проект.'); @@ -346,27 +479,55 @@ begin ApplyDarkTheme(Self); end; +{ Каждый шаг закрытия отмечается в журнале. + + Под Wine программа зависала при выходе, и по молчаливому журналу + понять, на чём именно, нельзя: последняя запись оставалась от работы, а + не от закрытия. Записи дешёвые, а без них искать пришлось бы наугад. } procedure TMainForm.FormDestroy(Sender: TObject); begin + Log('Закрытие: останавливаю предпросмотр.'); + FreeAndNil(FLookClip); 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); - UnloadMpvLib; + + { Библиотеку не выгружаем. + + Плеер отсоединяется от mpv, не дожидаясь, пока ядро добьёт свои + потоки, — иначе под Wine ожидание не кончалось вовсе. Значит, в + момент выхода эти потоки могут ещё жить внутри библиотеки, и + выгружать её из-под них нельзя. Программа всё равно закрывается, + и система освободит всё сама. } + Log('Закрытие: освобождаю проект.'); FreeAndNil(FProject); + Log('Закрытие завершено.'); { Сами списки принадлежат форме и уничтожатся с ней; здесь только перечень ссылок на них. } - FreeAndNil(FMenus); end; procedure TMainForm.ApplySettings; @@ -384,6 +545,7 @@ begin pnlVideo.Height := FSettings.VideoPanelHeight; FTimeline.TrackHeight := FSettings.TrackHeight; + FTimeline.WaveGain := FSettings.WaveGain; { Режим схлопывания и его состояние переживают перезапуск. } if FSettings.RippleAllTracks then @@ -391,6 +553,7 @@ begin else FProject.RippleMode := rmCurrentTrack; FProject.RippleEnabled := FSettings.RippleEnabled; + FTimeline.PlayheadSnap := FSettings.PlayheadSnap; { Каталоги подставляем в диалоги, чтобы не искать одно и то же место заново при каждом запуске. } @@ -418,8 +581,11 @@ begin 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; @@ -434,50 +600,43 @@ begin FTimeline.OnStructureChange := @TimelineStructureChange; FTimeline.OnSelectionChange := @TimelineSelectionChange; FTimeline.OnMediaDrop := @TimelineMediaDrop; + FTimeline.OnClipTransform := @TimelineClipTransform; FTimeline.OnTrackAdded := @TimelineTrackAdded; + FTimeline.OnTrackMenu := @TimelineTrackMenu; + FTimeline.OnTrackRename := @TimelineTrackRename; + FTimeline.OnRegionChange := @TimelineRegionChange; FTimeline.OnActiveTrackChange := @TimelineActiveTrackChange; end; { Меню строится кодом: в файле формы оно заняло бы сотню строк описания вложенных пунктов, где легко ошибиться и трудно что-то найти. - Полоса меню тоже своя, из обычных кнопок, а не системная. Причина одна: - системную полосу рисует Windows, и её светлый фон нашим цветом не - закрашивается — SetMenuInfo меняет подложку пунктов, но не саму полосу. - Сочетания клавиш от этого не теряются: их ищет TMenu.IsShortCut, и - вызвать его можно самим, что и делает FormShortCut. + Полоса меню — настоящая, TMainMenu. - Ценой отказа от системной полосы становится переход по меню клавишей - Alt — его больше нет. Сочетания клавиш работают все. } + Некоторое время она была своя, из обычных кнопок: под Windows системную + полосу нашим цветом не закрасить, SetMenuInfo меняет подложку пунктов, но + не саму полосу. Цена оказалась велика, и вся она в поведении: наведение + на соседнее название не перекидывало на него раскрытый список, не + работал переход по меню с Alt и стрелками. Подражать настоящему меню + своими руками пришлось бы до бесконечности. + + Цвет решается иначе, на каждой системе своим способом: под gtk2 строкой + стиля (ApplyMenuStyle), под win32 отрисовкой пунктов своими руками + (ApplyDarkMenu). Остаток полосы правее последнего названия под Windows + по-прежнему рисует система — это известная и принятая уступка. } procedure TMainForm.BuildMenu; function AddTop(const ACaption: string): TMenuItem; - var - Popup: TPopupMenu; - Btn: TThemedButton; - W: Integer; begin - Popup := TPopupMenu.Create(Self); - FMenus.Add(Popup); - - Btn := TThemedButton.Create(Self); - Btn.Parent := pnlMenu; - W := pnlMenu.Canvas.TextWidth(ACaption) + 24; - Btn.SetBounds(FMenuX, 0, W, pnlMenu.ClientHeight); - Btn.Caption := ACaption; - { Фокус кнопкам меню не нужен: по ним щёлкают, а обходить их клавишей - Tab при работе с монтажом только мешает. } - Btn.TabStop := False; - Btn.Flat := True; - Btn.Tag := FMenus.Count - 1; - Btn.OnClick := @MenuBarClick; - Inc(FMenuX, W); - - Result := Popup.Items; + Result := TMenuItem.Create(Self); + Result.Caption := ACaption; + FMenu.Items.Add(Result); end; - procedure AddItem(AParent: TMenuItem; const ACaption: string; - AHandler: TNotifyEvent; AShortCut: TShortCut = 0); + { Возвращает созданный пункт: у пунктов с галкой её потом надо ставить + и снимать, а искать пункт по названию — способ ненадёжный. } + function AddItem(AParent: TMenuItem; const ACaption: string; + AHandler: TNotifyEvent; AShortCut: TShortCut = 0): TMenuItem; var Item: TMenuItem; begin @@ -486,6 +645,7 @@ procedure TMainForm.BuildMenu; Item.OnClick := AHandler; Item.ShortCut := AShortCut; AParent.Add(Item); + Result := Item; end; procedure AddSep(AParent: TMenuItem); @@ -498,11 +658,24 @@ procedure TMainForm.BuildMenu; end; var - MFile, MEdit, MView, MProject: TMenuItem; + MFile, MEdit, MView, MProject, MHelp: TMenuItem; begin - FMenus := TFPList.Create; - FMenuX := 4; - OnShortCut := @FormShortCut; + { Подсказки всплывают почти сразу: на кнопке со значком они не + украшение, а единственный способ узнать, что она делает. Держатся + долго — читать там больше, чем одно слово. } + 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])); @@ -519,6 +692,8 @@ begin 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); @@ -534,6 +709,16 @@ begin @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, 'Скопировать свойства клипа', @MenuCopyLook, + ShortCut(VK_C, [ssCtrl, ssShift])); + AddItem(MEdit, 'Применить свойства к выделенным', @MenuPasteLook, + ShortCut(VK_V, [ssCtrl, ssShift])); + 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])); @@ -550,44 +735,406 @@ begin 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; -{ Щелчок по названию в полосе меню раскрывает соответствующий список. } -procedure TMainForm.MenuBarClick(Sender: TObject); +{ Показ фоновой работы. + + Разбор звука читает файл целиком — на шести гигабайтах это больше + десяти секунд, и всё это время программа выглядит просто задумчивой. + Молчать об этом нельзя: непонятно, идёт ли что-то вообще. + + Место справа в нижней полосе отводится сразу и насовсем, а надпись с + полоской показываются только когда работа есть. Так строка состояния и + показатель не наезжают друг на друга. } +{ Внутренняя ошибка не должна оставаться загадкой. + + Окно «Access violation» без единого слова о том, где именно, не даёт + ничего: ошибка повторяется на каждый кадр воспроизведения, а найти её + негде. Поэтому мы перехватываем её сами и пишем в журнал разбор стека — + сборка идёт с отладочными сведениями, поэтому в нём видны имена файлов + и номера строк. + + Окно показывается только на первую ошибку. Дальше они лишь считаются: + повторяющееся окно поверх воспроизведения невозможно закрыть. } +procedure TMainForm.HandleException(Sender: TObject; E: Exception); var - Btn: TThemedButton; - Popup: TPopupMenu; - P: TPoint; + Trace: string; + I: Integer; + Frames: PPointer; begin - Btn := Sender as TThemedButton; - if (Btn.Tag < 0) or (Btn.Tag >= FMenus.Count) then - Exit; - Popup := TPopupMenu(FMenus[Btn.Tag]); - ApplyDarkMenu(Popup); - P := Btn.ClientToScreen(Point(0, Btn.Height)); - Popup.PopUp(P.X, P.Y); + 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; -{ Сочетания клавиш ищем сами: системной полосы меню больше нет, а значит - форма их сама не найдёт. } -procedure TMainForm.FormShortCut(var Msg: TLMKey; var Handled: Boolean); +{ Значок окна. Вшит в программу, потому что рядом с ней может ничего не + лежать. Значок самого файла программы под 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 - for I := 0 to FMenus.Count - 1 do - if TPopupMenu(FMenus[I]).IsShortCut(Msg) then + Track := nil; + for I := 0 to FProject.TrackCount - 1 do + if FProject.Tracks[I].Kind = tkText then begin - Handled := True; - Exit; + Track := FProject.Tracks[I]; + Break; end; + + FProject.BeginChange; + + if Track = nil then + Track := FProject.AddTrackOfKind(FProject.UniqueTrackName('Т'), 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; @@ -598,7 +1145,34 @@ begin 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; { Файлы из командной строки попадают в список проекта. Так на программу можно перетащить файлы из файлового менеджера. @@ -622,6 +1196,7 @@ begin UpdateRippleButton; UpdateCaption; SchedulePreview; + FCheckMisplacedOnShow := True; end else Log('Не удалось открыть проект: ' + Err); @@ -638,6 +1213,63 @@ begin if lstPool.Items.Count > 0 then lstPool.ItemIndex := 0; end; + + { Спрашивать про клипы на чужих дорожках можно только теперь: окно + показано, и вопрос не окажется за кадром. } + if FCheckMisplacedOnShow then + begin + FCheckMisplacedOnShow := False; + CheckMisplacedClips; + 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; @@ -755,6 +1387,7 @@ begin [FProject.PoolCount, Plural(FProject.PoolCount, 'файл', 'файла', 'файлов')]); StartThumbs; + StartPeaks; end; { Запускает изготовление недостающих миниатюр. @@ -819,6 +1452,81 @@ begin 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 @@ -1004,7 +1712,9 @@ var Track: TTrack; Mismatches: TMismatches; Duration, PlaceAt: Double; - NormPath: string; + NormPath, Wanted: string; + NeedKind: TTrackKind; + I: Integer; begin Result := False; if (APoolIndex < 0) or (APoolIndex >= FProject.PoolCount) then @@ -1016,7 +1726,7 @@ begin if ATrackIndex < 0 then begin - FProject.AddTrack('V' + IntToStr(FProject.TrackCount + 1)); + FProject.AddTrack(FProject.UniqueTrackName('V')); ATrackIndex := FProject.TrackCount - 1; Log('Заведена дорожка ' + FProject.Tracks[ATrackIndex].Name); end; @@ -1024,6 +1734,36 @@ begin ATrackIndex := FProject.TrackCount - 1; Track := FProject.Tracks[ATrackIndex]; + { Дорожка чужого вида не годится: клип на ней не увидит ни сборка, ни + предпросмотр — уплощение обходит дорожки по видам. Поэтому не кладём + туда молча, а находим подходящую и говорим, куда положили. } + { Файл без картинки — только звук; всё остальное идёт на дорожку + картинки, а парный звук программа положит сама. } + if Item.Info.HasVideo or (Item.Info.Kind = mkImage) then + NeedKind := tkVideo + else + NeedKind := tkAudio; + if Track.Kind <> NeedKind then + begin + Wanted := Track.Name; + Track := nil; + for I := 0 to FProject.TrackCount - 1 do + if FProject.Tracks[I].Kind = NeedKind then + begin + Track := FProject.Tracks[I]; + Break; + end; + if Track = nil then + begin + if NeedKind = tkAudio then + Track := FProject.AddTrackOfKind(FProject.UniqueTrackName('A'), tkAudio) + else + Track := FProject.AddTrack(FProject.UniqueTrackName('V')); + end; + Log(Format('Дорожка %s не для этого вида клипов — положил на %s.', + [Wanted, Track.Name])); + end; + { Предупреждаем именно здесь, при попадании на монтаж: пока файл просто лежит в списке, он ни с чем не склеивается. } Mismatches := CompareToMaster(FProject.Master, Item.Info); @@ -1102,7 +1842,9 @@ begin end; FProject.BeginChange; - FProject.AddClip(Track, Item, 0, Duration, PlaceAt); + { Парой: клип картинки и его звук на соответствующей звуковой дорожке. + Связка держит их вместе, пока её не развяжут по Ctrl+G. } + FProject.AddClipPair(Track, Item, 0, Duration, PlaceAt); FTimeline.Invalidate; SchedulePreview; UpdateCaption; @@ -1228,8 +1970,12 @@ end; procedure TMainForm.RebuildPreview; var - Segments: TFlatSegmentArray; - Missing: TGenRequests; + 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; @@ -1242,19 +1988,72 @@ begin Exit; end; - if not FlattenProject(FProject, Segments, Missing) then + { Уплощение для предпросмотра: клипы, которые кладутся поверх, идут + отдельно. Плеер положит их сам, ничего не собирая. } + 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('Готовлю вставки для предпросмотра...'); - FGenerate := TGenerateThread.Create(Missing, FProject.Master); + { Вставки — картинки и связки — попадают в ролик наравне со съёмкой, + поэтому целятся в тот же битрейт. } + GenMaster := FProject.Master; + GenMaster.VideoBitrate := FProject.MaxVideoBitrate; + FGenerate := TGenerateThread.Create(Missing, GenMaster); FGenerate.OnProgress := @GenerateProgress; FGenerate.OnLog := @GenerateLog; FGenerate.OnTerminate := @GenerateDone; @@ -1262,14 +2061,80 @@ begin Exit; end; - LoadPreviewEdl(Segments); + LoadPreviewEdl(Segments, AudioSegs); end; -procedure TMainForm.LoadPreviewEdl(const ASegments: TFlatSegmentArray); +{ Список кусков оверлея и окна его показа. + + Список должен покрывать монтаж от начала и без разрывов: плеер + выравнивает дорожки по времени, и дыра сдвинула бы всё, что после неё. + Промежутки заполняются тем же файлом — показывать его там всё равно + никто не будет, за это отвечают окна. } +procedure TMainForm.BuildOverlayPreview(const AOverlays: TPreviewOverlays; + const ATotal: Double); var - Edl: string; + 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 должен показывать то, что получится в готовом ролике, а не размер очередного исходника. Файл @@ -1278,11 +2143,26 @@ begin 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 := ASegments; + FPreviewSegments := AAudio; FLastVolumeSent := -1; - if Edl = FLastLoadedEdl then + if (Edl = FLastLoadedEdl) and (AudioEdl = FLastLoadedAudioEdl) then Exit; Pos := FTimeline.Playhead; @@ -1296,9 +2176,13 @@ begin { Позиция и состояние паузы задаются прямо при загрузке, а не отдельной перемоткой следом. Иначе 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; { Пока плеер не доедет, его сообщения о позиции игнорируются — иначе курсор на монтаже прыгнул бы в начало при каждой правке. } @@ -1395,12 +2279,59 @@ begin FSettings.NoteRecentProject(FProject.FileName); RefreshRecentMenu; Log('Открыт проект: ' + FProject.FileName); + CheckMisplacedClips; end; { --- Схлопывание --- } { Кнопка показывает и состояние, и режим: утоплена — автосхлопывание включено, надпись говорит, на какие дорожки оно действует. } +{ Клипы на дорожках чужого вида: находим и предлагаем перенести. + + Такой клип нарисован на монтаже, но в ролик не попадает: уплощение + обходит дорожки по видам и клип с чужой дорожки не видит. Пропажа тихая + — сборка проходит без единой жалобы, а в готовом файле фотографии или + надписи нет. Проверено на живом проекте, где фотография оказалась на + текстовой дорожке, а надпись — на дорожке картинки. + + Молча переносить нельзя: человек мог положить клип туда осознанно, и + внезапно переехавший клип — сюрприз хуже пропажи. Поэтому спрашиваем. } +procedure TMainForm.CheckMisplacedClips; +var + N: Integer; +begin + N := FProject.MisplacedClipCount; + if N = 0 then + Exit; + + Log(Format('ВНИМАНИЕ: %d %s на дорожках чужого вида — в сборку они не попадут.', + [N, Plural(N, 'клип', 'клипа', 'клипов')])); + + if ThemedMessageDlg('nlve', + Format('В проекте %d %s лежит на дорожках не своего вида: ' + + 'картинка на звуковой или текстовой, надпись на дорожке картинки.' + + LineEnding + LineEnding + + 'Такой клип виден на монтаже, но в готовый ролик не попадает — ' + + 'ни в сборку, ни в предпросмотр.' + LineEnding + LineEnding + + 'Перенести их на подходящие дорожки? Время клипов не изменится.', + [N, Plural(N, 'клип', 'клипа', 'клипов')]), + mtWarning, [mbYes, mbNo], 0) <> mrYes then + begin + SetStatus(Format('%d %s не попадёт в сборку: они на дорожках чужого вида.', + [N, Plural(N, 'клип', 'клипа', 'клипов')])); + Exit; + end; + + FProject.BeginChange; + N := FProject.FixMisplacedClips; + FTimeline.Invalidate; + FLastLoadedEdl := ''; + SchedulePreview; + UpdateCaption; + Log(Format('Перенесено на подходящие дорожки: %d.', [N])); + SetStatus(Format('Перенесено клипов: %d.', [N])); +end; + procedure TMainForm.UpdateRippleButton; var ModeText: string; @@ -1409,10 +2340,15 @@ begin ModeText := 'все дорожки' else ModeText := 'текущая дорожка'; - btnRipple.Caption := 'Схлопывание: ' + ModeText; btnRipple.Down := FProject.RippleEnabled; - btnRipple.Hint := 'Ctrl+K — включить или выключить. ' + - 'Режим действует и при выключенном автосхлопывании: по нему работает Ctrl+Shift+R.'; + if FProject.RippleEnabled then + btnRipple.Hint := 'Автосхлопывание включено, режим: ' + ModeText + '.' + else + btnRipple.Hint := 'Автосхлопывание выключено, режим: ' + ModeText + '.'; + btnRipple.Hint := btnRipple.Hint + LineEnding + + 'Ctrl+K — включить или выключить. Режим действует и при выключенном ' + + 'автосхлопывании: по нему работает Ctrl+Shift+R.'; + btnRippleMenu.Hint := 'Выбрать режим схлопывания'; end; { Прилипание краёв клипов друг к другу. @@ -1420,14 +2356,20 @@ end; Shift работает как переключатель наоборот: при включённом прилипании временно отключает его, при выключенном — временно включает. Так одна клавиша полезна в обоих режимах, и не нужно помнить, какой сейчас. } +{ Кнопка со значком не может сказать словами, что она делает и в каком + она состоянии. Слова переезжают в подсказку — целиком, вместе с + состоянием: иначе о состоянии пришлось бы догадываться по цвету. } procedure TMainForm.UpdateSnapButton; +var + State: string; begin btnSnap.Down := FTimeline.SnapEnabled; if FTimeline.SnapEnabled then - btnSnap.Caption := 'Прилипание: вкл' + State := 'включено' else - btnSnap.Caption := 'Прилипание: выкл'; - btnSnap.Hint := 'Shift во время перетаскивания меняет решение на противоположное.'; + State := 'выключено'; + btnSnap.Hint := 'Прилипание: ' + State + '.' + LineEnding + + 'Shift во время перетаскивания меняет решение на противоположное.'; end; procedure TMainForm.btnSnapClick(Sender: TObject); @@ -1436,6 +2378,67 @@ begin 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; @@ -1475,6 +2478,143 @@ begin FRippleMenu.PopUp(P.X, P.Y); end; +{ --- Меню дорожки --- } + +{ Меню по правому щелчку в заголовке дорожки. + + Раньше дорожку можно было только добавить и убрать последнюю, а убрать + чаще нужно не последнюю. Порядок дорожек тоже правится здесь — тем, кому + перетаскивание заголовка неудобно. } +{ Участок подвинули мышью: показываем, что вышло, и помечаем проект + изменённым — отметки в нём и хранятся. } +procedure TMainForm.TimelineRegionChange(Sender: TObject); +begin + FProject.Modified := True; + UpdateCaption; + if FProject.HasRegion then + SetStatus(Format('Участок: %s — %s', + [SecondsToStr(FProject.RegionStart), SecondsToStr(FProject.RegionEnd)])) + else + SetStatus('Отметки участка сняты: собирается весь монтаж.'); +end; + +procedure TMainForm.BuildTrackMenu; +var + Item: TMenuItem; +begin + FTrackMenu := TPopupMenu.Create(Self); + + Item := TMenuItem.Create(FTrackMenu); + Item.Caption := 'Поднять дорожку'; + Item.OnClick := @TrackMenuUp; + FTrackMenu.Items.Add(Item); + + Item := TMenuItem.Create(FTrackMenu); + Item.Caption := 'Опустить дорожку'; + Item.OnClick := @TrackMenuDown; + FTrackMenu.Items.Add(Item); + + Item := TMenuItem.Create(FTrackMenu); + Item.Caption := 'Переименовать...'; + Item.OnClick := @TrackMenuRename; + FTrackMenu.Items.Add(Item); + + Item := TMenuItem.Create(FTrackMenu); + Item.Caption := '-'; + FTrackMenu.Items.Add(Item); + + Item := TMenuItem.Create(FTrackMenu); + Item.Caption := 'Удалить дорожку'; + Item.OnClick := @TrackMenuDelete; + FTrackMenu.Items.Add(Item); +end; + +procedure TMainForm.TimelineTrackMenu(Sender: TObject; ATrackIndex: Integer; + const AScreenPos: TPoint); +begin + if (ATrackIndex < 0) or (ATrackIndex >= FProject.TrackCount) then + Exit; + FTrackMenuIndex := ATrackIndex; + FTrackMenu.Items[0].Enabled := ATrackIndex > 0; + FTrackMenu.Items[1].Enabled := ATrackIndex < FProject.TrackCount - 1; + FTrackMenu.PopUp(AScreenPos.X, AScreenPos.Y); +end; + +procedure TMainForm.TrackMenuUp(Sender: TObject); +begin + if FTrackMenuIndex <= 0 then + Exit; + FProject.BeginChange; + FProject.MoveTrack(FTrackMenuIndex, FTrackMenuIndex - 1); + TimelineStructureChange(nil); + SetStatus('Дорожка поднята.'); +end; + +procedure TMainForm.TrackMenuDown(Sender: TObject); +begin + if (FTrackMenuIndex < 0) or (FTrackMenuIndex >= FProject.TrackCount - 1) then + Exit; + FProject.BeginChange; + FProject.MoveTrack(FTrackMenuIndex, FTrackMenuIndex + 1); + TimelineStructureChange(nil); + SetStatus('Дорожка опущена.'); +end; + +{ Удаление дорожки. С клипами — только с подтверждением: вместе с + дорожкой уходит всё, что на ней лежит, а отменить можно только одним + шагом назад. } +{ Переименование дорожки. + + Имя — только подпись, но на монтаже из десятка дорожек «карта», «звук + мотора» и «титры» читаются несравнимо лучше, чем V1, A2 и Т1. } +procedure TMainForm.TimelineTrackRename(Sender: TObject; ATrackIndex: Integer); +var + NewName: string; +begin + if (ATrackIndex < 0) or (ATrackIndex >= FProject.TrackCount) then + Exit; + NewName := FProject.Tracks[ATrackIndex].Name; + if not ThemedInputDlg('Имя дорожки', 'Как назвать дорожку:', NewName) then + Exit; + + FProject.BeginChange; + FProject.Tracks[ATrackIndex].Name := NewName; + FProject.EnsureUniqueTrackNames; + FTimeline.Invalidate; + UpdateCaption; + SetStatus('Дорожка названа: ' + FProject.Tracks[ATrackIndex].Name); +end; + +procedure TMainForm.TrackMenuRename(Sender: TObject); +begin + TimelineTrackRename(nil, FTrackMenuIndex); +end; + +procedure TMainForm.TrackMenuDelete(Sender: TObject); +var + Track: TTrack; + { Не Name: так называется свойство самой формы, и локальная переменная + его перекроет — компилятор ловит, но сообщение неочевидное. } + TrackName: string; +begin + if (FTrackMenuIndex < 0) or (FTrackMenuIndex >= FProject.TrackCount) then + Exit; + Track := FProject.Tracks[FTrackMenuIndex]; + TrackName := Track.Name; + + if (Track.Count > 0) and (ThemedMessageDlg('nlve', + Format('На дорожке %s %d %s. Удалить её вместе с ними?', + [TrackName, Track.Count, + Plural(Track.Count, 'клип', 'клипа', 'клипов')]), + mtConfirmation, [mbYes, mbNo], 0) <> mrYes) then + Exit; + + FProject.BeginChange; + FProject.RemoveTrack(FTrackMenuIndex); + TimelineStructureChange(nil); + SetStatus('Дорожка ' + TrackName + ' удалена.'); +end; + { --- Меню библиотеки --- } procedure TMainForm.BuildPoolMenu; @@ -1534,6 +2674,23 @@ 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; @@ -1603,11 +2760,66 @@ begin [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; @@ -1721,32 +2933,96 @@ begin AddClipFromPool(FProject.PoolCount - 1, TrackIdx, DropTime); end; +{ Громкость клипов в предпросмотре. + + Дорожки смешиваются, поэтому одной общей громкостью не обойтись: у + каждой дорожки под курсором свой клип со своей громкостью. Значения + собираются по дорожкам и отдаются плееру; он подставляет их в свою + цепочку смешивания. + + Пересобирать цепочку на каждый кадр нельзя — она создаётся заново и + звук щёлкает. Поэтому только при изменении. } +{ Разметка текста для предпросмотра. + + Сравнивается сама разметка, а не имя файла: имя у неё одно на весь + проект, и правка текста его не меняет. Плеер же, увидев прежнее имя, + файл не перечитывал — и новая надпись в окне не появлялась вовсе, пока + не перезагрузится весь список кусков. } +procedure TMainForm.UpdateSubtitles; +var + { Не Text: так называется свойство формы. } + Path, Markup: string; +begin + if (FProject = nil) or (FPlayer = nil) then + Exit; + if FProject.CacheDir = '' then + Exit; + + Markup := BuildAss(FProject); + if Markup = FLastAss then + Exit; + FLastAss := Markup; + + Path := IncludeTrailingPathDelimiter(FProject.CacheDir) + 'subs.ass'; + if (Markup <> '') and WriteAssFile(FProject, Path) then + FPlayer.SetSubtitleFile(Path, True) + else + FPlayer.SetSubtitleFile(''); +end; + procedure TMainForm.ApplyVolumeAt(const ATime: Double); var I: Integer; - Acc, Vol: Double; + Clip: TClip; + Track: TTrack; + Vols: array of Double; + Key: string; begin if (FPlayer = nil) or (not FPlayer.Initialized) then Exit; - if Length(FPreviewSegments) = 0 then + if FProject = nil then Exit; - Vol := 1; - Acc := 0; - for I := 0 to High(FPreviewSegments) do + Vols := nil; + Key := ''; + for I := 0 to High(FPreviewAudioTracks) do begin - if (ATime >= Acc) and (ATime < Acc + FPreviewSegments[I].Duration) then + Track := FProject.FindTrack(FPreviewAudioTracks[I]); + SetLength(Vols, Length(Vols) + 1); + Vols[High(Vols)] := 1; + if Track <> nil then begin - Vol := FPreviewSegments[I].Volume; - Break; + Clip := Track.ClipAt(ATime); + if Clip <> nil then + Vols[High(Vols)] := Clip.Volume; end; - Acc := Acc + FPreviewSegments[I].Duration; + Key := Key + SecondsToStr(Vols[High(Vols)]) + ','; end; - if Abs(Vol - FLastVolumeSent) < 0.001 then + if Key = FLastVolumeKey then Exit; - FLastVolumeSent := Vol; - FPlayer.SetVolume(Vol * 100); + 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); @@ -1854,8 +3130,11 @@ begin FTimeline.Playhead := FPlayer.TimePos; { Во время воспроизведения держим курсор посередине: так видно, что будет дальше, и не приходится гоняться за ним прокруткой. } + { Держать курсор посередине или дать монтажу стоять — решает человек: + на слабой машине и на мелком масштабе постоянная прокрутка мешает + разглядывать. } if not FPlayer.Paused then - FTimeline.ScrollToPlayhead(True); + FTimeline.ScrollToPlayhead(FSettings.CenterPlayhead); finally FUpdatingFromPlayer := False; end; @@ -1888,6 +3167,15 @@ begin 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); @@ -1924,6 +3212,15 @@ begin begin Key := 0; TogglePlayback; + Exit; + end; + + { Обратная косая: пункта меню для неё нет намеренно — сочетание из + одной такой клавиши в меню выглядит как опечатка, а работать должно. } + if (Key = VK_OEM_5) and (Shift = []) then + begin + Key := 0; + ToggleCenterPlayhead; end; end; @@ -2103,6 +3400,194 @@ 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; + +{ Отметки участка. + + Участок нужен, чтобы собрать кусок монтажа, а не весь ролик: на длинном + материале проверить правку иначе почти невозможно — сборка занимает + столько же, сколько сам ролик, а то и больше. + + Отметки ставятся по курсору, как в монтажных программах. Перепутанные + местами меняются сами: требовать от человека помнить порядок — лишняя + строгость там, где всё однозначно. } +{ Первый выделенный клип: с него берут свойства. } +function TMainForm.FirstSelectedClip: TClip; +var + T, C: Integer; +begin + Result := nil; + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + if FProject.Tracks[T][C].Selected then + Exit(FProject.Tracks[T][C]); +end; + +{ Копирование оформления с клипа на клип. + + Настроить кадрирование, ключ и прозрачность — работа на минуты, а + клипов с одинаковой настройкой в монтаже бывает десяток: та же + миникарта, разрезанная на куски, или несколько снимков в одной рамке. } +procedure TMainForm.MenuCopyLook(Sender: TObject); +var + Src: TClip; +begin + Src := FirstSelectedClip; + if Src = nil then + begin + SetStatus('Сначала выделите клип, с которого брать свойства.'); + Exit; + end; + + if FLookClip = nil then + FLookClip := TClip.Create; + FLookClip.Kind := Src.Kind; + FLookClip.CopyLookFrom(Src); + SetStatus('Свойства клипа скопированы. Применить: Ctrl+Shift+V.'); +end; + +procedure TMainForm.MenuPasteLook(Sender: TObject); +var + T, C, N: Integer; +begin + if FLookClip = nil then + begin + SetStatus('Сначала скопируйте свойства клипа: Ctrl+Shift+C.'); + Exit; + end; + + N := 0; + FProject.BeginChange; + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + if FProject.Tracks[T][C].Selected then + begin + FProject.Tracks[T][C].CopyLookFrom(FLookClip); + Inc(N); + end; + + if N = 0 then + begin + FProject.CancelChange; + SetStatus('Выделите клипы, к которым применить свойства.'); + Exit; + end; + + FTimeline.Invalidate; + FLastLoadedEdl := ''; + SchedulePreview; + UpdateCaption; + SetStatus(Format('Свойства применены к %d %s.', + [N, Plural(N, 'клипу', 'клипам', 'клипам')])); +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; @@ -2115,6 +3600,29 @@ 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; @@ -2151,7 +3659,7 @@ end; procedure TMainForm.MenuAddTrack(Sender: TObject); begin FProject.BeginChange; - FProject.AddTrack('V' + IntToStr(FProject.TrackCount + 1)); + FProject.AddTrack(FProject.UniqueTrackName('V')); FTimeline.Invalidate; UpdateCaption; end; @@ -2203,14 +3711,34 @@ end; { --- Сборка ролика --- } +{ Обычная сборка: копирование потоков, ради чего редактор и делался. } procedure TMainForm.MenuExport(Sender: TObject); +begin + DoExport(Default(TEncodeProfile)); +end; + +{ Сборка с перекодированием: отдельный пункт, потому что это осознанный + выбор — ролик пересобирается целиком, и быстрым это уже не будет. } +procedure TMainForm.MenuExportEncode(Sender: TObject); var - Segments: TFlatSegmentArray; + 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, Missing) then + if not FlattenProject(FProject, Segments, AudioSegs, Missing) then begin ThemedMessageDlg('nlve', 'На монтаже нечего собирать.', mtInformation, [mbOK], 0); Exit; @@ -2226,6 +3754,17 @@ begin Exit; end; + DescribeRegion(RegionFrom, RegionTo); + RegionCaption := ''; + if FProject.HasRegion then + RegionCaption := SecondsToStr(RegionFrom) + ' — ' + SecondsToStr(RegionTo); + + { Сколько материала придётся пересобрать. Наложение, переход, + полупрозрачность и чужие параметры файла — всё это перекодирование, и + человек должен знать цену заранее, а не обнаружить её по времени + сборки. } + Rebuilt := 0; + { Если есть хоть один точный рез, предупреждаем про контейнер: в MP4 перекодированный кусок и скопированный уживаются не всегда, а MKV к смене параметров потока терпимее. } @@ -2236,22 +3775,34 @@ begin (FProject.Tracks[T][C].EdgeOut = edPrecise) then HasPrecise := True; - if HasPrecise then + { Куда собирать, в каком контейнере и что делать с текстом — один + вопрос: ответ на любую его часть меняет допустимое в остальных. } + 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 - SaveExportDialog.DefaultExt := '.mkv'; - SaveExportDialog.FileName := 'ролик.mkv'; + RegionFrom := 0; + RegionTo := TotalDuration(Segments); end else begin - SaveExportDialog.DefaultExt := '.mp4'; - SaveExportDialog.FileName := 'ролик.mp4'; + ClipSegmentsToRange(Segments, RegionFrom, RegionTo); + ClipSegmentsToRange(AudioSegs, RegionFrom, RegionTo); + if Length(Segments) = 0 then + begin + ThemedMessageDlg('nlve', + 'В отмеченном участке нечего собирать.', mtInformation, [mbOK], 0); + Exit; + end; end; - if not SaveExportDialog.Execute then - Exit; - FSettings.LastExportDir := ExtractFilePath(SaveExportDialog.FileName); - - if HasPrecise and (LowerCase(ExtractFileExt(SaveExportDialog.FileName)) <> '.mkv') then + if HasPrecise and + (LowerCase(ExtractFileExt(FExportChoice.Path)) <> '.mkv') then if ThemedMessageDlg('nlve', 'В монтаже есть точные резы. В MP4 перекодированный стык может ' + 'воспроизводиться неправильно — надёжнее MKV.' + LineEnding + @@ -2259,19 +3810,118 @@ begin mtWarning, [mbYes, mbNo], 0) <> mrYes then Exit; - Log('Сборка в ' + SaveExportDialog.FileName); - Log(Format('%d %s, длительность %s с', + { Сколько материала придётся пересобрать — считаем уже по тому списку, + который пойдёт в сборку: с участком он короче, и обещать человеку + работу на весь ролик было бы неправдой. } + 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))])); - FExport := TExportThread.Create(Segments, SaveExportDialog.FileName, True, FProject.Master); + { Что именно собирается — по кускам. Без этого списка по журналу нельзя + понять, попал ли в сборку тот клип, которого потом не нашли в ролике. } + 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, FSettings.KeepParts, Master, AProfile); + FExport.SubtitlePath := SubsPath; + FExport.LogPath := FExportLogPath; + FExport.Resume := AskResume(FExportChoice.Path); FExport.OnProgress := @ExportProgress; FExport.OnLog := @ExportLog; FExport.OnTerminate := @ExportDone; FExportUi := TProgressForm.Create(Self); try - FExportUi.Caption := 'Сборка ролика'; + { Не «Сборка ролика»: так называется окно настроек, и два окна с + одинаковым заголовком путают. } + FExportUi.Caption := 'Ход сборки'; FExportUi.OnCancelRequest := @ExportCancel; FExport.Start; FExportUi.ShowModal; @@ -2282,6 +3932,10 @@ begin if Assigned(FExport) then begin FExport.WaitFor; + if FExport.ReusedParts > 0 then + LogExport(Format('Взято готовыми из прошлой сборки: %d %s.', + [FExport.ReusedParts, + Plural(FExport.ReusedParts, 'кусок', 'куска', 'кусков')])); ShowExportReport(FExport.Report); FreeAndNil(FExport); end; @@ -2320,6 +3974,77 @@ begin 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; + +{ Прерванная сборка: куски от неё лежат в кэше рядом с готовым файлом. + + Спрашиваем, а не продолжаем молча: человек мог править монтаж между + попытками, и тогда «готовые» куски — от другой расстановки. Сама сборка + это проверит по отпечатку плана и при несовпадении соберёт заново, но + знать об этом человек должен заранее. } +function TMainForm.AskResume(const AOutputPath: string): Boolean; +var + DonePath: string; + Done: TStringList; + N: Integer; +begin + Result := False; + DonePath := CacheDirFor(AOutputPath) + 'готово.txt'; + if not FileExists(DonePath) then + Exit; + + Done := TStringList.Create; + try + try + Done.LoadFromFile(DonePath); + except + Exit; + end; + { Первая строка — отпечаток плана, куски идут дальше. } + N := Done.Count - 1; + if N <= 0 then + Exit; + + Result := ThemedMessageDlg('nlve', + Format('От прошлой сборки осталось готовых кусков: %d.' + LineEnding + + LineEnding + + 'Продолжить с них? Если монтаж с тех пор менялся, куски не ' + + 'подойдут — программа это заметит и соберёт заново.', + [N]), + mtConfirmation, [mbYes, mbNo], 0) = mrYes; + finally + Done.Free; + end; +end; + procedure TMainForm.ShowExportReport(const AReport: TExportReport); var I, Encoded: Integer; @@ -2327,17 +4052,17 @@ var begin if AReport.Cancelled then begin - Log('Сборка отменена.'); + LogExport('Сборка отменена.'); Exit; end; if not AReport.Succeeded then begin - Log('Сборка не удалась: ' + AReport.Message); + LogExport('Сборка не удалась: ' + AReport.Message); Exit; end; - Log('--- Отчёт о сборке ---'); + LogExport('--- Отчёт о сборке ---'); Encoded := 0; for I := 0 to High(AReport.Segments) do begin @@ -2345,14 +4070,14 @@ begin if AReport.Segments[I].Encoded then begin Inc(Encoded); - Log(Format(' часть %d (кусок %d, ПЕРЕКОДИРОВАНА): старт %s, длина %s, пакетов %d', + 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 - Log(Format(' часть %d (кусок %d): старт %s (просили %s, сдвиг %s), длина %s, пакетов %d', + 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), @@ -2361,17 +4086,17 @@ begin AReport.Segments[I].Packets])); end; if Encoded > 0 then - Log(Format(' перекодировано частей: %d, остальное скопировано без потерь', + LogExport(Format(' перекодировано частей: %d, остальное скопировано без потерь', [Encoded])); - Log(Format(' сумма пакетов кусков: %d', [AReport.ExpectedPackets])); - Log(Format(' пакетов в готовом файле: %d', [AReport.ActualPackets])); + LogExport(Format(' сумма пакетов кусков: %d', [AReport.ExpectedPackets])); + LogExport(Format(' пакетов в готовом файле: %d', [AReport.ActualPackets])); if AReport.ExpectedPackets = AReport.ActualPackets then - Log(' СВЕРКА ПРОЙДЕНА: склейка не потеряла и не продублировала ни одного кадра.') + LogExport(' СВЕРКА ПРОЙДЕНА: склейка не потеряла и не продублировала ни одного кадра.') else - Log(Format(' РАСХОЖДЕНИЕ на %d кадров.', + LogExport(Format(' РАСХОЖДЕНИЕ на %d кадров.', [AReport.ActualPackets - AReport.ExpectedPackets])); - Log(' файл: ' + AReport.OutputPath); + LogExport(' файл: ' + AReport.OutputPath); SetStatus('Готово: ' + AReport.OutputPath); end; diff --git a/src/uMpvLib.pas b/src/uMpvLib.pas index 30b2606..03fc850 100644 --- a/src/uMpvLib.pas +++ b/src/uMpvLib.pas @@ -104,6 +104,10 @@ var mpv_create: function: Pmpv_handle; cdecl; mpv_initialize: function(ctx: Pmpv_handle): cint; cdecl; mpv_terminate_destroy: procedure(ctx: Pmpv_handle); cdecl; + { Необязательная: отсоединяет клиента, не дожидаясь, пока ядро добьёт + свои потоки. Есть в libmpv с давних версий, но если вдруг не найдётся, + работаем без неё. } + mpv_destroy: procedure(ctx: Pmpv_handle); cdecl; mpv_set_option_string: function(ctx: Pmpv_handle; name, data: PAnsiChar): cint; cdecl; mpv_set_property: function(ctx: Pmpv_handle; name: PAnsiChar; format: cint; data: Pointer): cint; cdecl; @@ -279,6 +283,8 @@ begin Need('mpv_request_log_messages', Pointer(mpv_request_log_messages)); Need('mpv_wait_event', Pointer(mpv_wait_event)); Need('mpv_event_name', Pointer(mpv_event_name)); + { Без Need: её отсутствие не повод отказываться от предпросмотра. } + Bind('mpv_destroy', Pointer(mpv_destroy)); if Missing <> '' then begin diff --git a/src/uMpvPlayer.pas b/src/uMpvPlayer.pas index 67f9495..8fdc762 100644 --- a/src/uMpvPlayer.pas +++ b/src/uMpvPlayer.pas @@ -57,6 +57,23 @@ type FInitialized: Boolean; FVideoFilter: string; FHwdec: string; + FAudioSource: string; + FAudioSources: array of string; + { Наложение: список кусков оверлея и окна, когда и куда его класть. } + FOverlayUrl: string; + FOverlayWindows: TOverlayWindows; + { Номера видеодорожек: своя (основа) и подключённая для наложения. + Пусто — наложения нет. } + FBaseVid: string; + FOverlayVid: string; + FTrackVolumes: array of Double; + { Номера подключённых звуковых дорожек, в порядке подключения. } + FAudioIds: array of string; + FLastGraph: string; + FSubtitlePath: string; + { Что произошло с выбором звуковой дорожки. Читается окном для + журнала: без этого понять, откуда взялся звук, нечем. } + FAudioTrackNote: string; { Работаем ли под Wine. Там свои правила вывода картинки, и узнать об этом надо до создания плеера. } FUnderWine: Boolean; @@ -80,6 +97,23 @@ type procedure PumpEvents(Sender: TObject); procedure HandlePropertyChange(AProp: Pmpv_event_property); procedure HandleLogMessage(AMsg: Pmpv_event_log_message); + { Выбирает внешнюю звуковую дорожку, если она есть. + + Без этого mpv играет звук, встроенный в саму картинку: внешний файл + он лишь добавляет ещё одной дорожкой, а выбирает по своему + усмотрению. Получалось, что звук слышен там, где на монтаже его нет + вовсе — он приходил из видеофайла, а не с звуковой дорожки. } + procedure SelectExternalAudio; + { Подключает оверлей второй видеодорожкой и запоминает её номер. } + procedure AttachOverlay; + { Часть цепочки, которая кладёт оверлей на основу. Пусто — нечего + класть. } + function OverlayGraph: string; + { Цепочка смешивания звуковых дорожек с их громкостями. } + { Собственная запись в журнал программы. Идёт тем же путём, что и + сообщения самого mpv: у окна для них уже есть обработчик. } + procedure Note(const AText: string); + procedure BuildGraph; function SetOption(const AName, AValue: string): Integer; public constructor Create(AVideoParent: TWinControl); @@ -135,6 +169,27 @@ type когда фильтр действительно нужен. } procedure SetHwdec(const AMode: string); + { Внешняя звуковая дорожка: список кусков звука, отдельный от + картинки. Нужен потому, что звук можно двигать отдельно, и у одного + файла звук всегда свой. + + Пустая строка снимает внешний звук. } + procedure SetAudioSource(const AUrl: string); + + { Несколько звуковых дорожек монтажа разом. Плеер играет только одну, + поэтому смесь собирается его же средствами — см. AttachAudio. } + procedure SetAudioSources(const AUrls: array of string); + { Что класть поверх картинки. Пустой список кусков — ничего. + + Наложение делает сам плеер, ничего заранее не собирается: две + дорожки играются одна поверх другой. } + procedure SetVideoOverlay(const AUrl: string; + const AWindows: TOverlayWindows); + + { Громкость каждой звуковой дорожки монтажа. Подставляется в цепочку + смешивания: одной общей громкостью тут не обойтись. } + procedure SetTrackVolumes(const AVolumes: array of Double); + function GetPropString(const AName: string): string; function GetPropDouble(const AName: string; out AValue: Double): Boolean; @@ -148,6 +203,7 @@ type property HasTimePos: Boolean read FHasTimePos; property Initialized: Boolean read FInitialized; property UnderWine: Boolean read FUnderWine; + property AudioTrackNote: string read FAudioTrackNote; property TimePos: Double read FTimePos; property Duration: Double read FDuration; property Paused: Boolean read FPaused; @@ -155,6 +211,17 @@ type property OnDuration: TNotifyEvent read FOnDuration write FOnDuration; property OnPauseChange: TNotifyEvent read FOnPauseChange write FOnPauseChange; property OnLog: TMpvLogEvent read FOnLog write FOnLog; + { Цепочка смешивания, отданная mpv. Нужна журналу: по ней видно, какая + дорожка какую громкость получила на самом деле. } + property AudioGraph: string read FLastGraph; + { Файл субтитров поверх картинки. Пустая строка снимает его. + + Держится отдельно от списка кусков: текст правится чаще, чем + монтаж, и перезагружать из-за него картинку незачем. } + { AForce — перечитать файл, даже если имя прежнее. Нужно всегда, когда + разметка переписана: имя у неё одно на весь проект, и по имени + изменение не видно. } + procedure SetSubtitleFile(const APath: string; AForce: Boolean = False); end; implementation @@ -340,16 +407,50 @@ begin FPump.OnTimer := @PumpEvents; end; +procedure TMpvPlayer.Note(const AText: string); +begin + if Assigned(FOnLog) then + FOnLog(Self, 'nlve', 'info', AText); +end; + +{ Закрытие плеера. + + Порядок здесь не случайный, и стоил зависания под Wine. + + mpv_terminate_destroy не просто отпускает клиента — она ждёт, пока ядро + mpv свернёт всю свою работу и добьёт свои потоки. Под Wine это ожидание + не кончалось никогда: журнал обрывался на «закрываю плеер», и дальше + ничего. Под Linux та же функция отрабатывает мгновенно. + + Поэтому отсоединяемся, не дожидаясь ядра: mpv_destroy отпускает клиента + и возвращает управление сразу, а ядро без клиентов сворачивается само. + Программа в этот момент и так закрывается — ждать её незачем. + + Команду «завершиться» перед этим не посылаем намеренно: она тоже + выполняется ядром и под Wine могла бы встать точно так же. Отсоединение + ни от чего не зависит. + + Окно, в которое рисовал mpv, убирается только после этого: в обратном + порядке он успел бы обратиться к уже несуществующему окну. } destructor TMpvPlayer.Destroy; begin FPump.Enabled := False; FreeAndNil(FPump); - { Сначала гасим mpv, и только потом убираем окно, в которое он рисовал: - в обратном порядке он успел бы обратиться к уже несуществующему окну. } if FHandle <> nil then begin - mpv_terminate_destroy(FHandle); + if Assigned(mpv_destroy) then + begin + Note('плеер: отсоединяюсь от mpv'); + mpv_destroy(FHandle); + end + else + begin + { Старая libmpv без mpv_destroy: другого способа нет, ждём. } + Note('плеер: закрываю mpv с ожиданием'); + mpv_terminate_destroy(FHandle); + end; FHandle := nil; + Note('плеер: закрыт'); end; {$IFDEF LCLGTK2} if (FVideoWin <> 0) and (FDisplay <> nil) then @@ -546,6 +647,17 @@ begin Гадать по номеру версии не нужно: те же самые настройки можно задать свойствами перед загрузкой. Свойства называются одинаково во всех версиях, и разбирать строку приходится нам, а не mpv. } + { Цепочка смешивания снимается ДО загрузки. + + Она ссылается на дорожки по номерам. Оставшаяся от прошлого раза + цепочка не даёт открыть новый файл вовсе: проверено на живом mpv — + после такой загрузки дорожек ноль, кадра нет, не играет ничего. + Снимать её после загрузки поздно. } + FLastGraph := ''; + FAudioIds := nil; + FOverlayVid := ''; + mpv_set_property_string(FHandle, 'lavfi-complex', ''); + Rest := AOptions; while Rest <> '' do begin @@ -637,6 +749,53 @@ begin mpv_set_property_string(FHandle, 'vf', PAnsiChar(Value)); end; +procedure TMpvPlayer.SetAudioSource(const AUrl: string); +begin + SetAudioSources([AUrl]); +end; + +procedure TMpvPlayer.SetAudioSources(const AUrls: array of string); +var + I, N: Integer; +begin + { Здесь только запоминаем. Подключается звук после загрузки картинки, + командой audio-add — см. SelectExternalAudio. } + SetLength(FAudioSources, Length(AUrls)); + N := 0; + for I := 0 to High(AUrls) do + if AUrls[I] <> '' then + begin + FAudioSources[N] := AUrls[I]; + Inc(N); + end; + SetLength(FAudioSources, N); + if N > 0 then + FAudioSource := FAudioSources[0] + else + FAudioSource := ''; +end; + +procedure TMpvPlayer.SetVideoOverlay(const AUrl: string; + const AWindows: TOverlayWindows); +var + I: Integer; +begin + FOverlayUrl := AUrl; + SetLength(FOverlayWindows, Length(AWindows)); + for I := 0 to High(AWindows) do + FOverlayWindows[I] := AWindows[I]; +end; + +procedure TMpvPlayer.SetTrackVolumes(const AVolumes: array of Double); +var + I: Integer; +begin + SetLength(FTrackVolumes, Length(AVolumes)); + for I := 0 to High(AVolumes) do + FTrackVolumes[I] := AVolumes[I]; + BuildGraph; +end; + procedure TMpvPlayer.SetHwdec(const AMode: string); begin if FHandle = nil then @@ -717,6 +876,314 @@ begin end; end; +{ Наложение оверлея на основу. + + Оверлей — обычная видеодорожка, подключённая рядом с основной. Класть её + поверх умеет сам плеер, поэтому ничего не собирается заранее: правка + видна сразу, а видеокарта не тратится на пересборку всего ролика. + + Окна с одинаковым размером и местом объединяются в одну ветку: масштаб + во времени не меняется, а вот показывать и прятать можно по времени — + это и делает enable. } +function TMpvPlayer.OverlayGraph: string; +var + I, J, N, Count: Integer; + Filters: array of string; + Xs, Ys: array of Integer; + Enables: array of string; + Src, Prev, Next, Fit: string; + + { Номер ветки для окна: у одинаковых по виду и месту она общая. } + function GroupOf(const AWin: TOverlayWindow): Integer; + var + K: Integer; + begin + for K := 0 to Count - 1 do + if (Filters[K] = AWin.Filter) and (Xs[K] = AWin.X) and + (Ys[K] = AWin.Y) then + Exit(K); + SetLength(Filters, Count + 1); + SetLength(Xs, Count + 1); + SetLength(Ys, Count + 1); + SetLength(Enables, Count + 1); + Filters[Count] := AWin.Filter; + Xs[Count] := AWin.X; + Ys[Count] := AWin.Y; + Enables[Count] := ''; + Result := Count; + Inc(Count); + end; + +begin + Result := ''; + if (FOverlayVid = '') or (FBaseVid = '') or + (Length(FOverlayWindows) = 0) then + Exit; + + Count := 0; + for I := 0 to High(FOverlayWindows) do + begin + J := GroupOf(FOverlayWindows[I]); + if Enables[J] <> '' then + Enables[J] := Enables[J] + '+'; + Enables[J] := Enables[J] + Format('between(t,%s,%s)', + [SecondsToStr(FOverlayWindows[I].TlStart), + SecondsToStr(FOverlayWindows[I].TlEnd)]); + end; + + { Одна ветка берёт оверлей напрямую, несколько — через split. } + if Count = 1 then + Result := Format('[vid%s]', [FOverlayVid]) + else + begin + Result := Format('[vid%s]split=%d', [FOverlayVid, Count]); + for I := 0 to Count - 1 do + Result := Result + Format('[q%d]', [I]); + Result := Result + ';'; + end; + + for I := 0 to Count - 1 do + begin + if Count = 1 then + Src := '' + else + Src := Format('[q%d]', [I]); + Fit := Filters[I]; + if Fit = '' then + Fit := 'null'; + Result := Result + Format('%s%s[ov%d];', [Src, Fit, I]); + end; + + Prev := Format('[vid%s]', [FBaseVid]); + for I := 0 to Count - 1 do + begin + if I = Count - 1 then + Next := '[vo]' + else + Next := Format('[m%d]', [I]); + { eof_action=pass и repeatlast=0: оверлей короче основы — обычное + дело, и после его конца картинка должна идти дальше как ни в чём + не бывало. } + Result := Result + Format('%s[ov%d]overlay=%d:%d:enable=''%s''' + + ':eof_action=pass:repeatlast=0%s;', + [Prev, I, Xs[I], Ys[I], Enables[I], Next]); + Prev := Next; + end; +end; + +procedure TMpvPlayer.BuildGraph; +var + I: Integer; + Graph, Vol, Video: string; + NeedAudioPart: Boolean; +begin + if FHandle = nil then + Exit; + + Video := OverlayGraph; + + { Цепочка отбирает дорожки: всё, что в ней не упомянуто, mpv снимает с + выбора. Поэтому при наложении звук приходится вести через неё же, + даже когда дорожка одна, — иначе он просто пропадёт. } + NeedAudioPart := (Length(FAudioIds) > 1) or + ((Video <> '') and (Length(FAudioIds) > 0)); + + if Length(FAudioIds) = 0 then + begin + { Дорожек нет — снимаем приглушение, иначе оно пережило бы смену + монтажа и заглушило следующий. } + SetVolume(100); + Graph := Video; + if Graph <> FLastGraph then + begin + FLastGraph := Graph; + mpv_set_property_string(FHandle, 'lavfi-complex', PAnsiChar(Graph)); + end; + Exit; + end; + + { Одна дорожка без наложения играется как есть: цепочка тут только + мешала бы, да и громкость задаётся обычным способом. } + if not NeedAudioPart then + begin + Graph := ''; + if (Length(FTrackVolumes) > 0) and (Abs(FTrackVolumes[0] - 1) > 0.001) then + SetVolume(FTrackVolumes[0] * 100) + else + SetVolume(100); + end + else if Length(FAudioIds) = 1 then + begin + SetVolume(100); + if Length(FTrackVolumes) > 0 then + Vol := SecondsToStr(FTrackVolumes[0]) + else + Vol := '1'; + Graph := Format('[aid%s]volume=%s[ao];', [FAudioIds[0], Vol]); + end + else + begin + { Общая громкость возвращается на место обязательно. + + Ветка выше выставляет её по громкости единственной дорожки, и ноль + там — обычное дело: клип с выключенным звуком. Раньше здесь она не + трогалась, и плеер, однажды заглушённый, оставался немым до конца + работы — на всём монтаже сразу, сколько бы дорожек потом ни + появилось. Здесь громкость каждой дорожки задана в самой цепочке, + поэтому общая всегда полная. } + SetVolume(100); + Graph := ''; + for I := 0 to High(FAudioIds) do + begin + if I <= High(FTrackVolumes) then + Vol := SecondsToStr(FTrackVolumes[I]) + else + Vol := '1'; + Graph := Graph + Format('[aid%s]volume=%s[t%d];', [FAudioIds[I], Vol, I]); + end; + for I := 0 to High(FAudioIds) do + Graph := Graph + Format('[t%d]', [I]); + Graph := Graph + Format('amix=inputs=%d:normalize=0[ao];', + [Length(FAudioIds)]); + end; + + Graph := Video + Graph; + if Graph = FLastGraph then + Exit; + FLastGraph := Graph; + mpv_set_property_string(FHandle, 'lavfi-complex', PAnsiChar(Graph)); +end; + +{ Оверлей подключается второй видеодорожкой. + + Как и со звуком, через свойство это не делается: нужна команда + video-add. Дорожка добавляется без выбора — выбирать её нельзя, иначе + она заменила бы картинку. Её дело — быть входом цепочки. } +procedure TMpvPlayer.AttachOverlay; +var + Count, I: Integer; + Kind, Ext, Id: string; +begin + if FHandle = nil then + Exit; + + FBaseVid := ''; + FOverlayVid := ''; + + if (FOverlayUrl <> '') and (Length(FOverlayWindows) > 0) then + Command(['video-add', FOverlayUrl, 'auto']); + + Count := StrToIntDef(GetPropString('track-list/count'), 0); + for I := 0 to Count - 1 do + begin + Kind := GetPropString(Format('track-list/%d/type', [I])); + if Kind <> 'video' then + Continue; + Id := GetPropString(Format('track-list/%d/id', [I])); + if Id = '' then + Continue; + Ext := GetPropString(Format('track-list/%d/external', [I])); + if (Ext = 'yes') or (Ext = 'true') then + begin + if FOverlayVid = '' then + FOverlayVid := Id; + end + else if FBaseVid = '' then + FBaseVid := Id; + end; +end; + +{ Субтитры подключаются двумя путями, и оба нужны. + + Здесь — когда файл поменялся, а картинка та же: снимаем прежние и + подключаем новые, не трогая воспроизведение. При загрузке нового списка + кусков mpv забывает все внешние дорожки, поэтому там подключение + повторяется — см. SelectExternalAudio. } +procedure TMpvPlayer.SetSubtitleFile(const APath: string; AForce: Boolean); +begin + if (FSubtitlePath = APath) and (not AForce) 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; + Kind, Ext, Id: string; +begin + if FHandle = nil then + Exit; + + { Своего звука нет — пусть играет как есть. } + if FAudioSource = '' then + Exit; + + { Подключаем каждую звуковую дорожку монтажа отдельным списком кусков. + + Через свойство audio-files это не работает: проверено на живом mpv — + список дорожек после загрузки остаётся прежним, внешний файл не + подключается вовсе, и играет звук, встроенный в саму картинку. Из-за + этого звук был слышен там, где на монтаже его нет, а после попытки + заглушить — пропал совсем. + + Команда audio-add с признаком select делает ровно то, что нужно: + добавляет дорожку, выбирает её и снимает выбор с внутренней. } + for I := 0 to High(FAudioSources) do + if I = 0 then + Command(['audio-add', FAudioSources[I], 'select']) + else + Command(['audio-add', FAudioSources[I], 'auto']); + + { Собираем номера всех подключённых звуковых дорожек. } + FAudioIds := nil; + Found := 0; + Count := StrToIntDef(GetPropString('track-list/count'), 0); + for I := 0 to Count - 1 do + begin + Kind := GetPropString(Format('track-list/%d/type', [I])); + if Kind <> 'audio' then + Continue; + Ext := GetPropString(Format('track-list/%d/external', [I])); + if (Ext <> 'yes') and (Ext <> 'true') then + Continue; + Id := GetPropString(Format('track-list/%d/id', [I])); + if Id = '' then + Continue; + if Found = 0 then + mpv_set_property_string(FHandle, 'aid', PAnsiChar(Id)); + SetLength(FAudioIds, Found + 1); + FAudioIds[Found] := Id; + Inc(Found); + end; + + if Found > 0 then + begin + FAudioTrackNote := 'Звук: дорожек монтажа ' + IntToStr(Found) + '.'; + { Цепочка строится отдельно: она зависит ещё и от громкостей, а те + меняются по ходу воспроизведения. } + BuildGraph; + Exit; + end; + + { Внешней дорожки не нашлось. + + Глушить звук здесь нельзя, и это проверено дорого: такая попытка + привела к тому, что звука не стало вовсе. Перебор дорожек может не + сработать по причинам, до которых отсюда не дознаться, а mpv и сам + предпочитает внешний список, когда тот открылся. + + Поэтому оставляем выбор ему, но записываем в журнал: если звук вдруг + окажется не тот, будет с чего начинать. } + FAudioTrackNote := 'ВНИМАНИЕ: внешняя звуковая дорожка не подключилась ' + + '(дорожек: ' + IntToStr(Count) + '). Звук может идти не с монтажа.'; +end; + procedure TMpvPlayer.HandleLogMessage(AMsg: Pmpv_event_log_message); begin if Assigned(FOnLog) then @@ -746,6 +1213,20 @@ begin HandlePropertyChange(Pmpv_event_property(Ev^.data)); MPV_EVENT_LOG_MESSAGE: HandleLogMessage(Pmpv_event_log_message(Ev^.data)); + MPV_EVENT_FILE_LOADED: + begin + { Оверлей подключается до звука: цепочка строится один раз, и в + ней должно быть сразу всё. } + AttachOverlay; + SelectExternalAudio; + { Звуковых дорожек может не оказаться вовсе, а наложение при + этом есть — тогда цепочку никто больше не соберёт. } + BuildGraph; + { Загрузка нового списка кусков сбрасывает все внешние дорожки, + в том числе субтитры. Подключаем заново. } + if FSubtitlePath <> '' then + Command(['sub-add', FSubtitlePath, 'select']); + end; MPV_EVENT_SHUTDOWN: begin FPump.Enabled := False; diff --git a/src/uPanCropForm.lfm b/src/uPanCropForm.lfm index be3f746..53a6ed6 100644 --- a/src/uPanCropForm.lfm +++ b/src/uPanCropForm.lfm @@ -1,24 +1,24 @@ object PanCropForm: TPanCropForm Left = 380 - Height = 560 + Height = 620 Top = 220 - Width = 940 + Width = 1260 BorderIcons = [biSystemMenu] Caption = 'Кадрирование и поворот' - ClientHeight = 560 - ClientWidth = 940 + ClientHeight = 620 + ClientWidth = 1260 OnCreate = FormCreate OnDestroy = FormDestroy Position = poOwnerFormCenter LCLVersion = '4.6' object pnlLeft: TPanel Left = 0 - Height = 560 + Height = 620 Top = 0 Width = 380 Align = alLeft BevelOuter = bvNone - ClientHeight = 560 + ClientHeight = 620 ClientWidth = 380 TabOrder = 0 object lblSource: TLabel @@ -179,13 +179,33 @@ object PanCropForm: TPanCropForm OnClick = btnCancelClick TabOrder = 9 end + object btnKey: TThemedButton + Left = 12 + Height = 30 + Top = 534 + Width = 356 + Caption = 'Цветовой ключ...' + OnClick = btnKeyClick + TabOrder = 10 + end + end + object pbSource: TPaintBox + Left = 380 + Height = 620 + Top = 0 + Width = 460 + Align = alClient + OnMouseDown = pbSourceMouseDown + OnMouseMove = pbSourceMouseMove + OnMouseUp = pbSourceMouseUp + OnPaint = pbSourcePaint end object imgPreview: TImage - Left = 380 - Height = 560 + Left = 840 + Height = 620 Top = 0 - Width = 560 - Align = alClient + Width = 420 + Align = alRight Center = True Proportional = True Stretch = True diff --git a/src/uPanCropForm.pas b/src/uPanCropForm.pas index edb2148..dfce88f 100644 --- a/src/uPanCropForm.pas +++ b/src/uPanCropForm.pas @@ -21,7 +21,7 @@ interface uses Classes, SysUtils, Forms, Controls, Graphics, ExtCtrls, StdCtrls, Spin, - ComCtrls, uTransform, uMediaProbe, uTheme; + ComCtrls, uTransform, uMediaProbe, uProject, uTheme; type @@ -29,6 +29,7 @@ type TPanCropForm = class(TForm) btnCancel: TThemedButton; + btnKey: TThemedButton; btnOk: TThemedButton; btnReset: TThemedButton; cbFit: TComboBox; @@ -36,6 +37,7 @@ type chkFlipH: TCheckBox; chkFlipV: TCheckBox; imgPreview: TImage; + pbSource: TPaintBox; lblFilter: TLabel; lblFit: TLabel; lblOffsetX: TLabel; @@ -48,20 +50,58 @@ type tbOffsetY: TTrackBar; tbZoom: TTrackBar; procedure btnCancelClick(Sender: TObject); + procedure btnKeyClick(Sender: TObject); procedure btnOkClick(Sender: TObject); procedure btnResetClick(Sender: TObject); procedure ControlChanged(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); + procedure pbSourcePaint(Sender: TObject); + procedure pbSourceMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); + procedure pbSourceMouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); + procedure pbSourceMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); private FTransform: TMediaTransform; FSourcePath: string; + { Цветовой ключ правится тут же, но принадлежит не окну, а клипу: + окно лишь показывает его хозяину. Пусто — правит нечего (так бывает + у заготовки для файла, у которой клипа ещё нет), и кнопки не + будет. } + FKey: PColorKey; FSourceInfo: TMediaInfo; FDstWidth: Integer; FDstHeight: Integer; FPreviewFile: string; FRefreshTimer: TTimer; FUpdating: Boolean; + { Кадр источника без всякой обработки — по нему тянут рамку. } + FSourceBmp: TBitmap; + { Размеры кадра после поворота: рамка живёт в этих координатах. } + FRotW: Integer; + FRotH: Integer; + { Рамка в координатах повёрнутого источника. } + FSel: TRect; + FDragMode: Integer; + FDragX: Integer; + FDragY: Integer; + FDragSel: TRect; + procedure LoadSourceFrame; + procedure UpdateRotatedSize; + { Прямоугольник, в который вписан кадр источника на панели. } + function SourceRect: TRect; + function SelToScreen(const ASel: TRect): TRect; + function ScreenToSourceX(AX: Integer): Integer; + function ScreenToSourceY(AY: Integer): Integer; + { Пересчёт между рамкой и настройкой. } + procedure SelFromTransform; + procedure TransformFromSel; + { Загоняет настройку в те пределы, которые умеют ползунки. Иначе + рамка и ползунки расходятся: рамка от неограниченного значения, + фильтр от обрезанного. } + procedure ClampTransform; procedure ReadControls; procedure WriteControls; procedure ScheduleRefresh; @@ -70,21 +110,28 @@ type { Готовит окно. ADstWidth и ADstHeight — кадр проекта. } procedure Setup(const APath: string; const AInfo: TMediaInfo; ADstWidth, ADstHeight: Integer; const ATransform: TMediaTransform; - const APreviewFile: string); + const APreviewFile: string; AKey: PColorKey = nil); property Transform: TMediaTransform read FTransform; end; { Показывает окно и возвращает True, если настройки приняты. } +{ AKey — цветовой ключ клипа. Нужен, чтобы правку ключа можно было + открыть отсюда: человек ищет её там же, где кадрирование, — обе + настройки про картинку одного клипа. Правка ключа сама себя + подтверждает и «Отменой» этого окна не отменяется. + + nil — ключа у этой настройки нет, кнопка не показывается. } function EditTransform(AOwner: TComponent; const APath: string; const AInfo: TMediaInfo; ADstWidth, ADstHeight: Integer; - var ATransform: TMediaTransform; const APreviewFile: string): Boolean; + var ATransform: TMediaTransform; const APreviewFile: string; + AKey: PColorKey = nil): Boolean; implementation {$R *.lfm} uses - Math, uAppTypes, uFfmpegCmd, uProcRunner; + Math, Types, LCLIntf, uAppTypes, uFfmpegCmd, uProcRunner, uColorKeyForm; const { Ширина показываемого кадра. Больше незачем: тут важны пропорции и то, @@ -95,9 +142,21 @@ const каждое движение бессмысленно. } RefreshDelayMs = 300; + { Что тянут мышью по кадру источника. } + dmNone = 0; + dmMove = 1; + dmResize = 2; + + { Сколько пикселей у угла считается «за угол». } + CornerGrip = 12; + ZoomMin = 50; ZoomMax = 400; - OffsetRange = 50; + { Предел смещения. При сильном увеличении кадр гуляет далеко за половину + своей ширины, и полсотни процентов не хватало: рамку можно было + утащить туда, куда ползунок не дотягивается, и они расходились — + рамка показывала одно, а получалось другое. } + OffsetRange = 200; procedure TPanCropForm.FormCreate(Sender: TObject); begin @@ -144,6 +203,7 @@ end; procedure TPanCropForm.FormDestroy(Sender: TObject); begin + FreeAndNil(FSourceBmp); FRefreshTimer.Enabled := False; if (FPreviewFile <> '') and FileExists(FPreviewFile) then DeleteFile(FPreviewFile); @@ -151,8 +211,10 @@ end; procedure TPanCropForm.Setup(const APath: string; const AInfo: TMediaInfo; ADstWidth, ADstHeight: Integer; const ATransform: TMediaTransform; - const APreviewFile: string); + const APreviewFile: string; AKey: PColorKey); begin + FKey := AKey; + btnKey.Visible := AKey <> nil; FSourcePath := APath; FSourceInfo := AInfo; FDstWidth := ADstWidth; @@ -164,6 +226,8 @@ begin [ExtractFileName(APath), AInfo.Width, AInfo.Height, ADstWidth, ADstHeight]); WriteControls; + LoadSourceFrame; + SelFromTransform; RefreshPreview(nil); end; @@ -233,6 +297,9 @@ begin if FUpdating then Exit; ReadControls; + { Рамка следует за ползунками: иначе они разошлись бы с картинкой. } + SelFromTransform; + pbSource.Invalidate; ScheduleRefresh; end; @@ -244,6 +311,23 @@ begin ScheduleRefresh; end; +{ Правка цветового ключа того же клипа. + + Кадр для выбора цвета окно ключа достаёт само — тот же, что и здесь: + первый кадр часто чёрный, и тыкать в него не во что. } +procedure TPanCropForm.btnKeyClick(Sender: TObject); +var + AtTime: Double; +begin + if FKey = nil then + Exit; + if FSourceInfo.Kind = mkImage then + AtTime := 0 + else + AtTime := Min(5, Max(0, FSourceInfo.Duration * 0.1)); + EditColorKey(FKey^, FSourcePath, AtTime, FPreviewFile + '.key.png'); +end; + procedure TPanCropForm.ScheduleRefresh; begin { Вызов может прийти во время сборки окна, когда таймера ещё нет. } @@ -253,6 +337,323 @@ begin FRefreshTimer.Enabled := True; end; + +{ --- Рамка поверх кадра источника --- } + +{ Размеры кадра после поворота: рамка живёт именно в них, иначе после + поворота на 90 она оказалась бы поперёк картинки. } +procedure TPanCropForm.UpdateRotatedSize; +begin + { Рамка живёт в координатах исходника как он есть. Поворот на неё не + влияет: он применяется к уже вырезанному куску, а не к кадру целиком — + иначе рамка показывала бы не то, что останется. } + FRotW := FSourceInfo.Width; + FRotH := FSourceInfo.Height; +end; + +{ Кадр источника, вписанный в панель с сохранением пропорций. } +function TPanCropForm.SourceRect: TRect; +var + K: Double; + W, H: Integer; +begin + Result := Rect(0, 0, 0, 0); + if (FRotW <= 0) or (FRotH <= 0) then + Exit; + K := Min((pbSource.Width - 20) / FRotW, (pbSource.Height - 20) / FRotH); + if K <= 0 then + Exit; + W := Round(FRotW * K); + H := Round(FRotH * K); + Result := Rect((pbSource.Width - W) div 2, (pbSource.Height - H) div 2, + (pbSource.Width - W) div 2 + W, (pbSource.Height - H) div 2 + H); +end; + +function TPanCropForm.SelToScreen(const ASel: TRect): TRect; +var + R: TRect; + KX, KY: Double; +begin + R := SourceRect; + if (FRotW <= 0) or (FRotH <= 0) or (R.Right <= R.Left) then + Exit(Rect(0, 0, 0, 0)); + KX := (R.Right - R.Left) / FRotW; + KY := (R.Bottom - R.Top) / FRotH; + Result := Rect( + R.Left + Round(ASel.Left * KX), R.Top + Round(ASel.Top * KY), + R.Left + Round(ASel.Right * KX), R.Top + Round(ASel.Bottom * KY)); +end; + +function TPanCropForm.ScreenToSourceX(AX: Integer): Integer; +var + R: TRect; +begin + R := SourceRect; + if R.Right <= R.Left then + Exit(0); + Result := Round((AX - R.Left) * FRotW / (R.Right - R.Left)); +end; + +function TPanCropForm.ScreenToSourceY(AY: Integer): Integer; +var + R: TRect; +begin + R := SourceRect; + if R.Bottom <= R.Top then + Exit(0); + Result := Round((AY - R.Top) * FRotH / (R.Bottom - R.Top)); +end; + +{ Рамка по настройке. Обратное к TransformFromSel: там же и объяснение, + откуда берутся числа. } +procedure TPanCropForm.SelFromTransform; +var + KFit, KFill, K: Double; + SW, SH, CW, CH, CX, CY: Double; + W, H: Double; +begin + UpdateRotatedSize; + if (FRotW <= 0) or (FRotH <= 0) or (FDstWidth <= 0) or (FDstHeight <= 0) then + Exit; + + KFit := Min(FDstWidth / FRotW, FDstHeight / FRotH); + KFill := Max(FDstWidth / FRotW, FDstHeight / FRotH); + if FTransform.Fit = fmFill then + K := KFill + else + K := KFit; + if FTransform.Fit = fmStretch then + begin + { Растяжение рамкой не описывается: берётся весь кадр. } + FSel := Rect(0, 0, FRotW, FRotH); + Exit; + end; + if FTransform.Zoom > 0 then + K := K * FTransform.Zoom; + if K <= 0 then + Exit; + + SW := FRotW * K; + SH := FRotH * K; + CW := Min(SW, FDstWidth); + CH := Min(SH, FDstHeight); + CX := (SW - CW) / 2 + FTransform.OffsetX * FDstWidth; + CY := (SH - CH) / 2 + FTransform.OffsetY * FDstHeight; + CX := Max(0, Min(SW - CW, CX)); + CY := Max(0, Min(SH - CH, CY)); + + W := CW / K; + H := CH / K; + FSel := Rect(Round(CX / K), Round(CY / K), + Round(CX / K + W), Round(CY / K + H)); +end; + +{ Настройка по рамке. + + Рамка говорит, какая часть источника займёт кадр проекта. Отсюда + увеличение — во сколько раз её надо растянуть, а смещение — насколько + она сдвинута относительно середины. } +procedure TPanCropForm.TransformFromSel; +var + KFit, KFill, KBase, K: Double; + SW, SH, CW, CH: Double; +begin + if (FRotW <= 0) or (FRotH <= 0) or (FDstWidth <= 0) or (FDstHeight <= 0) then + Exit; + if (FSel.Right - FSel.Left < 4) or (FSel.Bottom - FSel.Top < 4) then + Exit; + + KFit := Min(FDstWidth / FRotW, FDstHeight / FRotH); + KFill := Max(FDstWidth / FRotW, FDstHeight / FRotH); + if FTransform.Fit = fmFill then + KBase := KFill + else + KBase := KFit; + if KBase <= 0 then + Exit; + + K := FDstWidth / (FSel.Right - FSel.Left); + FTransform.Zoom := K / KBase; + + SW := FRotW * K; + SH := FRotH * K; + CW := Min(SW, FDstWidth); + CH := Min(SH, FDstHeight); + { Смещение пересчитывается по рамке только там, где рамка его и + задаёт, — то есть где картинка шире или выше кадра. Где она меньше, + рамка охватывает её целиком и о смещении ничего не знает; посчитанный + по ней ноль вернул бы картинку на середину и отменил бы то, что + выставлено ползунком. } + if SW > FDstWidth then + FTransform.OffsetX := (FSel.Left * K - (SW - CW) / 2) / FDstWidth; + if SH > FDstHeight then + FTransform.OffsetY := (FSel.Top * K - (SH - CH) / 2) / FDstHeight; +end; + +procedure TPanCropForm.ClampTransform; +begin + if FTransform.Zoom < ZoomMin / 100 then + FTransform.Zoom := ZoomMin / 100; + if FTransform.Zoom > ZoomMax / 100 then + FTransform.Zoom := ZoomMax / 100; + FTransform.OffsetX := Max(-OffsetRange / 100, Min(OffsetRange / 100, + FTransform.OffsetX)); + FTransform.OffsetY := Max(-OffsetRange / 100, Min(OffsetRange / 100, + FTransform.OffsetY)); +end; + +{ Кадр источника без обработки: по нему тянут рамку. } +procedure TPanCropForm.LoadSourceFrame; +var + Res: TProcResult; + Png: TPortableNetworkGraphic; + AtTime: Double; + Path: string; +begin + FreeAndNil(FSourceBmp); + if FSourcePath = '' then + Exit; + + Path := FPreviewFile + '.src.png'; + if FSourceInfo.Kind = mkImage then + AtTime := 0 + else + AtTime := Min(5, Max(0, FSourceInfo.Duration * 0.1)); + + { Пустая цепочка фильтров: нужен именно исходный кадр, без вписывания и + полей — иначе рамку не по чему тянуть. } + Res := RunProcess(FfmpegExe, + ArgsPreviewFrame(FSourcePath, Path, AtTime, ''), nil, nil, nil); + if (not Res.Started) or (Res.ExitCode <> 0) or (not FileExists(Path)) then + Exit; + + Png := TPortableNetworkGraphic.Create; + try + try + Png.LoadFromFile(Path); + FSourceBmp := TBitmap.Create; + FSourceBmp.Assign(Png); + except + FreeAndNil(FSourceBmp); + end; + finally + Png.Free; + end; + SysUtils.DeleteFile(Path); +end; + +procedure TPanCropForm.pbSourcePaint(Sender: TObject); +var + R, S: TRect; +begin + pbSource.Canvas.Brush.Style := bsSolid; + pbSource.Canvas.Brush.Color := ThemeWindow; + pbSource.Canvas.FillRect(pbSource.ClientRect); + + R := SourceRect; + if R.Right <= R.Left then + Exit; + + if FSourceBmp <> nil then + pbSource.Canvas.StretchDraw(R, FSourceBmp) + else + begin + pbSource.Canvas.Brush.Color := ThemeSurface; + pbSource.Canvas.FillRect(R); + end; + + { Затемнять то, что вне рамки, нечем без полупрозрачности, поэтому + просто рисуем саму рамку и её углы. } + S := SelToScreen(FSel); + pbSource.Canvas.Brush.Style := bsClear; + pbSource.Canvas.Pen.Color := ThemeAccent; + pbSource.Canvas.Pen.Width := 2; + pbSource.Canvas.Rectangle(S); + pbSource.Canvas.Pen.Width := 1; + + pbSource.Canvas.Brush.Style := bsSolid; + pbSource.Canvas.Brush.Color := ThemeAccent; + pbSource.Canvas.FillRect(S.Right - 8, S.Bottom - 8, S.Right, S.Bottom); +end; + +procedure TPanCropForm.pbSourceMouseDown(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +var + S: TRect; +begin + if Button <> mbLeft then + Exit; + S := SelToScreen(FSel); + FDragSel := FSel; + FDragX := X; + FDragY := Y; + + if (Abs(X - S.Right) <= CornerGrip) and (Abs(Y - S.Bottom) <= CornerGrip) then + FDragMode := dmResize + else if PtInRect(S, Point(X, Y)) then + FDragMode := dmMove + else + FDragMode := dmNone; +end; + +procedure TPanCropForm.pbSourceMouseMove(Sender: TObject; Shift: TShiftState; + X, Y: Integer); +var + DX, DY, W, H: Integer; +begin + if FDragMode = dmNone then + Exit; + + DX := ScreenToSourceX(X) - ScreenToSourceX(FDragX); + DY := ScreenToSourceY(Y) - ScreenToSourceY(FDragY); + + if FDragMode = dmMove then + begin + W := FDragSel.Right - FDragSel.Left; + H := FDragSel.Bottom - FDragSel.Top; + FSel.Left := Max(0, Min(FRotW - W, FDragSel.Left + DX)); + FSel.Top := Max(0, Min(FRotH - H, FDragSel.Top + DY)); + FSel.Right := FSel.Left + W; + FSel.Bottom := FSel.Top + H; + end + else + begin + { Ширину меняем мышью, высоту считаем: рамка держит пропорции кадра + проекта, иначе картинка поехала бы. } + W := Max(16, FDragSel.Right - FDragSel.Left + DX); + W := Min(W, FRotW - FSel.Left); + H := Round(W * FDstHeight / FDstWidth); + if FSel.Top + H > FRotH then + begin + H := FRotH - FSel.Top; + W := Round(H * FDstWidth / FDstHeight); + end; + FSel.Right := FSel.Left + W; + FSel.Bottom := FSel.Top + H; + end; + + TransformFromSel; + ClampTransform; + { Рамка пересчитывается обратно из настройки. Так она всегда показывает + ровно то, что получится: если настройка упёрлась в предел, это сразу + видно, а не расходится молча. } + SelFromTransform; + FUpdating := True; + try + WriteControls; + finally + FUpdating := False; + end; + pbSource.Invalidate; + ScheduleRefresh; +end; + +procedure TPanCropForm.pbSourceMouseUp(Sender: TObject; Button: TMouseButton; + Shift: TShiftState; X, Y: Integer); +begin + FDragMode := dmNone; +end; + procedure TPanCropForm.RefreshPreview(Sender: TObject); var PrevW, PrevH: Integer; @@ -318,13 +719,15 @@ end; function EditTransform(AOwner: TComponent; const APath: string; const AInfo: TMediaInfo; ADstWidth, ADstHeight: Integer; - var ATransform: TMediaTransform; const APreviewFile: string): Boolean; + var ATransform: TMediaTransform; const APreviewFile: string; + AKey: PColorKey): Boolean; var Form: TPanCropForm; begin Form := TPanCropForm.Create(AOwner); try - Form.Setup(APath, AInfo, ADstWidth, ADstHeight, ATransform, APreviewFile); + Form.Setup(APath, AInfo, ADstWidth, ADstHeight, ATransform, APreviewFile, + AKey); Result := Form.ShowModal = mrOK; if Result then ATransform := Form.Transform; diff --git a/src/uProgressForm.lfm b/src/uProgressForm.lfm index 7bc2c6d..0a829ac 100644 --- a/src/uProgressForm.lfm +++ b/src/uProgressForm.lfm @@ -38,6 +38,15 @@ object ProgressForm: TProgressForm Anchors = [akTop, akLeft, akRight] TabOrder = 0 end + object lblEta: TLabel + Left = 12 + Height = 20 + Top = 74 + Width = 500 + Anchors = [akTop, akLeft, akRight] + Caption = '' + ParentColor = False + end object btnAction: TThemedButton Left = 648 Height = 28 @@ -49,7 +58,7 @@ object ProgressForm: TProgressForm TabOrder = 1 end end - object memoLog: TMemo + object memoLog: TLogView Left = 0 Height = 310 Top = 110 @@ -58,9 +67,6 @@ object ProgressForm: TProgressForm Font.Height = -12 Font.Name = 'Monospace' ParentFont = False - ReadOnly = True - ScrollBars = ssAutoBoth TabOrder = 1 - WordWrap = False end end diff --git a/src/uProgressForm.pas b/src/uProgressForm.pas index 55e5dab..269e6c5 100644 --- a/src/uProgressForm.pas +++ b/src/uProgressForm.pas @@ -16,7 +16,8 @@ unit uProgressForm; interface uses - Classes, SysUtils, Forms, Controls, Graphics, ComCtrls, StdCtrls, ExtCtrls, uTheme; + Classes, SysUtils, Forms, Controls, Graphics, ComCtrls, StdCtrls, ExtCtrls, + uTheme, uLogView; type @@ -25,7 +26,8 @@ type TProgressForm = class(TForm) btnAction: TThemedButton; lblStage: TLabel; - memoLog: TMemo; + lblEta: TLabel; + memoLog: TLogView; pbBar: TProgressBar; pnlTop: TPanel; procedure btnActionClick(Sender: TObject); @@ -35,6 +37,11 @@ type FFinished: Boolean; FCancelRequested: Boolean; FOnCancelRequest: TNotifyEvent; + { Когда началась работа и какую долю показывали в прошлый раз: по ним + считается, сколько осталось. } + FStartedAt: TDateTime; + FLastFraction: Double; + function FormatSpan(const ASeconds: Double): string; public procedure SetStage(const AText: string); procedure SetFraction(AValue: Double); @@ -69,6 +76,9 @@ begin pbBar.Position := 0; memoLog.Clear; btnAction.Caption := 'Отмена'; + FStartedAt := Now; + FLastFraction := 0; + lblEta.Caption := ''; end; procedure TProgressForm.SetStage(const AText: string); @@ -76,24 +86,62 @@ begin lblStage.Caption := AText; end; +{ Время в виде «3 мин 20 с»: секунды сотнями человек не читает. } +function TProgressForm.FormatSpan(const ASeconds: Double): string; +var + Total, M, S: Integer; +begin + Total := Round(ASeconds); + if Total < 0 then + Total := 0; + M := Total div 60; + S := Total mod 60; + if M >= 60 then + Result := Format('%d ч %d мин', [M div 60, M mod 60]) + else if M > 0 then + Result := Format('%d мин %d с', [M, S]) + else + Result := Format('%d с', [S]); +end; + +{ Сколько прошло и сколько осталось. + + Осталось считается по простому правилу: если четверть пути заняла + минуту, весь путь займёт четыре. На деле скорость меняется — куски, + которые копируются, идут мгновенно, а те, что пересобираются, + медленно, — поэтому число называется «примерно» и пересчитывается на + каждом шаге. Даже такая оценка отвечает на главный вопрос: успею ли я + сходить за чаем. } procedure TProgressForm.SetFraction(AValue: Double); +var + { Не Left: так называется свойство формы. } + Elapsed, Remain: Double; begin if AValue < 0 then AValue := 0; if AValue > 1 then AValue := 1; pbBar.Position := Round(AValue * BarScale); + FLastFraction := AValue; + + Elapsed := (Now - FStartedAt) * SecsPerDay; + { Пока сделано меньше сотой доли, оценка была бы гаданием: первые + секунды уходят на запуск ffmpeg, а не на работу. } + if (AValue > 0.01) and (Elapsed > 1) then + begin + Remain := Elapsed * (1 - AValue) / AValue; + lblEta.Caption := Format('Прошло %s, осталось примерно %s (%d%%)', + [FormatSpan(Elapsed), FormatSpan(Remain), Round(AValue * 100)]); + end + else + lblEta.Caption := 'Прошло ' + FormatSpan(Elapsed); end; procedure TProgressForm.AddLog(const AText: string); begin - { Журнал одной операции не должен расти без предела: ffmpeg на битом - файле способен выдать тысячи одинаковых предупреждений. } - if memoLog.Lines.Count > 1000 then - memoLog.Lines.Delete(0); - memoLog.Lines.Add(AText); - { Держим видимой последнюю строку. } - memoLog.SelStart := Length(memoLog.Text); + { Свой журнал сам держится конца, пока пользователь не отмотал назад, и + сам обрезает старые строки. } + memoLog.Add(AText); end; procedure TProgressForm.Finish(ASuccess: Boolean; const AMessage: string); @@ -101,6 +149,8 @@ begin FFinished := True; btnAction.Caption := 'Закрыть'; lblStage.Caption := AMessage; + { На месте оценки — итог: сколько всё это заняло. } + lblEta.Caption := 'Заняло ' + FormatSpan((Now - FStartedAt) * SecsPerDay); if ASuccess then lblStage.Font.Color := clDefault else diff --git a/src/uProject.pas b/src/uProject.pas index c6501b0..6da4a5b 100644 --- a/src/uProject.pas +++ b/src/uProject.pas @@ -34,7 +34,60 @@ type кадра придётся перекодировать. } TEdgeMode = (edSnap, edPrecise); - 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 + ); + + { Цветовой ключ: цвет, который у клипа становится прозрачным. + + Нужен для накладок — плиток, значков, рамок, снятых на однотонном + фоне. Пурпурный берут потому, что в природе он почти не встречается: + ошибиться и вырезать кусок картинки труднее, чем с зелёным. + + Клип с ключом собрать копированием нельзя: участок пересобирается + вместе с тем, что под ним, как и полупрозрачный. } + TColorKey = record + Enabled: Boolean; + Color: TRgb; + { Насколько далеко от указанного цвета считать «тем же цветом», в + процентах. Ноль — только точное совпадение. } + Similarity: Integer; + { Смягчение края, в процентах. Ноль — резкая граница. } + Blend: Integer; + end; + PColorKey = ^TColorKey; + + { Оформление текстового клипа. + + Цвета хранятся как 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; { На какие дорожки действует схлопывание. @@ -80,8 +133,37 @@ type FKind: TClipKind; FSelected: Boolean; FVolume: Double; + FTransform: TMediaTransform; + FGroupId: string; + FOpacity: Double; + FFadeIn: Double; + FFadeOut: Double; + FText: string; + FTextStyle: TTextStyle; + FColorKey: TColorKey; public constructor Create; + { Переносит на этот клип всё, что настроено у другого: громкость, + кадрирование, прозрачность, ключ, затухания, текст. + + Не переносится то, что делает клип этим клипом: имя, место на + монтаже, кусок исходника, связка и выделение. + + Зачем метод, а не переписывание полей на месте: копия клипа нужна в + нескольких местах (рез — самое частое), и каждое новое свойство + иначе приходится вспоминать в каждом из них. Один раз не вспомнили — + и после реза половина клипа теряла цветовой ключ, а вместе с ним и + прозрачность: она переставала быть наложением и закрывала собой всё, + что ниже. } + procedure CopySettingsFrom(ASource: TClip); + { Переносит только оформление: кадрирование, поворот, увеличение, + смещение, прозрачность, ключ, затухания, громкость. + + От CopySettingsFrom отличается тем, что не трогает вид клипа и его + текст: свойства переносят между разными клипами, и превращать + картинку в надпись при этом незачем. Оформление надписи переносится + только между надписями. } + procedure CopyLookFrom(ASource: TClip); function TlEnd: Double; function SrcOut: Double; { Попадает ли момент внутрь клипа. Правый край не включается: там уже @@ -99,14 +181,49 @@ type громче. Хранится множителем, а не в децибелах, чтобы не переводить туда-сюда при каждой отрисовке; в интерфейсе показывается процентами. } property Volume: Double read FVolume write FVolume; + { Как кадр этого клипа ложится в кадр проекта. + + Настройка принадлежит клипу, а не файлу: два куска одного файла + бывает нужно кадрировать по-разному. У файла остаётся такая же + настройка, но она лишь заготовка — её берёт новый клип при + добавлении. } + property Transform: TMediaTransform read FTransform write FTransform; + { Непрозрачность клипа картинки: 1 — обычный, 0.5 — сквозь него видно + то, что ниже. + + Стоит понимать цену: как только клип перестаёт быть непрозрачным, + его нельзя скопировать — участок приходится пересобирать вместе со + всем, что под ним. Поэтому по умолчанию единица, и программа + предупреждает перед сборкой, сколько секунд это займёт. } + property Opacity: Double read FOpacity write FOpacity; + { Плавное появление и уход, в секундах от краёв клипа. Для картинки + это затемнение, для звука — нарастание громкости. } + property FadeIn: Double read FFadeIn write FFadeIn; + property FadeOut: Double read FFadeOut write FFadeOut; + { Связка. Клипы с одинаковым непустым значением двигаются, режутся и + удаляются вместе. По умолчанию так связаны картинка и её звук; + Ctrl+G связывает и развязывает что угодно. } + property GroupId: string read FGroupId write FGroupId; + { Цветовой ключ клипа. Выключен — клип обычный. } + property ColorKey: TColorKey read FColorKey write FColorKey; + { Текст и его оформление. Имеют смысл только у клипа вида ckText; + у остальных лежат пустыми и в файл проекта не пишутся. } + property Text: string read FText write FText; + property TextStyle: TTextStyle read FTextStyle write FTextStyle; { Выделение живёт только в памяти и в файл проекта не пишется. } property Selected: Boolean read FSelected write FSelected; end; + { Что живёт на дорожке. Картинка и звук разделены, потому что их можно + двигать порознь: звук из одного места монтажа под картинкой из + другого — обычное дело. } + TTrackKind = (tkVideo, tkAudio, tkText); + TTrack = class private FId: string; FName: string; + FKind: TTrackKind; FMuted: Boolean; FSolo: Boolean; FClips: TObjectList; @@ -126,6 +243,7 @@ type property Count: Integer read GetCount; property Id: string read FId write FId; property Name: string read FName write FName; + property Kind: TTrackKind read FKind write FKind; property Muted: Boolean read FMuted write FMuted; { Когда хоть у одной дорожки включено «соло», в результат идут только такие дорожки. Удобно, чтобы послушать одну, не выключая остальные @@ -139,6 +257,9 @@ type FTracks: TObjectList; FMaster: TMediaInfo; FRippleMode: TRippleMode; + { Отмеченный участок монтажа: от и до. Пока не отмечен, оба нуля. } + FRegionStart: Double; + FRegionEnd: Double; FRippleEnabled: Boolean; FFileName: string; FModified: Boolean; @@ -149,10 +270,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; @@ -164,11 +287,46 @@ type function FindMediaByPath(const APath: string): TMediaItem; procedure RemoveMedia(AItem: TMediaItem); + { Номер новой связки. Отдельным именем, чтобы не пришлось помнить + префикс в каждом месте, где связка заводится. } + function NewGroupId: string; + { Имя, которого ещё нет ни у одной дорожки: V1, V2, ... Считать + дорожки нужного вида и прибавлять единицу нельзя — после удаления + средней счёт совпадёт с уже занятым именем, и в окне окажутся две + дорожки Т2. } + function UniqueTrackName(const APrefix: string): string; + { Разводит одинаковые имена дорожек, доставшиеся от старых проектов. + Имя — только подпись, но две дорожки Т2 в окне сбивают с толку. } + procedure EnsureUniqueTrackNames; function AddTrack(const AName: string): TTrack; + function AddTrackOfKind(const AName: string; AKind: TTrackKind): TTrack; function FindTrack(const AId: string): TTrack; procedure RemoveTrack(AIndex: Integer); procedure MoveTrack(AFrom, ATo: Integer); + { Сколько дорожек каждого вида и как найти парную. + + Пара определяется порядковым номером: у первой дорожки картинки + первая дорожка звука. Так связка «картинка плюс её звук» ложится + напротив друг друга, и монтаж читается взглядом. } + function TrackCountOf(AKind: TTrackKind): Integer; + function TrackOfKind(AKind: TTrackKind; AIndex: Integer): TTrack; + function IndexAmongKind(ATrack: TTrack): Integer; + { Заводит недостающие звуковые дорожки, чтобы у каждой дорожки + картинки была парная. } + procedure EnsureAudioTracks; + { Перенос проектов, записанных до разделения звука и картинки: там + звук шёл вместе с клипом картинки, и без пары он бы просто пропал. } + procedure MigrateAudio; + { Клип на звуковой дорожке обязан быть звуковым. В проектах, записанных + до того, как вид клипа научился сохраняться, он остался «видео» — и + тогда у клипа пропадает форма звука, появляется лишняя кнопка + кадрирования, а ползунок правит прозрачность вместо громкости. } + procedure FixClipKinds; + { Кладёт клип и, если в файле есть звук, парный звуковой клип на + соответствующую звуковую дорожку. Возвращает клип картинки. } + function AddClipPair(ATrack: TTrack; AMedia: TMediaItem; + const ASrcIn, ADuration, ATlStart: Double): TClip; function AddClip(ATrack: TTrack; AMedia: TMediaItem; const ASrcIn, ADuration, ATlStart: Double): TClip; function FindClipTrack(AClip: TClip): TTrack; @@ -222,6 +380,38 @@ type { Режим действует всегда, даже когда автосхлопывание выключено: он определяет, что сделает Ctrl+Shift+R. } property RippleMode: TRippleMode read FRippleMode write FRippleMode; + { Отмеченный участок: собирать можно только его. Нужен, чтобы + проверить кусок монтажа, не собирая весь ролик — на длинном + материале это разница между минутой и часом. + + Отметок две, и обе живут в проекте, а не в настройках программы: + участок относится к этому монтажу, а не к привычкам человека. } + property RegionStart: Double read FRegionStart write FRegionStart; + property RegionEnd: Double read FRegionEnd write FRegionEnd; + function HasRegion: Boolean; + { Наибольший битрейт среди видеофайлов проекта. + + Им целятся при пересборке кусков. Брать средний или битрейт первого + файла нельзя: пересобранный кусок стоит рядом со скопированными, и + если он окажется хуже их, разница бросится в глаза именно на нём. + Лучше потратить место, чем показать шакала посреди чистой съёмки. } + function MaxVideoBitrate: Int64; + { Какая дорожка нужна клипу этого вида. Правило одно на всю + программу: картинке — дорожка картинки, звуку — звуковая, надписи — + текстовая. } + class function TrackKindFor(AClipKind: TClipKind): TTrackKind; + { Сколько клипов лежит на дорожках не своего вида. + + Такой клип не попадает никуда: уплощение обходит дорожки по видам, + и клип с чужой дорожки не видит ни сборка, ни предпросмотр. Пропажа + при этом тихая — на монтаже он нарисован, а в ролике его нет. } + function MisplacedClipCount: Integer; + { Переносит их на подходящие дорожки. Возвращает, сколько перенесено. + + Ищется первая дорожка нужного вида, где это время свободно; если + такой нет — заводится новая. Время клипа не меняется: человек ставил + его именно туда. } + function FixMisplacedClips: Integer; { Автоматическое схлопывание при перетаскивании клипов. } property RippleEnabled: Boolean read FRippleEnabled write FRippleEnabled; property FileName: string read FFileName write FFileName; @@ -232,6 +422,23 @@ const { Сколько длится картинка, пока её не растянули. } DefaultImageDuration = 5.0; +{ Цветовой ключ по умолчанию. } +function DefaultColorKey: TColorKey; + +{ Одинаковы ли два ключа. Записи в Паскале сравнивать оператором нельзя, + а знать, изменилось ли что-нибудь, нужно: иначе в истории отмены + появится пустой шаг. } +function SameColorKey(const A, B: TColorKey): Boolean; + +{ Оформление текста по умолчанию: белые буквы с тёмной обводкой внизу по + центру — то, что читается на любой картинке. } +function DefaultTextStyle: TTextStyle; + +{ Шрифт по умолчанию. Разный по системам: одинаковых имён у них нет. } +const + DefaultTextFont = + {$IFDEF WINDOWS}'Arial'{$ELSE}'DejaVu Sans'{$ENDIF}; + implementation uses @@ -259,11 +466,44 @@ end; { --- TClip --- } +procedure TClip.CopySettingsFrom(ASource: TClip); +begin + if ASource = nil then + Exit; + FKind := ASource.Kind; + FVolume := ASource.Volume; + FTransform := ASource.Transform; + FOpacity := ASource.Opacity; + FColorKey := ASource.ColorKey; + FFadeIn := ASource.FadeIn; + FFadeOut := ASource.FadeOut; + FText := ASource.Text; + FTextStyle := ASource.TextStyle; +end; + +procedure TClip.CopyLookFrom(ASource: TClip); +begin + if ASource = nil then + Exit; + FTransform := ASource.Transform; + FOpacity := ASource.Opacity; + FColorKey := ASource.ColorKey; + FFadeIn := ASource.FadeIn; + FFadeOut := ASource.FadeOut; + FVolume := ASource.Volume; + if (FKind = ckText) and (ASource.Kind = ckText) then + FTextStyle := ASource.TextStyle; +end; + constructor TClip.Create; begin inherited Create; { Без явного значения множитель был бы нулём, то есть тишиной. } FVolume := 1; + FOpacity := 1; + FTransform := DefaultTransform; + FTextStyle := DefaultTextStyle; + FColorKey := DefaultColorKey; end; function TClip.TlEnd: Double; @@ -401,6 +641,8 @@ begin FMaster := Default(TMediaInfo); FRippleMode := rmCurrentTrack; FRippleEnabled := False; + FRegionStart := 0; + FRegionEnd := 0; FFileName := ''; FModified := False; FNextId := 1; @@ -411,8 +653,12 @@ begin Clear; { Две дорожки с самого начала: одна пустая дорожка не показывает главного — что верхняя перекрывает нижнюю. } + { Две дорожки картинки и две звука. Звук снизу: так принято везде, и + так он не мешает смотреть на картинку. } AddTrack('V1'); AddTrack('V2'); + AddTrackOfKind('A1', tkAudio); + AddTrackOfKind('A2', tkAudio); FModified := False; end; @@ -436,6 +682,11 @@ begin Result := FTracks.Count; end; +function TProject.NewGroupId: string; +begin + Result := NewId('g'); +end; + function TProject.NewId(const APrefix: string): string; begin Result := APrefix + IntToStr(FNextId); @@ -496,12 +747,90 @@ begin FModified := True; end; +function TProject.UniqueTrackName(const APrefix: string): string; +var + N, I: Integer; + Taken: Boolean; +begin + N := 1; + repeat + Result := APrefix + IntToStr(N); + Taken := False; + for I := 0 to FTracks.Count - 1 do + if TTrack(FTracks[I]).Name = Result then + begin + Taken := True; + Break; + end; + Inc(N); + until not Taken; +end; + +procedure TProject.EnsureUniqueTrackNames; +var + I, J: Integer; + Prefix: string; +begin + for I := 0 to FTracks.Count - 1 do + for J := 0 to I - 1 do + if TTrack(FTracks[J]).Name = TTrack(FTracks[I]).Name then + begin + case TTrack(FTracks[I]).Kind of + tkAudio: Prefix := 'A'; + tkText: Prefix := 'Т'; + else + Prefix := 'V'; + end; + TTrack(FTracks[I]).Name := UniqueTrackName(Prefix); + Break; + end; +end; + function TProject.AddTrack(const AName: string): TTrack; +begin + Result := AddTrackOfKind(AName, tkVideo); +end; + +function TProject.AddTrackOfKind(const AName: string; + AKind: TTrackKind): TTrack; +var + I, Pos: Integer; begin Result := TTrack.Create; Result.Id := NewId('t'); Result.Name := AName; - FTracks.Add(Result); + Result.Kind := AKind; + + { Порядок дорожек не только украшение: он задаёт, кто побеждает при + перекрытии. Картинка всегда выше звука, поэтому новая дорожка + картинки встаёт перед первой звуковой, а не в самый конец. } + 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 + Pos := I; + Break; + end; + FTracks.Insert(Pos, Result); + end + else + FTracks.Add(Result); + FModified := True; end; @@ -533,6 +862,168 @@ begin FModified := True; end; +function TProject.TrackCountOf(AKind: TTrackKind): Integer; +var + I: Integer; +begin + Result := 0; + for I := 0 to FTracks.Count - 1 do + if TTrack(FTracks[I]).Kind = AKind then + Inc(Result); +end; + +function TProject.TrackOfKind(AKind: TTrackKind; AIndex: Integer): TTrack; +var + I, N: Integer; +begin + Result := nil; + N := 0; + for I := 0 to FTracks.Count - 1 do + if TTrack(FTracks[I]).Kind = AKind then + begin + if N = AIndex then + Exit(TTrack(FTracks[I])); + Inc(N); + end; +end; + +function TProject.IndexAmongKind(ATrack: TTrack): Integer; +var + I, N: Integer; +begin + Result := -1; + N := 0; + for I := 0 to FTracks.Count - 1 do + if TTrack(FTracks[I]).Kind = ATrack.Kind then + begin + if TTrack(FTracks[I]) = ATrack then + Exit(N); + Inc(N); + end; +end; + +procedure TProject.MigrateAudio; +var + T, C: Integer; + Track, Dst: TTrack; + Clip, Snd: TClip; + Item: TMediaItem; + Group: string; + Sources: TFPList; +begin + { Если звуковые дорожки уже есть, проект новый и переносить нечего. } + if TrackCountOf(tkAudio) > 0 then + Exit; + if TrackCountOf(tkVideo) = 0 then + Exit; + + EnsureAudioTracks; + + { Клипы собираются заранее: добавление в дорожку меняет её список, и + перебирать его на ходу нельзя. } + Sources := TFPList.Create; + try + for T := 0 to FTracks.Count - 1 do + begin + Track := TTrack(FTracks[T]); + if Track.Kind <> tkVideo then + Continue; + for C := 0 to Track.Count - 1 do + Sources.Add(Track[C]); + end; + + for C := 0 to Sources.Count - 1 do + begin + Clip := TClip(Sources[C]); + if Clip.Kind = ckBlack then + Continue; + Item := FindMedia(Clip.MediaId); + if (Item = nil) or (not Item.Info.HasAudio) then + Continue; + + Dst := nil; + for T := 0 to FTracks.Count - 1 do + if TTrack(FTracks[T]).IndexOf(Clip) >= 0 then + begin + Dst := TrackOfKind(tkAudio, IndexAmongKind(TTrack(FTracks[T]))); + Break; + end; + if Dst = nil then + Continue; + + Group := NewId('g'); + Clip.GroupId := Group; + Snd := AddClip(Dst, Item, Clip.SrcIn, Clip.Duration, Clip.TlStart); + Snd.GroupId := Group; + Snd.Kind := ckAudio; + Snd.Volume := Clip.Volume; + end; + finally + Sources.Free; + end; + + for T := 0 to FTracks.Count - 1 do + TTrack(FTracks[T]).Sort; +end; + +procedure TProject.FixClipKinds; +var + T, C: Integer; + Track: TTrack; +begin + for T := 0 to FTracks.Count - 1 do + begin + Track := TTrack(FTracks[T]); + for C := 0 to Track.Count - 1 do + if Track.Kind = tkAudio then + begin + if Track[C].Kind <> ckBlack then + Track[C].Kind := ckAudio; + end + else if Track[C].Kind = ckAudio then + Track[C].Kind := ckVideo; + end; +end; + +procedure TProject.EnsureAudioTracks; +var + Need, Have, I: Integer; + Track: TTrack; +begin + Need := TrackCountOf(tkVideo); + Have := TrackCountOf(tkAudio); + for I := Have to Need - 1 do + begin + Track := AddTrackOfKind('A' + IntToStr(I + 1), tkAudio); + end; +end; + +function TProject.AddClipPair(ATrack: TTrack; AMedia: TMediaItem; + const ASrcIn, ADuration, ATlStart: Double): TClip; +var + ATrackAudio: TTrack; + Snd: TClip; + Group: string; +begin + Result := AddClip(ATrack, AMedia, ASrcIn, ADuration, ATlStart); + if (ATrack.Kind <> tkVideo) or (not AMedia.Info.HasAudio) then + Exit; + + EnsureAudioTracks; + ATrackAudio := TrackOfKind(tkAudio, IndexAmongKind(ATrack)); + if ATrackAudio = nil then + Exit; + + Group := NewId('g'); + Result.GroupId := Group; + Snd := AddClip(ATrackAudio, AMedia, ASrcIn, ADuration, ATlStart); + Snd.GroupId := Group; + { Клип звука знает, что он звук: иначе сборка попыталась бы взять из + него картинку. } + Snd.Kind := ckAudio; + Snd.Transform := DefaultTransform; +end; + function TProject.AddClip(ATrack: TTrack; AMedia: TMediaItem; const ASrcIn, ADuration, ATlStart: Double): TClip; begin @@ -548,6 +1039,9 @@ begin Result.Kind := ckImage else Result.Kind := ckVideo; + { Настройка файла — заготовка: новый клип берёт её при добавлении и + дальше живёт своей. } + Result.Transform := AMedia.Transform; ATrack.Add(Result); FModified := True; end; @@ -574,6 +1068,122 @@ begin end; end; +{ Участок считается отмеченным, только если он не пустой: две отметки в + одной точке — это отсутствие участка, а не участок нулевой длины. } +function TProject.HasRegion: Boolean; +begin + Result := FRegionEnd > FRegionStart + 0.001; +end; + +class function TProject.TrackKindFor(AClipKind: TClipKind): TTrackKind; +begin + case AClipKind of + ckAudio: Result := tkAudio; + ckText: Result := tkText; + else + Result := tkVideo; + end; +end; + +function TProject.MisplacedClipCount: Integer; +var + T, C: Integer; + Track: TTrack; +begin + Result := 0; + for T := 0 to TrackCount - 1 do + begin + Track := Tracks[T]; + for C := 0 to Track.Count - 1 do + if TrackKindFor(Track[C].Kind) <> Track.Kind then + Inc(Result); + end; +end; + +function TProject.FixMisplacedClips: Integer; +var + T, C, K: Integer; + Track, Target: TTrack; + Clip: TClip; + Need: TTrackKind; + Moved: TFPList; + + { Свободна ли дорожка в это время. } + function Fits(ATrack: TTrack; AClip: TClip): Boolean; + var + I: Integer; + begin + Result := True; + for I := 0 to ATrack.Count - 1 do + if (AClip.TlStart < ATrack[I].TlEnd - 0.001) and + (AClip.TlEnd > ATrack[I].TlStart + 0.001) then + Exit(False); + end; + +begin + Result := 0; + Moved := TFPList.Create; + try + { Сперва собираем список: переносить прямо во время обхода нельзя — + состав дорожек меняется под ногами. } + for T := 0 to TrackCount - 1 do + begin + Track := Tracks[T]; + for C := 0 to Track.Count - 1 do + if TrackKindFor(Track[C].Kind) <> Track.Kind then + Moved.Add(Track[C]); + end; + + for C := 0 to Moved.Count - 1 do + begin + Clip := TClip(Moved[C]); + Track := FindClipTrack(Clip); + if Track = nil then + Continue; + Need := TrackKindFor(Clip.Kind); + + Target := nil; + for K := 0 to TrackCount - 1 do + if (Tracks[K].Kind = Need) and Fits(Tracks[K], Clip) then + begin + Target := Tracks[K]; + Break; + end; + + if Target = nil then + case Need of + tkAudio: Target := AddTrackOfKind(UniqueTrackName('A'), tkAudio); + tkText: Target := AddTrackOfKind(UniqueTrackName('Т'), tkText); + else + Target := AddTrackOfKind(UniqueTrackName('V'), tkVideo); + end; + + Track.Extract(Clip); + Target.Add(Clip); + Target.Sort; + Inc(Result); + end; + finally + Moved.Free; + end; +end; + +function TProject.MaxVideoBitrate: Int64; +var + I: Integer; + Item: TMediaItem; +begin + Result := FMaster.VideoBitrate; + for I := 0 to FPool.Count - 1 do + begin + Item := TMediaItem(FPool[I]); + if not Item.Info.HasVideo then + Continue; + if Item.Info.VideoBitrate > Result then + Result := Item.Info.VideoBitrate; + end; +end; + procedure TProject.ClearSelection; var T, C: Integer; @@ -644,7 +1254,7 @@ begin if FFileName = '' then { Проект ещё не сохранён — держим кэш рядом с программой, чтобы не разбрасывать файлы по системным каталогам. } - Result := IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0))) + + Result := ProgramDir + 'unsaved.nlve-cache' + PathDelim else Result := IncludeTrailingPathDelimiter(ExtractFilePath(FFileName)) + @@ -785,11 +1395,98 @@ begin Result := edSnap; end; +function SameColorKey(const A, B: TColorKey): Boolean; +begin + Result := (A.Enabled = B.Enabled) and (A.Color = B.Color) and + (A.Similarity = B.Similarity) and (A.Blend = B.Blend); +end; + +{ Цветовой ключ по умолчанию: выключен, пурпурный, с небольшим запасом по + сходству — сжатие видео размывает чистый цвет, и точное совпадение + оставило бы кайму. } +function DefaultColorKey: TColorKey; +begin + Result.Enabled := False; + Result.Color := TRgb($FF00FF); + Result.Similarity := 15; + Result.Blend := 5; +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 JsonToColorKey(AObj: TJSONObject): TColorKey; +begin + Result := DefaultColorKey; + if AObj = nil then + Exit; + Result.Enabled := AObj.Get('enabled', Result.Enabled); + Result.Color := TRgb(AObj.Get('color', Integer(Result.Color))); + Result.Similarity := AObj.Get('similarity', Result.Similarity); + Result.Blend := AObj.Get('blend', Result.Blend); +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 + 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; + function KindToStr(AKind: TClipKind): string; begin case AKind of ckImage: Result := 'image'; ckBlack: Result := 'black'; + ckAudio: Result := 'audio'; + ckText: Result := 'text'; else Result := 'video'; end; @@ -801,6 +1498,10 @@ begin Result := ckImage else if AValue = 'black' then Result := ckBlack + else if AValue = 'audio' then + Result := ckAudio + else if AValue = 'text' then + Result := ckText else Result := ckVideo; end; @@ -921,6 +1622,7 @@ begin Obj := TJSONObject.Create; Obj.Add('id', Track.Id); Obj.Add('name', Track.Name); + Obj.Add('kind', TrackKindToStr(Track.Kind)); Obj.Add('muted', Track.Muted); Obj.Add('solo', Track.Solo); @@ -937,7 +1639,42 @@ begin 'edge_in', EdgeToStr(Clip.EdgeIn), 'edge_out', EdgeToStr(Clip.EdgeOut), 'kind', KindToStr(Clip.Kind), - 'volume', Clip.Volume + 'group', Clip.GroupId, + 'volume', Clip.Volume, + 'opacity', Clip.Opacity, + 'fade_in', Clip.FadeIn, + 'fade_out', Clip.FadeOut, + 'transform', TJSONObject.Create([ + 'fit', FitModeToStr(Clip.Transform.Fit), + 'rotation', Clip.Transform.Rotation, + 'flip_h', Clip.Transform.FlipH, + 'flip_v', Clip.Transform.FlipV, + 'zoom', Clip.Transform.Zoom, + 'offset_x', Clip.Transform.OffsetX, + 'offset_y', Clip.Transform.OffsetY + ]), + { Оформление пишется только у текстовых клипов: у остальных оно + пустое, и таскать его в файле незачем. } + 'color_key', TJSONObject.Create([ + 'enabled', Clip.ColorKey.Enabled, + 'color', Integer(Clip.ColorKey.Color), + 'similarity', Clip.ColorKey.Similarity, + 'blend', Clip.ColorKey.Blend + ]), + '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; Obj.Add('clips', ClipsArr); @@ -947,7 +1684,9 @@ begin Root.Add('settings', TJSONObject.Create([ 'ripple_mode', RippleModeToStr(FRippleMode), - 'ripple_enabled', FRippleEnabled + 'ripple_enabled', FRippleEnabled, + 'region_start', FRegionStart, + 'region_end', FRegionEnd ])); Result := Root.FormatJSON; @@ -963,7 +1702,7 @@ var Obj, ItemObj, TrackObj, ClipObj, Settings: TJSONObject; Arr, ClipsArr: TJSONArray; I, J: Integer; - Item: TMediaItem; + Item, Media: TMediaItem; Track: TTrack; Clip: TClip; begin @@ -1015,6 +1754,7 @@ begin Track := TTrack.Create; Track.Id := TrackObj.Get('id', ''); Track.Name := TrackObj.Get('name', ''); + Track.Kind := StrToTrackKind(TrackObj.Get('kind', 'video')); Track.Muted := TrackObj.Get('muted', False); Track.Solo := TrackObj.Get('solo', False); FTracks.Add(Track); @@ -1036,16 +1776,42 @@ begin Clip.EdgeOut := StrToEdge(ClipObj.Get('edge_out', 'snap')); Clip.Kind := StrToKind(ClipObj.Get('kind', 'video')); Clip.Volume := ClipObj.Get('volume', Double(1)); + Clip.GroupId := ClipObj.Get('group', ''); + Clip.Opacity := ClipObj.Get('opacity', Double(1)); + Clip.FadeIn := ClipObj.Get('fade_in', Double(0)); + Clip.FadeOut := ClipObj.Get('fade_out', Double(0)); + { Проекты, записанные до появления кадрирования у клипа, + берут его у файла — там оно и хранилось раньше. } + if ClipObj.Find('transform') <> nil then + Clip.Transform := JsonToTransform( + ClipObj.Get('transform', TJSONObject(nil))) + else + begin + Media := FindMedia(Clip.MediaId); + if Media <> nil then + Clip.Transform := Media.Transform; + end; + Clip.ColorKey := JsonToColorKey( + ClipObj.Get('color_key', TJSONObject(nil))); + Clip.Text := ClipObj.Get('text', ''); + Clip.TextStyle := JsonToTextStyle( + ClipObj.Get('text_style', TJSONObject(nil))); Track.Add(Clip); end; Track.Sort; end; + MigrateAudio; + FixClipKinds; + EnsureUniqueTrackNames; + Settings := Obj.Find('settings', jtObject) as TJSONObject; if Settings <> nil then begin FRippleMode := StrToRippleMode(Settings.Get('ripple_mode', 'current')); FRippleEnabled := Settings.Get('ripple_enabled', False); + FRegionStart := Settings.Get('region_start', Double(0)); + FRegionEnd := Settings.Get('region_end', Double(0)); { Старые проекты хранили один флаг «все дорожки». } if Settings.Get('ripple_all_tracks', False) then FRippleMode := rmAllTracks; diff --git a/src/uSettings.pas b/src/uSettings.pas index 2b87557..777e18c 100644 --- a/src/uSettings.pas +++ b/src/uSettings.pas @@ -33,7 +33,14 @@ type FRippleAllTracks: Boolean; FRippleEnabled: Boolean; FTrackHeight: Integer; + FWaveGain: Double; FVideoPanelHeight: Integer; + FLogVisible: Boolean; + FPlayheadSnap: Boolean; + FPreviewKey: Boolean; + FCenterPlayhead: Boolean; + FKeepParts: Boolean; + FDepsReminder: Boolean; FRecentProjects: TStringList; function FileName: string; public @@ -58,7 +65,25 @@ type property RippleAllTracks: Boolean read FRippleAllTracks write FRippleAllTracks; property RippleEnabled: Boolean read FRippleEnabled write FRippleEnabled; property TrackHeight: Integer read FTrackHeight write FTrackHeight; + { Во сколько раз растянута форма звука на клипах. Только рисунок. } + property WaveGain: Double read FWaveGain write FWaveGain; property VideoPanelHeight: Integer read FVideoPanelHeight write FVideoPanelHeight; + { Видна ли нижняя полоса с журналом. По умолчанию видна: пока + программа молодая, её сообщения нужнее, чем лишние строки монтажа. } + property LogVisible: Boolean read FLogVisible write FLogVisible; + { Прилипание курсора воспроизведения к границам клипов. } + property PlayheadSnap: Boolean read FPlayheadSnap write FPlayheadSnap; + { Применять ли ключ и прозрачность прямо в предпросмотре. } + property PreviewKey: Boolean read FPreviewKey write FPreviewKey; + { Держать ли курсор посередине монтажа при воспроизведении. } + property CenterPlayhead: Boolean read FCenterPlayhead write FCenterPlayhead; + { Оставлять ли временные куски после удачной сборки. По умолчанию нет: + они весят столько же, сколько готовый ролик, а нужны только чтобы + продолжить прерванную сборку. } + property KeepParts: Boolean read FKeepParts write FKeepParts; + { Напоминать ли о недостающих зависимостях при запуске. Гасится + кнопкой «Не напоминать» в самом напоминании. } + property DepsReminder: Boolean read FDepsReminder write FDepsReminder; end; implementation @@ -70,6 +95,7 @@ const DefaultWidth = 1600; DefaultHeight = 900; DefaultTrackHeight = 64; + DefaultWaveGain = 1.0; DefaultVideoHeight = 400; { Больше десятка в меню не помещается по-человечески, да и не нужно. } @@ -84,7 +110,14 @@ begin FWindowWidth := DefaultWidth; FWindowHeight := DefaultHeight; FTrackHeight := DefaultTrackHeight; + FWaveGain := DefaultWaveGain; FVideoPanelHeight := DefaultVideoHeight; + FLogVisible := True; + FPlayheadSnap := True; + FPreviewKey := True; + FCenterPlayhead := True; + FKeepParts := False; + FDepsReminder := True; end; destructor TSettings.Destroy; @@ -161,7 +194,14 @@ begin FRippleAllTracks := Obj.Get('ripple_all_tracks', FRippleAllTracks); FRippleEnabled := Obj.Get('ripple_enabled', FRippleEnabled); FTrackHeight := Obj.Get('track_height', FTrackHeight); + FWaveGain := Obj.Get('wave_gain', FWaveGain); FVideoPanelHeight := Obj.Get('video_panel_height', FVideoPanelHeight); + FLogVisible := Obj.Get('log_visible', FLogVisible); + FPlayheadSnap := Obj.Get('playhead_snap', FPlayheadSnap); + FPreviewKey := Obj.Get('preview_key', FPreviewKey); + FCenterPlayhead := Obj.Get('center_playhead', FCenterPlayhead); + FKeepParts := Obj.Get('keep_parts', FKeepParts); + FDepsReminder := Obj.Get('deps_reminder', FDepsReminder); Arr := Obj.Find('recent_projects', jtArray) as TJSONArray; FRecentProjects.Clear; @@ -181,6 +221,8 @@ begin FWindowWidth := DefaultWidth; if FWindowHeight < 480 then FWindowHeight := DefaultHeight; + if (FWaveGain < 1) or (FWaveGain > 64) then + FWaveGain := DefaultWaveGain; if (FTrackHeight < 24) or (FTrackHeight > 300) then FTrackHeight := DefaultTrackHeight; if FVideoPanelHeight < 100 then @@ -207,7 +249,14 @@ begin Root.Add('ripple_all_tracks', FRippleAllTracks); Root.Add('ripple_enabled', FRippleEnabled); Root.Add('track_height', FTrackHeight); + Root.Add('wave_gain', FWaveGain); Root.Add('video_panel_height', FVideoPanelHeight); + Root.Add('log_visible', FLogVisible); + Root.Add('playhead_snap', FPlayheadSnap); + Root.Add('preview_key', FPreviewKey); + Root.Add('center_playhead', FCenterPlayhead); + Root.Add('keep_parts', FKeepParts); + Root.Add('deps_reminder', FDepsReminder); Arr := TJSONArray.Create; for I := 0 to FRecentProjects.Count - 1 do diff --git a/src/uSubtitles.pas b/src/uSubtitles.pas new file mode 100644 index 0000000..6f10e16 --- /dev/null +++ b/src/uSubtitles.pas @@ -0,0 +1,538 @@ +{ + 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, uFlatten; + +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; + +{ Разметка для одного куска монтажа: события сдвинуты к его началу и + обрезаны по его длине. + + Нужно вжиганию. Фильтр subtitles рисует по времени того файла, который + ему дали, а кусок начинается со своего нуля — общая разметка легла бы + не туда. } +function WriteAssForRange(AProject: TProject; const AFrom, ATo: Double; + const APath: string): Boolean; + +{ Готовит куски к вжиганию: тем, которые задевает текст, ставит признак + пересборки и подкладывает свою разметку. + + Возвращает, сколько секунд придётся пересобрать сверх того, что и так + пересобиралось: человеку это говорят до начала. + + AStartTime — время монтажа, которому соответствует начало списка. + Нужен, когда собирают не весь ролик, а отмеченный участок: иначе текст + брался бы с начала монтажа и лёг бы не на те куски. } +function BurnTextIntoSegments(AProject: TProject; + var ASegments: TFlatSegmentArray; const ACacheDir: string; + const AStartTime: Double = 0): Double; + +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; + +{ Общая сборка. AFrom и ATo ограничивают выборку; ATo меньше нуля значит + «до конца монтажа». При ненулевом AFrom времена сдвигаются к нулю — так + разметка годится для отдельного куска. } +function BuildAssRange(AProject: TProject; const AFrom, ATo: Double): string; +var + Lines: TStringList; + Styles, Events: TStringList; + T, C, I, Size: Integer; + Clip: TClip; + Track: TTrack; + Name, Body: string; + W, H, MarginH, MarginV: Integer; + StartAt, EndAt: Double; +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; + { Надписи, не попадающие в нужный отрезок, разбирать незачем. } + if (ATo >= 0) and (Clip.TlStart >= ATo - 0.0005) then + Continue; + if Clip.TlEnd <= AFrom + 0.0005 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; + + { Обрезаем по границам куска и сдвигаем к его началу. } + StartAt := Max(Clip.TlStart, AFrom) - AFrom; + EndAt := Clip.TlEnd - AFrom; + if ATo >= 0 then + EndAt := Min(EndAt, ATo - AFrom); + if EndAt <= StartAt then + Continue; + + Events.Add(Format('Dialogue: 0,%s,%s,%s,,0,0,0,,%s', + [AssTime(StartAt), AssTime(EndAt), 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 BuildAss(AProject: TProject): string; +begin + Result := BuildAssRange(AProject, 0, -1); +end; + +function WriteText(const AText, APath: string): Boolean; +var + Stream: TFileStream; +begin + Result := False; + try + ForceDirectories(ExtractFilePath(APath)); + Stream := TFileStream.Create(APath, fmCreate); + try + if Length(AText) > 0 then + Stream.WriteBuffer(AText[1], Length(AText)); + finally + Stream.Free; + end; + Result := True; + except + Result := False; + end; +end; + +function WriteAssForRange(AProject: TProject; const AFrom, ATo: Double; + const APath: string): Boolean; +var + Text: string; +begin + Text := BuildAssRange(AProject, AFrom, ATo); + Result := (Text <> '') and WriteText(Text, APath); +end; + +function BurnTextIntoSegments(AProject: TProject; + var ASegments: TFlatSegmentArray; const ACacheDir: string; + const AStartTime: Double): Double; +var + I: Integer; + At, SegEnd: Double; + Path: string; +begin + Result := 0; + if (AProject = nil) or (not HasText(AProject)) then + Exit; + + At := AStartTime; + for I := 0 to High(ASegments) do + begin + SegEnd := At + ASegments[I].Duration; + if TextCovers(AProject, At, SegEnd) then + begin + Path := IncludeTrailingPathDelimiter(ACacheDir) + + Format('burn_%.3d.ass', [I]); + if WriteAssForRange(AProject, At, SegEnd, Path) then + begin + { Кусок, который и так пересобирался, дороже не становится — + считаем только те, что раньше копировались. } + if not (ASegments[I].Transcode or (Length(ASegments[I].Layers) > 0)) then + Result := Result + ASegments[I].Duration; + ASegments[I].SubFile := Path; + ASegments[I].Transcode := True; + end; + end; + At := SegEnd; + end; +end; + +function WriteAssFile(AProject: TProject; const APath: string): Boolean; +var + Text: string; +begin + Result := False; + Text := BuildAss(AProject); + if Text = '' then + begin + { Текста не стало — старый файл убираем, иначе плеер покажет то, + чего на монтаже уже нет. } + if FileExists(APath) then + SysUtils.DeleteFile(APath); + Exit; + end; + + Result := WriteText(Text, APath); +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 562d943..08c9e0e 100644 --- a/src/uTheme.pas +++ b/src/uTheme.pas @@ -18,8 +18,10 @@ - полосы прокрутки внутри списков и журнала рисует система; - рамка окна и её кнопки принадлежат оконному менеджеру; - меню под gtk2 своими руками не рисуется — в LCL это прямо помечено - как неподдерживаемое (interfaces/gtk2/issues.xml). Под Windows - рисуется, там это и нужно. + как неподдерживаемое (interfaces/gtk2/issues.xml). Зато сам gtk + принимает описание стиля текстом, и цвет меню задаётся так + (ApplyMenuStyle). Под Windows наоборот: строк стиля нет, зато + работает отрисовка пунктов своими руками (ApplyDarkMenu). } unit uTheme; @@ -29,7 +31,8 @@ interface uses Classes, SysUtils, Types, Controls, Graphics, Forms, StdCtrls, ExtCtrls, - ComCtrls, Grids, Menus, Dialogs, LCLType, LCLIntf, LCLProc; + ComCtrls, Grids, Menus, Dialogs, Math, IntfGraphics, FPimage, + LCLType, LCLIntf, LCLProc, uIconData; const { Порядок байт в TColor — $00BBGGRR, а не привычный RGB. У серых цветов @@ -49,8 +52,46 @@ const ThemeSelection = TColor($785434); // приглушённый синий: выделение ThemeSelText = TColor($FFFFFF); ThemeGridLine = TColor($3A3A3A); + ThemeLink = TColor($E0A060); // голубой: ссылка type + { Значок на кнопке. + + Картинки вшиты в программу (uIconData): зависеть от того, лежит ли + рядом с ней файл, она не должна. Исходники — в icons_online, оттуда + же требование указать авторство, см. окно «О программе». + + Цвет значку задаётся при отрисовке: берётся прозрачность точки, а + цвет — тот, каким сейчас рисуется кнопка. Поэтому один значок годится + и для тёмной кнопки, и для оранжевой, и для недоступной. } + TThemedIcon = ( + tiNone, + tiSnap, // прилипание: края притягиваются к общей линии + tiRipple, // схлопывание: дыра между кусками закрывается + tiLog, // журнал: полоса с сообщениями + tiGlue, // курсор липнет к границам клипов + tiTarget // курсор держится середины монтажа + ); + + { Полоска выполнения, которая рисует себя сама. + + Системная берёт цвета у темы оформления и на тёмном окне остаётся + светлой — та же причина, по которой здесь своя кнопка и свои полосы + прокрутки. + + Доля хранится числом от нуля до единицы, а не «позицией» и + «максимумом»: снаружи она всегда получается делением одного на + другое, и хранить обе части незачем. } + TThemedProgress = class(TGraphicControl) + private + FFraction: Double; + procedure SetFraction(const AValue: Double); + protected + procedure Paint; override; + public + constructor Create(AOwner: TComponent); override; + property Fraction: Double read FFraction write SetFraction; + end; { Кнопка, которая рисует себя сама. @@ -60,6 +101,8 @@ type TThemedButton = class(TCustomControl) private FArrow: Boolean; + FSwatch: TColor; + FIcon: TThemedIcon; FFlat: Boolean; FDown: Boolean; FHover: Boolean; @@ -68,6 +111,9 @@ type FCancel: Boolean; 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); procedure SetDefault(AValue: Boolean); @@ -100,6 +146,12 @@ type property Arrow: Boolean read FArrow write SetArrow default False; property Cancel: Boolean read FCancel write SetCancel default False; property Caption; + { Значок вместо надписи. Надпись при этом не пропадает зря: её место — + подсказка, которая всплывает по наведению. } + 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; @@ -131,9 +183,41 @@ procedure ApplyDarkTheme(AComponent: TComponent); при запуске. } procedure HookNewForms; -{ Меню в наших цветах. Под gtk2 не действует — там меню рисует GTK. } +{ Меню в наших цветах отрисовкой своими руками. Действует только под + win32; под gtk2 цвет задаётся строкой стиля, см. ApplyMenuStyle. } procedure ApplyDarkMenu(AMenu: TMenu); +{ Закрашивает остаток полосы меню — то место правее последнего названия, + которое не занято ни одним пунктом. + + Нужно потому, что до него не дотянуться ни отрисовкой пунктов (это не + пункт), ни подложкой через SetMenuInfo (проверено под Wine: пункты + тёмные, полоса светлая). Полоса живёт в неклиентской части окна, + поэтому рисуем прямо в её область. + + Под gtk2 ничего не делает: там всю полосу красит строка стиля. } +procedure PaintMenuBarTail(AForm: TCustomForm); + +{ Что вышло у последней закраски: какие прямоугольники выдала система и + куда мы рисовали. Нужно, чтобы не гадать, почему полоса осталась + светлой. } +function MenuBarTailNote: string; + +{ Цвета для меню, которое рисует не программа, а система. + + Вызывать до создания окон: строка стиля разбирается один раз, и уже + созданные виджеты о ней не узнают. + + Под gtk2 это единственный способ. Собственных средств у LCL там нет — + OwnerDraw, OnDrawItem и OnMeasureItem в gtk2 прямо помечены как + неподдерживаемые (lcl/interfaces/gtk2/issues.xml), и событие из + инспектора объектов просто никогда не наступит. Зато сам gtk принимает + описание стиля текстом. + + Под win32 ничего не делает: там работает отрисовка своими руками через + ApplyDarkMenu. } +procedure ApplyMenuStyle; + { Окно сообщения в наших цветах вместо системного. Кнопки задаются готовым набором, как у MessageDlg, но рисуются нашими. @@ -142,8 +226,26 @@ function ThemedMessageDlg(const ACaption, AText: string; ADlgType: TMsgDlgType; AButtons: TMsgDlgButtons; AHelpCtx: Longint = 0): TModalResult; +{ Вопрос со своими кнопками. Возвращает номер нажатой, считая с нуля, или + -1, если окно просто закрыли. + + Нужен там, где готовых «Да / Нет / Отмена» не хватает: например, + третьей кнопкой «Больше не напоминать». } +function ThemedChoiceDlg(const ACaption, AText: string; + const ACaptions: array of string): Integer; + +{ Ввод одной строки в тёмном окне. Системный InputQuery выглядел бы белым + пятном посреди тёмной программы. } +function ThemedInputDlg(const ACaption, APrompt: string; + var AValue: string): Boolean; + implementation +{$IFDEF LCLGTK2} +uses + glib2, gtk2; +{$ENDIF} + {$IFDEF WINDOWS} { Модуль Windows целиком подключать нельзя: он объявляет свои TRect и RegisterClass, а имена в Паскале нечувствительны к регистру — и обычные @@ -166,6 +268,42 @@ const function SetMenuInfo(AMenu: HMENU; const AInfo: TMenuInfoRec): LongBool; stdcall; external 'user32' name 'SetMenuInfo'; + +{ Имя своё, а не DrawMenuBar: так называется и функция LCL, а имена в + Паскале нечувствительны к регистру. По той же причине своё имя у всех + остальных вызовов ниже. } +function SysDrawMenuBar(AWnd: HWND): LongBool; + stdcall; external 'user32' name 'DrawMenuBar'; + +type + TMenuBarInfoRec = record + cbSize: DWORD; + rcBar: TRect; + hMenu: HMENU; + hwndMenu: HWND; + Flags: DWORD; { два битовых признака, нам не нужны } + end; + +const + { Знаковое, как в заголовках Windows: -3. } + OBJID_MENU = LongInt(-3); + +function SysGetMenuBarInfo(AWnd: HWND; AObject, AItem: LongInt; + var AInfo: TMenuBarInfoRec): LongBool; + stdcall; external 'user32' name 'GetMenuBarInfo'; +function SysGetMenuItemRect(AWnd: HWND; AMenu: HMENU; AItem: UINT; + var ARect: TRect): LongBool; + stdcall; external 'user32' name 'GetMenuItemRect'; +function SysGetMenuItemCount(AMenu: HMENU): Integer; + stdcall; external 'user32' name 'GetMenuItemCount'; +function SysGetWindowDC(AWnd: HWND): HDC; + stdcall; external 'user32' name 'GetWindowDC'; +function SysReleaseDC(AWnd: HWND; ADC: HDC): Integer; + stdcall; external 'user32' name 'ReleaseDC'; +function SysFillRect(ADC: HDC; const ARect: TRect; ABrush: HBRUSH): Integer; + stdcall; external 'user32' name 'FillRect'; +function SysGetWindowRect(AWnd: HWND; var ARect: TRect): LongBool; + stdcall; external 'user32' name 'GetWindowRect'; {$ENDIF} type @@ -183,6 +321,8 @@ type var Painter: TThemePainter; + { Перекрашенные значки: ключ «номер значка : цвет». } + IconCache: TStringList; {$IFDEF WINDOWS} { Кисть под полосу меню. Создаётся один раз: Windows держит на неё ссылку, пока меню живо, и удалять её раньше нельзя. } @@ -193,6 +333,54 @@ const MenuTextLeft = 26; { отступ слева: место под галочку } MenuTextRight = 16; { отступ справа: место под стрелку подменю } MenuGap = 28; { просвет между названием и сочетанием клавиш } + MenuBarSide = 10; { отступ по краям названия в полосе меню } + +{ TThemedProgress } + +constructor TThemedProgress.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FFraction := 0; + Height := 6; + Width := 120; +end; + +procedure TThemedProgress.SetFraction(const AValue: Double); +var + V: Double; +begin + V := AValue; + if V < 0 then + V := 0; + if V > 1 then + V := 1; + { Перерисовываем только при заметном изменении: полоска обновляется по + таймеру, и дёргать отрисовку на каждую тысячную незачем. } + if Abs(V - FFraction) < 0.002 then + Exit; + FFraction := V; + Invalidate; +end; + +procedure TThemedProgress.Paint; +var + R: TRect; + W: Integer; +begin + R := ClientRect; + Canvas.Brush.Style := bsSolid; + Canvas.Brush.Color := ThemeButtonDown; + Canvas.FillRect(R); + W := Round(R.Right * FFraction); + if W > 0 then + begin + Canvas.Brush.Color := ThemeAccent; + Canvas.FillRect(Rect(0, 0, W, R.Bottom)); + end; + Canvas.Brush.Style := bsClear; + Canvas.Pen.Color := ThemeBorder; + Canvas.Rectangle(R); +end; { TThemedButton } @@ -204,6 +392,9 @@ begin ControlStyle := ControlStyle + [csHasDefaultAction, csHasCancelAction]; TabStop := True; DoubleBuffered := True; + { Без явного значения образец был бы чёрным (ноль — это clBlack), и + чёрные прямоугольники полезли бы на все кнопки разом. } + FSwatch := clNone; with GetControlClassDefaultSize do SetInitialBounds(0, 0, cx, cy); end; @@ -214,6 +405,121 @@ 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 + Exit; + FIcon := AValue; + Invalidate; +end; + +{ Значок в нужном цвете. + + Картинка чёрная с прозрачностью, поэтому перекрашивается прямо по + точкам: прозрачность остаётся своя, цвет ставится наш. Результат + запоминается — цветов ровно три (обычный, на оранжевом, недоступный), и + пересчитывать их на каждую перерисовку незачем. } +function ThemedIconImage(AIcon: TThemedIcon; AColor: TColor): + TPortableNetworkGraphic; +var + Key: string; + Idx, X, Y: Integer; + Stream: TMemoryStream; + Img: TLazIntfImage; + Px: TFPColor; + R, G, B: Byte; +begin + Result := nil; + if AIcon = tiNone then + Exit; + + Key := IntToStr(Ord(AIcon)) + ':' + IntToStr(AColor); + if IconCache = nil then + begin + IconCache := TStringList.Create; + IconCache.Sorted := True; + IconCache.OwnsObjects := True; + end; + Idx := IconCache.IndexOf(Key); + if Idx >= 0 then + Exit(TPortableNetworkGraphic(IconCache.Objects[Idx])); + + Stream := TMemoryStream.Create; + try + case AIcon of + tiSnap: Stream.WriteBuffer(IconSnapData[0], Length(IconSnapData)); + tiRipple: Stream.WriteBuffer(IconRippleData[0], Length(IconRippleData)); + tiLog: Stream.WriteBuffer(IconLogData[0], Length(IconLogData)); + tiGlue: Stream.WriteBuffer(IconGlueData[0], Length(IconGlueData)); + tiTarget: Stream.WriteBuffer(IconTargetData[0], Length(IconTargetData)); + else + Exit; + end; + Stream.Position := 0; + + Result := TPortableNetworkGraphic.Create; + try + Result.LoadFromStream(Stream); + { Порядок байт в TColor обратный привычному. } + R := AColor and $FF; + G := (AColor shr 8) and $FF; + B := (AColor shr 16) and $FF; + + Img := Result.CreateIntfImage; + try + for Y := 0 to Img.Height - 1 do + for X := 0 to Img.Width - 1 do + begin + Px := Img.Colors[X, Y]; + { Прозрачное трогать незачем, а видимое красим целиком. } + if Px.Alpha = 0 then + Continue; + Px.Red := R * 257; + Px.Green := G * 257; + Px.Blue := B * 257; + Img.Colors[X, Y] := Px; + end; + Result.LoadFromIntfImage(Img); + finally + Img.Free; + end; + except + FreeAndNil(Result); + end; + finally + Stream.Free; + end; + + { Неудачу тоже запоминаем: иначе разбирать картинку заново пришлось бы + на каждой перерисовке. } + IconCache.AddObject(Key, Result); +end; + +{ Значок рисуется без растягивания: картинка вшита ровно того размера, под + который сделана кнопка. Если кнопка оказалась крупнее — значок остаётся + своего размера и стоит по центру, а не расплывается. } +procedure TThemedButton.DrawIcon(const ARect: TRect; AColor: TColor); +var + Img: TPortableNetworkGraphic; + X, Y: Integer; +begin + Img := ThemedIconImage(FIcon, AColor); + if (Img = nil) or (Img.Width = 0) then + Exit; + + X := (ARect.Left + ARect.Right - Img.Width) div 2; + Y := (ARect.Top + ARect.Bottom - Img.Height) div 2; + Canvas.Draw(X, Y, Img); +end; + procedure TThemedButton.Paint; var R: TRect; @@ -279,6 +585,16 @@ 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 begin Canvas.Font.Assign(Font); @@ -287,7 +603,10 @@ begin Canvas.TextOut((R.Right - TS.cx) div 2, (R.Bottom - TS.cy) div 2, Caption); end; - if Focused then + { Рамка фокуса рисуется только там, где фокус вообще предусмотрен. + Кнопки полосы меню его не берут, а рамка на них появлялась и + выглядела как испорченный пункт. } + if Focused and TabStop then begin Canvas.Pen.Color := ThemeTextDim; Canvas.Pen.Style := psDot; @@ -390,18 +709,22 @@ end; procedure TThemedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); -var - WasPressed: Boolean; begin - WasPressed := FPressed; FPressed := False; Invalidate; inherited MouseUp(Button, Shift, X, Y); - { Щелчком считается только отпускание внутри кнопки: увёл курсор в - сторону — значит передумал. } - if WasPressed and (Button = mbLeft) and - PtInRect(ClientRect, Point(X, Y)) then - Click; + + { Click отсюда не вызывается. + + Его вызывает сама LCL при отпускании внутри кнопки — TControl. + WMLButtonUp, с той же проверкой «внутри», какая напрашивается здесь. + Написанный руками вызов оказывался вторым, и каждый щелчок срабатывал + дважды. На кнопке-переключателе это значит «ничего не произошло»: + первое срабатывание меняло состояние, второе возвращало обратно. + + Найдено на невидимом экране: в журнал легли две записи «обработчик + кнопки журнала вызван» на один щелчок мышью, тогда как то же действие + с клавиатуры давало одну. } end; procedure TThemedButton.KeyDown(var Key: Word; Shift: TShiftState); @@ -497,6 +820,15 @@ begin H := ACanvas.TextHeight('Wg'); Y := ARect.Top + (ARect.Bottom - ARect.Top - H) div 2; + { В полосе меню отступ слева другой: место под галочку и под сочетание + клавиш там не нужно, а с отступом раскрытого списка названия разошлись + бы с шириной, которую мы же и посчитали. } + if Item.IsInMenuBar then + begin + ACanvas.TextOut(ARect.Left + MenuBarSide, Y, Item.Caption); + Exit; + end; + if Item.Checked then ACanvas.TextOut(ARect.Left + 8, Y, '•'); @@ -529,6 +861,13 @@ begin end; AHeight := ACanvas.TextHeight('Wg') + 10; + + if Item.IsInMenuBar then + begin + AWidth := ACanvas.TextWidth(Item.Caption) + MenuBarSide * 2; + Exit; + end; + W := MenuTextLeft + ACanvas.TextWidth(Item.Caption) + MenuTextRight; if Item.ShortCut <> 0 then Inc(W, MenuGap + ACanvas.TextWidth(ShortCutToText(Item.ShortCut))); @@ -702,6 +1041,153 @@ begin ApplyToChildren(TWinControl(AControl)); end; +{ Цвет Паскаля хранит составляющие в обратном порядке, а gtk ждёт + привычную запись «решётка, красный, зелёный, синий». } +function GtkColorText(AColor: TColor): string; +begin + Result := Format('#%.2x%.2x%.2x', + [AColor and $FF, (AColor shr 8) and $FF, (AColor shr 16) and $FF]); +end; + +procedure ApplyMenuStyle; +{$IFDEF LCLGTK2} +var + Rc: string; +{$ENDIF} +begin +{$IFDEF LCLGTK2} + Rc := + 'style "nlve-menu" {' + LineEnding + + ' bg[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' bg[PRELIGHT] = "' + GtkColorText(ThemeAccent) + '"' + LineEnding + + ' bg[ACTIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' bg[INSENSITIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + ' fg[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' fg[PRELIGHT] = "' + GtkColorText(ThemeAccentText) + '"' + LineEnding + + ' fg[ACTIVE] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' fg[INSENSITIVE] = "' + GtkColorText(ThemeTextDim) + '"' + LineEnding + + ' text[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding + + ' base[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding + + '}' + LineEnding + + 'class "GtkMenuBar" style "nlve-menu"' + LineEnding + + 'class "GtkMenu" style "nlve-menu"' + LineEnding + + 'class "GtkMenuItem" style "nlve-menu"' + LineEnding + + 'widget_class "**" style "nlve-menu"' + LineEnding + + 'widget_class "**" style "nlve-menu"' + LineEnding; + gtk_rc_parse_string(PChar(Rc)); +{$ENDIF} +end; + +var + TailNote: string = 'закраска полосы меню не вызывалась'; + { Идёт ли закраска прямо сейчас. См. пояснение у PaintMenuBarTail. } + TailBusy: Boolean = False; + +function MenuBarTailNote: string; +begin + Result := TailNote; +end; + +procedure PaintMenuBarTail(AForm: TCustomForm); +{$IFDEF LCLWIN32} +{ Защита от повторного входа. + + Закраска вызывается из обработчика перерисовки рамки окна, а сама + рисует в эту рамку — и под Wine рисование снова просило перерисовку. + Получалась воронка: при появлении любого модального окна стек кончался + и программа падала с «stack overflow». Найдено на невидимом экране в + отдельном префиксе Wine: падало и из напоминания о зависимостях, и из + меню «Файл → Зависимости». } +{$ENDIF} +{$IFDEF LCLWIN32} +var + Info: TMenuBarInfoRec; + WinRect, ItemRect, Fill: TRect; + DC: HDC; + Count: Integer; + Menu: HMENU; +{$ENDIF} +begin +{$IFDEF LCLWIN32} + if TailBusy then + Exit; + if (AForm = nil) or (not AForm.HandleAllocated) or (MenuBrush = 0) then + begin + TailNote := 'полоса: нет окна или кисти'; + Exit; + end; + if (AForm.Menu = nil) or (not AForm.Menu.HandleAllocated) then + begin + TailNote := 'полоса: у меню нет дескриптора'; + Exit; + end; + Menu := AForm.Menu.Handle; + + FillChar(Info{%H-}, SizeOf(Info), 0); + Info.cbSize := SizeOf(Info); + if not SysGetMenuBarInfo(AForm.Handle, OBJID_MENU, 0, Info) then + begin + TailNote := 'полоса: GetMenuBarInfo отказала'; + Exit; + end; + + Count := SysGetMenuItemCount(Menu); + if Count <= 0 then + begin + TailNote := 'полоса: пунктов не найдено'; + Exit; + end; + { Правый край последнего названия. Всё, что правее, — ничьё, его и + закрашиваем. } + if not SysGetMenuItemRect(AForm.Handle, Menu, Count - 1, ItemRect{%H-}) then + begin + TailNote := 'полоса: GetMenuItemRect отказала'; + Exit; + end; + if not SysGetWindowRect(AForm.Handle, WinRect{%H-}) then + begin + TailNote := 'полоса: GetWindowRect отказала'; + Exit; + end; + + { Обе рамки система выдаёт в координатах экрана, а рисуем мы в + координатах окна. } + Fill.Left := ItemRect.Right - WinRect.Left; + Fill.Top := Info.rcBar.Top - WinRect.Top; + Fill.Right := Info.rcBar.Right - WinRect.Left; + Fill.Bottom := Info.rcBar.Bottom - WinRect.Top; + TailNote := Format( + 'полоса: пунктов %d, полоса экрана %d,%d..%d,%d, край пункта %d, ' + + 'окно %d,%d, красим %d,%d..%d,%d', + [Count, Info.rcBar.Left, Info.rcBar.Top, Info.rcBar.Right, + Info.rcBar.Bottom, ItemRect.Right, WinRect.Left, WinRect.Top, + Fill.Left, Fill.Top, Fill.Right, Fill.Bottom]); + + if (Fill.Right <= Fill.Left) or (Fill.Bottom <= Fill.Top) then + begin + TailNote := TailNote + ' — красить нечего'; + Exit; + end; + + TailBusy := True; + try + DC := SysGetWindowDC(AForm.Handle); + if DC = 0 then + begin + TailNote := TailNote + ' — окно не дало холста'; + Exit; + end; + try + SysFillRect(DC, Fill, MenuBrush); + finally + SysReleaseDC(AForm.Handle, DC); + end; + finally + TailBusy := False; + end; +{$ENDIF} +end; + procedure ApplyDarkMenu(AMenu: TMenu); procedure Walk(AItem: TMenuItem); @@ -732,7 +1218,11 @@ begin создаёт его принудительно, и у всплывающего меню, до показа которого ещё далеко, это ломает само меню: оно перестаёт открываться. Цена отказа — тонкая рамка вокруг раскрытого списка остаётся системной; - сами пункты рисуются нами и цвет берут. } + сами пункты рисуются нами и цвет берут. + + Отсюда следует, что для полосы меню эту процедуру надо звать дважды: + до присваивания окну — чтобы расставить обработчики отрисовки, и после + — когда дескриптор уже есть и подложку можно задать. } if AMenu.HandleAllocated then begin FillChar(Info{%H-}, SizeOf(Info), 0); @@ -740,6 +1230,13 @@ begin Info.fMask := MIM_BACKGROUND or MIM_APPLYTOSUBMENUS; Info.hbrBack := MenuBrush; SetMenuInfo(AMenu.Handle, Info); + + { Полоса меню живёт в неклиентской части окна и сама себя не + перерисовывает: без этого новая подложка появилась бы только при + следующем изменении размера окна. } + if (AMenu.Parent is TCustomForm) and + TCustomForm(AMenu.Parent).HandleAllocated then + SysDrawMenuBar(TCustomForm(AMenu.Parent).Handle); end; {$ENDIF} end; @@ -768,6 +1265,170 @@ end; { Окно сообщения } +{ Высота надписи с переносом. + + Считать по общей ширине текста нельзя: в сообщении бывают свои переводы + строк, и оценка «ширина поделить на ширину поля» их не видит — текст + обрезается снизу. Здесь каждая строка считается отдельно, а пустые + строки дают пустой ряд. } +function WrappedTextHeight(ACanvas: TCanvas; const AText: string; + AWidth: Integer): Integer; +var + Lines: TStringList; + I, Rows, RowH: Integer; +begin + RowH := ACanvas.TextHeight('Wg'); + Rows := 0; + Lines := TStringList.Create; + try + Lines.Text := AText; + if Lines.Count = 0 then + Rows := 1; + for I := 0 to Lines.Count - 1 do + if Lines[I] = '' then + Inc(Rows) + else + Inc(Rows, 1 + (ACanvas.TextWidth(Lines[I]) div AWidth)); + finally + Lines.Free; + end; + Result := Rows * RowH + RowH div 2; +end; + +function ThemedChoiceDlg(const ACaption, AText: string; + const ACaptions: array of string): Integer; +const + MarginX = 20; + MarginY = 18; + ButtonH = 30; + ButtonGap = 10; +var + Dlg: TForm; + Lbl: TLabel; + Btn: TThemedButton; + I, X, TotalW, Wid: Integer; + Widths: array of Integer; +begin + Result := -1; + if Length(ACaptions) = 0 then + Exit; + + Dlg := TForm.CreateNew(nil); + try + Dlg.Caption := ACaption; + Dlg.BorderStyle := bsDialog; + Dlg.Position := poScreenCenter; + Dlg.Color := ThemeWindow; + Dlg.Font.Color := ThemeText; + + Lbl := TLabel.Create(Dlg); + Lbl.Parent := Dlg; + Lbl.Left := MarginX; + Lbl.Top := MarginY; + Lbl.WordWrap := True; + Lbl.AutoSize := False; + Lbl.Width := 520; + Lbl.Caption := AText; + Lbl.Font.Color := ThemeText; + Lbl.Transparent := True; + + Lbl.Height := WrappedTextHeight(Dlg.Canvas, AText, Lbl.Width); + + { Ширина у каждой кнопки своя: надписи разной длины, а одинаковая + ширина по самой длинной растянула бы «ОК» на пол-окна. } + SetLength(Widths, Length(ACaptions)); + TotalW := 0; + for I := 0 to High(ACaptions) do + begin + Wid := Dlg.Canvas.TextWidth(ACaptions[I]) + 32; + if Wid < 90 then + Wid := 90; + Widths[I] := Wid; + Inc(TotalW, Wid); + end; + Inc(TotalW, ButtonGap * High(ACaptions)); + + Dlg.ClientWidth := Lbl.Width + MarginX * 2; + if TotalW + MarginX * 2 > Dlg.ClientWidth then + Dlg.ClientWidth := TotalW + MarginX * 2; + Dlg.ClientHeight := MarginY + Lbl.Height + MarginY + ButtonH + MarginY; + + X := (Dlg.ClientWidth - TotalW) div 2; + for I := 0 to High(ACaptions) do + begin + Btn := TThemedButton.Create(Dlg); + Btn.Parent := Dlg; + Btn.SetBounds(X, Dlg.ClientHeight - MarginY - ButtonH, Widths[I], + ButtonH); + Btn.Caption := ACaptions[I]; + { Номер кнопки возвращается через ModalResult: mrNone равен нулю, + поэтому считаем с единицы и вычитаем её обратно. } + Btn.ModalResult := I + 1; + Btn.Default := I = 0; + Btn.Cancel := I = High(ACaptions); + Inc(X, Widths[I] + ButtonGap); + end; + + Result := Dlg.ShowModal - 1; + if Result > High(ACaptions) then + Result := -1; + finally + Dlg.Free; + end; +end; + +function ThemedInputDlg(const ACaption, APrompt: string; + var AValue: string): Boolean; +var + Dlg: TForm; + Lbl: TLabel; + Edit: TEdit; + BtnOk, BtnCancel: TThemedButton; +begin + Result := False; + Dlg := TForm.CreateNew(nil); + try + Dlg.Caption := ACaption; + Dlg.BorderStyle := bsDialog; + Dlg.Position := poScreenCenter; + Dlg.ClientWidth := 360; + Dlg.ClientHeight := 130; + + Lbl := TLabel.Create(Dlg); + Lbl.Parent := Dlg; + Lbl.SetBounds(16, 16, 328, 20); + Lbl.Caption := APrompt; + + Edit := TEdit.Create(Dlg); + Edit.Parent := Dlg; + Edit.SetBounds(16, 40, 328, 26); + Edit.Text := AValue; + + BtnOk := TThemedButton.Create(Dlg); + BtnOk.Parent := Dlg; + BtnOk.SetBounds(136, 84, 100, 30); + BtnOk.Caption := 'Готово'; + BtnOk.ModalResult := mrOk; + BtnOk.Default := True; + + BtnCancel := TThemedButton.Create(Dlg); + BtnCancel.Parent := Dlg; + BtnCancel.SetBounds(244, 84, 100, 30); + BtnCancel.Caption := 'Отмена'; + BtnCancel.ModalResult := mrCancel; + BtnCancel.Cancel := True; + + ApplyDarkTheme(Dlg); + Edit.SetFocus; + if Dlg.ShowModal <> mrOk then + Exit; + AValue := Trim(Edit.Text); + Result := AValue <> ''; + finally + Dlg.Free; + end; +end; + function ThemedMessageDlg(const ACaption, AText: string; ADlgType: TMsgDlgType; AButtons: TMsgDlgButtons; AHelpCtx: Longint): TModalResult; @@ -784,7 +1445,7 @@ var Order: array[0..3] of TModalResult = (mrOk, mrYes, mrNo, mrCancel); Names: array[0..3] of string = ('ОК', 'Да', 'Нет', 'Отмена'); Flags: array[0..3] of TMsgDlgBtn = (mbOK, mbYes, mbNo, mbCancel); - I, Count, X, TextW, TextH, TotalW: Integer; + I, Count, X, TotalW: Integer; begin Dlg := TForm.CreateNew(nil); try @@ -814,9 +1475,7 @@ begin { Высоту надписи считаем по её содержимому: сообщения бывают и в одну строку, и в десять. } - TextH := Dlg.Canvas.TextHeight('Wg'); - TextW := Dlg.Canvas.TextWidth(AText); - Lbl.Height := TextH * (1 + TextW div Lbl.Width) + TextH div 2; + Lbl.Height := WrappedTextHeight(Dlg.Canvas, AText, Lbl.Width); TotalW := Count * ButtonW + (Count - 1) * ButtonGap; Dlg.ClientWidth := Lbl.Width + MarginX * 2; @@ -861,5 +1520,6 @@ initialization finalization Painter.Free; + IconCache.Free; end. diff --git a/src/uThemedScroll.pas b/src/uThemedScroll.pas index a85c2af..bd49f8a 100644 --- a/src/uThemedScroll.pas +++ b/src/uThemedScroll.pas @@ -93,6 +93,8 @@ type FVBar: TThemedScrollBar; FHBar: TThemedScrollBar; FUpdating: Boolean; + { Глубина вложенности пересчёта размещения. Ограничена: см. SyncBars. } + FDepth: Integer; { Сколько места занимает всё содержимое таблицы. Считается сложением ширин столбцов и высот строк, а не свойствами GridWidth и GridHeight: с выключенными полосами прокрутки те возвращают не @@ -475,10 +477,28 @@ begin finally FUpdating := False; end; - { Пересчёт размещения сам вызовет согласование ещё раз, но уже без - расхождения — второго круга не будет. } - if NeedRelayout then - Relayout; + { Пересчёт размещения сам вызовет согласование ещё раз. + + Обещать, что второго круга не будет, нельзя, и это стоило падения: + появление вертикальной полосы сужает таблицу, от этого перестаёт + помещаться содержимое по ширине, появляется горизонтальная полоса, + от неё убавляется высота — и решение о вертикальной принимается + заново. Под Wine эти качели не сходились никогда: стек в шестнадцать + мегабайт съедался целиком, и программа падала при открытии окна + зависимостей. + + Поэтому глубина ограничена. Три круга хватает любому разумному + случаю, а на четвёртом мы просто оставляем как есть: лишняя полоса + прокрутки не беда, а падение — беда. } + if NeedRelayout and (FDepth < 3) then + begin + Inc(FDepth); + try + Relayout; + finally + Dec(FDepth); + end; + end; end; procedure TScrolledGrid.GridTopLeftChanged(Sender: TObject); diff --git a/src/uThumbs.pas b/src/uThumbs.pas index c9a7e00..198cc9f 100644 --- a/src/uThumbs.pas +++ b/src/uThumbs.pas @@ -45,6 +45,7 @@ type private FRequests: TThumbRequests; FCurrent: Integer; + FDone: Integer; FOnReady: TThumbReadyEvent; procedure SyncReady; function CancelQuery: Boolean; @@ -53,6 +54,9 @@ type public constructor Create(const ARequests: TThumbRequests); property OnReady: TThumbReadyEvent read FOnReady write FOnReady; + { Столько же, сколько у разбора звука: очередь и сделанное. } + function Total: Integer; + property Done: Integer read FDone; end; { Путь к миниатюре в кэше проекта. Имя выводится из пути к исходнику, @@ -91,11 +95,17 @@ var begin inherited Create(True); FreeOnTerminate := False; + FDone := 0; SetLength(FRequests, Length(ARequests)); for I := 0 to High(ARequests) do FRequests[I] := ARequests[I]; end; +function TThumbThread.Total: Integer; +begin + Result := Length(FRequests); +end; + function TThumbThread.CancelQuery: Boolean; begin Result := Terminated; @@ -122,11 +132,13 @@ begin Exit; FCurrent := I; + FDone := I; { Уже готовая миниатюра — просто сообщаем о ней. } if FileExists(FRequests[I].TargetPath) then begin Synchronize(@SyncReady); + FDone := I + 1; Continue; end; @@ -143,6 +155,7 @@ begin if Res.Started and (Res.ExitCode = 0) and FileExists(FRequests[I].TargetPath) then Synchronize(@SyncReady); + FDone := I + 1; end; end; diff --git a/src/uTimelineCtrl.pas b/src/uTimelineCtrl.pas index 2577288..735cf8b 100644 --- a/src/uTimelineCtrl.pas +++ b/src/uTimelineCtrl.pas @@ -25,7 +25,7 @@ interface uses Classes, SysUtils, Controls, Graphics, LCLType, LCLIntf, Forms, Math, - uAppTypes, uProject, uMediaProbe, uKeyframeIndex; + uAppTypes, uProject, uMediaProbe, uKeyframeIndex, uWaveform; type { Что сейчас делает мышь. } @@ -36,11 +36,24 @@ type taTrimOut, // растягивание за правый край taScrub, // протяжка курсора воспроизведения taPan, // прокрутка средней кнопкой - taVolume // тянем ручку громкости клипа + taVolume, // тянем ручку громкости клипа + taFadeIn, // тянем появление за верхний левый угол + taFadeOut, // тянем уход за верхний правый угол + taRegionIn, // тянем начало отмеченного участка + taRegionOut, // тянем конец отмеченного участка + taDragTrack // тянем дорожку за заголовок, меняя порядок ); { Что находится под указателем в полосе заголовков дорожек. } - THeaderPart = (hpNone, hpBody, hpMute, hpSolo); + THeaderPart = (hpNone, hpBody, hpMute, hpSolo, hpUp, hpDown, hpName); + + { Правый щелчок по заголовку дорожки. Само меню строит окно: компонент + не знает, что с дорожкой можно делать. } + TTrackMenuEvent = procedure(Sender: TObject; ATrackIndex: Integer; + const AScreenPos: TPoint) of object; + + { Дорожку просят переименовать: окно спросит новое имя. } + TTrackRenameEvent = procedure(Sender: TObject; ATrackIndex: Integer) of object; { Файл из списка проекта бросили на монтаж. @@ -50,8 +63,13 @@ type TMediaDropEvent = procedure(Sender: TObject; ASource: TObject; ATrackIndex: Integer; const ATime: Double) of object; + { Нажали кнопку кадрирования на клипе. } + TClipEvent = procedure(Sender: TObject; AClip: TClip) of object; + TTimelineControl = class(TCustomControl) private + FBusyFrom: Double; + FBusyTo: Double; FProject: TProject; FPixelsPerSecond: Double; FScrollOffset: Double; @@ -93,18 +111,37 @@ type выключено — временно включает. } FSnapEnabled: Boolean; FSnapSuspended: Boolean; + { Прилипание курсора воспроизведения к границам клипов. Отдельно от + прилипания клипов друг к другу: это разные привычки, и человек + может хотеть одно без другого. } + FPlayheadSnap: Boolean; FDragOrigVolume: Double; + { Во сколько раз растянуть форму звука по высоте. Только рисунок, + самого звука не касается: у тихих записей иначе не видно, где + тишина, а где нет. } + FWaveGain: Double; { Клипы, которые поедут вслед за перетаскиваемым, и их исходные позиции. Список составляется один раз при нажатии: пересчитывать его на каждое движение мыши нельзя, иначе в него начнут попадать клипы, которые уже сдвинулись. } FRippleClips: array of TClip; FRippleOrigStarts: array of Double; + FGroupClips: array of TClip; + FGroupOrigStarts: array of Double; FOnPlayheadChange: TNotifyEvent; FOnStructureChange: TNotifyEvent; FOnSelectionChange: TNotifyEvent; + { Отмеченный участок подвинули мышью. } + FOnRegionChange: TNotifyEvent; + { Правый щелчок по заголовку дорожки: окно покажет своё меню. } + FOnTrackMenu: TTrackMenuEvent; + FOnTrackRename: TTrackRenameEvent; + { Дорожка, которую тащат за заголовок. } + FDragTrackIndex: Integer; + FDragTrackFrom: Integer; FOnMediaDrop: TMediaDropEvent; + FOnClipTransform: TClipEvent; FOnTrackAdded: TNotifyEvent; FOnActiveTrackChange: TNotifyEvent; @@ -125,13 +162,49 @@ type function YToVolume(const AY: Integer; ATop: Integer): Double; procedure DrawRuler(ACanvas: TCanvas); + procedure DrawRegion(ACanvas: TCanvas); + procedure DrawRegionHandle(ACanvas: TCanvas; AX: Integer; + AIsStart: Boolean); + procedure DrawTrackArrow(ACanvas: TCanvas; ALeft, ATop: Integer; + AUp, AEnabled: Boolean); + function RegionHandleAt(AX, AY: Integer): Integer; + procedure DragRegionEdge(AX: Integer; AIsStart: Boolean); procedure DrawTracks(ACanvas: TCanvas); procedure DrawClip(ACanvas: TCanvas; AClip: TClip; ATop: Integer); procedure DrawPlayhead(ACanvas: TCanvas); procedure DrawHeaders(ACanvas: TCanvas); + procedure DrawWaveform(ACanvas: TCanvas; AClip: TClip; const ABody: TRect); + { Появление и уход: наклонная линия по верху клипа и квадратная ручка + на её конце. Так это устроено в монтажных программах, и так сразу + видно, где звук или картинка нарастают. } + procedure DrawFades(ACanvas: TCanvas; AClip: TClip; const ABody: TRect); + { Ручка затухания. AIn = True — появление (левый угол), иначе уход. } + function FadeHandleRect(AClip: TClip; ATop: Integer; AIn: Boolean): TRect; + { Полоса перекрытия двух клипов одной дорожки: там сам собой выходит + переход, и это надо видеть. } + procedure DrawOverlaps(ACanvas: TCanvas; ATrack: TTrack; ATop: Integer); + { Полоса поверх участка, который прямо сейчас пересобирается. } + procedure DrawBusyRange(ACanvas: TCanvas); + { Сдвиг всего, что правее дыры, влево до первого касания. } + procedure RippleAfterDelete(const AHoleEnd: Double; + const ATracks: TStringList); + public + { Отметить участок монтажа, который сейчас пересобирается. Нули + снимают отметку. } + procedure SetBusyRange(const AFrom, ATo: Double); + private + { Кнопка кадрирования в правом нижнем углу видимой части клипа. + Именно видимой: у клипа длиной в час настоящий угол почти всегда за + краем экрана, и дотянуться до него мышью нельзя. } + function CropButtonRect(const ABody: TRect): TRect; + { Тот же прямоугольник, но по клипу: тело считается так же, как при + отрисовке. } + function ClipCropRect(AClip: TClip; ATop: Integer): TRect; + procedure DrawCropButton(ACanvas: TCanvas; const ABody: TRect); procedure DrawVolume(ACanvas: TCanvas; AClip: TClip; ATop: Integer; const ABody: TRect); + procedure SetWaveGain(const AValue: Double); procedure SetPlayhead(const AValue: Double); procedure SetPixelsPerSecond(const AValue: Double); procedure ClampScroll; @@ -197,6 +270,17 @@ type расстояния между опорными кадрами. } procedure SplitAtPlayhead(APrecise: Boolean; AOnlyCurrentTrack: Boolean); procedure DeleteSelected; + { Связать выделенные клипы или развязать, если они уже связаны. + + Связанные двигаются, режутся и удаляются вместе. По умолчанию так + связаны картинка и её звук. } + procedure ToggleGroupSelected; + procedure SelectWholeGroups; + function ClipLevel(AClip: TClip): Double; + procedure SetClipLevel(AClip: TClip; const AValue: Double); + { Клипы одной связки с перетаскиваемым и их исходные позиции. } + procedure CollectGroupClips(AClip: TClip); + procedure ApplyGroupMove(const ADelta: Double); { Сдвинуть клипы влево, закрыв дыру под курсором. } procedure RippleCloseGap; procedure SelectAll; @@ -206,8 +290,14 @@ type { Дорожка, выбранная щелчком по заголовку. } property ActiveTrack: Integer read FActiveTrack write FActiveTrack; property SnapEnabled: Boolean read FSnapEnabled write FSnapEnabled; + property PlayheadSnap: Boolean read FPlayheadSnap write FPlayheadSnap; + { Куда встанет курсор, если поставить его в это время. Открыто, чтобы + расчёт можно было проверить числами, не гоняя мышь по окну. } + function SnapPlayhead(const ATime: Double): Double; property Project: TProject read FProject write FProject; + { Усиление формы звука. Меняется по Shift со стрелками. } + property WaveGain: Double read FWaveGain write SetWaveGain; property Playhead: Double read FPlayhead write SetPlayhead; property PixelsPerSecond: Double read FPixelsPerSecond write SetPixelsPerSecond; property ScrollOffset: Double read FScrollOffset write FScrollOffset; @@ -219,7 +309,16 @@ type write FOnStructureChange; property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange; + property OnRegionChange: TNotifyEvent read FOnRegionChange + write FOnRegionChange; + property OnTrackMenu: TTrackMenuEvent read FOnTrackMenu + write FOnTrackMenu; + property OnTrackRename: TTrackRenameEvent read FOnTrackRename + write FOnTrackRename; property OnMediaDrop: TMediaDropEvent read FOnMediaDrop write FOnMediaDrop; + { Нажата кнопка кадрирования в углу клипа. } + property OnClipTransform: TClipEvent read FOnClipTransform + write FOnClipTransform; { Компонент сам создал дорожку при перетаскивании клипа вниз. } property OnTrackAdded: TNotifyEvent read FOnTrackAdded write FOnTrackAdded; property OnActiveTrackChange: TNotifyEvent read FOnActiveTrackChange @@ -234,6 +333,16 @@ const { На сколько пикселей примагничиваются края при перетаскивании. } SnapPixels = 8; + { Уголок отметки участка: сторона треугольника в точках. } + RegionHandleWidth = 9; + { Стрелки порядка дорожек в заголовке. } + ArrowSize = 14; + ArrowLeft = 5; + { Полоса участка вверху линейки: в ней живут уголки, и протяжка по ней + отмечает участок, а не двигает курсор. Так же устроено в монтажных + программах: у линейки два этажа, верхний про отметки, нижний про + курсор. } + RegionBarHeight = 12; { Сдвиг мыши, до которого нажатие считается щелчком, а не перетаскиванием. Совсем без запаса нельзя: рука дрожит, и попасть кнопкой в один и тот же @@ -284,10 +393,20 @@ const ColorClipBorder = TColor($5080AA); // светлая рамка клипа ColorClipText = TColor($F0F0F0); ColorPlayhead = TColor($4040FF); // красный: привычный цвет курсора + ColorRegion = TColor($30A0D0); // отмеченный участок: янтарная полоса + ColorRegionEdge = TColor($1878B0); + ColorRegionHandle = TColor($40E0F0); // уголки отметок: жёлтые, как в Vegas ColorEdgeSnap = TColor($909090); // серый: рез притянут к опорному кадру ColorEdgePrecise = TColor($FFC030); // голубой: рез потребует перекодирования + ColorWave = TColor($96C8D2); // пастельно-жёлтый: форма звука + ColorCropButton = TColor($4A6A8A); // кнопка кадрирования на клипе + ColorClipAudio = TColor($5A4A2A); // приглушённый синий: звуковой клип ColorVolumeLine = TColor($60E0E0); // жёлтый: линия громкости ColorVolumeHandle = TColor($30C0FF); // оранжевый: ручка громкости + ColorFadeLine = TColor($E0E0E0); // белый: линия затухания + ColorFadeFill = TColor($505050); // серый: срезанный угол клипа + ColorOverlap = TColor($30C0FF); // оранжевый: полоса перехода + ColorBusy = TColor($30C0FF); // оранжевый: участок в работе ColorHeaderActive = TColor($3A3A3A); // подсветка выбранной дорожки ColorButtonOff = TColor($3A3A3A); ColorMuteOn = TColor($4040D0); // красный: дорожка выключена @@ -297,6 +416,7 @@ const constructor TTimelineControl.Create(AOwner: TComponent); begin + FWaveGain := 1; inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; TabStop := True; @@ -313,6 +433,9 @@ begin FHoverTrack := -1; FActiveTrack := 0; FSnapEnabled := True; + FPlayheadSnap := True; + FDragTrackIndex := -1; + FDragTrackFrom := -1; end; destructor TTimelineControl.Destroy; @@ -437,6 +560,22 @@ begin Result := hpBody; RowTop := TrackTop(ATrackIndex); + + { Стрелки порядка — слева, одна под другой: дорожку двигают вверх и + вниз чаще, чем делают с ней что-либо ещё, и лезть за этим в меню + неудобно. } + if (AX >= ArrowLeft) and (AX < ArrowLeft + ArrowSize) then + begin + if (AY >= RowTop + 6) and (AY < RowTop + 6 + ArrowSize) then + Exit(hpUp); + if (AY >= RowTop + 8 + ArrowSize) and (AY < RowTop + 8 + 2 * ArrowSize) then + Exit(hpDown); + end; + + { Имя: по двойному щелчку его переименовывают. } + if (AY >= RowTop + 4) and (AY < RowTop + 22) and (AX >= ArrowLeft + ArrowSize) then + Exit(hpName); + BtnTop := RowTop + FTrackHeight - HeaderButtonSize - 6; if (AY < BtnTop) or (AY > BtnTop + HeaderButtonSize) then Exit; @@ -481,6 +620,32 @@ begin Result := MaxClipVolume; end; +{ Что задаёт ползунок на клипе. + + У звука это громкость, у картинки — непрозрачность. Величина одна и та + же по смыслу (доля от единицы), поэтому и ползунок один, но означает он + разное, и подписывается по-разному. } +function TTimelineControl.ClipLevel(AClip: TClip): Double; +begin + if AClip = nil then + Exit(1); + if AClip.Kind = ckAudio then + Result := AClip.Volume + else + Result := AClip.Opacity; +end; + +procedure TTimelineControl.SetClipLevel(AClip: TClip; const AValue: Double); +begin + if AClip = nil then + Exit; + if AClip.Kind = ckAudio then + AClip.Volume := AValue + else + { Прозрачнее полного клип быть может, а ярче исходника — нет. } + AClip.Opacity := Min(1, AValue); +end; + function TTimelineControl.VolumeHandleRect(AClip: TClip; ATop: Integer): TRect; var L, R, CenterX, Y: Integer; @@ -504,7 +669,7 @@ begin Exit; CenterX := (L + R) div 2; - Y := VolumeToY(AClip.Volume, ATop); + Y := VolumeToY(ClipLevel(AClip), ATop); Result := Rect(CenterX - VolumeHandleWidth div 2, Y - VolumeHandleHeight div 2, CenterX + VolumeHandleWidth div 2, Y + VolumeHandleHeight div 2); end; @@ -533,6 +698,9 @@ begin FBuffer.Canvas.FillRect(0, 0, FBuffer.Width, FBuffer.Height); DrawTracks(FBuffer.Canvas); + { Отметка занятого участка идёт после клипов и до линейки: она должна + лежать поверх клипов, но не наползать на подписи времени. } + DrawBusyRange(FBuffer.Canvas); DrawRuler(FBuffer.Canvas); DrawHeaders(FBuffer.Canvas); DrawPlayhead(FBuffer.Canvas); @@ -599,13 +767,119 @@ begin T := T + Step; end; + { Отмеченный участок: полоса по низу линейки и стойки по краям. + + Рисуется после делений, чтобы не оказаться под ними, и только на + линейке: закрашивать сами дорожки нельзя — под краской не разглядеть + клипы, а участок отмечают как раз чтобы в них разбираться. } + DrawRegion(ACanvas); + ACanvas.Brush.Style := bsSolid; end; +procedure TTimelineControl.DrawRegion(ACanvas: TCanvas); +var + L, R: Integer; +begin + if (FProject = nil) or (not FProject.HasRegion) then + Exit; + + L := Max(FHeaderWidth, TimeToX(FProject.RegionStart)); + R := Min(ClientWidth, TimeToX(FProject.RegionEnd)); + if R <= L then + Exit; + + ACanvas.Brush.Style := bsSolid; + ACanvas.Brush.Color := ColorRegion; + ACanvas.FillRect(L, FRulerHeight - 6, R, FRulerHeight - 1); + + { Стойки во всю высоту: край участка должен быть виден и там, где + линейка уже уехала вверх за пределы видимого. } + ACanvas.Pen.Color := ColorRegionEdge; + if TimeToX(FProject.RegionStart) >= FHeaderWidth then + ACanvas.Line(L, 0, L, ClientHeight); + if TimeToX(FProject.RegionEnd) <= ClientWidth then + ACanvas.Line(R - 1, 0, R - 1, ClientHeight); + + { Уголки, за которые тянут. Отметки должны не только показывать, где + участок, но и позволять его двигать: клавишами это выходит долго — + поставил, посмотрел, промахнулся, ставь заново. } + DrawRegionHandle(ACanvas, TimeToX(FProject.RegionStart), True); + DrawRegionHandle(ACanvas, TimeToX(FProject.RegionEnd), False); +end; + +{ Уголок отметки: прямоугольный треугольник, прижатый к своей стороне + участка. Так видно, какой край он держит, — у симметричной стрелки это + пришлось бы угадывать. } +procedure TTimelineControl.DrawRegionHandle(ACanvas: TCanvas; AX: Integer; + AIsStart: Boolean); +var + Pts: array[0..2] of TPoint; +begin + if (AX < FHeaderWidth - RegionHandleWidth) or + (AX > ClientWidth + RegionHandleWidth) then + Exit; + + if AIsStart then + begin + Pts[0] := Point(AX, 0); + Pts[1] := Point(AX + RegionHandleWidth, 0); + Pts[2] := Point(AX, RegionHandleWidth); + end + else + begin + Pts[0] := Point(AX, 0); + Pts[1] := Point(AX - RegionHandleWidth, 0); + Pts[2] := Point(AX, RegionHandleWidth); + end; + + ACanvas.Brush.Style := bsSolid; + ACanvas.Brush.Color := ColorRegionHandle; + ACanvas.Pen.Color := ColorRegionEdge; + ACanvas.Polygon(Pts); +end; + +{ Что под указателем на линейке: 1 — уголок начала, 2 — уголок конца. } +{ Двигает край участка за уголком. + + Край прилипает к границам клипов тем же способом, что и курсор: участок + чаще всего отмечают по кускам, а попасть мышью в стык на общем плане + нельзя. Края не пропускаются друг за друга: перевёрнутый участок — это + не участок. } +procedure TTimelineControl.DragRegionEdge(AX: Integer; AIsStart: Boolean); +var + T: Double; +begin + if FProject = nil then + Exit; + T := Max(0, SnapPlayhead(XToTime(AX))); + if AIsStart then + FProject.RegionStart := Min(T, FProject.RegionEnd - 0.001) + else + FProject.RegionEnd := Max(T, FProject.RegionStart + 0.001); + Invalidate; + if Assigned(FOnRegionChange) then + FOnRegionChange(Self); +end; + +function TTimelineControl.RegionHandleAt(AX, AY: Integer): Integer; +begin + Result := 0; + if (FProject = nil) or (not FProject.HasRegion) then + Exit; + if (AY < 0) or (AY > RegionHandleWidth + 2) then + Exit; + + if Abs(AX - TimeToX(FProject.RegionStart)) <= RegionHandleWidth then + Exit(1); + if Abs(AX - TimeToX(FProject.RegionEnd)) <= RegionHandleWidth then + Exit(2); +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, и локальная переменная их перекроет. Компилятор ловит, но сообщение неочевидное. } @@ -633,6 +907,8 @@ begin ACanvas.Brush.Color := ColorClipSelected else if AClip.Kind = ckImage then ACanvas.Brush.Color := ColorClipImage + else if AClip.Kind = ckAudio then + ACanvas.Brush.Color := ColorClipAudio else ACanvas.Brush.Color := ColorClip; ACanvas.FillRect(Body); @@ -661,6 +937,19 @@ begin ACanvas.FillRect(Body.Right - 4, Body.Top + 1, Body.Right - 1, Body.Bottom - 1); end; + { Форма звука — фон клипа, поэтому идёт раньше всего остального, что на + нём рисуется. } + DrawWaveform(ACanvas, AClip, Body); + + { Кнопка на клипе: у картинки — кадрирование, у надписи — правка + текста. У звука нет ни того, ни другого. } + if AClip.Kind in [ckVideo, ckImage, ckText] then + DrawCropButton(ACanvas, Body); + + { Затухания идут до громкости и подписей: срезанный угол не должен + затирать ни линию громкости, ни название. } + DrawFades(ACanvas, AClip, Body); + { Громкость рисуется до подписей: иначе её линия перечёркивает название и длительность. } DrawVolume(ACanvas, AClip, ATop, Body); @@ -670,7 +959,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 := '(нет файла)'; @@ -683,9 +983,283 @@ begin SecondsToStr(AClip.Duration) + ' с'); end; + { Метка цветового ключа: сам выбиваемый цвет квадратиком в нижнем левом + углу. Иначе клип с ключом ничем не отличается от обычного, а разница + у них большая — участок под ним будет пересобран. } + if AClip.ColorKey.Enabled and (W > 20) then + begin + ACanvas.Brush.Style := bsSolid; + ACanvas.Brush.Color := TColor(AClip.ColorKey.Color); + ACanvas.Pen.Color := ColorClipText; + ACanvas.Rectangle(Body.Left + 6, Body.Bottom - 15, + Body.Left + 18, Body.Bottom - 3); + end; + ACanvas.Brush.Style := bsSolid; end; +{ Форма звука внутри клипа. + + Рисуется по заранее посчитанным пикам, а не по самому звуку: в секунде + 48 тысяч отсчётов, а в клипе на экране — сотни пикселей. + + Считается только видимая часть: у часового клипа за краем экрана + остаётся почти всё, и перебирать его целиком на каждую перерисовку + незачем. } +procedure TTimelineControl.DrawWaveform(ACanvas: TCanvas; AClip: TClip; + const ABody: TRect); +var + Item: TMediaItem; + Peaks: TPeaks; + X, MidY, HalfH, H: Integer; + SrcTime: Double; + Idx, Value: Integer; +begin + { Форма звука рисуется на звуковом клипе. На клипе картинки ей не место: + звук у него отдельный и живёт на своей дорожке. } + if (FProject = nil) or (AClip.Kind <> ckAudio) then + Exit; + Item := FProject.FindMedia(AClip.MediaId); + if (Item = nil) or (not Item.Info.HasAudio) then + Exit; + if not CachedPeaks(FProject.CacheDir, Item.EffectivePath, Peaks) then + Exit; + if (Peaks.Rate <= 0) or (Length(Peaks.Data) = 0) then + Exit; + + MidY := (ABody.Top + ABody.Bottom) div 2; + HalfH := (ABody.Bottom - ABody.Top) div 2 - 2; + if HalfH < 2 then + Exit; + + ACanvas.Pen.Color := ColorWave; + ACanvas.Pen.Style := psSolid; + + for X := ABody.Left + 1 to ABody.Right - 2 do + begin + { От точки на экране — к моменту внутри исходника. } + SrcTime := AClip.SrcIn + (XToTime(X) - AClip.TlStart); + if SrcTime < 0 then + Continue; + Idx := Trunc(SrcTime * Peaks.Rate); + if (Idx < 0) or (Idx > High(Peaks.Data)) then + Continue; + + Value := Round(Peaks.Data[Idx] * FWaveGain); + if Value > 255 then + Value := 255; + H := Value * HalfH div 255; + if H < 1 then + Continue; + ACanvas.Line(X, MidY - H, X, MidY + H); + end; +end; + +function TTimelineControl.FadeHandleRect(AClip: TClip; ATop: Integer; + AIn: Boolean): TRect; +const + Size = 9; +var + L, R, X: Integer; + Body: TRect; + FadeLen: Double; +begin + Result := Rect(0, 0, 0, 0); + if (AClip = nil) or (AClip.Kind = ckBlack) then + Exit; + + L := TimeToX(AClip.TlStart); + R := TimeToX(AClip.TlEnd); + if (R < FHeaderWidth) or (L > ClientWidth) then + Exit; + { Слишком узкий клип ручками не увешиваем: они закроют его целиком. } + if R - L < Size * 4 then + Exit; + + Body := Rect(L, ATop + 3, R, ATop + FTrackHeight - 3); + + if AIn then + begin + FadeLen := AClip.FadeIn; + X := TimeToX(AClip.TlStart + FadeLen); + end + else + begin + FadeLen := AClip.FadeOut; + X := TimeToX(AClip.TlEnd - FadeLen); + end; + + { Ручка ненулевого затухания стоит на его конце, нулевого — в самом + углу: иначе её негде было бы взять в первый раз. } + Result := Rect(X - Size div 2, Body.Top, X + Size div 2, Body.Top + Size); + if Result.Left < FHeaderWidth then + Exit(Rect(0, 0, 0, 0)); + if Result.Right > ClientWidth then + Exit(Rect(0, 0, 0, 0)); +end; + +procedure TTimelineControl.DrawFades(ACanvas: TCanvas; AClip: TClip; + const ABody: TRect); +var + X: Integer; + H: TRect; + + procedure Corner(AX: Integer; AIn: Boolean); + begin + { Срезанный угол: от угла клипа к концу затухания по верхней грани. + Закрашиваем сам срез, чтобы было видно, сколько взято. } + ACanvas.Brush.Color := ColorFadeFill; + ACanvas.Brush.Style := bsSolid; + ACanvas.Pen.Color := ColorFadeLine; + if AIn then + ACanvas.Polygon([Point(ABody.Left, ABody.Bottom), Point(ABody.Left, ABody.Top), + Point(AX, ABody.Top)]) + else + ACanvas.Polygon([Point(ABody.Right, ABody.Bottom), Point(ABody.Right, ABody.Top), + Point(AX, ABody.Top)]); + end; + +begin + if (AClip = nil) or (AClip.Kind = ckBlack) then + Exit; + if ABody.Right - ABody.Left < 8 then + Exit; + + if AClip.FadeIn > 0.0005 then + begin + X := TimeToX(AClip.TlStart + AClip.FadeIn); + if X > ABody.Left then + Corner(Min(X, ABody.Right), True); + end; + if AClip.FadeOut > 0.0005 then + begin + X := TimeToX(AClip.TlEnd - AClip.FadeOut); + if X < ABody.Right then + Corner(Max(X, ABody.Left), False); + end; + + { Ручки рисуются всегда, даже при нулевом затухании: иначе непонятно, + за что тянуть. } + ACanvas.Brush.Style := bsSolid; + ACanvas.Pen.Color := ColorFadeLine; + H := FadeHandleRect(AClip, ABody.Top - 3, True); + if H.Right > H.Left then + begin + ACanvas.Brush.Color := ColorFadeLine; + ACanvas.Rectangle(H); + end; + H := FadeHandleRect(AClip, ABody.Top - 3, False); + if H.Right > H.Left then + begin + ACanvas.Brush.Color := ColorFadeLine; + ACanvas.Rectangle(H); + end; +end; + +procedure TTimelineControl.DrawOverlaps(ACanvas: TCanvas; ATrack: TTrack; + ATop: Integer); +var + I, L, R: Integer; + A, B: TClip; +begin + if (ATrack = nil) or (ATrack.Count < 2) then + Exit; + ACanvas.Pen.Color := ColorOverlap; + ACanvas.Brush.Style := bsClear; + for I := 0 to ATrack.Count - 2 do + begin + A := ATrack[I]; + B := ATrack[I + 1]; + if B.TlStart >= A.TlEnd - 0.0005 then + Continue; + L := TimeToX(B.TlStart); + R := TimeToX(A.TlEnd); + if (R < FHeaderWidth) or (L > ClientWidth) or (R - L < 3) then + Continue; + if L < FHeaderWidth then + L := FHeaderWidth; + if R > ClientWidth then + R := ClientWidth; + { Косой крест по всей высоте: так переход обозначают везде, и его + ширина сразу видна. } + ACanvas.Line(L, ATop + 3, R, ATop + FTrackHeight - 3); + ACanvas.Line(L, ATop + FTrackHeight - 3, R, ATop + 3); + end; +end; + +function TTimelineControl.CropButtonRect(const ABody: TRect): TRect; +const + Size = 16; + Margin = 3; +begin + Result := Rect(ABody.Right - Size - Margin, ABody.Bottom - Size - Margin, + ABody.Right - Margin, ABody.Bottom - Margin); + { На узком или низком клипе кнопке не место: она закроет собой сам клип. } + if (ABody.Right - ABody.Left < Size * 3) or + (ABody.Bottom - ABody.Top < Size + Margin * 2) then + Result := Rect(0, 0, 0, 0); +end; + +function TTimelineControl.ClipCropRect(AClip: TClip; ATop: Integer): TRect; +var + L, R: Integer; +begin + Result := Rect(0, 0, 0, 0); + { У надписи та же кнопка открывает правку текста — окно решает, что + именно показать. } + if (AClip = nil) or (not (AClip.Kind in [ckVideo, ckImage, ckText])) then + Exit; + + L := TimeToX(AClip.TlStart); + R := TimeToX(AClip.TlEnd); + if (R < FHeaderWidth) or (L > ClientWidth) then + Exit; + if L < FHeaderWidth then + L := FHeaderWidth; + if R > ClientWidth then + R := ClientWidth; + + Result := CropButtonRect(Rect(L, ATop + 3, R, ATop + FTrackHeight - 3)); +end; + +procedure TTimelineControl.DrawCropButton(ACanvas: TCanvas; const ABody: TRect); +var + R: TRect; +begin + R := CropButtonRect(ABody); + if R.Right <= R.Left then + Exit; + + ACanvas.Brush.Style := bsSolid; + ACanvas.Brush.Color := ColorCropButton; + ACanvas.FillRect(R); + ACanvas.Pen.Color := ColorClipBorder; + ACanvas.Brush.Style := bsClear; + ACanvas.Rectangle(R); + + { Значок: рамка внутри рамки — то самое кадрирование. } + ACanvas.Pen.Color := ColorClipText; + ACanvas.Rectangle(R.Left + 4, R.Top + 4, R.Right - 4, R.Bottom - 4); + ACanvas.Brush.Style := bsSolid; +end; + +procedure TTimelineControl.SetWaveGain(const AValue: Double); +var + V: Double; +begin + V := AValue; + { Ниже единицы опускаться незачем: это уже настоящая амплитуда. + Выше шестидесяти четырёх — сплошная заливка, смысла тоже нет. } + if V < 1 then + V := 1; + if V > 64 then + V := 64; + if Abs(V - FWaveGain) < 0.001 then + Exit; + FWaveGain := V; + Invalidate; +end; + { Линия громкости с ручкой посередине видимой части клипа. Сделано как в монтажных программах: линия показывает уровень, за ручку @@ -704,7 +1278,7 @@ begin if ABody.Right - ABody.Left < 12 then Exit; - Y := VolumeToY(AClip.Volume, ATop); + Y := VolumeToY(ClipLevel(AClip), ATop); if (Y <= ABody.Top) then Y := ABody.Top + 1; if (Y >= ABody.Bottom) then @@ -727,7 +1301,7 @@ begin надпись налезет на соседние. } if ABody.Right - ABody.Left > 130 then begin - VolText := IntToStr(Round(AClip.Volume * 100)) + '%'; + VolText := IntToStr(Round(ClipLevel(AClip) * 100)) + '%'; ACanvas.Brush.Style := bsClear; ACanvas.Font.Color := ColorVolumeLine; ACanvas.Font.Height := -10; @@ -736,6 +1310,57 @@ begin end; end; +procedure TTimelineControl.SetBusyRange(const AFrom, ATo: Double); +begin + if (Abs(AFrom - FBusyFrom) < 0.0005) and (Abs(ATo - FBusyTo) < 0.0005) then + Exit; + FBusyFrom := AFrom; + FBusyTo := ATo; + Invalidate; +end; + +{ Участок, который сейчас пересобирается. + + Помечается косой штриховкой во всю высоту дорожек: сплошная заливка + закрыла бы клипы, а рамка на узком участке была бы неразличима. Штрих + наклонный — так его не спутать ни с курсором воспроизведения, ни с + границами клипов, которые все вертикальные. } +procedure TTimelineControl.DrawBusyRange(ACanvas: TCanvas); +const + Step = 10; +var + L, R, X, Bottom: Integer; +begin + if FBusyTo <= FBusyFrom then + Exit; + + L := TimeToX(FBusyFrom); + R := TimeToX(FBusyTo); + if (R < FHeaderWidth) or (L > ClientWidth) then + Exit; + if L < FHeaderWidth then + L := FHeaderWidth; + if R > ClientWidth then + R := ClientWidth; + { Совсем узкий участок штриховкой не показать — рисуем хотя бы полоску. } + if R - L < 3 then + R := L + 3; + + Bottom := ClientHeight; + ACanvas.Pen.Color := ColorBusy; + ACanvas.Brush.Style := bsClear; + ACanvas.Rectangle(L, FRulerHeight, R, Bottom); + + X := L - (Bottom - FRulerHeight); + while X < R do + begin + ACanvas.Line(Max(L, X), FRulerHeight + Max(0, L - X), + Min(R, X + Bottom - FRulerHeight), FRulerHeight + + Min(Bottom - FRulerHeight, R - X)); + Inc(X, Step); + end; +end; + procedure TTimelineControl.DrawTracks(ACanvas: TCanvas); var T, C, RowTop: Integer; @@ -766,6 +1391,9 @@ begin Track := FProject.Tracks[T]; for C := 0 to Track.Count - 1 do DrawClip(ACanvas, Track[C], RowTop); + { Перекрытия рисуются поверх клипов: крест должен быть виден на обоих + сразу, иначе непонятно, какие именно куски переходят друг в друга. } + DrawOverlaps(ACanvas, Track, RowTop); end; end; @@ -839,18 +1467,25 @@ begin ACanvas.Font.Color := clGray; ACanvas.Font.Height := -12; ACanvas.Font.Style := [fsBold]; - ACanvas.TextOut(8, RowTop + 6, Track.Name); + ACanvas.TextOut(ArrowLeft + ArrowSize + 6, RowTop + 6, Track.Name); ACanvas.Font.Style := []; ACanvas.Font.Color := clGray; ACanvas.Font.Height := -10; if T = 0 then - ACanvas.TextOut(8, RowTop + 24, + ACanvas.TextOut(ArrowLeft + ArrowSize + 6, RowTop + 24, IntToStr(Track.Count) + ' кл. верх') else - ACanvas.TextOut(8, RowTop + 24, IntToStr(Track.Count) + ' кл.'); + ACanvas.TextOut(ArrowLeft + ArrowSize + 6, RowTop + 24, + IntToStr(Track.Count) + ' кл.'); ACanvas.Brush.Style := bsSolid; + { Стрелки порядка. У верхней дорожки некуда вверх, у нижней вниз — + такая стрелка рисуется тускло и не нажимается. } + DrawTrackArrow(ACanvas, ArrowLeft, RowTop + 6, True, T > 0); + DrawTrackArrow(ACanvas, ArrowLeft, RowTop + 8 + ArrowSize, False, + T < FProject.TrackCount - 1); + BtnTop := RowTop + FTrackHeight - HeaderButtonSize - 6; BtnLeft := FHeaderWidth - 2 * HeaderButtonSize - HeaderButtonGap - 8; { М — выключить дорожку целиком, С — слушать только её. } @@ -862,6 +1497,36 @@ begin ACanvas.Brush.Style := bsSolid; end; +{ Треугольник порядка дорожек. } +procedure TTimelineControl.DrawTrackArrow(ACanvas: TCanvas; + ALeft, ATop: Integer; AUp, AEnabled: Boolean); +var + Pts: array[0..2] of TPoint; + Mid: Integer; +begin + Mid := ALeft + ArrowSize div 2; + if AUp then + begin + Pts[0] := Point(Mid, ATop + 2); + Pts[1] := Point(ALeft + 1, ATop + ArrowSize - 3); + Pts[2] := Point(ALeft + ArrowSize - 1, ATop + ArrowSize - 3); + end + else + begin + Pts[0] := Point(Mid, ATop + ArrowSize - 3); + Pts[1] := Point(ALeft + 1, ATop + 2); + Pts[2] := Point(ALeft + ArrowSize - 1, ATop + 2); + end; + + ACanvas.Brush.Style := bsSolid; + if AEnabled then + ACanvas.Brush.Color := ColorRulerText + else + ACanvas.Brush.Color := ColorButtonOff; + ACanvas.Pen.Color := ACanvas.Brush.Color; + ACanvas.Polygon(Pts); +end; + procedure TTimelineControl.DrawPlayhead(ACanvas: TCanvas); var X: Integer; @@ -1075,6 +1740,61 @@ begin Result := Best; end; +{ Куда встанет курсор воспроизведения: к ближайшей границе клипа, если + она близко. + + Зачем. Точно попасть мышью в стык двух кусков нельзя: одна точка экрана + на общем плане — это секунды материала. А ставят курсор чаще всего + именно на стык: посмотреть переход, разрезать вплотную, свести концы. + + Границы берутся со всех дорожек: стык на нижней дорожке нужен не реже, + чем на текущей. } +function TTimelineControl.SnapPlayhead(const ATime: Double): Double; +var + T, C: Integer; + Track: TTrack; + Clip: TClip; + Best, BestDist, Dist, Tolerance: Double; + + procedure Consider(const ACandidate: Double); + begin + Dist := Abs(ACandidate - ATime); + if Dist < BestDist then + begin + BestDist := Dist; + Best := ACandidate; + end; + end; + +begin + Result := ATime; + if FProject = nil then + Exit; + { Shift меняет решение на противоположное — как и у прилипания клипов. } + if FPlayheadSnap = FSnapSuspended then + Exit; + if FPixelsPerSecond <= 0 then + Exit; + + Tolerance := SnapPixels / FPixelsPerSecond; + BestDist := Tolerance; + Best := ATime; + + Consider(0); + for T := 0 to FProject.TrackCount - 1 do + begin + Track := FProject.Tracks[T]; + for C := 0 to Track.Count - 1 do + begin + Clip := Track[C]; + Consider(Clip.TlStart); + Consider(Clip.TlEnd); + end; + end; + + Result := Best; +end; + { --- Мышь --- } procedure TTimelineControl.MouseDown(Button: TMouseButton; Shift: TShiftState; @@ -1085,6 +1805,8 @@ var Edge, Idx: Integer; Part: THeaderPart; VolHandle: TRect; + CropRect: TRect; + FadeHandle: TRect; begin inherited MouseDown(Button, Shift, X, Y); SetFocus; @@ -1100,6 +1822,21 @@ begin Exit; end; + { Правый щелчок по заголовку — меню дорожки. Удалять и переставлять + дорожки больше негде: в главном меню есть только «добавить» и «убрать + последнюю», а убрать нужно бывает не последнюю. } + if (Button = mbRight) and (X < FHeaderWidth) and (Y >= FRulerHeight) then + begin + Idx := TrackIndexAt(Y); + if (Idx >= 0) and Assigned(FOnTrackMenu) then + begin + FActiveTrack := Idx; + Invalidate; + FOnTrackMenu(Self, Idx, ClientToScreen(Point(X, Y))); + end; + Exit; + end; + if Button <> mbLeft then Exit; @@ -1122,9 +1859,39 @@ begin FProject.Tracks[Idx].Solo := not FProject.Tracks[Idx].Solo; StructureChanged; end; + hpUp: + if Idx > 0 then + begin + FProject.MoveTrack(Idx, Idx - 1); + FActiveTrack := Idx - 1; + FProject.Modified := True; + StructureChanged; + end; + hpDown: + if Idx < FProject.TrackCount - 1 then + begin + FProject.MoveTrack(Idx, Idx + 1); + FActiveTrack := Idx + 1; + FProject.Modified := True; + StructureChanged; + end; + hpName: + begin + FActiveTrack := Idx; + Invalidate; + { Двойной щелчок по имени — переименование. Одиночный просто + выбирает дорожку: имя правят редко, а выбирают часто. } + if (ssDouble in Shift) and Assigned(FOnTrackRename) then + FOnTrackRename(Self, Idx); + end; hpBody: begin FActiveTrack := Idx; + { Заголовок можно потащить: порядок дорожек — это приоритет, и + менять его перетаскиванием привычнее, чем через меню. } + FAction := taDragTrack; + FDragTrackIndex := Idx; + FDragTrackFrom := Idx; Invalidate; if Assigned(FOnActiveTrackChange) then FOnActiveTrackChange(Self); @@ -1133,11 +1900,30 @@ begin Exit; end; - { Щелчок по линейке ставит курсор воспроизведения. } + { Щелчок по линейке: сперва уголки отмеченного участка, потом курсор. + + Приоритет у уголков: они мелкие, промахнуться мимо них легко, а + поставить курсор можно где угодно рядом. } if Y < FRulerHeight then begin + case RegionHandleAt(X, Y) of + 1: begin FAction := taRegionIn; Exit; end; + 2: begin FAction := taRegionOut; Exit; end; + end; + + { Верхний этаж линейки — про участок: протяжка по нему отмечает его + заново, даже если отметок не было. Нижний — про курсор. } + if (Y < RegionBarHeight) and (FProject <> nil) then + begin + FAction := taRegionOut; + FProject.RegionStart := Max(0, SnapPlayhead(XToTime(X))); + FProject.RegionEnd := FProject.RegionStart; + Invalidate; + Exit; + end; + FAction := taScrub; - Playhead := Max(0, XToTime(X)); + Playhead := Max(0, SnapPlayhead(XToTime(X))); Exit; end; @@ -1154,7 +1940,7 @@ begin FOnSelectionChange(Self); end; FAction := taScrub; - Playhead := Max(0, XToTime(X)); + Playhead := Max(0, SnapPlayhead(XToTime(X))); Exit; end; @@ -1167,6 +1953,9 @@ begin FDragClip := Clip; FDragTrack := Track; + { Клипы связки поедут следом. Список составляется один раз при нажатии: + пересчитывать его на каждое движение нельзя — они уже сдвинулись. } + CollectGroupClips(Clip); FDragOrigStart := Clip.TlStart; FDragOrigSrcIn := Clip.SrcIn; FDragOrigDuration := Clip.Duration; @@ -1174,6 +1963,45 @@ begin { Ручка громкости имеет приоритет над переносом клипа: она мелкая, и промахнуться мимо неё легче, чем мимо всего клипа. } + { Кнопка кадрирования перехватывает щелчок раньше всех: иначе клип + успеет выделиться и поехать за мышью. } + CropRect := ClipCropRect(Clip, TrackTop(TrackIndexAt(Y))); + if (CropRect.Right > CropRect.Left) and PtInRect(CropRect, Point(X, Y)) then + begin + FAction := taNone; + if Assigned(FOnClipTransform) then + FOnClipTransform(Self, Clip); + Exit; + end; + + { Ручки затухания стоят в верхних углах, а там же начинается зона + растягивания за край. Приоритет у ручек: они мелкие, промахнуться + мимо них легче, а растянуть клип можно, взявшись за край ниже. } + FadeHandle := FadeHandleRect(Clip, TrackTop(TrackIndexAt(Y)), True); + if (FadeHandle.Right > FadeHandle.Left) and + PtInRect(FadeHandle, Point(X, Y)) then + begin + FAction := taFadeIn; + FProject.BeginChange; + FPressX := X; + FPressY := Y; + FMovedWhileDown := False; + Invalidate; + Exit; + end; + FadeHandle := FadeHandleRect(Clip, TrackTop(TrackIndexAt(Y)), False); + if (FadeHandle.Right > FadeHandle.Left) and + PtInRect(FadeHandle, Point(X, Y)) then + begin + FAction := taFadeOut; + FProject.BeginChange; + FPressX := X; + FPressY := Y; + FMovedWhileDown := False; + Invalidate; + Exit; + end; + VolHandle := VolumeHandleRect(Clip, TrackTop(TrackIndexAt(Y))); Edge := EdgeAtPoint(X, Clip); @@ -1181,7 +2009,7 @@ begin (Y >= VolHandle.Top - 3) and (Y <= VolHandle.Bottom + 3) then begin FAction := taVolume; - FDragOrigVolume := Clip.Volume; + FDragOrigVolume := ClipLevel(Clip); end else case Edge of @@ -1272,7 +2100,28 @@ begin end; taScrub: - Playhead := Max(0, XToTime(X)); + { Протяжка прилипает так же, как щелчок: иначе курсор, поставленный + на стык, соскакивал бы с него от малейшего движения мыши. } + Playhead := Max(0, SnapPlayhead(XToTime(X))); + + taDragTrack: + if (FProject <> nil) and (FDragTrackIndex >= 0) then + begin + Idx := TrackIndexAt(Y); + if (Idx >= 0) and (Idx <> FDragTrackIndex) then + begin + FProject.MoveTrack(FDragTrackIndex, Idx); + FDragTrackIndex := Idx; + FActiveTrack := Idx; + Invalidate; + end; + end; + + taRegionIn: + DragRegionEdge(X, True); + + taRegionOut: + DragRegionEdge(X, False); taVolume: if FDragClip <> nil then @@ -1280,27 +2129,55 @@ begin Idx := TrackIndexAt(FPressY); if Idx >= 0 then begin - FDragClip.Volume := YToVolume(Y, TrackTop(Idx)); + SetClipLevel(FDragClip, YToVolume(Y, TrackTop(Idx))); Invalidate; end; end; + taFadeIn: + if FDragClip <> nil then + begin + { Длина появления — от начала клипа до указателя. Длиннее самого + клипа быть не может: тогда он не успел бы появиться. } + FDragClip.FadeIn := Max(0, Min(FDragClip.Duration, + XToTime(X) - FDragClip.TlStart)); + FMovedWhileDown := True; + Invalidate; + end; + + taFadeOut: + if FDragClip <> nil then + begin + FDragClip.FadeOut := Max(0, Min(FDragClip.Duration, + FDragClip.TlEnd - XToTime(X))); + FMovedWhileDown := True; + Invalidate; + end; + taDragClip: if FDragClip <> nil then begin NewStart := SnapTime(XToTime(X) - FDragGrabOffset, FDragClip); FDragClip.TlStart := Max(0, NewStart); + { Связка едет целиком: звук должен остаться под своей картинкой. } + ApplyGroupMove(FDragClip.TlStart - FDragOrigStart); { Всё, что правее, едет на ту же величину. } if Length(FRippleClips) > 0 then ApplyRipple(FDragClip.TlStart - FDragOrigStart); { Утащили ниже последней дорожки — заводим новую, как в Vegas. За одно перетаскивание не больше одной: иначе движение мыши - вниз наплодило бы их десяток. } + вниз наплодило бы их десяток. Вид новой дорожки — по клипу: + картинку на звуковую дорожку класть незачем. } if (Idx < 0) and (FProject <> nil) and (Y > TracksBottom) and (not FTrackAddedDuringDrag) then begin - FProject.AddTrack('V' + IntToStr(FProject.TrackCount + 1)); + case TProject.TrackKindFor(FDragClip.Kind) of + tkAudio: FProject.AddTrackOfKind(FProject.UniqueTrackName('A'), tkAudio); + tkText: FProject.AddTrackOfKind(FProject.UniqueTrackName('Т'), tkText); + else + FProject.AddTrack(FProject.UniqueTrackName('V')); + end; FTrackAddedDuringDrag := True; Idx := FProject.TrackCount - 1; if Assigned(FOnTrackAdded) then @@ -1308,11 +2185,18 @@ begin end; { Перенос на другую дорожку: клип следует за указателем по - вертикали. Именно перенос, а не копирование. } + вертикали. Именно перенос, а не копирование. + + На дорожку чужого вида клип не пускаем. Уплощение обходит + дорожки по видам, и клип, попавший не на свою, пропадает и из + сборки, и из предпросмотра — молча: на монтаже он нарисован, а + в ролике его нет. Проверено на живом проекте, где фотография + оказалась на текстовой дорожке. } if (Idx >= 0) and (FProject <> nil) then begin TargetTrack := FProject.Tracks[Idx]; - if TargetTrack <> FDragTrack then + if (TargetTrack <> FDragTrack) and + (TargetTrack.Kind = TProject.TrackKindFor(FDragClip.Kind)) then begin FDragTrack.Extract(FDragClip); TargetTrack.Add(FDragClip); @@ -1419,6 +2303,39 @@ end; двигал нижние, а нижний не двигал верхние — те начинались раньше его конца и в список не попадали. От начала правило читается просто: едет всё, что начинается не раньше того, за что взялись. } +procedure TTimelineControl.CollectGroupClips(AClip: TClip); +var + T, C, N: Integer; + Clip: TClip; +begin + FGroupClips := nil; + FGroupOrigStarts := nil; + if (FProject = nil) or (AClip = nil) or (AClip.GroupId = '') then + Exit; + + N := 0; + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + begin + Clip := FProject.Tracks[T][C]; + if (Clip = AClip) or (Clip.GroupId <> AClip.GroupId) then + Continue; + SetLength(FGroupClips, N + 1); + SetLength(FGroupOrigStarts, N + 1); + FGroupClips[N] := Clip; + FGroupOrigStarts[N] := Clip.TlStart; + Inc(N); + end; +end; + +procedure TTimelineControl.ApplyGroupMove(const ADelta: Double); +var + I: Integer; +begin + for I := 0 to High(FGroupClips) do + FGroupClips[I].TlStart := Max(0, FGroupOrigStarts[I] + ADelta); +end; + procedure TTimelineControl.CollectRippleClips(ATrackIndex: Integer; AExclude: TClip; const AFromTime: Double); var @@ -1478,7 +2395,42 @@ var Clip: TClip; begin inherited MouseUp(Button, Shift, X, Y); - WasEditing := FAction in [taDragClip, taTrimIn, taTrimOut, taVolume]; + { Shift читается и здесь: курсор по щелчку ставится при отпускании, и + решение о прилипании должно быть по клавише, которую держат сейчас. } + FSnapSuspended := ssShift in Shift; + { Дорожку переставили — предпросмотр надо пересобрать: порядок дорожек + и есть порядок перекрытия. Сообщаем один раз, в конце: во время + перетаскивания дорожка проходит через все промежуточные места. } + if FAction = taDragTrack then + begin + FAction := taNone; + if (FProject <> nil) and (FDragTrackIndex <> FDragTrackFrom) then + begin + FProject.Modified := True; + StructureChanged; + end; + FDragTrackIndex := -1; + Exit; + end; + + { Отметка участка протяжкой: щелчок без движения снимает отметки — это + и есть привычный способ от них избавиться. } + if (FAction in [taRegionIn, taRegionOut]) and (FProject <> nil) then + begin + FAction := taNone; + if not FProject.HasRegion then + begin + FProject.RegionStart := 0; + FProject.RegionEnd := 0; + end; + if Assigned(FOnRegionChange) then + FOnRegionChange(Self); + Invalidate; + Exit; + end; + + WasEditing := FAction in [taDragClip, taTrimIn, taTrimOut, taVolume, + taFadeIn, taFadeOut]; WasTrimIn := FAction = taTrimIn; WasClipPress := FAction = taDragClip; Clip := FDragClip; @@ -1498,7 +2450,7 @@ begin if FProject <> nil then FProject.CancelChange; if WasClipPress then - Playhead := Max(0, XToTime(FPressX)); + Playhead := Max(0, SnapPlayhead(XToTime(FPressX))); Exit; end; @@ -1568,23 +2520,42 @@ var Clip, Tail: TClip; AnyChange: Boolean; Offset: Double; + HoverGroup: string; + { Старый номер связки — новый. Одна связка при резе становится двумя: + голова со своей парой и хвост со своей. } + NewGroups: TStringList; + Idx: Integer; begin if FProject = nil then Exit; AnyChange := False; FProject.BeginChange; + NewGroups := TStringList.Create; + try + + { Связка режется целиком. Резать только картинку, оставив звук цельным, + значит развалить пару: дальше они поедут порознь. } + HoverGroup := ''; + if AOnlyCurrentTrack and (FHoverTrack >= 0) and + (FHoverTrack < FProject.TrackCount) then + begin + Clip := FProject.Tracks[FHoverTrack].ClipAt(FPlayhead); + if Clip <> nil then + HoverGroup := Clip.GroupId; + end; for T := 0 to FProject.TrackCount - 1 do begin - if AOnlyCurrentTrack and (FHoverTrack >= 0) and (T <> FHoverTrack) then - Continue; - Track := FProject.Tracks[T]; Clip := Track.ClipAt(FPlayhead); if Clip = nil then Continue; + if AOnlyCurrentTrack and (FHoverTrack >= 0) and (T <> FHoverTrack) then + if (HoverGroup = '') or (Clip.GroupId <> HoverGroup) then + Continue; + Offset := FPlayhead - Clip.TlStart; { Рез вплотную к краю ничего не даёт, только плодит клипы нулевой длины. } if (Offset < 0.001) or (Offset > Clip.Duration - 0.001) then @@ -1593,11 +2564,37 @@ begin Tail := TClip.Create; Tail.Id := Clip.Id + '_b'; Tail.MediaId := Clip.MediaId; - Tail.Kind := Clip.Kind; Tail.SrcIn := Clip.SrcIn + Offset; Tail.TlStart := FPlayhead; Tail.Duration := Clip.Duration - Offset; Tail.EdgeOut := Clip.EdgeOut; + { Хвост — тот же клип, только вторая его половина. Всё настроенное + переходит к нему одним махом: перечислять поля по одному значит + однажды забыть новое. } + Tail.CopySettingsFrom(Clip); + { Кроме появления: оно относится к началу клипа, а начало осталось у + первой половины. } + Tail.FadeIn := 0; + + { Связка хвоста — новая. + + Оставить прежнюю значило бы связать между собой куски, которые + после реза стали разными клипами: удаление одного уносило бы и + второй, и весь исходный клип целиком. Проверено на монтаже — от + удаления куска 0..2 исчезал весь клип 0..4 вместе со звуком. + + Новый номер один на весь рез: все хвосты, отрезанные от одной + связки, остаются связанными между собой — картинка со своим + звуком. } + if Clip.GroupId = '' then + Tail.GroupId := '' + else + begin + Idx := NewGroups.IndexOfName(Clip.GroupId); + if Idx < 0 then + NewGroups.Add(Clip.GroupId + '=' + FProject.NewGroupId); + Tail.GroupId := NewGroups.Values[Clip.GroupId]; + end; { Новый рез описывается одинаково с обеих сторон: конец первой части и начало второй — это одно и то же место. } @@ -1618,6 +2615,10 @@ begin AnyChange := True; end; + finally + NewGroups.Free; + end; + if AnyChange then StructureChanged else @@ -1625,27 +2626,198 @@ begin FProject.Undo; end; +{ Расширяет выделение на всю связку: клипы, связанные с уже выделенными, + тоже считаются выделенными. Иначе удаление или перенос разорвали бы + связку пополам. } +procedure TTimelineControl.SelectWholeGroups; +var + T, C, T2, C2: Integer; + Groups: TStringList; + Clip: TClip; +begin + if FProject = nil then + Exit; + + Groups := TStringList.Create; + try + Groups.Sorted := True; + Groups.Duplicates := dupIgnore; + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + begin + Clip := FProject.Tracks[T][C]; + if Clip.Selected and (Clip.GroupId <> '') then + Groups.Add(Clip.GroupId); + end; + if Groups.Count = 0 then + Exit; + + for T2 := 0 to FProject.TrackCount - 1 do + for C2 := 0 to FProject.Tracks[T2].Count - 1 do + begin + Clip := FProject.Tracks[T2][C2]; + if (Clip.GroupId <> '') and (Groups.IndexOf(Clip.GroupId) >= 0) then + Clip.Selected := True; + end; + finally + Groups.Free; + end; +end; + +procedure TTimelineControl.ToggleGroupSelected; +var + T, C, N: Integer; + Clip: TClip; + Group: string; + AllSame: Boolean; +begin + if FProject = nil then + Exit; + + { Сначала смотрим, что выделено: если все выделенные уже в одной + связке, значит их надо развязать. } + Group := ''; + AllSame := True; + N := 0; + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + begin + Clip := FProject.Tracks[T][C]; + if not Clip.Selected then + Continue; + Inc(N); + if Group = '' then + Group := Clip.GroupId + else if Clip.GroupId <> Group then + AllSame := False; + end; + + if N < 1 then + Exit; + + FProject.BeginChange; + if AllSame and (Group <> '') then + Group := '' + else + Group := FProject.NewGroupId; + + for T := 0 to FProject.TrackCount - 1 do + for C := 0 to FProject.Tracks[T].Count - 1 do + if FProject.Tracks[T][C].Selected then + FProject.Tracks[T][C].GroupId := Group; + + StructureChanged; +end; + +{ Сдвиг всего, что правее дыры, влево до первого касания. + + Считается по всем дорожкам сразу, а не по каждой отдельно: сдвинуть + одну дорожку значило бы развалить выверенное соответствие картинки и + звука. Насколько можно сдвинуть — решает та дорожка, где запас меньше + всего: до стыка с ближайшим клипом слева от дыры. + + Дыра при этом не обязана быть пустой на всех дорожках. Клип, который её + перекрывает, никуда не едет, и запас на его дорожке считается от его + конца — так сдвиг сам собой останавливается там, где упёрся. } +procedure TTimelineControl.RippleAfterDelete(const AHoleEnd: Double; + const ATracks: TStringList); +var + T, C: Integer; + Track: TTrack; + PrevEnd, NextStart, Shift, Room: Double; + HasMoving: Boolean; +begin + if FProject = nil then + Exit; + + Shift := -1; + for T := 0 to FProject.TrackCount - 1 do + begin + if (FProject.RippleMode = rmCurrentTrack) and + (ATracks.IndexOf(IntToStr(T)) < 0) then + Continue; + + Track := FProject.Tracks[T]; + PrevEnd := 0; + NextStart := 0; + HasMoving := False; + for C := 0 to Track.Count - 1 do + if Track[C].TlStart >= AHoleEnd - 0.0005 then + begin + if (not HasMoving) or (Track[C].TlStart < NextStart) then + NextStart := Track[C].TlStart; + HasMoving := True; + end + else + PrevEnd := Max(PrevEnd, Track[C].TlEnd); + + if not HasMoving then + Continue; + + Room := NextStart - PrevEnd; + if (Shift < 0) or (Room < Shift) then + Shift := Room; + end; + + if Shift <= 0.0005 then + Exit; + + for T := 0 to FProject.TrackCount - 1 do + begin + if (FProject.RippleMode = rmCurrentTrack) and + (ATracks.IndexOf(IntToStr(T)) < 0) then + Continue; + + Track := FProject.Tracks[T]; + for C := 0 to Track.Count - 1 do + if Track[C].TlStart >= AHoleEnd - 0.0005 then + Track[C].TlStart := Track[C].TlStart - Shift; + Track.Sort; + end; +end; + procedure TTimelineControl.DeleteSelected; var T, C: Integer; Track: TTrack; AnyChange: Boolean; + HoleEnd: Double; + Touched: TStringList; begin if FProject = nil then Exit; - AnyChange := False; - FProject.BeginChange; + { Удалять надо связку целиком: половина связки — это разъехавшийся + звук, который потом не найти. } + SelectWholeGroups; - for T := 0 to FProject.TrackCount - 1 do - begin - Track := FProject.Tracks[T]; - for C := Track.Count - 1 downto 0 do - if Track[C].Selected then - begin - Track.Remove(Track[C]); - AnyChange := True; - end; + AnyChange := False; + HoleEnd := 0; + FProject.BeginChange; + Touched := TStringList.Create; + try + for T := 0 to FProject.TrackCount - 1 do + begin + Track := FProject.Tracks[T]; + for C := Track.Count - 1 downto 0 do + if Track[C].Selected then + begin + { Правый край дыры: дальше него всё поедет влево. } + HoleEnd := Max(HoleEnd, Track[C].TlEnd); + if Touched.IndexOf(IntToStr(T)) < 0 then + Touched.Add(IntToStr(T)); + Track.Remove(Track[C]); + AnyChange := True; + end; + end; + + { Схлопывание после удаления — то же самое автосхлопывание, что и при + перетаскивании: если оно выключено, дыра остаётся, и сборка потом + заполнит её чернотой. } + if AnyChange and FProject.RippleEnabled then + RippleAfterDelete(HoleEnd, Touched); + finally + Touched.Free; end; if AnyChange then @@ -1748,12 +2920,37 @@ procedure TTimelineControl.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); + { Shift со стрелками растягивает форму звука по высоте. Угадывать + нужное усиление за пользователя неправильно: запись бывает и тихой, + и на пределе. } + if (ssShift in Shift) and not (ssCtrl in Shift) then + case Key of + VK_UP: + begin + WaveGain := FWaveGain * 1.5; + Key := 0; + Exit; + end; + VK_DOWN: + begin + WaveGain := FWaveGain / 1.5; + Key := 0; + Exit; + end; + end; + case Key of VK_DELETE: begin DeleteSelected; Key := 0; end; + VK_G: + if ssCtrl in Shift then + begin + ToggleGroupSelected; + Key := 0; + end; VK_A: if ssCtrl in Shift then begin diff --git a/src/uTransform.pas b/src/uTransform.pas index bff9c7c..acddee3 100644 --- a/src/uTransform.pas +++ b/src/uTransform.pas @@ -22,7 +22,7 @@ unit uTransform; interface uses - Classes, SysUtils; + Classes, SysUtils, uAppTypes; type { Как соотносятся кадр исходника и кадр проекта. } @@ -69,6 +69,29 @@ function TransformFilter(const AT: TMediaTransform; Отсюда честное ограничение: предпросмотр показывает кадр проекта верно, но собственную настройку кадрирования файла не учитывает. Её видно в окне кадрирования и в готовом ролике. } +{ То же самое, но для наложения в плеере: цепочка без обкладывания + полями и отдельно точка, куда встанет получившаяся картинка. + + Поля и наложение — две записи одного и того же. Сборка обкладывает + картинку полями до кадра проекта, потому что кусок должен быть + самостоятельным файлом. Плееру поля не нужны и вредны: чёрное поле + закрыло бы нижнее видео. Ему нужны те же самые координаты, но как место + наложения. Считаются они одним и тем же кодом — иначе окно показывало + бы одно, а сборка давала другое. } +function OverlayFilter(const AT: TMediaTransform; + ASrcWidth, ASrcHeight, ADstWidth, ADstHeight: Integer; + out AX, AY, AWidth, AHeight: Integer): string; + +{ Фильтр цветового ключа: этот цвет становится прозрачным. + + Один на всех: и сборка, и предпросмотр должны выбивать одинаково, иначе + окно обещает одно, а готовый ролик даёт другое. Цвет записывается как + 0xRRGGBB — порядок обратный тому, в каком он хранится у нас. } +function ColorKeyFilter(AColor: TRgb; ASimilarity, ABlend: Integer): string; + +{ Фильтр приглушения по альфа-каналу. Пусто, если приглушать нечего. } +function OpacityFilter(const AOpacity: Double): string; + function PreviewFitFilter(ADstWidth, ADstHeight: Integer): string; function FitModeToStr(AMode: TFitMode): string; @@ -78,7 +101,7 @@ function FitModeCaption(AMode: TFitMode): string; implementation uses - Math, uAppTypes; + Math; function DefaultTransform: TMediaTransform; begin @@ -130,6 +153,28 @@ begin (ASrcWidth = ADstWidth) and (ASrcHeight = ADstHeight); end; +{ Дробное число через точку: у ffmpeg разделитель всегда точка, а в + русской локали Format вставил бы запятую и развалил бы всю цепочку. } +function FilterNum(const AValue: Double): string; +begin + Result := SecondsToStr(AValue); +end; + +function ColorKeyFilter(AColor: TRgb; ASimilarity, ABlend: Integer): string; +begin + Result := Format('colorkey=0x%.2x%.2x%.2x:%s:%s', + [AColor and $FF, (AColor shr 8) and $FF, (AColor shr 16) and $FF, + FilterNum(ASimilarity / 100), FilterNum(ABlend / 100)]); +end; + +function OpacityFilter(const AOpacity: Double): string; +begin + if AOpacity >= 0.999 then + Result := '' + else + Result := 'colorchannelmixer=aa=' + FilterNum(Max(0, AOpacity)); +end; + function PreviewFitFilter(ADstWidth, ADstHeight: Integer): string; var W, H: string; @@ -160,15 +205,17 @@ begin Result := 2; end; -function TransformFilter(const AT: TMediaTransform; - ASrcWidth, ASrcHeight, ADstWidth, ADstHeight: Integer): string; +{ Общая часть: цепочка до обкладывания полями и место, куда встанет + получившаяся картинка в кадре проекта. } +function BuildTransform(const AT: TMediaTransform; + ASrcWidth, ASrcHeight, ADstWidth, ADstHeight: Integer; + out AX, AY, AWidth, AHeight: Integer): string; var Chain: string; - W0, H0, Tmp: Integer; K, KFit, KFill: Double; SW, SH: Integer; CW, CH, CX, CY: Integer; - PX, PY: Integer; + PW, PH, PX, PY: Integer; Rot: Integer; procedure Add(const AFilter: string); @@ -185,32 +232,14 @@ begin Exit; Chain := ''; - W0 := ASrcWidth; - H0 := ASrcHeight; - { --- Поворот и отражение --- } - Rot := ((AT.Rotation mod 360) + 360) mod 360; - case Rot of - 90: - begin - { transpose=1 — поворот на 90 по часовой стрелке. } - Add('transpose=1'); - Tmp := W0; W0 := H0; H0 := Tmp; - end; - 180: - { Два поворота подряд дешевле и точнее, чем поворот на произвольный - угол: последний пересчитывает каждый пиксель. } - Add('transpose=1,transpose=1'); - 270: - begin - Add('transpose=2'); - Tmp := W0; W0 := H0; H0 := Tmp; - end; - end; - if AT.FlipH then - Add('hflip'); - if AT.FlipV then - Add('vflip'); + { Порядок действий: сначала выбирается кусок кадра, и только потом он + поворачивается и отражается. + + Так это устроено в монтажных программах, и так понятнее: рамка + показывает, что́ останется, а поворот применяется к оставшемуся. При + обратном порядке обрезался бы уже перевёрнутый кадр, и в рамку + попадало бы совсем не то, что видно. } { --- Масштаб --- } if AT.Fit = fmStretch then @@ -220,16 +249,16 @@ begin end else begin - KFit := Min(ADstWidth / W0, ADstHeight / H0); - KFill := Max(ADstWidth / W0, ADstHeight / H0); + KFit := Min(ADstWidth / ASrcWidth, ADstHeight / ASrcHeight); + KFill := Max(ADstWidth / ASrcWidth, ADstHeight / ASrcHeight); if AT.Fit = fmFill then K := KFill else K := KFit; if AT.Zoom > 0 then K := K * AT.Zoom; - SW := MakeEven(Round(W0 * K)); - SH := MakeEven(Round(H0 * K)); + SW := MakeEven(Round(ASrcWidth * K)); + SH := MakeEven(Round(ASrcHeight * K)); end; Add(Format('scale=%d:%d', [SW, SH])); @@ -247,20 +276,91 @@ begin Add(Format('crop=%d:%d:%d:%d', [CW, CH, CX, CY])); end; - { --- Поля, если картинка меньше кадра --- } - if (CW < ADstWidth) or (CH < ADstHeight) then + { --- Поворот и отражение оставшегося куска --- } + Rot := ((AT.Rotation mod 360) + 360) mod 360; + case Rot of + 90: + begin + { transpose=1 — поворот на 90 по часовой стрелке. } + Add('transpose=1'); + PW := CH; PH := CW; + end; + 180: + begin + { Два поворота подряд дешевле и точнее, чем поворот на + произвольный угол: последний пересчитывает каждый пиксель. } + Add('transpose=1,transpose=1'); + PW := CW; PH := CH; + end; + 270: + begin + Add('transpose=2'); + PW := CH; PH := CW; + end; + else + PW := CW; PH := CH; + end; + if AT.FlipH then + Add('hflip'); + if AT.FlipV then + Add('vflip'); + + { --- Приведение к кадру проекта --- } + + { После поворота на 90 кусок лежит поперёк и в кадр проекта уже не + вписывается. Вписываем целиком, с полями. } + if (PW > ADstWidth) or (PH > ADstHeight) then begin - PX := Round((ADstWidth - CW) / 2 + AT.OffsetX * ADstWidth); - PY := Round((ADstHeight - CH) / 2 + AT.OffsetY * ADstHeight); - PX := Max(0, Min(ADstWidth - CW, PX)); - PY := Max(0, Min(ADstHeight - CH, PY)); - Add(Format('pad=%d:%d:%d:%d', [ADstWidth, ADstHeight, PX, PY])); + K := Min(ADstWidth / PW, ADstHeight / PH); + PW := MakeEven(Round(PW * K)); + PH := MakeEven(Round(PH * K)); + Add(Format('scale=%d:%d', [PW, PH])); end; - { Пиксель считаем квадратным: иначе плеер растянет кадр по своему - разумению, и результат разойдётся с тем, что видно в предпросмотре. } - Add('setsar=1'); + { Смещение двигает картинку и там, где её не обрезали. Когда картинка + больше кадра, двигать можно лишь окно, через которое на неё смотрят, + — это делает crop выше. Когда она меньше, двигать надо её саму по + полю, иначе уменьшенный кадр навсегда прибит к середине и в угол его + не отправить. Обе стороны считают смещение в долях кадра проекта, так + что число значит одно и то же. } + PX := (ADstWidth - PW) div 2 + Round(AT.OffsetX * ADstWidth); + PY := (ADstHeight - PH) div 2 + Round(AT.OffsetY * ADstHeight); + PX := Max(0, Min(Max(0, ADstWidth - PW), PX)); + PY := Max(0, Min(Max(0, ADstHeight - PH), PY)); + + AX := PX; + AY := PY; + AWidth := PW; + AHeight := PH; Result := Chain; end; +function TransformFilter(const AT: TMediaTransform; + ASrcWidth, ASrcHeight, ADstWidth, ADstHeight: Integer): string; +var + X, Y, W, H: Integer; +begin + Result := BuildTransform(AT, ASrcWidth, ASrcHeight, ADstWidth, ADstHeight, + X, Y, W, H); + if Result = '' then + Exit; + + if (W < ADstWidth) or (H < ADstHeight) then + Result := Result + Format(',pad=%d:%d:%d:%d', [ADstWidth, ADstHeight, X, Y]); + + { Пиксель считаем квадратным: иначе плеер растянет кадр по своему + разумению, и результат разойдётся с тем, что видно в предпросмотре. } + Result := Result + ',setsar=1'; +end; + +function OverlayFilter(const AT: TMediaTransform; + ASrcWidth, ASrcHeight, ADstWidth, ADstHeight: Integer; + out AX, AY, AWidth, AHeight: Integer): string; +begin + Result := BuildTransform(AT, ASrcWidth, ASrcHeight, ADstWidth, ADstHeight, + AX, AY, AWidth, AHeight); + if Result <> '' then + Result := Result + ',setsar=1'; +end; + end. diff --git a/src/uWaveform.pas b/src/uWaveform.pas new file mode 100644 index 0000000..154eda7 --- /dev/null +++ b/src/uWaveform.pas @@ -0,0 +1,396 @@ +{ + uWaveform — форма звука для отрисовки на клипах. + + Что считается. Для каждого файла один раз строится список пиков: сто + значений в секунду, каждое — наибольший модуль отсчёта за свои десять + миллисекунд. Часовая запись даёт 360 тысяч байт, это ничто. + + Почему не полная звуковая дорожка. Рисовать по настоящим отсчётам + нельзя: в секунде их 48 тысяч, а в клипе на экране — сотни пикселей. + Пришлось бы каждый раз перечитывать файл целиком. + + Почему через временный файл, а не по трубе. Запуск внешних программ у + нас режет вывод на строки, а тут поток байтов, где перевод строки — + такой же отсчёт, как любой другой. Временный файл на четырнадцать + мегабайт для часовой записи проще и надёжнее, чем отдельный двоичный + путь чтения. + + Считается в отдельном потоке: список файлов должен работать, пока звук + разбирается. +} +unit uWaveform; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, uProcRunner; + +const + { Пиков в секунду. Сто — это десять миллисекунд на пик: мельче глазу + всё равно не видно, а крупнее уже теряются короткие звуки. } + PeaksPerSecond = 100; + + { Частота, на которой разбирается звук. Восьми килогерц хватает, чтобы + отличить тишину от звука, а объём вчетверо меньше исходного. } + DecodeRate = 8000; + +type + TPeaks = record + Valid: Boolean; + Rate: Integer; + { Наибольший модуль отсчёта за интервал, приведённый к 0..255. } + Data: array of Byte; + end; + +{ Путь к файлу пиков в кэше проекта. } +function PeaksPath(const ACacheDir, ASourcePath: string): string; + +{ Разбирает звук файла и записывает пики. Долгая операция, вызывать из + рабочего потока. } +function BuildPeaks(const ASourcePath, ATargetPath: string; + ACancel: TProcCancelQuery; out AError: string): Boolean; + +{ Читает готовые пики. } +function LoadPeaks(const APath: string; out APeaks: TPeaks): Boolean; + +{ Пики файла с запоминанием в памяти. Если их ещё нет на диске, вернёт + False — считать надо отдельно, в потоке. } +function CachedPeaks(const ACacheDir, ASourcePath: string; + out APeaks: TPeaks): Boolean; + +{ Забыть запомненное. Нужно при закрытии проекта: следующий проект живёт + в другом кэше. } +procedure ForgetPeaks; + +type + TPeaksRequest = record + SourcePath: string; + TargetPath: string; + end; + + TPeaksRequests = array of TPeaksRequest; + + TPeaksReadyEvent = procedure(Sender: TObject; + const ASourcePath: string) of object; + + TPeaksThread = class(TThread) + private + FRequests: TPeaksRequests; + FCurrent: Integer; + FDone: Integer; + FOnReady: TPeaksReadyEvent; + procedure SyncReady; + function CancelQuery: Boolean; + protected + procedure Execute; override; + public + constructor Create(const ARequests: TPeaksRequests); + property OnReady: TPeaksReadyEvent read FOnReady write FOnReady; + { Сколько всего файлов в очереди и сколько уже разобрано. Читаются из + главного потока для показа хода работы; целое читается и пишется + одним действием, поэтому замок здесь не нужен. } + function Total: Integer; + property Done: Integer read FDone; + end; + +implementation + +uses + md5, uFfmpegCmd; + +const + { Заголовок файла пиков: подпись и номер вида. Номер понадобится, если + когда-нибудь поменяется частота или формат. } + PeaksMagic = 'NLVW'; + PeaksVersion = 1; + + { Сколько отсчётов приходится на один пик. } + SamplesPerPeak = DecodeRate div PeaksPerSecond; + + ReadChunk = 64 * 1024; + +type + TPeaksCacheItem = class + Peaks: TPeaks; + end; + +var + { Запомненные пики: путь к исходнику — объект с данными. } + FCache: TStringList = nil; + +function PeaksPath(const ACacheDir, ASourcePath: string): string; +begin + Result := IncludeTrailingPathDelimiter(ACacheDir) + 'peaks' + PathDelim + + MD5Print(MD5String(ASourcePath)) + '.pk'; +end; + +function BuildPeaks(const ASourcePath, ATargetPath: string; + ACancel: TProcCancelQuery; out AError: string): Boolean; +var + RawPath: string; + Res: TProcResult; + Src: TFileStream; + Dst: TFileStream; + Buffer: array[0..ReadChunk - 1] of SmallInt; + Got, I, Count: Integer; + Acc, Peak: Integer; + InPeak: Integer; + Peaks: array of Byte; + PeakCount: Integer; + Rate: Integer; + V: SmallInt; + + procedure PushPeak(AValue: Integer); + begin + if PeakCount >= Length(Peaks) then + SetLength(Peaks, Length(Peaks) * 2 + 1024); + { Отсчёт занимает 15 бит со знаком, а в байте помещается 8. Делим на + 129, а не на 128: иначе полная амплитуда дала бы 256. } + Peaks[PeakCount] := AValue div 129; + Inc(PeakCount); + end; + +begin + Result := False; + AError := ''; + Rate := PeaksPerSecond; + + if not ForceDirectories(ExtractFilePath(ATargetPath)) then + begin + AError := 'Не удалось создать каталог для пиков.'; + Exit; + end; + + RawPath := ATargetPath + '.raw'; + + { Один звуковой поток, одна дорожка, восемь килогерц. Видео отбрасываем + целиком: оно здесь только мешает и тратит время. } + Res := RunProcess(FfmpegExe, + ['-hide_banner', '-nostdin', '-loglevel', 'error', '-y', + '-i', ASourcePath, '-vn', '-map', '0:a:0', + '-ac', '1', '-ar', IntToStr(DecodeRate), + '-f', 's16le', RawPath], + nil, nil, ACancel); + + if not Res.Started then + begin + AError := 'Не удалось запустить ffmpeg: ' + Res.ErrorText; + Exit; + end; + if Res.Cancelled then + begin + SysUtils.DeleteFile(RawPath); + Exit; + end; + if (Res.ExitCode <> 0) or (not FileExists(RawPath)) then + begin + { Обычная причина — в файле нет звука. Это не беда, просто рисовать + нечего. } + AError := 'Звук не разобран (код ' + IntToStr(Res.ExitCode) + ').'; + SysUtils.DeleteFile(RawPath); + Exit; + end; + + Peaks := nil; + PeakCount := 0; + InPeak := 0; + Peak := 0; + + try + Src := TFileStream.Create(RawPath, fmOpenRead or fmShareDenyNone); + try + repeat + Got := Src.Read(Buffer, SizeOf(Buffer)) div SizeOf(SmallInt); + if Got <= 0 then + Break; + for I := 0 to Got - 1 do + begin + V := Buffer[I]; + if V < 0 then + Acc := -Integer(V) + else + Acc := V; + if Acc > Peak then + Peak := Acc; + Inc(InPeak); + if InPeak >= SamplesPerPeak then + begin + PushPeak(Peak); + Peak := 0; + InPeak := 0; + end; + end; + until False; + + { Хвост короче полного интервала тоже показываем. } + if InPeak > 0 then + PushPeak(Peak); + finally + Src.Free; + end; + + Dst := TFileStream.Create(ATargetPath, fmCreate); + try + Dst.WriteBuffer(PeaksMagic[1], 4); + Count := PeaksVersion; + Dst.WriteBuffer(Count, SizeOf(Count)); + Dst.WriteBuffer(Rate, SizeOf(Rate)); + Dst.WriteBuffer(PeakCount, SizeOf(PeakCount)); + if PeakCount > 0 then + Dst.WriteBuffer(Peaks[0], PeakCount); + finally + Dst.Free; + end; + + Result := True; + except + on E: Exception do + AError := E.Message; + end; + + SysUtils.DeleteFile(RawPath); +end; + +function LoadPeaks(const APath: string; out APeaks: TPeaks): Boolean; +var + Src: TFileStream; + Sig: array[0..3] of AnsiChar; + Version, Rate, Count: Integer; +begin + Result := False; + APeaks := Default(TPeaks); + if not FileExists(APath) then + Exit; + + try + Src := TFileStream.Create(APath, fmOpenRead or fmShareDenyNone); + try + if Src.Size < 16 then + Exit; + Src.ReadBuffer(Sig, 4); + if (Sig[0] <> 'N') or (Sig[1] <> 'L') or (Sig[2] <> 'V') or + (Sig[3] <> 'W') then + Exit; + Src.ReadBuffer(Version, SizeOf(Version)); + if Version <> PeaksVersion then + Exit; + Src.ReadBuffer(Rate, SizeOf(Rate)); + Src.ReadBuffer(Count, SizeOf(Count)); + if (Count < 0) or (Count > Src.Size - Src.Position) then + Exit; + + SetLength(APeaks.Data, Count); + if Count > 0 then + Src.ReadBuffer(APeaks.Data[0], Count); + APeaks.Rate := Rate; + APeaks.Valid := True; + Result := True; + finally + Src.Free; + end; + except + { Испорченный кэш — не беда: осциллограммы просто не будет. } + APeaks := Default(TPeaks); + Result := False; + end; +end; + +function CachedPeaks(const ACacheDir, ASourcePath: string; + out APeaks: TPeaks): Boolean; +var + Idx: Integer; + Item: TPeaksCacheItem; + Path: string; +begin + APeaks := Default(TPeaks); + if FCache = nil then + begin + FCache := TStringList.Create; + FCache.Sorted := True; + FCache.OwnsObjects := True; + end; + + Idx := FCache.IndexOf(ASourcePath); + if Idx >= 0 then + begin + APeaks := TPeaksCacheItem(FCache.Objects[Idx]).Peaks; + Exit(APeaks.Valid); + end; + + Path := PeaksPath(ACacheDir, ASourcePath); + Item := TPeaksCacheItem.Create; + { Неудачу тоже запоминаем: иначе при каждой отрисовке мы бы стучались + на диск за файлом, которого нет. } + LoadPeaks(Path, Item.Peaks); + FCache.AddObject(ASourcePath, Item); + APeaks := Item.Peaks; + Result := APeaks.Valid; +end; + +procedure ForgetPeaks; +begin + FreeAndNil(FCache); +end; + +{ TPeaksThread } + +constructor TPeaksThread.Create(const ARequests: TPeaksRequests); +var + I: Integer; +begin + inherited Create(True); + { Освобождает поток окно, а не он сам: окно обращается к нему и после + завершения, чтобы понять, надо ли начинать заново. } + FreeOnTerminate := False; + FDone := 0; + SetLength(FRequests, Length(ARequests)); + for I := 0 to High(ARequests) do + FRequests[I] := ARequests[I]; +end; + +function TPeaksThread.Total: Integer; +begin + Result := Length(FRequests); +end; + +function TPeaksThread.CancelQuery: Boolean; +begin + Result := Terminated; +end; + +procedure TPeaksThread.SyncReady; +begin + if Assigned(FOnReady) and (FCurrent >= 0) and + (FCurrent <= High(FRequests)) then + FOnReady(Self, FRequests[FCurrent].SourcePath); +end; + +procedure TPeaksThread.Execute; +var + I: Integer; + Err: string; +begin + for I := 0 to High(FRequests) do + begin + if Terminated then + Break; + FCurrent := I; + if FileExists(FRequests[I].TargetPath) then + begin + Synchronize(@SyncReady); + FDone := I + 1; + Continue; + end; + if BuildPeaks(FRequests[I].SourcePath, FRequests[I].TargetPath, + @CancelQuery, Err) then + Synchronize(@SyncReady); + FDone := I + 1; + end; +end; + +finalization + FreeAndNil(FCache); + +end. diff --git a/tests/lfmcheck/lfmcheck.lpi b/tests/lfmcheck/lfmcheck.lpi new file mode 100644 index 0000000..705b2ff --- /dev/null +++ b/tests/lfmcheck/lfmcheck.lpi @@ -0,0 +1,37 @@ + + + + + + + + + + + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="1"> + <Unit0> + <Filename Value="lfmcheck.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="lfmcheck"/> + </Target> + <SearchPaths> + <OtherUnitFiles Value="../../src"/> + <UnitOutputDirectory Value="units"/> + </SearchPaths> + </CompilerOptions> +</CONFIG> diff --git a/tests/lfmcheck/lfmcheck.lpr b/tests/lfmcheck/lfmcheck.lpr new file mode 100644 index 0000000..31ce56f --- /dev/null +++ b/tests/lfmcheck/lfmcheck.lpr @@ -0,0 +1,287 @@ +{ + Проверка того, что свойства, записанные в файле формы, у наших + элементов действительно есть. + + Зачем отдельно. Файл формы разбирается при запуске, а не при сборке: + опечатка в имени свойства или в значении перечисления даёт не ошибку + компиляции, а падение окна на старте. Здесь то же самое проверяется без + окна — по сведениям о типах. +} +program lfmcheck; + +{$mode objfpc}{$H+} + +uses + { Interfaces нужен, чтобы связалась вся LCL и заработала загрузка + файлов форм. } + Interfaces, Forms, Classes, SysUtils, Math, TypInfo, uTheme, + uMediaProbe, uProject, uTransform, uTimelineCtrl, + uPanCropForm, uDepsForm, uMismatchForm, uProgressForm, uProjectInfoForm, + uRemuxForm; + +var + Failed: Integer = 0; + +procedure CheckProp(AClass: TClass; const AName: string); +begin + if GetPropInfo(AClass, AName) <> nil then + WriteLn(' ok ', AClass.ClassName, '.', AName) + else + begin + WriteLn(' ПЛОХО ', AClass.ClassName, '.', AName, ' — свойства нет'); + Inc(Failed); + end; +end; + +procedure CheckEnum(ATypeInfo: PTypeInfo; const AName: string); +begin + if GetEnumValue(ATypeInfo, AName) >= 0 then + WriteLn(' ok значение ', AName) + else + begin + WriteLn(' ПЛОХО значение ', AName, ' — такого нет'); + Inc(Failed); + end; +end; + +{ Создаёт окно и тут же убирает. + + Смысл в самом создании: файл формы разбирается именно тогда. Элемент, + который есть в файле формы и которого нет в классе, или обработчик с + опечаткой в имени — всё это здесь и вскрывается, а иначе вскрылось бы у + человека при открытии окна. + + Главное окно не проверяется: оно при создании читает настройки, строит + меню и заводит плеер — это уже не проверка формы, а запуск программы. } +procedure CheckForm(AClass: TFormClass); +var + F: TForm; +begin + try + F := AClass.Create(nil); + try + WriteLn(' ok ', AClass.ClassName, ' — форма загружена'); + finally + F.Free; + end; + except + on E: Exception do + begin + WriteLn(' ПЛОХО ', AClass.ClassName, ': ', E.Message); + Inc(Failed); + end; + end; +end; + +procedure CheckTrue(const AName: string; AValue: Boolean); +begin + if AValue then + WriteLn(' ok ', AName) + else + begin + WriteLn(' ПЛОХО ', AName); + Inc(Failed); + end; +end; + +{ Прилипание курсора воспроизведения к границам клипов. + + Проверяется числами, а не мышью: расчёт открыт наружу именно ради + этого. Мышью пришлось бы поднимать окно, а окно в проверках — это уже + не проверка расчёта, а проверка окружения. } +procedure CheckPlayheadSnap; +var + Proj: TProject; + Info: TMediaInfo; + Media: TMediaItem; + Timeline: TTimelineControl; +begin + WriteLn; + WriteLn('Прилипание курсора к границам клипов'); + WriteLn; + + Info := Default(TMediaInfo); + Info.Valid := True; + Info.Kind := mkVideo; + Info.Duration := 600; + Info.HasVideo := True; + Info.VideoCodec := 'hevc'; + Info.Width := 1920; + Info.Height := 1080; + Info.FpsNum := 30; + Info.FpsDen := 1; + Info.PixFmt := 'yuv420p'; + + Proj := TProject.Create; + Timeline := TTimelineControl.Create(nil); + try + Proj.Clear; + Proj.AddTrack('V1'); + Media := Proj.AddMedia('/несуществующий/видео.mp4', Info); + { Два куска встык: границы на 0, 1.5 и 3. } + Proj.AddClip(Proj.Tracks[0], Media, 0, 1.5, 0); + Proj.AddClip(Proj.Tracks[0], Media, 10, 1.5, 1.5); + + Timeline.Project := Proj; + { Сто точек в секунду: порог прилипания в восемь точек — это 0.08 с. } + Timeline.PixelsPerSecond := 100; + Timeline.PlayheadSnap := True; + + CheckTrue('стык рядом — притянуло', + Abs(Timeline.SnapPlayhead(1.53) - 1.5) < 0.0001); + CheckTrue('с другой стороны — тоже', + Abs(Timeline.SnapPlayhead(1.47) - 1.5) < 0.0001); + CheckTrue('далеко от границ — не тронуло', + Abs(Timeline.SnapPlayhead(0.7) - 0.7) < 0.0001); + CheckTrue('начало монтажа притягивает', + Abs(Timeline.SnapPlayhead(0.05)) < 0.0001); + CheckTrue('конец последнего клипа притягивает', + Abs(Timeline.SnapPlayhead(2.96) - 3) < 0.0001); + + { На мелком масштабе порог в точках даёт больший запас по времени. } + Timeline.PixelsPerSecond := 10; + CheckTrue('масштаб мельче — притягивает дальше', + Abs(Timeline.SnapPlayhead(1.7) - 1.5) < 0.0001); + + Timeline.PixelsPerSecond := 100; + Timeline.PlayheadSnap := False; + CheckTrue('выключено — не притягивает', + Abs(Timeline.SnapPlayhead(1.53) - 1.53) < 0.0001); + finally + Timeline.Free; + Proj.Free; + end; +end; + +{ Рез не должен терять настройки клипа. + + Половина клипа после реза — тот же клип, и цветовой ключ, кадрирование, + прозрачность, громкость и текст должны остаться при обеих половинах. + Однажды не остались: у хвоста пропадал ключ, клип переставал быть + наложением и закрывал собой всё, что под ним. } +procedure CheckSplitKeepsSettings; +var + Proj: TProject; + Info: TMediaInfo; + Media: TMediaItem; + Timeline: TTimelineControl; + Head, Tail, Cl: TClip; + Key: TColorKey; + Tr: TMediaTransform; + I: Integer; +begin + WriteLn; + WriteLn('Рез сохраняет настройки клипа'); + WriteLn; + + Info := Default(TMediaInfo); + Info.Valid := True; + Info.Kind := mkVideo; + Info.Duration := 600; + Info.HasVideo := True; + Info.VideoCodec := 'hevc'; + Info.Width := 1920; + Info.Height := 1080; + Info.FpsNum := 30; + Info.FpsDen := 1; + Info.PixFmt := 'yuv420p'; + + Proj := TProject.Create; + Timeline := TTimelineControl.Create(nil); + try + Proj.Clear; + Proj.AddTrack('V1'); + Media := Proj.AddMedia('/несуществующий/видео.mp4', Info); + Cl := Proj.AddClip(Proj.Tracks[0], Media, 0, 10, 0); + + Key := DefaultColorKey; + Key.Enabled := True; + Key.Similarity := 22; + Cl.ColorKey := Key; + Cl.Opacity := 0.5; + Cl.Volume := 0.3; + Tr := Cl.Transform; + Tr.Zoom := 0.4; + Tr.OffsetX := 0.7; + Cl.Transform := Tr; + Cl.GroupId := 'g1'; + + Timeline.Project := Proj; + Timeline.PixelsPerSecond := 100; + Timeline.Playhead := 4; + Timeline.SplitAtPlayhead(False, False); + + CheckTrue('клипов стало два', Proj.Tracks[0].Count = 2); + if Proj.Tracks[0].Count <> 2 then + Exit; + + Head := nil; + Tail := nil; + for I := 0 to Proj.Tracks[0].Count - 1 do + if Proj.Tracks[0][I].TlStart < 0.001 then + Head := Proj.Tracks[0][I] + else + Tail := Proj.Tracks[0][I]; + CheckTrue('обе половины нашлись', (Head <> nil) and (Tail <> nil)); + if (Head = nil) or (Tail = nil) then + Exit; + + CheckTrue('ключ остался у хвоста', Tail.ColorKey.Enabled); + CheckTrue('и с тем же цветом', Tail.ColorKey.Color = Key.Color); + CheckTrue('и с тем же допуском', Tail.ColorKey.Similarity = 22); + CheckTrue('прозрачность осталась', Abs(Tail.Opacity - 0.5) < 0.001); + CheckTrue('громкость осталась', Abs(Tail.Volume - 0.3) < 0.001); + CheckTrue('кадрирование осталось', + (Abs(Tail.Transform.Zoom - 0.4) < 0.001) and + (Abs(Tail.Transform.OffsetX - 0.7) < 0.001)); + CheckTrue('ключ остался и у головы', Head.ColorKey.Enabled); + { Связки разные, и обе не пустые: иначе удаление одной половины + уносило бы вторую. } + CheckTrue('связка у половин разная и не пустая', + (Head.GroupId <> Tail.GroupId) and (Head.GroupId <> '') and + (Tail.GroupId <> '')); + CheckTrue('появление у хвоста снято', Abs(Tail.FadeIn) < 0.001); + finally + Timeline.Free; + Proj.Free; + end; +end; + +begin + WriteLn('Свойства из файлов форм'); + WriteLn; + + CheckProp(TThemedButton, 'Icon'); + CheckProp(TThemedButton, 'Down'); + CheckProp(TThemedButton, 'Arrow'); + CheckProp(TThemedButton, 'Caption'); + CheckProp(TThemedButton, 'ShowHint'); + + CheckEnum(TypeInfo(TThemedIcon), 'tiSnap'); + CheckEnum(TypeInfo(TThemedIcon), 'tiRipple'); + CheckEnum(TypeInfo(TThemedIcon), 'tiLog'); + CheckEnum(TypeInfo(TThemedIcon), 'tiNone'); + + WriteLn; + WriteLn('Загрузка файлов форм'); + WriteLn; + Application.Initialize; + CheckForm(TPanCropForm); + CheckForm(TDepsForm); + CheckForm(TMismatchForm); + CheckForm(TProgressForm); + CheckForm(TProjectInfoForm); + CheckForm(TRemuxForm); + + CheckPlayheadSnap; + CheckSplitKeepsSettings; + + WriteLn; + if Failed = 0 then + WriteLn('ВЕРДИКТ: все проверки пройдены') + else + begin + WriteLn('ВЕРДИКТ: не пройдено проверок: ', Failed); + Halt(1); + end; +end. diff --git a/tests/nlvetool.lpr b/tests/nlvetool.lpr index 28d0f5e..b886838 100644 --- a/tests/nlvetool.lpr +++ b/tests/nlvetool.lpr @@ -23,6 +23,16 @@ render <проект.nlve> <выход> уплотить проект, создать вставки, собрать ролик и сверить число кадров + subs <проект.nlve> + собрать разметку субтитров из текстовых клипов + и напечатать её + preview <проект.nlve> + собрать список кусков так же, как это делает + предпросмотр: с готовыми наложениями вместо + участков с прозрачностью и переходами + audio <проект.nlve> + разложить звуковые дорожки проекта на куски и + напечатать их вместе со строками edl:// buildcut <проект.nlve> <видео> проект из одного файла с точным резом в заведомо неопорной точке @@ -37,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, uTransform; procedure PrintUsage; begin @@ -306,8 +316,9 @@ begin WriteLn('остановка через: ', SecondsToStr(CancelAfter), ' с'); WriteLn; - Thread := TExportThread.Create(Segments, ParamStr(FirstArg - 1), True, - Default(TMediaInfo)); + { Проверка вырезания и склейки картинки: звук здесь не собирается. } + Thread := TExportThread.Create(Segments, nil, ParamStr(FirstArg - 1), True, + Default(TMediaInfo), Default(TEncodeProfile)); Watcher := TExportWatcher.Create(Thread); try Thread.OnProgress := @Watcher.Progress; @@ -550,8 +561,12 @@ procedure CmdFlatTest; var Proj: TProject; Media: TMediaItem; - Segs: TFlatSegmentArray; + Segs, AudioSegs: TFlatSegmentArray; + Overlays: TPreviewOverlays; Missing: TGenRequests; + Clip: TClip; + Key: TColorKey; + Tr: TMediaTransform; TempFile, Err: string; begin WriteLn('Проверка уплощения монтажа'); @@ -563,7 +578,7 @@ begin try Proj.AddClip(Proj.Tracks[0], Media, 10, 5, 0); Proj.AddClip(Proj.Tracks[0], Media, 15, 5, 5); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 1, 'склеились в один кусок'); if Length(Segs) = 1 then @@ -582,7 +597,7 @@ begin try Proj.AddClip(Proj.Tracks[0], Media, 100, 5, 0); Proj.AddClip(Proj.Tracks[0], Media, 200, 5, 5); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 2, 'остались двумя кусками'); finally @@ -597,7 +612,7 @@ begin { Дорожка 0 — верхняя, она побеждает. } Proj.AddClip(Proj.Tracks[1], Media, 0, 30, 0); Proj.AddClip(Proj.Tracks[0], Media, 100, 10, 10); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 3, 'получилось три куска'); if Length(Segs) = 3 then @@ -621,7 +636,7 @@ begin try Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 3); Proj.AddClip(Proj.Tracks[0], Media, 50, 5, 12); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 4, 'четыре куска: чёрное, видео, чёрное, видео'); if Length(Segs) = 4 then @@ -651,7 +666,7 @@ begin try Proj.AddClip(Proj.Tracks[1], Media, 0, 10, 0); Proj.AddClip(Proj.Tracks[0], Media, 200, 10, 0); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 1, 'остался один кусок'); if Length(Segs) = 1 then @@ -668,7 +683,7 @@ begin Proj.AddClip(Proj.Tracks[1], Media, 0, 10, 0); Proj.AddClip(Proj.Tracks[0], Media, 200, 10, 0); Proj.Tracks[0].Muted := True; - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 1, 'остался один кусок'); if Length(Segs) = 1 then @@ -688,7 +703,7 @@ begin Proj.Tracks[0][0].EdgeIn := edPrecise; Proj.RippleMode := rmAllTracks; Proj.RippleEnabled := True; - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); Check(Length(Segs) = 3, 'до записи три куска'); Check(Proj.SaveToFile(TempFile, Err), 'записан: ' + Err); finally @@ -698,13 +713,17 @@ begin Proj := TProject.Create; try Check(Proj.LoadFromFile(TempFile, Err), 'прочитан: ' + Err); - Check(Proj.TrackCount = 2, 'дорожек снова две'); + { Четыре: две картинки и две звука. Звуковые заводятся сразу, чтобы + каждому клипу картинки было куда положить парный звук. } + Check(Proj.TrackCount = 4, 'дорожек снова четыре'); + Check(Proj.TrackCountOf(tkVideo) = 2, 'из них две для картинки'); + Check(Proj.TrackCountOf(tkAudio) = 2, 'и две для звука'); Check(Proj.PoolCount = 1, 'файл в списке один'); Check(Proj.RippleMode = rmAllTracks, 'режим схлопывания сохранился'); Check(Proj.RippleEnabled, 'состояние схлопывания сохранилось'); if Proj.TrackCount = 2 then Check(Proj.Tracks[0][0].EdgeIn = edPrecise, 'признак точного реза сохранился'); - FlattenProject(Proj, Segs, Missing); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); DumpSegments(Segs); Check(Length(Segs) = 3, 'после чтения снова три куска'); if Length(Segs) = 3 then @@ -715,6 +734,185 @@ begin DeleteFile(TempFile); WriteLn; + { --- 8. Оверлей в предпросмотре не закрывает нижний клип --- } + WriteLn(' 8. Клип с ключом поверх: основа и оверлей врозь'); + Proj := MakeProject(2, Media); + try + Proj.Master := Media.Info; + { Нижняя дорожка — обычный кусок, верхняя — тот же файл с выбитым + цветом во всю длину. Так выглядит компас или карта поверх ролика. } + Proj.AddClip(Proj.Tracks[1], Media, 0, 10, 0); + Clip := Proj.AddClip(Proj.Tracks[0], Media, 100, 10, 0); + Key := DefaultColorKey; + Key.Enabled := True; + Clip.ColorKey := Key; + Tr := Clip.Transform; + Tr.Zoom := 0.5; + Clip.Transform := Tr; + + { Обычное уплощение: побеждает верхний, нижнего не видно. } + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + Check(Length(Segs) = 1, 'при сборке кусок один'); + if Length(Segs) = 1 then + Check(Abs(Segs[0].SrcStart - 100) < 0.001, 'и это верхний клип'); + + { Уплощение для предпросмотра: верхний ушёл в оверлей. } + Check(FlattenPreview(Proj, Segs, AudioSegs, Overlays, Missing), + 'уплощение для предпросмотра прошло'); + DumpSegments(Segs); + Check(Length(Segs) = 1, 'основа из одного куска'); + if Length(Segs) = 1 then + Check(Abs(Segs[0].SrcStart - 0) < 0.001, 'в основе виден нижний клип'); + Check(Length(Overlays) = 1, 'оверлей один'); + if Length(Overlays) = 1 then + begin + Check(Abs(Overlays[0].TlStart) < 0.001, 'оверлей с начала'); + Check(Abs(Overlays[0].TlEnd - 10) < 0.001, 'и до конца'); + Check(Abs(Overlays[0].SrcStart - 100) < 0.001, 'берётся с 100 с'); + Check((Overlays[0].Width = 960) and (Overlays[0].Height = 540), + 'уменьшен вдвое: ' + IntToStr(Overlays[0].Width) + 'x' + + IntToStr(Overlays[0].Height)); + Check((Overlays[0].X = 480) and (Overlays[0].Y = 270), + 'и стоит в середине кадра: ' + IntToStr(Overlays[0].X) + ':' + + IntToStr(Overlays[0].Y)); + end; + finally + Proj.Free; + end; + WriteLn; + + { --- 9. Обрезка списка кусков по отмеченному участку --- } + WriteLn(' 9. Сборка только отмеченного участка'); + Proj := MakeProject(1, Media); + try + { Три куска по 5 секунд из разных мест файла: склеиться в один они не + могут, и границы участка приходятся на середину крайних. } + Proj.AddClip(Proj.Tracks[0], Media, 100, 5, 0); + Proj.AddClip(Proj.Tracks[0], Media, 200, 5, 5); + Proj.AddClip(Proj.Tracks[0], Media, 300, 5, 10); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + Check(Length(Segs) = 3, 'до обрезки три куска'); + + Check(Abs(ClipSegmentsToRange(Segs, 2, 12) - 10) < 0.001, + 'осталось десять секунд'); + DumpSegments(Segs); + Check(Length(Segs) = 3, 'куски остались все три'); + if Length(Segs) = 3 then + begin + Check(Abs(Segs[0].SrcStart - 102) < 0.001, + 'первый начинается на две секунды позже'); + Check(Abs(Segs[0].Duration - 3) < 0.001, 'и длится три секунды'); + Check(Abs(Segs[1].SrcStart - 200) < 0.001, 'средний не тронут'); + Check(Abs(Segs[1].Duration - 5) < 0.001, 'и целиком'); + Check(Abs(Segs[2].SrcStart - 300) < 0.001, 'последний с начала'); + Check(Abs(Segs[2].Duration - 2) < 0.001, 'и укорочен до двух секунд'); + end; + + { Участок целиком внутри одного куска. } + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + Check(Abs(ClipSegmentsToRange(Segs, 6, 8) - 2) < 0.001, + 'внутри одного куска остались две секунды'); + Check(Length(Segs) = 1, 'и один кусок'); + if Length(Segs) = 1 then + Check(Abs(Segs[0].SrcStart - 201) < 0.001, 'взят с нужного места'); + + { Участок мимо монтажа. } + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + Check(Abs(ClipSegmentsToRange(Segs, 100, 200)) < 0.001, + 'за концом монтажа не осталось ничего'); + Check(Length(Segs) = 0, 'и ни одного куска'); + finally + Proj.Free; + end; + WriteLn; + + { --- 10. Клипы на дорожках чужого вида --- } + WriteLn(' 10. Клип на дорожке не своего вида'); + Proj := MakeProject(1, Media); + try + Proj.EnsureAudioTracks; + Proj.AddTrackOfKind('Т1', tkText); + { Картинка на текстовой дорожке — ровно то, что нашлось в живом + проекте: клип виден на монтаже, а в ролик не попадает. } + Clip := Proj.AddClip(Proj.Tracks[Proj.TrackCount - 1], Media, 0, 3, 10); + Clip.Kind := ckImage; + + Check(Proj.MisplacedClipCount = 1, 'нашёлся один такой клип'); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + Check(Length(Segs) = 0, 'в уплощении его нет'); + + Check(Proj.FixMisplacedClips = 1, 'перенесён один клип'); + Check(Proj.MisplacedClipCount = 0, 'чужих клипов не осталось'); + FlattenStream(Proj, tkVideo, 0, Segs, Missing); + DumpSegments(Segs); + Check(Length(Segs) > 0, 'после переноса он попадает в уплощение'); + Clip := Proj.Tracks[0].ClipAt(11); + Check((Clip <> nil) and (Abs(Clip.TlStart - 10) < 0.001), + 'и стоит на прежнем месте'); + finally + Proj.Free; + end; + WriteLn; + + { --- 11. Оверлей под сплошным клипом в окне не показывается --- } + WriteLn(' 11. Оверлей закрыт сверху сплошным клипом'); + Proj := MakeProject(3, Media); + try + Proj.Master := Media.Info; + { Снизу вверх: V3 — съёмка, V2 — оверлей с ключом на весь ролик, + V1 — фотография поверх куска. Так и было в живом проекте. } + Proj.AddClip(Proj.Tracks[2], Media, 0, 20, 0); + Clip := Proj.AddClip(Proj.Tracks[1], Media, 0, 20, 0); + Key := DefaultColorKey; + Key.Enabled := True; + Clip.ColorKey := Key; + Clip := Proj.AddClip(Proj.Tracks[0], Media, 0, 5, 5); + Clip.Kind := ckImage; + + Check(FlattenPreview(Proj, Segs, AudioSegs, Overlays, Missing), + 'уплощение для предпросмотра прошло'); + { Фотография лежит с 5 по 10 секунду и закрывает оверлей: показывать + его там нельзя — в ролике его там не будет. Значит, от оверлея + остаются два окна: до фотографии и после. } + Check(Length(Overlays) = 2, 'оверлей показывается двумя окнами: ' + + IntToStr(Length(Overlays))); + if Length(Overlays) = 2 then + begin + Check(Abs(Overlays[0].TlStart) < 0.001, 'первое окно с начала'); + Check(Abs(Overlays[0].TlEnd - 5) < 0.001, 'и до фотографии'); + Check(Abs(Overlays[1].TlStart - 10) < 0.001, 'второе после неё'); + Check(Abs(Overlays[1].TlEnd - 20) < 0.001, 'и до конца'); + Check(Abs(Overlays[1].SrcStart - 10) < 0.001, + 'и берётся с того же места исходника'); + end; + finally + Proj.Free; + end; + WriteLn; + + { --- 12. Имена дорожек не повторяются --- } + WriteLn(' 12. Имена дорожек'); + Proj := MakeProject(3, Media); + try + Check(Proj.UniqueTrackName('V') = 'V4', 'следующее имя V4: ' + + Proj.UniqueTrackName('V')); + { Убираем среднюю: счёт дорожек снова три, но имя V3 уже занято, и + считать их для имени нельзя. } + Proj.RemoveTrack(1); + Check(Proj.UniqueTrackName('V') = 'V2', 'после удаления средней — V2: ' + + Proj.UniqueTrackName('V')); + Proj.AddTrack(Proj.UniqueTrackName('V')); + Check(Proj.Tracks[2].Name = 'V2', 'новая дорожка названа V2'); + + { Одинаковые имена, доставшиеся от старого проекта, разводятся. } + Proj.Tracks[2].Name := 'V1'; + Proj.EnsureUniqueTrackNames; + Check(Proj.Tracks[2].Name <> 'V1', 'повтор разведён: ' + Proj.Tracks[2].Name); + finally + Proj.Free; + end; + WriteLn; + WriteLn; if FailCount = 0 then begin @@ -739,6 +937,7 @@ begin Proj.Clear; Proj.AddTrack('V1'); Proj.AddTrack('V2'); + Proj.EnsureAudioTracks; if not ProbeMedia(ExpandFileName(ParamStr(3)), Info, Err) then begin @@ -750,8 +949,10 @@ begin { Нижняя дорожка: два куска видео из разных мест, между ними дыра в две секунды, и ещё дыра в начале. } - Proj.AddClip(Proj.Tracks[1], Video, 100, 6, 1.5); - Proj.AddClip(Proj.Tracks[1], Video, 400, 6, 9.5); + { Парой: клип картинки и его звук на соответствующей звуковой + дорожке. Так собранный проект похож на настоящий. } + Proj.AddClipPair(Proj.Tracks[1], Video, 100, 6, 1.5); + Proj.AddClipPair(Proj.Tracks[1], Video, 400, 6, 9.5); if ParamCount >= 4 then begin @@ -779,6 +980,58 @@ begin end; end; +{ Проект для проверки цветового ключа: нижний клип во всю длину и + верхний с выбитым пурпурным поверх него. Собранное потом смотрим по + точкам кадра: где был пурпурный, должно быть видно нижний клип. } +procedure CmdKeyTest; +var + Proj: TProject; + Info: TMediaInfo; + Bottom, Top: TMediaItem; + Clip: TClip; + Key: TColorKey; + Err: string; +begin + Proj := TProject.Create; + try + Proj.Clear; + Proj.AddTrack('V1'); + Proj.AddTrack('V2'); + Proj.EnsureAudioTracks; + + if not ProbeMedia(ExpandFileName(ParamStr(3)), Info, Err) then + begin + WriteLn('Не удалось прочитать нижнее видео: ', Err); + Halt(1); + end; + Bottom := Proj.AddMedia(ExpandFileName(ParamStr(3)), Info); + WriteLn('низ: ', DescribeMedia(Info)); + Proj.AddClipPair(Proj.Tracks[1], Bottom, 0, 3, 0); + + if not ProbeMedia(ExpandFileName(ParamStr(4)), Info, Err) then + begin + WriteLn('Не удалось прочитать верхнее видео: ', Err); + Halt(1); + end; + Top := Proj.AddMedia(ExpandFileName(ParamStr(4)), Info); + WriteLn('верх: ', DescribeMedia(Info)); + Clip := Proj.AddClip(Proj.Tracks[0], Top, 0, 3, 0); + + Key := DefaultColorKey; + Key.Enabled := True; + Clip.ColorKey := Key; + + if not Proj.SaveToFile(ExpandFileName(ParamStr(2)), Err) then + begin + WriteLn('Не удалось записать проект: ', Err); + Halt(1); + end; + WriteLn('проект записан: ', Proj.FileName); + finally + Proj.Free; + end; +end; + procedure CmdBuildCut; var Proj: TProject; @@ -850,12 +1103,208 @@ begin WriteLn(' ', FThread.PendingLog); end; -procedure CmdRender; + +{ Раскладка звуковых дорожек. + + Нужна потому, что «звука нет вот здесь» глазами не разобрать: громкость + может быть верной, а кусок в этом месте — ссылаться не туда. Здесь + печатается ровно то, что уходит в плеер: место на монтаже, файл, место + в файле, длина. } +procedure CmdAudio; var Proj: TProject; Segs: TFlatSegmentArray; Missing: TGenRequests; Err: string; + I, J: Integer; + Total, At: Double; + Kind: string; +begin + Proj := TProject.Create; + try + if not Proj.LoadFromFile(ExpandFileName(ParamStr(2)), Err) then + begin + WriteLn('Не удалось прочитать проект: ', Err); + Halt(1); + end; + + Total := Max(AudibleEnd(Proj, tkVideo), AudibleEnd(Proj, tkAudio)); + WriteLn('проект: ', Proj.FileName); + WriteLn('длина слышимого: ', SecondsToStr(Total), ' с'); + WriteLn; + + for I := 0 to Proj.TrackCount - 1 do + begin + if Proj.Tracks[I].Kind <> tkAudio then + Continue; + WriteLn('=== ', Proj.Tracks[I].Name, ' ==='); + if not Proj.TrackAudible(Proj.Tracks[I]) then + begin + WriteLn(' не слышна (заглушена или пуста)'); + WriteLn; + Continue; + end; + if Proj.Tracks[I].Count = 0 then + begin + WriteLn(' клипов нет'); + WriteLn; + Continue; + end; + if not FlattenAudioTrack(Proj, Proj.Tracks[I], Total, Segs, Missing) then + begin + WriteLn(' разложить не удалось'); + WriteLn; + Continue; + end; + + At := 0; + for J := 0 to High(Segs) do + begin + if Segs[J].Kind = skBlack then + Kind := 'тишина' + else + Kind := 'звук '; + WriteLn(Format(' [%2d] %s монтаж %8s..%8s длина %8s из %8s %s', + [J, Kind, SecondsToStr(At), SecondsToStr(At + Segs[J].Duration), + SecondsToStr(Segs[J].Duration), SecondsToStr(Segs[J].SrcStart), + ExtractFileName(Segs[J].FilePath)])); + if (Segs[J].Kind = skBlack) and (not FileExists(Segs[J].FilePath)) then + WriteLn(' ВНИМАНИЕ: вставки тишины нет на диске'); + At := At + Segs[J].Duration; + end; + WriteLn(' всего по дорожке: ', SecondsToStr(At), ' с'); + WriteLn; + WriteLn(' ', BuildEdlUri(Segs)); + WriteLn; + end; + finally + Proj.Free; + end; +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; + Segs, AudioSegs: TFlatSegmentArray; + Missing: TGenRequests; + Err: string; + I: Integer; + At: Double; + Gen: TGenerateThread; + GenWatch: TGenWatcher; + Kind: string; +begin + Proj := TProject.Create; + try + if not Proj.LoadFromFile(ExpandFileName(ParamStr(2)), Err) then + begin + WriteLn('Не удалось прочитать проект: ', Err); + Halt(1); + end; + + if not FlattenProject(Proj, Segs, AudioSegs, Missing) then + begin + WriteLn('Уплотить нечего.'); + Halt(1); + end; + + ResolveLayers(Proj, Segs, Missing); + + if Length(Missing) > 0 then + begin + WriteLn('Не хватает вставок: ', Length(Missing), '. Делаю.'); + Gen := TGenerateThread.Create(Missing, Proj.Master); + GenWatch := TGenWatcher.Create(Gen); + try + Gen.OnProgress := @GenWatch.Progress; + Gen.OnLog := @GenWatch.LogLine; + Gen.Start; + while not Gen.Finished do + CheckSynchronize(100); + CheckSynchronize(0); + if not Gen.Succeeded then + begin + WriteLn('Не вышло: ', Gen.Message); + Halt(1); + end; + finally + GenWatch.Free; + Gen.Free; + end; + + { Второй заход: теперь файлы на месте и должны подставиться. } + Missing := nil; + ResolveLayers(Proj, Segs, Missing); + if Length(Missing) > 0 then + begin + WriteLn('Часть наложений так и не появилась.'); + Halt(1); + end; + end; + + At := 0; + for I := 0 to High(Segs) do + begin + if Length(Segs[I].Layers) > 0 then + Kind := 'НАЛОЖЕНИЕ (плеер не покажет)' + else if Segs[I].Kind = skBlack then + Kind := 'чёрное' + else + Kind := 'кусок '; + WriteLn(Format(' [%2d] %s монтаж %8s..%8s из %8s %s', + [I, Kind, SecondsToStr(At), SecondsToStr(At + Segs[I].Duration), + SecondsToStr(Segs[I].SrcStart), ExtractFileName(Segs[I].FilePath)])); + At := At + Segs[I].Duration; + end; + WriteLn; + WriteLn(BuildEdlUri(Segs)); + finally + Proj.Free; + end; +end; + +procedure CmdRender; +var + Proj: TProject; + Segs, AudioSegs: TFlatSegmentArray; + Missing: TGenRequests; + Err: string; Gen: TGenerateThread; GenWatch: TGenWatcher; Thread: TExportThread; @@ -877,7 +1326,7 @@ begin WriteLn('длина: ', SecondsToStr(Proj.EndTime), ' с'); WriteLn; - if not FlattenProject(Proj, Segs, Missing) then + if not FlattenProject(Proj, Segs, AudioSegs, Missing) then begin WriteLn('Уплотить нечего.'); Halt(1); @@ -914,7 +1363,7 @@ begin WriteLn; { После создания уплощаем заново: теперь все файлы на месте. } - FlattenProject(Proj, Segs, Missing); + FlattenProject(Proj, Segs, AudioSegs, Missing); if Length(Missing) > 0 then begin WriteLn('Часть вставок так и не появилась.'); @@ -922,8 +1371,23 @@ begin end; end; - Thread := TExportThread.Create(Segs, ExpandFileName(ParamStr(3)), True, - Proj.Master); + { Вжигание текста — последним, уже по окончательному списку кусков: + повторное уплощение стёрло бы отметки о разметке. Так же устроено и + окно сборки. } + if (ParamCount >= 4) and (LowerCase(ParamStr(4)) = 'burn') then + WriteLn('вжигаю текст, пересобрать придётся ', + SecondsToStr(BurnTextIntoSegments(Proj, Segs, Proj.CacheDir)), ' с'); + + { Куски после удачной сборки убираются — как и в самой программе. + Словом keep их можно оставить: пригодится, когда разбираешься, из + чего собрался ролик. } + Thread := TExportThread.Create(Segs, AudioSegs, + ExpandFileName(ParamStr(3)), + (ParamCount >= 4) and (LowerCase(ParamStr(4)) = 'keep'), + Proj.Master, Default(TEncodeProfile)); + { Словом resume просят продолжить прерванную сборку: готовые куски + берутся с диска, а не считаются заново. } + Thread.Resume := (ParamCount >= 4) and (LowerCase(ParamStr(4)) = 'resume'); Watcher := TExportWatcher.Create(Thread); try Thread.OnProgress := @Watcher.Progress; @@ -989,8 +1453,16 @@ begin CmdFlatTest else if (Cmd = 'build') and (ParamCount >= 3) then CmdBuild + else if (Cmd = 'keytest') and (ParamCount >= 4) then + CmdKeyTest 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 + CmdAudio else if (Cmd = 'render') and (ParamCount >= 3) then CmdRender else diff --git a/tests/progress/progtest.lpr b/tests/progress/progtest.lpr new file mode 100644 index 0000000..7706b25 --- /dev/null +++ b/tests/progress/progtest.lpr @@ -0,0 +1,110 @@ +{ + Проверка того, как ползёт полоска выполнения. + + Проверяется не картинка, а поведение: назад не идёт, между вехами + замедляется, при затянувшейся работе не упирается в конец. + + Отдельная программа, а не проверка внутри редактора: расчёт вынесен в + uAppTypes именно затем, чтобы его можно было прогнать числами. +} +program progtest; + +{$mode objfpc}{$H+} + +uses + SysUtils, uAppTypes; + +const + Step = 0.07; + +var + Failed: Integer = 0; + +procedure Check(const AName: string; ACondition: Boolean); +begin + if ACondition then + WriteLn(' ok ', AName) + else + begin + WriteLn(' ПЛОХО ', AName); + Inc(Failed); + end; +end; + +{ Сколько шагов таймера пройдёт, пока полоска идёт от одного значения к + другому при неизменных вехах. } +function StepsFrom(AShown, AReal, ANext, ATarget: Double): Integer; +var + V: Double; +begin + Result := 0; + V := AShown; + while (V < ATarget) and (Result < 100000) do + begin + V := AdvanceProgress(V, AReal, ANext, Step); + Inc(Result); + end; +end; + +var + V, Prev: Double; + I, N1, N2: Integer; + +begin + WriteLn('Ход полоски выполнения'); + WriteLn; + + { 1. Назад не идёт никогда, даже если настоящая доля вдруг меньше. + + Сравнение с запасом: константа в исходнике считается в расширенной + точности, а значение хранится как Double, и точное равенство между + ними не выполняется никогда. } + V := AdvanceProgress(0.6, 0.2, 0.25, Step); + Check('назад не идёт', V >= 0.6 - 1E-9); + + { 2. Веха достигнута — прыгаем к ней сразу. } + V := AdvanceProgress(0.1, 0.5, 0.75, Step); + Check('до настоящей доли догоняет сразу', V >= 0.5); + + { 3. Между вехами ползёт, но следующей не достигает. } + V := 0; + for I := 1 to 200 do + V := AdvanceProgress(V, 0, 0.25, Step); + Check('между вехами движется', V > 0.2); + Check('следующую веху не переступает', V < 0.25); + + { 4. Замедление: вторая половина пути до вехи занимает столько же шагов, + сколько первая. Это и значит «чем дольше, тем медленнее». } + N1 := StepsFrom(0, 0, 1, 0.5); + N2 := StepsFrom(0.5, 0, 1, 0.75); + Check('вторая половина пути не быстрее первой', N2 >= N1); + WriteLn(Format(' шагов до половины: %d, до трёх четвертей: %d', + [N1, N1 + N2])); + + { 5. В конец не упирается, сколько ни жди. } + V := 0; + for I := 1 to 100000 do + V := AdvanceProgress(V, 0, 1, Step); + Check('полной не становится без настоящего конца', V <= 0.999); + + { 6. Ход монотонный. } + V := 0; + Prev := -1; + for I := 1 to 500 do + begin + V := AdvanceProgress(V, 0, 1, Step); + if V < Prev then + Break; + Prev := V; + end; + Check('ход монотонный', V >= Prev); + + WriteLn; + if Failed = 0 then + WriteLn('ВЕРДИКТ: все проверки пройдены') + else + begin + WriteLn('ВЕРДИКТ: не пройдено проверок: ', Failed); + Halt(1); + end; +end. diff --git a/tools/install-desktop.sh b/tools/install-desktop.sh new file mode 100755 index 0000000..447b82d --- /dev/null +++ b/tools/install-desktop.sh @@ -0,0 +1,75 @@ +#!/bin/bash +# Встраивание в рабочий стол: пункт меню, значки и тип файла проекта. +# +# Что делает: +# - кладёт значок программы и значок файла проекта в ~/.local/share/icons +# - описывает тип application/x-nlve-project, чтобы *.nlve перестали +# считаться просто текстом +# - кладёт пункт меню, который открывает такие файлы нашей программой +# +# Всё в домашнем каталоге: прав администратора не нужно, другим +# пользователям системы ничего не меняется. +# +# Запуск: tools/install-desktop.sh [путь к программе] +# По умолчанию берётся nlve рядом с этим репозиторием. +set -u + +HERE=$(cd "$(dirname "$0")/.." && pwd) +BIN=${1:-$HERE/nlve} +PKG=$HERE/packaging + +DATA=${XDG_DATA_HOME:-$HOME/.local/share} +APPS=$DATA/applications +MIME=$DATA/mime/packages +ICONS=$DATA/icons/hicolor + +note() { echo "== $*"; } +fail() { echo "$*" >&2; exit 1; } + +[ -x "$BIN" ] || fail "программы нет или она не запускается: $BIN" +[ -d "$PKG" ] || fail "нет каталога $PKG" + +note "Значки" +for SIZE in 32 48 64 128; do + mkdir -p "$ICONS/${SIZE}x${SIZE}/apps" "$ICONS/${SIZE}x${SIZE}/mimetypes" + # convert есть не у всех; без него кладём один размер как есть. + if command -v convert >/dev/null 2>&1; then + convert "$PKG/nlve.png" -resize ${SIZE}x${SIZE} \ + "$ICONS/${SIZE}x${SIZE}/apps/nlve.png" + convert "$PKG/application-x-nlve-project.png" -resize ${SIZE}x${SIZE} \ + "$ICONS/${SIZE}x${SIZE}/mimetypes/application-x-nlve-project.png" + elif [ "$SIZE" = 128 ]; then + cp -f "$PKG/nlve.png" "$ICONS/128x128/apps/nlve.png" + cp -f "$PKG/application-x-nlve-project.png" \ + "$ICONS/128x128/mimetypes/application-x-nlve-project.png" + fi +done + +note "Тип файла проекта" +mkdir -p "$MIME" +cp -f "$PKG/application-x-nlve-project.xml" "$MIME/nlve.xml" +if command -v update-mime-database >/dev/null 2>&1; then + update-mime-database "$DATA/mime" +else + echo "update-mime-database не найдена: тип не зарегистрируется" >&2 +fi + +note "Пункт меню" +mkdir -p "$APPS" +sed -e "s|@BIN@|$BIN|g" -e "s|@DIR@|$(dirname "$BIN")|g" \ + "$PKG/nlve.desktop.in" > "$APPS/nlve.desktop" +chmod 644 "$APPS/nlve.desktop" +command -v update-desktop-database >/dev/null 2>&1 && + update-desktop-database "$APPS" + +note "Программа по умолчанию для *.nlve" +command -v xdg-mime >/dev/null 2>&1 && + xdg-mime default nlve.desktop application/x-nlve-project + +command -v gtk-update-icon-cache >/dev/null 2>&1 && + gtk-update-icon-cache -f -t "$ICONS" >/dev/null 2>&1 + +echo +echo "готово. Проверить: xdg-mime query filetype <файл>.nlve" +echo "Файловый менеджер может показать новый значок не сразу:" +echo "ему нужно перечитать базу (обычно достаточно перезапуска)." diff --git a/tools/make_file_icon.py b/tools/make_file_icon.py new file mode 100644 index 0000000..49a0c8e --- /dev/null +++ b/tools/make_file_icon.py @@ -0,0 +1,62 @@ +#!/usr/bin/env python3 +""" +Делает значок файла проекта из значка программы. + +Зачем отдельный. Значок программы и значок её файлов — разные вещи: в +списке файлов должно быть видно, что это документ, а не сама программа. +Поэтому берётся лист с загнутым углом, а знак программы кладётся на него. + +Запуск: python3 tools/make_file_icon.py +Итог: packaging/application-x-nlve-project.png +""" + +from pathlib import Path +from PIL import Image, ImageDraw + +ROOT = Path(__file__).resolve().parent.parent +SRC = ROOT / 'packaging' / 'nlve.png' +DST = ROOT / 'packaging' / 'application-x-nlve-project.png' + +SIZE = 128 +# Лист занимает не всю клетку: значкам документов принято оставлять поля. +MARGIN_X = 16 +MARGIN_Y = 6 +FOLD = 30 + +PAPER = (245, 245, 245, 255) +FOLD_COLOR = (205, 205, 205, 255) +EDGE = (120, 120, 120, 255) + + +def main(): + if not SRC.exists(): + raise SystemExit(f'нет файла {SRC}') + + img = Image.new('RGBA', (SIZE, SIZE), (0, 0, 0, 0)) + d = ImageDraw.Draw(img) + + left, right = MARGIN_X, SIZE - MARGIN_X + top, bottom = MARGIN_Y, SIZE - MARGIN_Y + + # Лист с срезанным правым верхним углом. + body = [ + (left, top), (right - FOLD, top), (right, top + FOLD), + (right, bottom), (left, bottom), + ] + d.polygon(body, fill=PAPER, outline=EDGE) + # Сам загнутый угол. + d.polygon([(right - FOLD, top), (right, top + FOLD), + (right - FOLD, top + FOLD)], fill=FOLD_COLOR, outline=EDGE) + + # Знак программы поверх листа, в нижней его части: сверху угол. + mark = Image.open(SRC).convert('RGBA') + side = 66 + mark = mark.resize((side, side), Image.LANCZOS) + img.alpha_composite(mark, ((SIZE - side) // 2, bottom - side - 8)) + + img.save(DST) + print('готов:', DST) + + +if __name__ == '__main__': + main() diff --git a/tools/make_icons.py b/tools/make_icons.py new file mode 100644 index 0000000..7ccf0a8 --- /dev/null +++ b/tools/make_icons.py @@ -0,0 +1,137 @@ +#!/usr/bin/env python3 +""" +Готовит модуль с данными значков из файлов в icons_online. + +Зачем модулем, а не файлами рядом с программой: программа не должна +зависеть от того, лежит ли что-то в её каталоге. Значки маленькие, все +вместе занимают единицы килобайт. + +Размер выбран под кнопку: у неё двадцать восемь точек стороны, значку +достаётся клетка двадцать четыре на двадцать четыре. Уменьшение делает +convert с обычным сглаживанием, пропорции при этом сохраняются — все +исходники квадратные, растягивать нечего. + +Запуск: python3 tools/make_icons.py +""" + +import subprocess +import sys +from pathlib import Path + +ROOT = Path(__file__).resolve().parent.parent +SRC = ROOT / 'icons_online' +OUT = ROOT / 'src' / 'uIconData.pas' + +# Имя в программе -> файл исходника и сторона в точках. +# Для «схлопывания» берётся вариант на шестьдесят четыре точки: чем крупнее +# исходник, тем чище получается уменьшение. +ICONS = [ + ('Snap', 'icons8-магнит-30.png', 24), + ('Ripple', 'icons8-merge-vertical-64.png', 24), + ('Log', 'icons8-property-30.png', 24), + ('Glue', 'icons8-клей-30.png', 24), + ('Target', 'icons8-цель-30.png', 24), +] + +# Значок самой программы: отдельно, потому что окну нужен формат ico — +# только его умеет читать TIcon в LCL. +APP_ICON = ('icons8-показ-видеокадров-30.png', 32) + + +def make_ico(path: Path, side: int) -> bytes: + out = subprocess.run( + ['convert', str(path), '-background', 'none', '-alpha', 'on', + '-resize', '%dx%d' % (side, side), 'ico:-'], + check=True, capture_output=True) + return out.stdout + + +def scale(path: Path, side: int) -> bytes: + out = subprocess.run( + ['convert', str(path), '-background', 'none', '-alpha', 'on', + '-resize', '%dx%d' % (side, side), 'png:-'], + check=True, capture_output=True) + return out.stdout + + +def pascal_bytes(data: bytes, indent: str = ' ') -> str: + parts = [] + for i in range(0, len(data), 16): + chunk = ', '.join('$%02X' % b for b in data[i:i + 16]) + parts.append(indent + chunk) + return ',\n'.join(parts) + + +def main() -> int: + if not SRC.is_dir(): + print('нет каталога с исходниками:', SRC, file=sys.stderr) + return 1 + + blocks = [] + names = [] + for name, filename, side in ICONS: + path = SRC / filename + if not path.is_file(): + print('нет файла:', path, file=sys.stderr) + return 1 + data = scale(path, side) + names.append((name, len(data))) + blocks.append( + ' { %s, %d на %d точек }\n' + ' Icon%sData: array[0..%d] of Byte = (\n%s\n );' + % (filename, side, side, name, len(data) - 1, pascal_bytes(data))) + + app_src, app_side = APP_ICON + app_path = SRC / app_src + if not app_path.is_file(): + print('нет файла:', app_path, file=sys.stderr) + return 1 + app_data = make_ico(app_path, app_side) + names.append(('App (ico)', len(app_data))) + blocks.append( + ' { %s, значок окна, %d на %d точек, формат ico }\n' + ' IconAppData: array[0..%d] of Byte = (\n%s\n );' + % (app_src, app_side, app_side, len(app_data) - 1, + pascal_bytes(app_data))) + + text = '''{ + uIconData — значки, вшитые в программу. + + Собран из файлов в icons_online командой: + + python3 tools/make_icons.py + + Правится не он, а исходные картинки: этот файл переписывается целиком. + + Значки взяты у Icons8 и требуют указания авторства — оно есть в окне + «О программе», вкладка «Библиотеки и авторство». Ссылки на каждый значок + лежат в icons_online/attribution.txt. + + Картинки чёрные на прозрачном фоне. Цвет им задаётся при отрисовке: + берётся прозрачность точки, а цвет — тот, каким сейчас рисуется кнопка. + Поэтому один и тот же значок годится и для тёмной кнопки, и для + оранжевой. +} +unit uIconData; + +{$mode objfpc}{$H+} + +interface + +const +%s + +implementation + +end. +''' % ('\n\n'.join(blocks)) + + OUT.write_text(text, encoding='utf-8') + print('записан', OUT) + for name, size in names: + print(' %-8s %d байт' % (name, size)) + return 0 + + +if __name__ == '__main__': + sys.exit(main())