nlve/src/uTimelineCtrl.pas

{
  uTimelineCtrl — компонент монтажного стола.

  В LCL нет готовой сцены с объектами, поэтому всё рисуется вручную.
  Это не недостаток: полный контроль над отрисовкой здесь нужнее, чем
  готовые примитивы, а рисовать прямоугольники быстро.

  Устройство координат. Хранятся две величины: сколько пикселей приходится
  на секунду и какое время показано у левого края. Всё остальное считается
  из них. Зум по Ctrl с колесом мыши сделан так, чтобы точка под курсором
  оставалась на месте: меняется масштаб, затем сдвиг подбирается обратным
  счётом. Без этого при увеличении уезжает не туда, куда смотришь.

  Отрисовка идёт в теневое изображение и копируется целиком. Иначе при
  перетаскивании клипов мерцает.

  Слева отведена полоса под названия дорожек: без неё непонятно, какая
  дорожка верхняя, а порядок дорожек здесь определяет, что будет видно.
}
unit uTimelineCtrl;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Controls, Graphics, LCLType, LCLIntf, Forms, Math,
  uAppTypes, uProject, uMediaProbe, uKeyframeIndex, uWaveform;

type
  { Что сейчас делает мышь. }
  TTimelineAction = (
    taNone,
    taDragClip,     // перенос клипа
    taTrimIn,       // растягивание за левый край
    taTrimOut,      // растягивание за правый край
    taScrub,        // протяжка курсора воспроизведения
    taPan,          // прокрутка средней кнопкой
    taVolume,       // тянем ручку громкости клипа
    taFadeIn,       // тянем появление за верхний левый угол
    taFadeOut       // тянем уход за верхний правый угол
  );

  { Что находится под указателем в полосе заголовков дорожек. }
  THeaderPart = (hpNone, hpBody, hpMute, hpSolo);

  { Файл из списка проекта бросили на монтаж.

    ATrackIndex = -1 означает, что бросили ниже всех дорожек и нужна новая.
    Само добавление делает окно: компонент не знает, что за объект тащат
    и какой файл ему соответствует. }
  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;
    FPlayhead: Double;
    FBuffer: TBitmap;

    FTrackHeight: Integer;
    FRulerHeight: Integer;
    FHeaderWidth: Integer;

    FAction: TTimelineAction;
    FDragClip: TClip;
    FDragTrack: TTrack;
    FDragGrabOffset: Double;
    FDragOrigStart: Double;
    FDragOrigSrcIn: Double;
    FDragOrigDuration: Double;
    FPanOriginX: Integer;
    FPanOriginY: Integer;
    FPanOriginTime: Double;
    FPanOriginScrollY: Integer;
    FHoverTrack: Integer;
    { Вертикальная прокрутка в пикселях: дорожек может быть больше, чем
      помещается в окно. }
    FScrollY: Integer;
    { За одно перетаскивание разрешено создать не больше одной дорожки,
      иначе таскание мышью вниз наплодит их десяток. }
    FTrackAddedDuringDrag: Boolean;
    { Где нажали кнопку и сдвинулась ли мышь с тех пор. Нужно, чтобы
      отличить щелчок по клипу от начала его перетаскивания. }
    FPressX: Integer;
    FPressY: Integer;
    FMovedWhileDown: Boolean;
    { Дорожка, на которую кладут файл кнопкой «На таймлайн». Выбирается
      щелчком по заголовку. }
    FActiveTrack: Integer;
    { Прилипание краёв клипов друг к другу. Shift на время переключает
      его в противоположное состояние: включено — временно выключает,
      выключено — временно включает. }
    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;
    FOnMediaDrop: TMediaDropEvent;
    FOnClipTransform: TClipEvent;
    FOnTrackAdded: TNotifyEvent;
    FOnActiveTrackChange: TNotifyEvent;

    function GetVisibleWidth: Integer;
    function TimeToX(const ATime: Double): Integer;
    function XToTime(const AX: Integer): Double;
    function TrackTop(AIndex: Integer): Integer;
    function TrackIndexAt(const AY: Integer): Integer;
    function ClipAtPoint(const AX, AY: Integer; out ATrack: TTrack): TClip;
    function EdgeAtPoint(const AX: Integer; AClip: TClip): Integer;
    { Что под указателем в полосе заголовков и на какой дорожке. }
    function HeaderPartAt(const AX, AY: Integer; out ATrackIndex: Integer): THeaderPart;
    { Прямоугольник ручки громкости клипа. Ручка ставится посередине
      ВИДИМОЙ части клипа, а не всего клипа: до середины часового клипа,
      уехавшей за край экрана, мышью не дотянуться. }
    function VolumeHandleRect(AClip: TClip; ATop: Integer): TRect;
    function VolumeToY(const AVolume: Double; ATop: Integer): Integer;
    function YToVolume(const AY: Integer; ATop: Integer): Double;

    procedure DrawRuler(ACanvas: TCanvas);
    procedure DrawRegion(ACanvas: TCanvas);
    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;
    procedure ClampScrollY;
    function TracksBottom: Integer;
    function SnapTime(const ATime: Double; AExclude: TClip): Double;
    function MediaDurationOf(AClip: TClip): Double;
    procedure StructureChanged;
    { Помечает край клипа точным, если он не попал на опорный кадр.

      Смысл: пользователь подвинул край руками, значит он хотел именно
      этот кадр. Притягивать такой рез к опорному кадру — значит молча
      сделать не то, о чём просили. }
    procedure UpdateEdgePrecision(AClip: TClip);
    { Составляет список клипов правее перетаскиваемого. }
    procedure CollectRippleClips(ATrackIndex: Integer; AExclude: TClip;
      const AFromTime: Double);
    procedure ApplyRipple(const ADelta: Double);
    function IsRippling(AClip: TClip): Boolean;
  protected
    procedure Paint; override;
    procedure DragOver(Source: TObject; X, Y: Integer; State: TDragState;
      var Accept: Boolean); override;
    procedure DragDrop(Source: TObject; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    { Показать весь проект целиком. }
    procedure ZoomToFit;
    procedure ZoomAt(const AFactor: Double; AAnchorX: Integer);

    { Подвинуть окно просмотра так, чтобы курсор воспроизведения был виден.

      ACenter — держать его строго посередине. Так удобно при
      воспроизведении: изображение едет, а курсор стоит на месте.
      Без ACenter окно двигается только когда курсор ушёл за край. }
    procedure ScrollToPlayhead(ACenter: Boolean);

    { Начало самого раннего и конец самого позднего клипа по всем дорожкам. }
    function FirstClipTime: Double;
    function LastClipTime: Double;

    { Перевод координат для тех, кто снаружи: например, чтобы понять,
      куда бросили файл. Номер дорожки минус один означает «ниже всех». }
    function TrackIndexAtPoint(const AY: Integer): Integer;
    function TimeAtPoint(const AX: Integer): Double;

    { Разрезать клипы под курсором воспроизведения.

      APrecise помечает новые края как требующие точного реза: при сборке
      огрызок до опорного кадра будет перекодирован. Без этого рез
      притянется к опорному кадру, и точка съедет на величину до
      расстояния между опорными кадрами. }
    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;

    { Номер дорожки под указателем мыши, минус один если ни одной. }
    property HoverTrack: Integer read FHoverTrack;
    { Дорожка, выбранная щелчком по заголовку. }
    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;
    property TrackHeight: Integer read FTrackHeight write FTrackHeight;

    property OnPlayheadChange: TNotifyEvent read FOnPlayheadChange
      write FOnPlayheadChange;
    property OnStructureChange: TNotifyEvent read FOnStructureChange
      write FOnStructureChange;
    property OnSelectionChange: TNotifyEvent read FOnSelectionChange
      write FOnSelectionChange;
    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
      write FOnActiveTrackChange;
  end;

implementation

const
  { Ширина зоны у края клипа, где курсор берётся за растягивание. }
  EdgeGrabPixels = 6;

  { На сколько пикселей примагничиваются края при перетаскивании. }
  SnapPixels = 8;

  { Сдвиг мыши, до которого нажатие считается щелчком, а не перетаскиванием.
    Совсем без запаса нельзя: рука дрожит, и попасть кнопкой в один и тот же
    пиксель мало кому удаётся. }
  ClickSlopPixels = 4;

  { Наибольшая громкость клипа. Двойка, а не что-то большее: дальше
    начинаются искажения, и толку от такой прибавки мало. }
  MaxClipVolume = 2.0;

  { Размеры ручки громкости и кнопок в заголовке дорожки. }
  VolumeHandleWidth = 30;
  VolumeHandleHeight = 9;
  HeaderButtonSize = 20;
  HeaderButtonGap = 4;

  MinPixelsPerSecond = 0.01;
  MaxPixelsPerSecond = 4000;

  { Шаг увеличения на один щелчок колеса. }
  ZoomStep = 1.25;

  { Возможные шаги делений линейки в секундах. Ниже секунды идут доли,
    выше — привычные отрезки времени, а не круглые числа: делить час
    на 16 частей неудобно читать. }
  RulerSteps: array[0..17] of Double = (
    0.04, 0.1, 0.2, 0.5, 1, 2, 5, 10, 15, 30,
    60, 120, 300, 600, 900, 1800, 3600, 7200);

  { Меньше этого расстояния деления сливаются в кашу. }
  MinTickPixels = 70;

  { Внимание на порядок байт: TColor хранит цвет как $00BBGGRR, то есть
    синий в старшем байте, а не красный. Записанный как привычный RGB
    код даст цвет с переставленными местами красным и синим — ошибка
    незаметная в отладчике и очевидная на экране. Ниже указаны значения
    уже в порядке TColor, а в скобках — что это за цвет на самом деле. }
  ColorBack = TColor($1E1E1E);          // тёмно-серый фон
  ColorRuler = TColor($2A2A2A);         // линейка
  ColorRulerText = TColor($C8C8C8);     // подписи делений
  ColorHeader = TColor($262626);        // полоса с названиями дорожек
  ColorTrackOdd = TColor($232323);
  ColorTrackEven = TColor($1F1F1F);
  ColorGrid = TColor($3A3A3A);          // разделители
  ColorClip = TColor($2A4A6B);          // тёплый коричневый: обычный клип
  ColorClipImage = TColor($4A5A2A);     // приглушённый зелёный: картинка
  ColorClipSelected = TColor($38608A);  // тот же коричневый, но светлее
  ColorClipBorder = TColor($5080AA);    // светлая рамка клипа
  ColorClipText = TColor($F0F0F0);
  ColorPlayhead = TColor($4040FF);      // красный: привычный цвет курсора
  ColorRegion = TColor($30A0D0);        // отмеченный участок: янтарная полоса
  ColorRegionEdge = TColor($1878B0);
  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);        // красный: дорожка выключена
  ColorSoloOn = TColor($40C0D0);        // жёлтый: дорожка солирует

