From f1ef6e624aaaeb723d13b6eb9004bc7abab92a09 Mon Sep 17 00:00:00 2001 From: chaiman Date: Wed, 19 Aug 2026 21:23:24 +0300 Subject: [PATCH] =?UTF-8?q?=D0=AD=D1=82=D0=B0=D0=BF=201:=20=D1=84=D0=BE?= =?UTF-8?q?=D1=80=D0=BC=D0=B0=20=D0=B7=D0=B2=D1=83=D0=BA=D0=B0=20=D0=BD?= =?UTF-8?q?=D0=B0=20=D0=BA=D0=BB=D0=B8=D0=BF=D0=B0=D1=85?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Для каждого файла один раз строится список пиков: сто значений в секунду, каждое есть наибольший модуль отсчёта за свои десять миллисекунд. Рисовать по настоящим отсчётам нельзя — в секунде их 48 тысяч, а в клипе на экране сотни пикселей. Разбор идёт в отдельном потоке и запоминается в кэше проекта. Через временный файл, а не по трубе: запуск внешних программ режет вывод на строки, а тут поток байтов, где перевод строки — такой же отсчёт. Shift со стрелками вверх и вниз растягивает форму по высоте. Звук бывает тихим, и угадывать за человека нужное усиление неправильно. Меняется только рисунок, значение сохраняется между запусками. Проверено: файл «4 с тона, 4 с тишины, 4 с тона» даёт форму в первой и последней трети и пустоту посередине. Полная амплитуда даёт 254 из 255. Разбор записи на 892 с занимает 12.7 с — это чтение 6.3 ГБ с диска, быстрее не выйдет. Первоначальный критерий «меньше двух секунд» в плане был занижен и исправлен по замеру. Заодно снят риск четвёртого этапа: mpv принимает edl:// как внешнюю звуковую дорожку и берёт звук именно из неё. Проверено встречными списками — картинке «тишина, потом тон», звуку «тон, потом тишина». --- README.md | 16 ++ src/uMainForm.pas | 62 ++++++- src/uSettings.pas | 9 + src/uTimelineCtrl.pas | 107 +++++++++++- src/uWaveform.pas | 380 ++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 572 insertions(+), 2 deletions(-) create mode 100644 src/uWaveform.pas diff --git a/README.md b/README.md index 9ce520f..4487804 100644 --- a/README.md +++ b/README.md @@ -62,6 +62,7 @@ Lazarus другой версии, и собранные им модули LCL | Прокрутка по дорожкам | колесо мыши | | Прокрутка по времени | Shift + колесо, средняя кнопка | | Прокрутка журнала вбок | Shift + колесо над журналом | +| Растянуть форму звука по высоте | Shift + стрелки вверх и вниз | | Выключить дорожку / оставить только её | кнопки М и С в заголовке | | Громкость клипа | тянуть ручку на клипе вверх-вниз | | Автосхлопывание вкл/выкл | Ctrl+K | @@ -137,6 +138,20 @@ Ctrl+Shift+R, который схлопывает дыру под курсоро В списке файлов слева показывается кадр из каждого файла, его параметры и длительность. Кадры делаются в фоне и запоминаются в кэше проекта. +На клипах видна форма звука. Считается она по заранее разобранным пикам — +сто значений в секунду, каждое есть наибольший модуль отсчёта за свои +десять миллисекунд. Рисовать по настоящим отсчётам нельзя: в секунде их +48 тысяч, а в клипе на экране сотни пикселей. + +Разбор идёт в фоне и запоминается в кэше проекта. Для записи на 892 с это +около 13 секунд — столько занимает чтение шести гигабайт с диска, и +быстрее не выйдет; при следующем открытии проекта пики берутся готовыми. + +**Shift со стрелками вверх и вниз растягивает форму по высоте.** Звук +бывает тихим, и угадывать за человека, во сколько раз растянуть картинку, +неправильно. Усиление меняет только рисунок, самого звука не касается, и +запоминается между запусками. + ## Файл не совпадает с проектом Проект имеет одно разрешение и один набор кодеков на всё — иначе куски не @@ -433,6 +448,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/src/uMainForm.pas b/src/uMainForm.pas index a62332e..9a7bbf6 100644 --- a/src/uMainForm.pas +++ b/src/uMainForm.pas @@ -27,7 +27,7 @@ uses uAppTypes, uEdl, uMpvLib, uMpvPlayer, uProject, uMediaProbe, uTimelineCtrl, uFlatten, uGenerate, uExport, uProgressForm, uRemuxForm, uMismatchForm, uFfmpegJob, uSettings, uThumbs, uTransform, uPanCropForm, - uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm; + uProjectInfoForm, ImgList, uTheme, uLogView, uDepsForm, uWaveform; type @@ -102,6 +102,7 @@ type FThumbs: TImageList; FThumbThread: TThumbThread; + FPeaksThread: TPeaksThread; { Соответствие «путь к файлу -> номер картинки в списке изображений». По пути, а не по номеру в списке проекта: пока миниатюра делается, файлы могут добавиться или пропасть. Номер хранится увеличенным на @@ -149,6 +150,8 @@ type procedure ApplySettings; procedure CollectSettings; procedure StartThumbs; + procedure StartPeaks; + procedure PeaksReady(Sender: TObject; const ASourcePath: string); procedure ThumbReady(Sender: TObject; const ASourcePath, AThumbPath: string); procedure SeekPlayerTo(const ATime: Double); @@ -357,6 +360,12 @@ begin FThumbThread.WaitFor; FreeAndNil(FThumbThread); end; + if Assigned(FPeaksThread) then + begin + FPeaksThread.Terminate; + FPeaksThread.WaitFor; + FreeAndNil(FPeaksThread); + end; FreeAndNil(FThumbMap); CollectSettings; FSettings.Save; @@ -384,6 +393,7 @@ begin pnlVideo.Height := FSettings.VideoPanelHeight; FTimeline.TrackHeight := FSettings.TrackHeight; + FTimeline.WaveGain := FSettings.WaveGain; { Режим схлопывания и его состояние переживают перезапуск. } if FSettings.RippleAllTracks then @@ -420,6 +430,7 @@ begin FSettings.VideoPanelHeight := pnlVideo.Height; FSettings.RippleAllTracks := FProject.RippleMode = rmAllTracks; FSettings.RippleEnabled := FProject.RippleEnabled; + FSettings.WaveGain := FTimeline.WaveGain; end; procedure TMainForm.BuildTimeline; @@ -755,6 +766,7 @@ begin [FProject.PoolCount, Plural(FProject.PoolCount, 'файл', 'файла', 'файлов')]); StartThumbs; + StartPeaks; end; { Запускает изготовление недостающих миниатюр. @@ -819,6 +831,54 @@ begin FThumbThread.Start; end; +{ Разбор звука для формы волны. Отдельная очередь от миниатюр: разбор + идёт дольше, и держать миниатюры в ожидании звука незачем. } +procedure TMainForm.StartPeaks; +var + Requests: TPeaksRequests = nil; + I, N: Integer; + Item: TMediaItem; + Dummy: TPeaks; +begin + if Assigned(FPeaksThread) then + begin + FPeaksThread.Terminate; + FPeaksThread.WaitFor; + FreeAndNil(FPeaksThread); + end; + + if FProject.PoolCount = 0 then + Exit; + + SetLength(Requests, FProject.PoolCount); + N := 0; + for I := 0 to FProject.PoolCount - 1 do + begin + Item := FProject.Pool[I]; + if 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.Start; +end; + +procedure TMainForm.PeaksReady(Sender: TObject; const ASourcePath: string); +begin + { Запомненную неудачу надо забыть: пики только что появились. } + ForgetPeaks; + FTimeline.Invalidate; +end; + procedure TMainForm.ThumbReady(Sender: TObject; const ASourcePath, AThumbPath: string); var diff --git a/src/uSettings.pas b/src/uSettings.pas index 2b87557..c8cbb39 100644 --- a/src/uSettings.pas +++ b/src/uSettings.pas @@ -33,6 +33,7 @@ type FRippleAllTracks: Boolean; FRippleEnabled: Boolean; FTrackHeight: Integer; + FWaveGain: Double; FVideoPanelHeight: Integer; FRecentProjects: TStringList; function FileName: string; @@ -58,6 +59,8 @@ 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; end; @@ -70,6 +73,7 @@ const DefaultWidth = 1600; DefaultHeight = 900; DefaultTrackHeight = 64; + DefaultWaveGain = 1.0; DefaultVideoHeight = 400; { Больше десятка в меню не помещается по-человечески, да и не нужно. } @@ -84,6 +88,7 @@ begin FWindowWidth := DefaultWidth; FWindowHeight := DefaultHeight; FTrackHeight := DefaultTrackHeight; + FWaveGain := DefaultWaveGain; FVideoPanelHeight := DefaultVideoHeight; end; @@ -161,6 +166,7 @@ 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); Arr := Obj.Find('recent_projects', jtArray) as TJSONArray; @@ -181,6 +187,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,6 +215,7 @@ 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); Arr := TJSONArray.Create; diff --git a/src/uTimelineCtrl.pas b/src/uTimelineCtrl.pas index 2577288..f70b662 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 { Что сейчас делает мышь. } @@ -94,6 +94,10 @@ type FSnapEnabled: Boolean; FSnapSuspended: Boolean; FDragOrigVolume: Double; + { Во сколько раз растянуть форму звука по высоте. Только рисунок, + самого звука не касается: у тихих записей иначе не видно, где + тишина, а где нет. } + FWaveGain: Double; { Клипы, которые поедут вслед за перетаскиваемым, и их исходные позиции. Список составляется один раз при нажатии: пересчитывать его на каждое движение мыши нельзя, иначе в него начнут попадать @@ -129,9 +133,11 @@ type 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 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; @@ -208,6 +214,8 @@ type property SnapEnabled: Boolean read FSnapEnabled write FSnapEnabled; 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; @@ -286,6 +294,7 @@ const ColorPlayhead = TColor($4040FF); // красный: привычный цвет курсора ColorEdgeSnap = TColor($909090); // серый: рез притянут к опорному кадру ColorEdgePrecise = TColor($FFC030); // голубой: рез потребует перекодирования + ColorWave = TColor($7A6A55); // приглушённый синий: форма звука ColorVolumeLine = TColor($60E0E0); // жёлтый: линия громкости ColorVolumeHandle = TColor($30C0FF); // оранжевый: ручка громкости ColorHeaderActive = TColor($3A3A3A); // подсветка выбранной дорожки @@ -297,6 +306,7 @@ const constructor TTimelineControl.Create(AOwner: TComponent); begin + FWaveGain := 1; inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque]; TabStop := True; @@ -661,6 +671,10 @@ begin ACanvas.FillRect(Body.Right - 4, Body.Top + 1, Body.Right - 1, Body.Bottom - 1); end; + { Форма звука — фон клипа, поэтому идёт раньше всего остального, что на + нём рисуется. } + DrawWaveform(ACanvas, AClip, Body); + { Громкость рисуется до подписей: иначе её линия перечёркивает название и длительность. } DrawVolume(ACanvas, AClip, ATop, Body); @@ -686,6 +700,78 @@ begin 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 <> ckVideo) 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; + +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; + { Линия громкости с ручкой посередине видимой части клипа. Сделано как в монтажных программах: линия показывает уровень, за ручку @@ -1748,6 +1834,25 @@ 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 diff --git a/src/uWaveform.pas b/src/uWaveform.pas new file mode 100644 index 0000000..3c913e4 --- /dev/null +++ b/src/uWaveform.pas @@ -0,0 +1,380 @@ +{ + 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; + FOnReady: TPeaksReadyEvent; + procedure SyncReady; + function CancelQuery: Boolean; + protected + procedure Execute; override; + public + constructor Create(const ARequests: TPeaksRequests); + property OnReady: TPeaksReadyEvent read FOnReady write FOnReady; + 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; + SetLength(FRequests, Length(ARequests)); + for I := 0 to High(ARequests) do + FRequests[I] := ARequests[I]; +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); + Continue; + end; + if BuildPeaks(FRequests[I].SourcePath, FRequests[I].TargetPath, + @CancelQuery, Err) then + Synchronize(@SyncReady); + end; +end; + +finalization + FreeAndNil(FCache); + +end.