diff --git a/src/uAboutForm.pas b/src/uAboutForm.pas index 7ca3a65..520282c 100644 --- a/src/uAboutForm.pas +++ b/src/uAboutForm.pas @@ -1,22 +1,15 @@ { uAboutForm — окно «О программе». - Две вкладки. Первая обязательна: значки взяты у Icons8, а их бесплатная - лицензия требует указать авторство со ссылкой на каждый значок. Заодно - там же перечислено всё, на чём программа держится, и под какой лицензией - оно раздаётся — под Windows и под Linux наборы разные. + Две вкладки. «Ресурсы» — на чём программа держится и чьи значки + использует: бесплатная лицензия Icons8 требует ссылку на каждый значок. + «Возможности» — что программа умеет. - Вторая вкладка отвечает на вопрос «что эта штука умеет», который иначе - задают каждому новому человеку голосом. + Вкладки свои, а не TPageControl: системные под Windows остались бы + светлой полосой поверх тёмного окна. - Вкладки свои, а не TPageControl: системные вкладки рисует система, и под - Windows они остались бы светлой полосой поверх тёмного окна — ровно то, - из-за чего здесь уже переписаны кнопки, полосы прокрутки, журнал и меню. - Две кнопки-переключателя и две панели делают то же самое и выглядят как - остальная программа. - - Текст показывается нашим журналом: он умеет прокрутку, выделение и - копирование в буфер — ссылку из списка можно взять и открыть в браузере. + Текст показывает uArticleView: он сам переносит строки по ширине окна и + делает ссылки нажимаемыми. } unit uAboutForm; @@ -26,94 +19,35 @@ interface uses Classes, SysUtils, Controls, Forms, Graphics, StdCtrls, Dialogs, - uTheme, uLogView; + uTheme, uArticleView; -{ Показывает окно. Возвращается, когда его закрыли. } procedure ShowAboutForm; implementation -{ Перенос по словам. - - Журнал строки не переносит: он показывает сообщения программы, где - перенос сбил бы выравнивание. Здесь же текст сплошной, и без переноса - абзац уезжает за правый край. - - Ссылки не трогаются вовсе: разорванную пополам ссылку не собрать - обратно. Отступ строки переносится на её продолжения — иначе список - рассыпается. - - Ширина считается в знаках, а шрифт у нас пропорциональный, поэтому - строка выходит короче обещанного. Это лучше, чем длиннее: за правый край - не уедет ничего. } -function Wrap(const AText: string; AWidth: Integer): string; -var - Src: TStringList; - I, Space, Indent: Integer; - Line, Rest: string; -begin - Result := ''; - Src := TStringList.Create; - try - Src.Text := AText; - for I := 0 to Src.Count - 1 do - begin - Rest := Src[I]; - - if (Rest = '') or (Length(Rest) <= AWidth) or (Pos('http', Rest) > 0) then - begin - Result := Result + Rest + LineEnding; - Continue; - end; - - { Отступ запоминается и повторяется на всех продолжениях. } - Indent := 0; - while (Indent < Length(Rest)) and (Rest[Indent + 1] = ' ') do - Inc(Indent); - - while Length(Rest) > AWidth do - begin - { Ищем последний пробел в пределах ширины; не нашли — рвём по - ширине, иначе одно длинное слово повесило бы разбор. } - Space := AWidth; - while (Space > Indent + 1) and (Rest[Space] <> ' ') do - Dec(Space); - if Space <= Indent + 1 then - Space := AWidth; - Line := Copy(Rest, 1, Space); - Rest := StringOfChar(' ', Indent) + Copy(Rest, Space + 1, Length(Rest)); - Result := Result + TrimRight(Line) + LineEnding; - end; - Result := Result + Rest + LineEnding; - end; - finally - Src.Free; - end; -end; - type { Обработчики живут в объекте: событиям нужны методы. } TAboutDialog = class(TComponent) public Form: TForm; - BtnCredits: TThemedButton; + BtnResources: TThemedButton; BtnFeatures: TThemedButton; - ViewCredits: TLogView; - ViewFeatures: TLogView; - procedure ShowCredits(Sender: TObject); + ViewResources: TArticleView; + ViewFeatures: TArticleView; + procedure ShowResources(Sender: TObject); procedure ShowFeatures(Sender: TObject); - procedure Select(ACredits: Boolean); + procedure Select(AResources: Boolean); end; -procedure TAboutDialog.Select(ACredits: Boolean); +procedure TAboutDialog.Select(AResources: Boolean); begin - BtnCredits.Down := ACredits; - BtnFeatures.Down := not ACredits; - ViewCredits.Visible := ACredits; - ViewFeatures.Visible := not ACredits; + BtnResources.Down := AResources; + BtnFeatures.Down := not AResources; + ViewResources.Visible := AResources; + ViewFeatures.Visible := not AResources; end; -procedure TAboutDialog.ShowCredits(Sender: TObject); +procedure TAboutDialog.ShowResources(Sender: TObject); begin Select(True); end; @@ -123,163 +57,114 @@ begin Select(False); end; -{ Кто это написал и на чём оно держится. - - Списки разные по системам не для красоты: под Linux ffmpeg и libmpv - ставит пакетный менеджер, под Windows их скачивает сама программа из - окна «Зависимости», и это разные сборки с разными лицензиями. Указывать - надо то, что стоит у человека, а не то, что бывает вообще. } -function CreditsText: string; +{ Списки под Windows и под Linux разные: там сборки скачивает сама + программа, здесь их ставит пакетный менеджер. } +function ResourcesText: string; begin Result := - 'nlve — монтаж без перекодирования' + LineEnding + - LineEnding + + '# nlve' + LineEnding + + 'Монтаж без перекодирования: куски вырезаются и склеиваются ' + + 'копированием потока.' + LineEnding + 'Автор: 4aiman' + LineEnding + LineEnding + - 'Замысел в одном: куски видео вырезаются и склеиваются копированием ' + - 'потока, без пересчёта картинки. То, что обычный монтажный редактор ' + - 'считает часами, здесь собирается за время копирования файла. ' + - 'Пересобирается только то, что иначе никак: переходы, прозрачность, ' + - 'точные резы и куски файлов с чужими параметрами.' + LineEnding + - LineEnding + - '── Значки ──' + LineEnding + - LineEnding + - 'Значки взяты у Icons8 и требуют указания авторства.' + LineEnding + - LineEnding + - 'Прилипание — значок «Magnet» от Icons8:' + LineEnding + - ' https://icons8.com/icon/79942/magnet' + LineEnding + - 'Схлопывание — значок «Merge Vertical» от Icons8:' + LineEnding + - ' https://icons8.com/icon/2EQegp8tbR6Q/merge-vertical' + LineEnding + - 'Журнал — значок «Property» от Icons8:' + LineEnding + - ' https://icons8.com/icon/79872/property' + LineEnding + - 'Значок программы — «Showing Video Frames» от Icons8:' + LineEnding + - ' https://icons8.com/icon/69093/showing-video-frames' + LineEnding + - LineEnding + - 'Сам Icons8: https://icons8.com' + LineEnding + - 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 + + 'Значок программы — Showing Video Frames' + LineEnding + + ' https://icons8.com/icon/69093/showing-video-frames' + LineEnding + + 'Сам Icons8' + LineEnding + + ' https://icons8.com' + LineEnding + LineEnding + + '# Видео и звук' + LineEnding + {$IFDEF WINDOWS} - 'ffmpeg и ffprobe — вся работа с видео и звуком: нарезка, склейка, ' + - 'перекодирование, разбор файлов.' + LineEnding + - ' Сборка BtbN, вариант gpl:' + LineEnding + - ' https://github.com/BtbN/FFmpeg-Builds' + LineEnding + - ' Лицензия сборки: GPL-3.0' + LineEnding + - ' Сам ffmpeg: https://ffmpeg.org' + LineEnding + + 'ffmpeg — нарезка, склейка, перекодирование. Сборка BtbN, GPL.' + LineEnding + - 'libmpv — предпросмотр монтажа. Играет виртуальный список кусков, ' + - 'не собирая при этом ни одного файла.' + LineEnding + - ' Сборка shinchiro/mpv-winbuild-cmake:' + LineEnding + - ' https://github.com/shinchiro/mpv-winbuild-cmake' + LineEnding + - ' Лицензия сборки: GPL' + LineEnding + - ' Сам mpv: https://mpv.io' + LineEnding + - LineEnding + - '7-Zip (7zr.exe) — распаковка сборок libmpv, они раздаются в .7z.' + - LineEnding + - ' https://www.7-zip.org' + LineEnding + - ' Лицензия: LGPL-2.1' + 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 и ffprobe — вся работа с видео и звуком: нарезка, склейка, ' + - 'перекодирование, разбор файлов.' + LineEnding + - ' Ставится пакетным менеджером: sudo apt install ffmpeg' + LineEnding + - ' https://ffmpeg.org' + LineEnding + - ' Лицензия сборок в Ubuntu: GPL-2 и новее' + LineEnding + + 'ffmpeg — нарезка, склейка, перекодирование. GPL-2 и новее.' + LineEnding + - 'libmpv — предпросмотр монтажа. Играет виртуальный список кусков, ' + - 'не собирая при этом ни одного файла.' + LineEnding + - ' Ставится пакетным менеджером: sudo apt install mpv' + LineEnding + - ' https://mpv.io' + LineEnding + - ' Лицензия сборок в Ubuntu: GPL-3 и новее' + 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 + + '# Инструменты' + LineEnding + + 'Free Pascal' + LineEnding + + ' https://www.freepascal.org' + LineEnding + + 'Lazarus LCL' + LineEnding + + ' https://www.lazarus-ide.org' + LineEnding + LineEnding + - 'Free Pascal — компилятор.' + LineEnding + - ' https://www.freepascal.org' + LineEnding + - ' Лицензия: GPL с оговоркой о компоновке для библиотеки времени ' + - 'выполнения' + LineEnding + - LineEnding + - 'Lazarus LCL — библиотека окон и элементов управления.' + LineEnding + - ' https://www.lazarus-ide.org' + LineEnding + - ' Лицензия: LGPL-2 с оговоркой о компоновке' + LineEnding + - LineEnding + - 'Ни ffmpeg, ни libmpv в состав программы не входят и вместе с ней не ' + - 'раздаются: ffmpeg запускается отдельной программой, libmpv ' + - 'подключается на ходу и ставится отдельно.'; + 'ffmpeg и libmpv в состав программы не входят: ffmpeg запускается ' + + 'отдельной программой, libmpv ставится отдельно.'; end; -{ Что программа умеет. Не список кнопок, а список того, ради чего её - открывают. } function FeaturesText: string; begin Result := - 'Монтаж' + LineEnding + + '# Монтаж' + LineEnding + + 'Дорожки для картинки и для звука.' + LineEnding + + 'При перекрытии картинку даёт верхняя дорожка, звук всех дорожек ' + + 'смешивается.' + LineEnding + + 'Перенос, растягивание за края, рез по курсору (S), удаление.' + LineEnding + - ' Дорожки для картинки и для звука, сколько нужно. При перекрытии ' + - 'картинку даёт верхняя дорожка целиком, а звук всех дорожек ' + - 'смешивается: под голос кладётся музыка.' + LineEnding + - ' Клипы переносятся, растягиваются за края, режутся по курсору ' + - '(S) и удаляются. Прилипание к краям соседей и к курсору; Shift во ' + - 'время перетаскивания отменяет его.' + LineEnding + - ' Связки: видео и его звук ходят вместе, Ctrl+G связывает и ' + - 'развязывает. Развязанный звук двигается отдельно от своей картинки.' + + 'Прилипание к соседям и к курсору. Shift отменяет его.' + LineEnding + + 'Связки: видео и его звук ходят вместе. Ctrl+G связывает и ' + + 'развязывает.' + LineEnding + + 'Схлопывание дыр: Ctrl+Shift+R или само при перетаскивании.' + LineEnding + - ' Схлопывание дыр: вручную (Ctrl+Shift+R) или само при ' + - 'перетаскивании, на текущей дорожке или на всех сразу.' + LineEnding + - ' Отмена и повтор любого действия.' + LineEnding + + 'Отмена и повтор: Ctrl+Z, Ctrl+Y.' + LineEnding + LineEnding + - 'Что видно на дорожках' + LineEnding + + '# На дорожках' + LineEnding + + 'Форма звука. Shift со стрелками усиливает её на тихих записях.' + LineEnding + - ' Форма звука на звуковых клипах; Shift со стрелками вверх и вниз ' + - 'усиливает её, когда запись тихая.' + LineEnding + - ' Громкость клипа — ручкой прямо на нём, прозрачность — так же на ' + - 'видеоклипе.' + LineEnding + - ' Появление и уход — за верхние углы клипа. Перекрытие двух клипов ' + - 'одной дорожки помечено косым крестом: там сам собой выходит переход.' + + 'Громкость и прозрачность — ручкой на клипе.' + LineEnding + + 'Появление и уход — за верхние углы клипа.' + LineEnding + + 'Перекрытие на одной дорожке помечено крестом: там переход.' + LineEnding + - ' Цвет краёв показывает, притянут рез к опорному кадру или потребует ' + - 'перекодирования.' + LineEnding + + 'Цвет краёв показывает, потребует ли рез перекодирования.' + LineEnding + LineEnding + - 'Предпросмотр' + LineEnding + + '# Предпросмотр' + 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 + - ' Перед сборкой программа говорит, сколько секунд придётся ' + - 'пересобрать и почему.' + LineEnding + - ' Точный рез перекодирует только огрызок до ближайшего опорного ' + - 'кадра, остальное копируется.' + LineEnding + - ' Отдельно — сборка с перекодированием: размер кадра от 720p до 4K, ' + - 'поток в килобитах, кодек HEVC или H.264. Считает видеокарта.' + + '# Прочее' + LineEnding + + 'Индекс опорных кадров читается из заголовка: 20 мс вместо 12 секунд.' + LineEnding + - ' Перепаковка готовых файлов в другой контейнер, без пересчёта.' + + 'Фоновая работа видна полоской внизу и штриховкой на монтаже.' + LineEnding + - LineEnding + - 'Мелочи, которые важны' + LineEnding + - LineEnding + - ' Индекс опорных кадров читается из заголовка файла, а не ' + - 'перебором: на шестигигабайтном файле это двадцать миллисекунд ' + - 'вместо двенадцати секунд.' + LineEnding + - ' Фоновая работа видна внизу полоской и отмечена на монтаже ' + - 'штриховкой.' + LineEnding + - ' Все окна в своих цветах, а не в системных.' + LineEnding + - ' Настройки, недавние проекты и размеры окна переживают перезапуск.'; + 'Свои цвета во всех окнах.' + LineEnding + + 'Настройки и недавние проекты переживают перезапуск.'; end; procedure ShowAboutForm; @@ -294,36 +179,32 @@ begin Dlg.Form.Position := poScreenCenter; Dlg.Form.ClientWidth := 720; Dlg.Form.ClientHeight := 560; - Dlg.Form.Constraints.MinWidth := 480; - Dlg.Form.Constraints.MinHeight := 320; + Dlg.Form.Constraints.MinWidth := 420; + Dlg.Form.Constraints.MinHeight := 300; - Dlg.BtnCredits := TThemedButton.Create(Dlg.Form); - Dlg.BtnCredits.Parent := Dlg.Form; - Dlg.BtnCredits.SetBounds(12, 12, 240, 28); - Dlg.BtnCredits.Caption := 'Библиотеки и авторство'; - Dlg.BtnCredits.TabStop := False; - Dlg.BtnCredits.OnClick := @Dlg.ShowCredits; + 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(258, 12, 180, 28); - Dlg.BtnFeatures.Caption := 'Что умеет'; + Dlg.BtnFeatures.SetBounds(158, 12, 140, 28); + Dlg.BtnFeatures.Caption := 'Возможности'; Dlg.BtnFeatures.TabStop := False; Dlg.BtnFeatures.OnClick := @Dlg.ShowFeatures; - Dlg.ViewCredits := TLogView.Create(Dlg.Form); - Dlg.ViewCredits.Parent := Dlg.Form; - Dlg.ViewCredits.SetBounds(12, 48, 696, 460); - Dlg.ViewCredits.Anchors := [akTop, akLeft, akRight, akBottom]; - { Ширина подобрана замером: при 720 точках окна в строку входит около - ста шестидесяти знаков, берём с запасом. } - Dlg.ViewCredits.SetText(Wrap(CreditsText, 150)); + 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 := TLogView.Create(Dlg.Form); + 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]; - Dlg.ViewFeatures.SetText(Wrap(FeaturesText, 150)); BtnClose := TThemedButton.Create(Dlg.Form); BtnClose.Parent := Dlg.Form; @@ -335,8 +216,13 @@ begin BtnClose.Cancel := True; ApplyDarkTheme(Dlg.Form); - { Значок окна берётся у главного окна: своего у диалога нет. } + + { Текст задаётся после раскраски: раскладка считается по тому шрифту, + которым он будет нарисован. } + Dlg.ViewResources.SetText(ResourcesText); + Dlg.ViewFeatures.SetText(FeaturesText); Dlg.Select(True); + Dlg.Form.ShowModal; finally Dlg.Form.Free; 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/uTheme.pas b/src/uTheme.pas index ac94142..1b38eba 100644 --- a/src/uTheme.pas +++ b/src/uTheme.pas @@ -52,6 +52,7 @@ const ThemeSelection = TColor($785434); // приглушённый синий: выделение ThemeSelText = TColor($FFFFFF); ThemeGridLine = TColor($3A3A3A); + ThemeLink = TColor($E0A060); // голубой: ссылка type { Значок на кнопке.