{ --- Создание --- }

constructor TTimelineControl.Create(AOwner: TComponent);
begin
  FWaveGain := 1;
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  TabStop := True;
  FBuffer := TBitmap.Create;
  FBuffer.PixelFormat := pf32bit;

  FPixelsPerSecond := 20;
  FScrollOffset := 0;
  FTrackHeight := 64;
  FRulerHeight := 28;
  { Шире, чем раньше: в заголовке теперь живут название, число клипов и
    кнопки выключения и «соло». }
  FHeaderWidth := 150;
  FHoverTrack := -1;
  FActiveTrack := 0;
  FSnapEnabled := True;
  FPlayheadSnap := True;
end;

destructor TTimelineControl.Destroy;
begin
  FBuffer.Free;
  inherited Destroy;
end;

{ --- Координаты --- }

function TTimelineControl.GetVisibleWidth: Integer;
begin
  Result := Max(1, ClientWidth - FHeaderWidth);
end;

function TTimelineControl.TimeToX(const ATime: Double): Integer;
begin
  Result := FHeaderWidth + Round((ATime - FScrollOffset) * FPixelsPerSecond);
end;

function TTimelineControl.XToTime(const AX: Integer): Double;
begin
  if FPixelsPerSecond <= 0 then
    Exit(FScrollOffset);
  Result := FScrollOffset + (AX - FHeaderWidth) / FPixelsPerSecond;
end;

function TTimelineControl.TrackTop(AIndex: Integer): Integer;
begin
  Result := FRulerHeight + AIndex * FTrackHeight - FScrollY;
end;

{ Нижняя граница последней дорожки на экране. Ниже неё начинается пустое
  место, куда можно бросить клип, чтобы завести новую дорожку. }
function TTimelineControl.TracksBottom: Integer;
begin
  if FProject = nil then
    Exit(FRulerHeight);
  Result := TrackTop(FProject.TrackCount - 1) + FTrackHeight;
end;

function TTimelineControl.TrackIndexAt(const AY: Integer): Integer;
begin
  if (FProject = nil) or (AY < FRulerHeight) then
    Exit(-1);
  Result := (AY - FRulerHeight + FScrollY) div FTrackHeight;
  if (Result < 0) or (Result >= FProject.TrackCount) then
    Result := -1;
end;

procedure TTimelineControl.ClampScrollY;
var
  Content, View, MaxY: Integer;
begin
  if FProject = nil then
  begin
    FScrollY := 0;
    Exit;
  end;
  Content := FProject.TrackCount * FTrackHeight;
  View := Max(1, ClientHeight - FRulerHeight);
  { Оставляем полдорожки запаса снизу: туда бросают клип, чтобы завести
    новую дорожку, и до этого места надо иметь возможность доскроллить. }
  MaxY := Max(0, Content - View + FTrackHeight div 2);
  if FScrollY > MaxY then
    FScrollY := MaxY;
  if FScrollY < 0 then
    FScrollY := 0;
end;

function TTimelineControl.ClipAtPoint(const AX, AY: Integer;
  out ATrack: TTrack): TClip;
var
  Idx: Integer;
begin
  ATrack := nil;
  Result := nil;
  if (FProject = nil) or (AX < FHeaderWidth) then
    Exit;
  Idx := TrackIndexAt(AY);
  if Idx < 0 then
    Exit;
  ATrack := FProject.Tracks[Idx];
  Result := ATrack.ClipAt(XToTime(AX));
end;

{ Минус один — левый край, плюс один — правый, ноль — середина. }
function TTimelineControl.EdgeAtPoint(const AX: Integer; AClip: TClip): Integer;
var
  L, R: Integer;
begin
  Result := 0;
  if AClip = nil then
    Exit;
  L := TimeToX(AClip.TlStart);
  R := TimeToX(AClip.TlEnd);
  { Узкий клип не должен состоять из одних краёв: иначе его нельзя
    будет перенести. }
  if R - L < EdgeGrabPixels * 3 then
    Exit;
  if Abs(AX - L) <= EdgeGrabPixels then
    Result := -1
  else if Abs(AX - R) <= EdgeGrabPixels then
    Result := 1;
end;

{ Кнопки выключения и «соло» стоят в правой части заголовка, одна под
  другой возле нижнего края. }
function TTimelineControl.HeaderPartAt(const AX, AY: Integer;
  out ATrackIndex: Integer): THeaderPart;
var
  RowTop, BtnTop, BtnLeft: Integer;
begin
  Result := hpNone;
  ATrackIndex := -1;
  if (FProject = nil) or (AX >= FHeaderWidth) or (AY < FRulerHeight) then
    Exit;

  ATrackIndex := TrackIndexAt(AY);
  if ATrackIndex < 0 then
    Exit;

  Result := hpBody;
  RowTop := TrackTop(ATrackIndex);
  BtnTop := RowTop + FTrackHeight - HeaderButtonSize - 6;
  if (AY < BtnTop) or (AY > BtnTop + HeaderButtonSize) then
    Exit;

  BtnLeft := FHeaderWidth - 2 * HeaderButtonSize - HeaderButtonGap - 8;
  if (AX >= BtnLeft) and (AX < BtnLeft + HeaderButtonSize) then
    Result := hpMute
  else if (AX >= BtnLeft + HeaderButtonSize + HeaderButtonGap) and
          (AX < BtnLeft + 2 * HeaderButtonSize + HeaderButtonGap) then
    Result := hpSolo;
end;

{ Громкость откладывается по высоте клипа: полная тишина внизу, двойная
  громкость вверху, обычная ровно посередине. }
function TTimelineControl.VolumeToY(const AVolume: Double; ATop: Integer): Integer;
var
  BodyTop, BodyHeight: Integer;
  V: Double;
begin
  BodyTop := ATop + 3;
  BodyHeight := FTrackHeight - 6;
  V := AVolume;
  if V < 0 then
    V := 0;
  if V > MaxClipVolume then
    V := MaxClipVolume;
  Result := BodyTop + Round((1 - V / MaxClipVolume) * BodyHeight);
end;

function TTimelineControl.YToVolume(const AY: Integer; ATop: Integer): Double;
var
  BodyTop, BodyHeight: Integer;
begin
  BodyTop := ATop + 3;
  BodyHeight := FTrackHeight - 6;
  if BodyHeight <= 0 then
    Exit(1);
  Result := (1 - (AY - BodyTop) / BodyHeight) * MaxClipVolume;
  if Result < 0 then
    Result := 0;
  if Result > MaxClipVolume then
    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;
begin
  Result := Rect(0, 0, 0, 0);
  if AClip = nil 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;
  if R - L < VolumeHandleWidth then
    Exit;

  CenterX := (L + R) div 2;
  Y := VolumeToY(ClipLevel(AClip), ATop);
  Result := Rect(CenterX - VolumeHandleWidth div 2, Y - VolumeHandleHeight div 2,
    CenterX + VolumeHandleWidth div 2, Y + VolumeHandleHeight div 2);
end;

function TTimelineControl.MediaDurationOf(AClip: TClip): Double;
var
  Item: TMediaItem;
begin
  Result := 0;
  if (FProject = nil) or (AClip = nil) then
    Exit;
  Item := FProject.FindMedia(AClip.MediaId);
  if Item = nil then
    Exit;
  Result := Item.Info.Duration;
end;

{ --- Отрисовка --- }

procedure TTimelineControl.Paint;
begin
  if (FBuffer.Width <> ClientWidth) or (FBuffer.Height <> ClientHeight) then
    FBuffer.SetSize(Max(1, ClientWidth), Max(1, ClientHeight));

  FBuffer.Canvas.Brush.Color := ColorBack;
  FBuffer.Canvas.FillRect(0, 0, FBuffer.Width, FBuffer.Height);

  DrawTracks(FBuffer.Canvas);
  { Отметка занятого участка идёт после клипов и до линейки: она должна
    лежать поверх клипов, но не наползать на подписи времени. }
  DrawBusyRange(FBuffer.Canvas);
  DrawRuler(FBuffer.Canvas);
  DrawHeaders(FBuffer.Canvas);
  DrawPlayhead(FBuffer.Canvas);

  Canvas.Draw(0, 0, FBuffer);
end;

{ Подпись деления. Ниже секунды показываются доли, выше — часы и минуты. }
function TickLabel(const ATime, AStep: Double): string;
var
  Total, H, M, S: Integer;
begin
  Total := Trunc(ATime);
  H := Total div 3600;
  M := (Total mod 3600) div 60;
  S := Total mod 60;
  if AStep < 1 then
    Result := Format('%.2d:%.2d.%.2d', [M, S, Round(Frac(ATime) * 100)])
  else if H > 0 then
    Result := Format('%d:%.2d:%.2d', [H, M, S])
  else
    Result := Format('%.2d:%.2d', [M, S]);
end;

procedure TTimelineControl.DrawRuler(ACanvas: TCanvas);
var
  I, X: Integer;
  Step, T, TFirst, TLast: Double;
begin
  ACanvas.Brush.Color := ColorRuler;
  ACanvas.FillRect(0, 0, ClientWidth, FRulerHeight);

  ACanvas.Pen.Color := ColorGrid;
  ACanvas.Line(0, FRulerHeight - 1, ClientWidth, FRulerHeight - 1);

  { Подбираем самый мелкий шаг, при котором деления ещё не слипаются. }
  Step := RulerSteps[High(RulerSteps)];
  for I := 0 to High(RulerSteps) do
    if RulerSteps[I] * FPixelsPerSecond >= MinTickPixels then
    begin
      Step := RulerSteps[I];
      Break;
    end;

  TFirst := XToTime(FHeaderWidth);
  TLast := XToTime(ClientWidth);
  if TFirst < 0 then
    TFirst := 0;

  ACanvas.Font.Color := ColorRulerText;
  ACanvas.Font.Height := -11;
  ACanvas.Brush.Style := bsClear;

  T := Int(TFirst / Step) * Step;
  while T <= TLast do
  begin
    X := TimeToX(T);
    if X >= FHeaderWidth then
    begin
      ACanvas.Pen.Color := ColorGrid;
      ACanvas.Line(X, FRulerHeight - 8, X, FRulerHeight - 1);
      ACanvas.TextOut(X + 3, 4, TickLabel(T, Step));
    end;
    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);
end;

procedure TTimelineControl.DrawClip(ACanvas: TCanvas; AClip: TClip;
  ATop: Integer);
var
  L, R, W, I: Integer;
  Item: TMediaItem;
  { Не Caption и не Top: эти имена заняты свойствами TControl, и локальная
    переменная их перекроет. Компилятор ловит, но сообщение неочевидное. }
  ClipCaption: string;
  Body: TRect;
begin
  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;
  if R <= L then
    R := L + 1;

  Body := Rect(L, ATop + 3, R, ATop + FTrackHeight - 3);

  if AClip.Selected then
    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);

  ACanvas.Pen.Color := ColorClipBorder;
  ACanvas.Brush.Style := bsClear;
  ACanvas.Rectangle(Body);

  { Полоски на краях показывают, притянут рез к опорному кадру или
    потребует перекодирования. Без этого непонятно, где сборка будет
    быстрой, а где нет. }
  W := R - L;
  if W > 6 then
  begin
    if AClip.EdgeIn = edPrecise then
      ACanvas.Brush.Color := ColorEdgePrecise
    else
      ACanvas.Brush.Color := ColorEdgeSnap;
    ACanvas.Brush.Style := bsSolid;
    ACanvas.FillRect(Body.Left + 1, Body.Top + 1, Body.Left + 4, Body.Bottom - 1);

    if AClip.EdgeOut = edPrecise then
      ACanvas.Brush.Color := ColorEdgePrecise
    else
      ACanvas.Brush.Color := ColorEdgeSnap;
    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);

  if W > 40 then
  begin
    Item := nil;
    if FProject <> nil then
      Item := FProject.FindMedia(AClip.MediaId);
    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 := '(нет файла)';

    ACanvas.Brush.Style := bsClear;
    ACanvas.Font.Color := ColorClipText;
    ACanvas.Font.Height := -11;
    ACanvas.TextOut(Body.Left + 7, Body.Top + 4, ClipCaption);
    ACanvas.TextOut(Body.Left + 7, Body.Top + 20,
      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;

{ Линия громкости с ручкой посередине видимой части клипа.

  Сделано как в монтажных программах: линия показывает уровень, за ручку
  её тянут вверх и вниз. Смысл линии, а не числа, в том, что уровень
  сразу виден у всех клипов разом. }
procedure TTimelineControl.DrawVolume(ACanvas: TCanvas; AClip: TClip;
  ATop: Integer; const ABody: TRect);
var
  Y: Integer;
  H: TRect;
  { Не Caption и не Handle: оба имени заняты у предков. }
  VolText: string;
begin
  if AClip.Kind = ckBlack then
    Exit;
  if ABody.Right - ABody.Left < 12 then
    Exit;

  Y := VolumeToY(ClipLevel(AClip), ATop);
  if (Y <= ABody.Top) then
    Y := ABody.Top + 1;
  if (Y >= ABody.Bottom) then
    Y := ABody.Bottom - 1;

  ACanvas.Pen.Color := ColorVolumeLine;
  ACanvas.Pen.Width := 1;
  ACanvas.Line(ABody.Left + 1, Y, ABody.Right - 1, Y);

  H := VolumeHandleRect(AClip, ATop);
  if H.Right <= H.Left then
    Exit;

  ACanvas.Brush.Color := ColorVolumeHandle;
  ACanvas.Brush.Style := bsSolid;
  ACanvas.Pen.Color := ColorClipText;
  ACanvas.Rectangle(H);

  { Значение подписываем только когда клип достаточно широк, иначе
    надпись налезет на соседние. }
  if ABody.Right - ABody.Left > 130 then
  begin
    VolText := IntToStr(Round(ClipLevel(AClip) * 100)) + '%';
    ACanvas.Brush.Style := bsClear;
    ACanvas.Font.Color := ColorVolumeLine;
    ACanvas.Font.Height := -10;
    ACanvas.TextOut(H.Right + 6, Y - 7, VolText);
    ACanvas.Brush.Style := bsSolid;
  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;
  Track: TTrack;
begin
  if FProject = nil then
    Exit;

  for T := 0 to FProject.TrackCount - 1 do
  begin
    RowTop := TrackTop(T);
    if RowTop > ClientHeight then
      Break;
    { Дорожки, уехавшие вверх за линейку, рисовать не нужно. }
    if RowTop + FTrackHeight < FRulerHeight then
      Continue;

    if Odd(T) then
      ACanvas.Brush.Color := ColorTrackOdd
    else
      ACanvas.Brush.Color := ColorTrackEven;
    ACanvas.FillRect(FHeaderWidth, RowTop, ClientWidth, RowTop + FTrackHeight);

    ACanvas.Pen.Color := ColorGrid;
    ACanvas.Line(FHeaderWidth, RowTop + FTrackHeight - 1,
      ClientWidth, RowTop + FTrackHeight - 1);

    Track := FProject.Tracks[T];
    for C := 0 to Track.Count - 1 do
      DrawClip(ACanvas, Track[C], RowTop);
    { Перекрытия рисуются поверх клипов: крест должен быть виден на обоих
      сразу, иначе непонятно, какие именно куски переходят друг в друга. }
    DrawOverlaps(ACanvas, Track, RowTop);
  end;
end;

procedure TTimelineControl.DrawHeaders(ACanvas: TCanvas);
var
  T, RowTop, BtnTop, BtnLeft: Integer;
  Track: TTrack;

  { Маленькая кнопка с буквой. Цвет заливки показывает состояние. }
  procedure Button(ALeft, ATop: Integer; const ACaption: string;
    AOn: Boolean; AOnColor: TColor);
  var
    R: TRect;
    TextX: Integer;
  begin
    R := Rect(ALeft, ATop, ALeft + HeaderButtonSize, ATop + HeaderButtonSize);
    if AOn then
      ACanvas.Brush.Color := AOnColor
    else
      ACanvas.Brush.Color := ColorButtonOff;
    ACanvas.Brush.Style := bsSolid;
    ACanvas.Pen.Color := ColorGrid;
    ACanvas.Rectangle(R);

    ACanvas.Brush.Style := bsClear;
    if AOn then
      ACanvas.Font.Color := clBlack
    else
      ACanvas.Font.Color := ColorRulerText;
    ACanvas.Font.Height := -12;
    TextX := ALeft + (HeaderButtonSize - ACanvas.TextWidth(ACaption)) div 2;
    ACanvas.TextOut(TextX, ATop + 2, ACaption);
    ACanvas.Brush.Style := bsSolid;
  end;

begin
  ACanvas.Brush.Color := ColorHeader;
  ACanvas.FillRect(0, 0, FHeaderWidth, ClientHeight);
  ACanvas.Pen.Color := ColorGrid;
  ACanvas.Line(FHeaderWidth - 1, 0, FHeaderWidth - 1, ClientHeight);

  if FProject = nil then
    Exit;

  for T := 0 to FProject.TrackCount - 1 do
  begin
    RowTop := TrackTop(T);
    if RowTop > ClientHeight then
      Break;
    if RowTop + FTrackHeight < FRulerHeight then
      Continue;
    Track := FProject.Tracks[T];

    { Выбранная дорожка подсвечена: именно на неё кладётся файл кнопкой. }
    if T = FActiveTrack then
    begin
      ACanvas.Brush.Color := ColorHeaderActive;
      ACanvas.FillRect(0, RowTop, FHeaderWidth - 1, RowTop + FTrackHeight - 1);
      ACanvas.Brush.Color := ColorEdgePrecise;
      ACanvas.FillRect(0, RowTop, 3, RowTop + FTrackHeight - 1);
    end;

    ACanvas.Pen.Color := ColorGrid;
    ACanvas.Line(0, RowTop + FTrackHeight - 1, FHeaderWidth,
      RowTop + FTrackHeight - 1);

    ACanvas.Brush.Style := bsClear;
    if FProject.TrackAudible(Track) then
      ACanvas.Font.Color := ColorRulerText
    else
      ACanvas.Font.Color := clGray;
    ACanvas.Font.Height := -12;
    ACanvas.Font.Style := [fsBold];
    ACanvas.TextOut(8, RowTop + 6, Track.Name);
    ACanvas.Font.Style := [];

    ACanvas.Font.Color := clGray;
    ACanvas.Font.Height := -10;
    if T = 0 then
      ACanvas.TextOut(8, RowTop + 24,
        IntToStr(Track.Count) + ' кл.  верх')
    else
      ACanvas.TextOut(8, RowTop + 24, IntToStr(Track.Count) + ' кл.');
    ACanvas.Brush.Style := bsSolid;

    BtnTop := RowTop + FTrackHeight - HeaderButtonSize - 6;
    BtnLeft := FHeaderWidth - 2 * HeaderButtonSize - HeaderButtonGap - 8;
    { М — выключить дорожку целиком, С — слушать только её. }
    Button(BtnLeft, BtnTop, 'М', Track.Muted, ColorMuteOn);
    Button(BtnLeft + HeaderButtonSize + HeaderButtonGap, BtnTop, 'С',
      Track.Solo, ColorSoloOn);
  end;

  ACanvas.Brush.Style := bsSolid;
end;

procedure TTimelineControl.DrawPlayhead(ACanvas: TCanvas);
var
  X: Integer;
begin
  X := TimeToX(FPlayhead);
  if (X < FHeaderWidth) or (X > ClientWidth) then
    Exit;
  ACanvas.Pen.Color := ColorPlayhead;
  ACanvas.Pen.Width := 1;
  ACanvas.Line(X, 0, X, ClientHeight);

  { Треугольник-указатель на линейке: тонкую линию трудно поймать мышью. }
  ACanvas.Brush.Color := ColorPlayhead;
  ACanvas.Polygon([Point(X - 5, 0), Point(X + 5, 0), Point(X, 9)]);
end;

{ --- Масштаб и прокрутка --- }

procedure TTimelineControl.SetPixelsPerSecond(const AValue: Double);
begin
  FPixelsPerSecond := Min(MaxPixelsPerSecond, Max(MinPixelsPerSecond, AValue));
  ClampScroll;
  Invalidate;
end;

procedure TTimelineControl.ClampScroll;
var
  MaxTime: Double;
begin
  if FScrollOffset < 0 then
    FScrollOffset := 0;
  if FProject = nil then
    Exit;
  { Уехать правее конца монтажа можно, но не бесконечно: иначе прокрутка
    теряет смысл. Оставляем один экран запаса. }
  MaxTime := FProject.EndTime;
  if FScrollOffset > MaxTime then
    FScrollOffset := Max(0, MaxTime);
end;

procedure TTimelineControl.ZoomAt(const AFactor: Double; AAnchorX: Integer);
var
  TimeAtAnchor: Double;
begin
  { Смысл этих трёх строк: запомнить, какое время под курсором, поменять
    масштаб, затем подобрать сдвиг так, чтобы это время снова оказалось
    под курсором. }
  TimeAtAnchor := XToTime(AAnchorX);
  FPixelsPerSecond := Min(MaxPixelsPerSecond,
    Max(MinPixelsPerSecond, FPixelsPerSecond * AFactor));
  FScrollOffset := TimeAtAnchor - (AAnchorX - FHeaderWidth) / FPixelsPerSecond;
  ClampScroll;
  Invalidate;
end;

procedure TTimelineControl.ZoomToFit;
var
  Total: Double;
begin
  if FProject = nil then
    Exit;
  Total := FProject.EndTime;
  if Total <= 0 then
    Total := 60;
  FScrollOffset := 0;
  FPixelsPerSecond := Min(MaxPixelsPerSecond,
    Max(MinPixelsPerSecond, GetVisibleWidth / (Total * 1.05)));
  Invalidate;
end;

procedure TTimelineControl.ScrollToPlayhead(ACenter: Boolean);
var
  Span, Target, Old: Double;
begin
  if FPixelsPerSecond <= 0 then
    Exit;
  Span := GetVisibleWidth / FPixelsPerSecond;
  Old := FScrollOffset;

  if ACenter then
    Target := FPlayhead - Span / 2
  else
  begin
    { Курсор внутри видимой части — двигать нечего. }
    if (FPlayhead >= FScrollOffset) and (FPlayhead <= FScrollOffset + Span) then
      Exit;
    { Ушёл за край — показываем его посередине, а не впритык: так видно,
      что происходит и до, и после. }
    Target := FPlayhead - Span / 2;
  end;

  if Target < 0 then
    Target := 0;

  { Перерисовываем только при заметном сдвиге: при воспроизведении этот
    метод зовётся на каждый кадр. }
  if Abs(Target - Old) * FPixelsPerSecond < 1 then
    Exit;

  FScrollOffset := Target;
  Invalidate;
end;

function TTimelineControl.TrackIndexAtPoint(const AY: Integer): Integer;
begin
  Result := TrackIndexAt(AY);
end;

function TTimelineControl.TimeAtPoint(const AX: Integer): Double;
begin
  Result := Max(0, XToTime(AX));
end;

function TTimelineControl.FirstClipTime: Double;
var
  T, C: Integer;
  Found: Boolean;
begin
  Result := 0;
  Found := False;
  if FProject = nil then
    Exit;
  for T := 0 to FProject.TrackCount - 1 do
    for C := 0 to FProject.Tracks[T].Count - 1 do
      if (not Found) or (FProject.Tracks[T][C].TlStart < Result) then
      begin
        Result := FProject.Tracks[T][C].TlStart;
        Found := True;
      end;
  if not Found then
    Result := 0;
end;

function TTimelineControl.LastClipTime: Double;
begin
  Result := 0;
  if FProject <> nil then
    Result := FProject.EndTime;
end;

procedure TTimelineControl.SetPlayhead(const AValue: Double);
begin
  if FPlayhead = AValue then
    Exit;
  FPlayhead := Max(0, AValue);
  Invalidate;
  if Assigned(FOnPlayheadChange) then
    FOnPlayheadChange(Self);
end;

procedure TTimelineControl.StructureChanged;
begin
  Invalidate;
  if Assigned(FOnStructureChange) then
    FOnStructureChange(Self);
end;

{ Примагничивание к краям соседних клипов и к курсору воспроизведения. }
function TTimelineControl.SnapTime(const ATime: Double; AExclude: TClip): 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 FSnapEnabled = FSnapSuspended then
    Exit;

  Tolerance := SnapPixels / FPixelsPerSecond;
  BestDist := Tolerance;
  Best := ATime;

  Consider(0);
  Consider(FPlayhead);

  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];
      if Clip = AExclude then
        Continue;
      { Клипы, которые едут вместе с перетаскиваемым, притягивать нельзя:
        они движутся синхронно с ним, и примагничивание к ним заставило бы
        клип цепляться за собственное следствие. }
      if IsRippling(Clip) then
        Continue;
      Consider(Clip.TlStart);
      Consider(Clip.TlEnd);
    end;
  end;

  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;
  X, Y: Integer);
var
  Track: TTrack;
  Clip: TClip;
  Edge, Idx: Integer;
  Part: THeaderPart;
  VolHandle: TRect;
  CropRect: TRect;
  FadeHandle: TRect;
begin
  inherited MouseDown(Button, Shift, X, Y);
  SetFocus;
  FSnapSuspended := ssShift in Shift;

  if Button = mbMiddle then
  begin
    FAction := taPan;
    FPanOriginX := X;
    FPanOriginY := Y;
    FPanOriginTime := FScrollOffset;
    FPanOriginScrollY := FScrollY;
    Exit;
  end;

  if Button <> mbLeft then
    Exit;

  { Полоса заголовков: выбор дорожки и её кнопки. }
  if X < FHeaderWidth then
  begin
    Part := HeaderPartAt(X, Y, Idx);
    if Idx < 0 then
      Exit;
    case Part of
      hpMute:
        begin
          FProject.BeginChange;
          FProject.Tracks[Idx].Muted := not FProject.Tracks[Idx].Muted;
          StructureChanged;
        end;
      hpSolo:
        begin
          FProject.BeginChange;
          FProject.Tracks[Idx].Solo := not FProject.Tracks[Idx].Solo;
          StructureChanged;
        end;
      hpBody:
        begin
          FActiveTrack := Idx;
          Invalidate;
          if Assigned(FOnActiveTrackChange) then
            FOnActiveTrackChange(Self);
        end;
    end;
    Exit;
  end;

  { Щелчок по линейке ставит курсор воспроизведения. }
  if Y < FRulerHeight then
  begin
    FAction := taScrub;
    Playhead := Max(0, SnapPlayhead(XToTime(X)));
    Exit;
  end;

  Clip := ClipAtPoint(X, Y, Track);

  if Clip = nil then
  begin
    { По пустому месту дорожки — тоже ставим курсор: так удобнее, чем
      тянуться к линейке. }
    if not (ssCtrl in Shift) then
    begin
      FProject.ClearSelection;
      if Assigned(FOnSelectionChange) then
        FOnSelectionChange(Self);
    end;
    FAction := taScrub;
    Playhead := Max(0, SnapPlayhead(XToTime(X)));
    Exit;
  end;

  if not (ssCtrl in Shift) then
    if not Clip.Selected then
      FProject.ClearSelection;
  Clip.Selected := True;
  if Assigned(FOnSelectionChange) then
    FOnSelectionChange(Self);

  FDragClip := Clip;
  FDragTrack := Track;
  { Клипы связки поедут следом. Список составляется один раз при нажатии:
    пересчитывать его на каждое движение нельзя — они уже сдвинулись. }
  CollectGroupClips(Clip);
  FDragOrigStart := Clip.TlStart;
  FDragOrigSrcIn := Clip.SrcIn;
  FDragOrigDuration := Clip.Duration;
  FTrackAddedDuringDrag := False;

  { Ручка громкости имеет приоритет над переносом клипа: она мелкая, и
    промахнуться мимо неё легче, чем мимо всего клипа. }
  { Кнопка кадрирования перехватывает щелчок раньше всех: иначе клип
    успеет выделиться и поехать за мышью. }
  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);

  if (Clip.Kind <> ckBlack) and (X >= VolHandle.Left) and (X <= VolHandle.Right) and
     (Y >= VolHandle.Top - 3) and (Y <= VolHandle.Bottom + 3) then
  begin
    FAction := taVolume;
    FDragOrigVolume := ClipLevel(Clip);
  end
  else
    case Edge of
      -1: FAction := taTrimIn;
       1: FAction := taTrimOut;
    else
      begin
        FAction := taDragClip;
        FDragGrabOffset := XToTime(X) - Clip.TlStart;
      end;
    end;

  { Автосхлопывание: составляем список того, что поедет вслед за клипом.

    Список берётся один раз, при нажатии, и хранит исходные позиции.
    Пересчитывать его на каждое движение мыши нельзя: туда начали бы
    попадать клипы, которые уже сдвинулись. }
  FRippleClips := nil;
  FRippleOrigStarts := nil;
  if (FAction = taDragClip) and FProject.RippleEnabled then
    CollectRippleClips(TrackIndexAt(Y), Clip, Clip.TlStart);

  { Курсор воспроизведения здесь не трогаем. Нажатие на клип — это ещё
    не щелчок: с него может начаться перетаскивание, и дёргать курсор в
    начале каждого переноса неправильно, особенно во время
    воспроизведения. Решение принимается при отпускании кнопки. }
  FPressX := X;
  FPressY := Y;
  FMovedWhileDown := False;

  FProject.BeginChange;
  Invalidate;
end;

procedure TTimelineControl.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewStart, NewEnd, Delta, MediaLen: Double;
  Edge, Idx: Integer;
  Clip: TClip;
  Track, TargetTrack: TTrack;
  VolHandle: TRect;
begin
  inherited MouseMove(Shift, X, Y);
  VolHandle := Rect(0, 0, 0, 0);
  FSnapSuspended := ssShift in Shift;

  Idx := TrackIndexAt(Y);
  if Idx <> FHoverTrack then
  begin
    FHoverTrack := Idx;
    Invalidate;
  end;

  if (FAction in [taDragClip, taTrimIn, taTrimOut, taVolume]) and
     (not FMovedWhileDown) then
    if (Abs(X - FPressX) > ClickSlopPixels) or
       (Abs(Y - FPressY) > ClickSlopPixels) then
      FMovedWhileDown := True;

  { Курсор мыши подсказывает, что произойдёт при нажатии. }
  if FAction = taNone then
  begin
    Clip := ClipAtPoint(X, Y, Track);
    Edge := EdgeAtPoint(X, Clip);
    if (Clip <> nil) and (Idx >= 0) then
      VolHandle := VolumeHandleRect(Clip, TrackTop(Idx));
    if (Clip <> nil) and (Clip.Kind <> ckBlack) and
       (X >= VolHandle.Left) and (X <= VolHandle.Right) and
       (Y >= VolHandle.Top - 3) and (Y <= VolHandle.Bottom + 3) then
      Cursor := crSizeNS
    else if Edge <> 0 then
      Cursor := crSizeWE
    else if Clip <> nil then
      Cursor := crHandPoint
    else
      Cursor := crDefault;
    Exit;
  end;

  case FAction of
    taPan:
      begin
        FScrollOffset := FPanOriginTime - (X - FPanOriginX) / FPixelsPerSecond;
        FScrollY := FPanOriginScrollY - (Y - FPanOriginY);
        ClampScroll;
        ClampScrollY;
        Invalidate;
      end;

    taScrub:
      { Протяжка прилипает так же, как щелчок: иначе курсор, поставленный
        на стык, соскакивал бы с него от малейшего движения мыши. }
      Playhead := Max(0, SnapPlayhead(XToTime(X)));

    taVolume:
      if FDragClip <> nil then
      begin
        Idx := TrackIndexAt(FPressY);
        if Idx >= 0 then
        begin
          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.TrackCountOf(tkVideo) + 1));
          FTrackAddedDuringDrag := True;
          Idx := FProject.TrackCount - 1;
          if Assigned(FOnTrackAdded) then
            FOnTrackAdded(Self);
        end;

        { Перенос на другую дорожку: клип следует за указателем по
          вертикали. Именно перенос, а не копирование. }
        if (Idx >= 0) and (FProject <> nil) then
        begin
          TargetTrack := FProject.Tracks[Idx];
          if TargetTrack <> FDragTrack then
          begin
            FDragTrack.Extract(FDragClip);
            TargetTrack.Add(FDragClip);
            FDragTrack := TargetTrack;
          end;
        end;

        FDragTrack.Sort;
        Invalidate;
      end;

    taTrimIn:
      if FDragClip <> nil then
      begin
        NewStart := SnapTime(XToTime(X), FDragClip);
        { Правый край стоит на месте, двигается левый: меняются и позиция
          на монтаже, и то, с какого места берётся материал. }
        Delta := NewStart - FDragOrigStart;

        { Дальше начала исходника уйти нельзя — материала там нет.
          Для картинки такого ограничения нет: она тянется сколько угодно. }
        if FDragClip.Kind <> ckImage then
          if FDragOrigSrcIn + Delta < 0 then
            Delta := -FDragOrigSrcIn;

        { Клип не может стать короче, чем ничего. }
        if FDragOrigDuration - Delta < 0.04 then
          Delta := FDragOrigDuration - 0.04;

        FDragClip.TlStart := Max(0, FDragOrigStart + Delta);
        if FDragClip.Kind <> ckImage then
          FDragClip.SrcIn := FDragOrigSrcIn + Delta;
        FDragClip.Duration := FDragOrigDuration - Delta;
        Invalidate;
      end;

    taTrimOut:
      if FDragClip <> nil then
      begin
        NewEnd := SnapTime(XToTime(X), FDragClip);
        Delta := NewEnd - (FDragOrigStart + FDragOrigDuration);

        MediaLen := MediaDurationOf(FDragClip);
        if (FDragClip.Kind <> ckImage) and (MediaLen > 0) then
          if FDragOrigSrcIn + FDragOrigDuration + Delta > MediaLen then
            Delta := MediaLen - FDragOrigSrcIn - FDragOrigDuration;

        if FDragOrigDuration + Delta < 0.04 then
          Delta := 0.04 - FDragOrigDuration;

        FDragClip.Duration := FDragOrigDuration + Delta;
        Invalidate;
      end;
  end;
end;

{ Левый край клипа определяет, откуда копировать материал, а копировать
  можно только с опорного кадра. Если человек подвинул край руками и попал
  между опорными кадрами, значит ему нужен именно этот кадр — помечаем рез
  точным, и при сборке перекодируется огрызок до следующего опорного кадра.
  Попал на опорный — перекодировать нечего.

  Правого края это не касается: при копировании потока он и так выходит
  кадроточным. }
procedure TTimelineControl.UpdateEdgePrecision(AClip: TClip);
var
  Item: TMediaItem;
  Index: TKeyframeIndex;
  Err: string;
  Snapped: Double;
begin
  if (FProject = nil) or (AClip = nil) then
    Exit;
  if AClip.Kind <> ckVideo then
    Exit;

  Item := FProject.FindMedia(AClip.MediaId);
  if Item = nil then
    Exit;
  if not FProject.KeyframeIndexOf(Item, Index, Err) then
    Exit;
  if Index.AllFrames then
  begin
    { У кодека без межкадрового сжатия опорный каждый кадр, резать можно
      где угодно и без перекодирования. }
    AClip.EdgeIn := edSnap;
    Exit;
  end;

  Snapped := SnapNearest(Index, AClip.SrcIn);
  if Abs(Snapped - AClip.SrcIn) > 0.0005 then
    AClip.EdgeIn := edPrecise
  else
    AClip.EdgeIn := edSnap;
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
  T, C, N: Integer;
  Track: TTrack;
  Clip: TClip;
begin
  FRippleClips := nil;
  FRippleOrigStarts := nil;
  if FProject = nil then
    Exit;

  N := 0;
  for T := 0 to FProject.TrackCount - 1 do
  begin
    if (FProject.RippleMode = rmCurrentTrack) and (T <> ATrackIndex) then
      Continue;
    Track := FProject.Tracks[T];
    for C := 0 to Track.Count - 1 do
    begin
      Clip := Track[C];
      if Clip = AExclude then
        Continue;
      if Clip.TlStart < AFromTime - 0.0005 then
        Continue;
      SetLength(FRippleClips, N + 1);
      SetLength(FRippleOrigStarts, N + 1);
      FRippleClips[N] := Clip;
      FRippleOrigStarts[N] := Clip.TlStart;
      Inc(N);
    end;
  end;
end;

function TTimelineControl.IsRippling(AClip: TClip): Boolean;
var
  I: Integer;
begin
  for I := 0 to High(FRippleClips) do
    if FRippleClips[I] = AClip then
      Exit(True);
  Result := False;
end;

procedure TTimelineControl.ApplyRipple(const ADelta: Double);
var
  I: Integer;
begin
  for I := 0 to High(FRippleClips) do
    FRippleClips[I].TlStart := Max(0, FRippleOrigStarts[I] + ADelta);
end;

procedure TTimelineControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  WasEditing, WasTrimIn, WasClipPress: Boolean;
  Clip: TClip;
begin
  inherited MouseUp(Button, Shift, X, Y);
  { Shift читается и здесь: курсор по щелчку ставится при отпускании, и
    решение о прилипании должно быть по клавише, которую держат сейчас. }
  FSnapSuspended := ssShift in Shift;
  WasEditing := FAction in [taDragClip, taTrimIn, taTrimOut, taVolume,
    taFadeIn, taFadeOut];
  WasTrimIn := FAction = taTrimIn;
  WasClipPress := FAction = taDragClip;
  Clip := FDragClip;

  FAction := taNone;
  FDragClip := nil;
  FDragTrack := nil;
  FTrackAddedDuringDrag := False;
  FRippleClips := nil;
  FRippleOrigStarts := nil;

  if WasEditing and (not FMovedWhileDown) then
  begin
    { Нажали и отпустили, не сдвинув, — это щелчок. Ничего не изменилось,
      поэтому заявку на изменение снимаем, а по щелчку именно на теле клипа
      ставим курсор воспроизведения: так удобнее, чем целиться в линейку. }
    if FProject <> nil then
      FProject.CancelChange;
    if WasClipPress then
      Playhead := Max(0, SnapPlayhead(XToTime(FPressX)));
    Exit;
  end;

  { Проверку на опорный кадр делаем один раз в конце, а не на каждое
    движение мыши: для не-MP4 она может обойтись в чтение всего файла. }
  if WasTrimIn and (Clip <> nil) then
    UpdateEdgePrecision(Clip);

  if WasEditing then
    StructureChanged;
end;

function TTimelineControl.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
var
  Pt: TPoint;
begin
  Pt := ScreenToClient(MousePos);

  if ssCtrl in Shift then
  begin
    { Ctrl с колесом — масштаб, точка под курсором остаётся на месте. }
    if WheelDelta > 0 then
      ZoomAt(ZoomStep, Pt.X)
    else
      ZoomAt(1 / ZoomStep, Pt.X);
    Exit(True);
  end;

  if ssShift in Shift then
  begin
    { Shift с колесом — прокрутка по времени на треть видимой ширины. }
    if WheelDelta > 0 then
      FScrollOffset := FScrollOffset - (GetVisibleWidth / 3) / FPixelsPerSecond
    else
      FScrollOffset := FScrollOffset + (GetVisibleWidth / 3) / FPixelsPerSecond;
    ClampScroll;
    Invalidate;
    Exit(True);
  end;

  { Просто колесо — прокрутка по дорожкам. Их бывает больше, чем помещается
    в окно, и добираться до нижних важнее, чем ездить по времени: по
    времени есть и Shift с колесом, и средняя кнопка. }
  if WheelDelta > 0 then
    Dec(FScrollY, FTrackHeight)
  else
    Inc(FScrollY, FTrackHeight);
  ClampScrollY;
  Invalidate;
  Result := True;
end;

procedure TTimelineControl.Resize;
begin
  inherited Resize;
  Invalidate;
end;

{ --- Правки --- }

procedure TTimelineControl.SplitAtPlayhead(APrecise: Boolean;
  AOnlyCurrentTrack: Boolean);
var
  T: Integer;
  Track: TTrack;
  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
    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
      Continue;

    Tail := TClip.Create;
    Tail.Id := Clip.Id + '_b';
    Tail.MediaId := Clip.MediaId;
    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;

    { Новый рез описывается одинаково с обеих сторон: конец первой части
      и начало второй — это одно и то же место. }
    if APrecise then
    begin
      Clip.EdgeOut := edPrecise;
      Tail.EdgeIn := edPrecise;
    end
    else
    begin
      Clip.EdgeOut := edSnap;
      Tail.EdgeIn := edSnap;
    end;

    Clip.Duration := Offset;

    Track.Add(Tail);
    AnyChange := True;
  end;

  finally
    NewGroups.Free;
  end;

  if AnyChange then
    StructureChanged
  else
    { Ничего не разрезали — снимок отмены не нужен, откатываем его. }
    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;

  { Удалять надо связку целиком: половина связки — это разъехавшийся
    звук, который потом не найти. }
  SelectWholeGroups;

  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
    StructureChanged
  else
    FProject.Undo;
end;

procedure TTimelineControl.RippleCloseGap;
var
  T, C: Integer;
  Track: TTrack;
  GapStart, GapEnd, Shift: Double;
  AnyChange: Boolean;

  { Находит дыру под курсором на дорожке: конец предыдущего клипа и
    начало следующего. }
  function FindGap(ATrack: TTrack; out AFrom, ATo: Double): Boolean;
  var
    I: Integer;
    PrevEnd: Double;
  begin
    Result := False;
    PrevEnd := 0;
    for I := 0 to ATrack.Count - 1 do
    begin
      if ATrack[I].TlStart > PrevEnd + 0.0005 then
        if (FPlayhead >= PrevEnd) and (FPlayhead <= ATrack[I].TlStart) then
        begin
          AFrom := PrevEnd;
          ATo := ATrack[I].TlStart;
          Exit(True);
        end;
      PrevEnd := Max(PrevEnd, ATrack[I].TlEnd);
    end;
  end;

begin
  if FProject = nil then
    Exit;

  { Дыру ищем на той дорожке, где стоит указатель мыши: под курсором
    воспроизведения дыры бывают сразу на нескольких, и надо знать, какая
    имеется в виду. }
  if (FHoverTrack < 0) or (FHoverTrack >= FProject.TrackCount) then
    Exit;

  if not FindGap(FProject.Tracks[FHoverTrack], GapStart, GapEnd) then
    Exit;

  Shift := GapEnd - GapStart;
  if Shift <= 0 then
    Exit;

  AnyChange := False;
  FProject.BeginChange;

  for T := 0 to FProject.TrackCount - 1 do
  begin
    { Режим решает, сдвигать только эту дорожку или все. Смысл второго:
      когда дорожки уже выверены друг относительно друга, сдвиг одной
      всё бы разрушил.

      Режим действует и при выключенном автосхлопывании: это осознанная
      команда, а не побочный эффект перетаскивания. }
    if (FProject.RippleMode = rmCurrentTrack) and (T <> FHoverTrack) then
      Continue;

    Track := FProject.Tracks[T];
    for C := 0 to Track.Count - 1 do
      if Track[C].TlStart >= GapEnd - 0.0005 then
      begin
        Track[C].TlStart := Track[C].TlStart - Shift;
        AnyChange := True;
      end;
    Track.Sort;
  end;

  if AnyChange then
    StructureChanged
  else
    FProject.Undo;
end;

procedure TTimelineControl.SelectAll;
var
  T, C: Integer;
begin
  if FProject = nil then
    Exit;
  for T := 0 to FProject.TrackCount - 1 do
    for C := 0 to FProject.Tracks[T].Count - 1 do
      FProject.Tracks[T][C].Selected := True;
  Invalidate;
  if Assigned(FOnSelectionChange) then
    FOnSelectionChange(Self);
end;

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
        SelectAll;
        Key := 0;
      end;
    VK_HOME:
      begin
        { К началу самого раннего клипа, а не просто в ноль: если монтаж
          начинается с пятой секунды, ноль — не то место, куда хотят
          попасть. Когда клипов нет, начало и есть ноль. }
        Playhead := FirstClipTime;
        ScrollToPlayhead(False);
        Key := 0;
      end;
    VK_END:
      begin
        Playhead := LastClipTime;
        ScrollToPlayhead(False);
        Key := 0;
      end;
  end;
end;

{ --- Приём файлов из списка проекта --- }

procedure TTimelineControl.DragOver(Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  inherited DragOver(Source, X, Y, State, Accept);
  { Берём всё, что тащат из списка, — какой именно файл, разбирается окно.
    Бросать можно и ниже дорожек: там заведётся новая. }
  Accept := Assigned(FOnMediaDrop) and (X >= FHeaderWidth) and
    (Y >= FRulerHeight);
end;

procedure TTimelineControl.DragDrop(Source: TObject; X, Y: Integer);
var
  Idx: Integer;
begin
  inherited DragDrop(Source, X, Y);
  if not Assigned(FOnMediaDrop) then
    Exit;

  Idx := TrackIndexAt(Y);
  { Ниже всех дорожек — просим окно завести новую. }
  if (Idx < 0) and (Y > TracksBottom) then
    Idx := -1;

  FOnMediaDrop(Self, Source, Idx, Max(0, XToTime(X)));
end;

end.