nlve/src/uLogView.pas

{
  uLogView — журнал сообщений, нарисованный своими силами.

  Зачем не многострочное поле. Полосы прокрутки у него рисует система, и
  цвет им задать нечем: на тёмном окне они остаются светлыми. Всё
  остальное окно уже в своих цветах, и две светлые полосы внизу — то
  единственное, что оставалось.

  Заодно чинится вторая вещь. Прокрутка вбок колесом с Shift была сделана
  только под gtk2 через внутренности виджета; в сборке под Windows она
  молча не работала. Здесь прокрутка своя и одинаковая везде.

  Что сохранено от прежнего поля: выделение мышью, Ctrl+A, копирование по
  Ctrl+C. В журнал попадают команды ffmpeg длиной в несколько экранов, и
  забрать их оттуда надо уметь.

  Шрифт предполагается моноширинным: по нему считается, какой столбец под
  курсором. С пропорциональным шрифтом выделение будет промахиваться.
}
unit uLogView;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Types, Controls, Graphics, LCLType, LazUTF8;

type

  TLogView = class(TCustomControl)
  private
    FLines: TStringList;
    FMaxLines: Integer;
    { Первая видимая строка и сдвиг содержимого вправо, в пикселях. }
    FTopLine: Integer;
    FLeftPx: Integer;
    FLineHeight: Integer;
    FCharWidth: Integer;
    { Длина самой длинной строки в знаках. Считается в знаках, а не в
      байтах: в кириллице знак занимает два байта, и по длине строки в
      байтах ширина вышла бы вдвое больше настоящей. }
    FMaxLen: Integer;
    { Держаться конца журнала. Сбрасывается, когда пользователь отматывает
      назад: он читает старое сообщение, и утаскивать его вниз при каждой
      новой строке нельзя. }
    FFollowTail: Boolean;

    FDragKind: Integer;
    FDragOffset: Integer;
    { Начало и конец выделения: X — столбец, Y — номер строки. }
    FSelFrom: TPoint;
    FSelTo: TPoint;
    FHasSel: Boolean;

    procedure UpdateMetrics;
    function BarSize: Integer;
    function ContentRect: TRect;
    function VisibleLines: Integer;
    function MaxTopLine: Integer;
    function ContentWidthPx: Integer;
    function MaxLeftPx: Integer;
    function NeedVBar: Boolean;
    function NeedHBar: Boolean;
    function VBarRect: TRect;
    function HBarRect: TRect;
    function VThumbRect: TRect;
    function HThumbRect: TRect;
    procedure SetTopLine(AValue: Integer);
    procedure SetLeftPx(AValue: Integer);
    function PointToCell(X, Y: Integer): TPoint;
    function NormalizedSel(out AFrom, ATo: TPoint): Boolean;
    procedure RecalcMaxLen;
  protected
    procedure Paint; 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 FontChanged(Sender: TObject); override;
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Add(const AText: string);
    procedure AddLine(const AText: string);
    procedure Clear;
    { Заменить всё содержимое разом. Так пользовались многострочным полем
      через свойство Text. }
    procedure SetText(const AText: string);
    function SelectedText: string;
    procedure SelectAll;
    procedure CopyToClipboard;
    procedure ScrollToBottom;
    procedure ScrollToTop;

    property Lines: TStringList read FLines;
  published
    property Align;
    property Anchors;
    property Color;
    property Font;
    property ParentFont;
    property PopupMenu;
    property TabOrder;
    property TabStop default True;
    property Visible;
    { Сколько строк держать. Старые уходят сверху: журнал за длинную
      сборку иначе съел бы всю память. }
    property MaxLines: Integer read FMaxLines write FMaxLines default 800;
  end;

implementation

uses
  Clipbrd, uTheme;

const
  { Что сейчас тянут мышью. }
  DragNone = 0;
  DragVThumb = 1;
  DragHThumb = 2;
  DragSelect = 3;

  BarWidth = 12;
  MinThumb = 24;
  TextMarginX = 3;
  WheelLines = 3;
  WheelChars = 8;

constructor TLogView.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FLines := TStringList.Create;
  FMaxLines := 800;
  FFollowTail := True;
  FDragKind := DragNone;
  TabStop := True;
  DoubleBuffered := True;
  { Заведомо разумные значения до первой отрисовки: по ним считаются
    видимые строки, и ноль тут привёл бы к делению на ноль. }
  FCharWidth := 7;
  FLineHeight := 14;
  Color := ThemeSurface;
  Font.Color := ThemeText;
  ControlStyle := ControlStyle + [csOpaque];
end;

destructor TLogView.Destroy;
begin
  FLines.Free;
  inherited Destroy;
end;

procedure TLogView.UpdateMetrics;
begin
  { Пока у контрола нет своего окна, холста тоже нет, и обращение к нему
    роняет программу сообщением «control has no parent window». Момент
    настаёт при чтении формы: там задаётся шрифт, а окна ещё нет.
    Поэтому до появления окна остаются значения из конструктора. }
  if not HandleAllocated then
    Exit;
  Canvas.Font.Assign(Font);
  FCharWidth := Canvas.TextWidth('0');
  if FCharWidth < 1 then
    FCharWidth := 1;
  FLineHeight := Canvas.TextHeight('Wg') + 2;
  if FLineHeight < 4 then
    FLineHeight := 4;
end;

function TLogView.BarSize: Integer;
begin
  Result := BarWidth;
end;

function TLogView.NeedVBar: Boolean;
begin
  Result := (FLineHeight > 0) and
    (FLines.Count > (ClientHeight - BarSize) div FLineHeight);
end;

function TLogView.NeedHBar: Boolean;
begin
  Result := FMaxLen * FCharWidth + TextMarginX * 2 > ClientWidth - BarSize;
end;

function TLogView.ContentRect: TRect;
begin
  Result := ClientRect;
  if NeedVBar then
    Dec(Result.Right, BarSize);
  if NeedHBar then
    Dec(Result.Bottom, BarSize);
  if Result.Right < Result.Left then
    Result.Right := Result.Left;
  if Result.Bottom < Result.Top then
    Result.Bottom := Result.Top;
end;

function TLogView.VisibleLines: Integer;
var
  R: TRect;
begin
  R := ContentRect;
  if FLineHeight <= 0 then
    Exit(1);
  Result := (R.Bottom - R.Top) div FLineHeight;
  if Result < 1 then
    Result := 1;
end;

function TLogView.MaxTopLine: Integer;
begin
  Result := FLines.Count - VisibleLines;
  if Result < 0 then
    Result := 0;
end;

function TLogView.ContentWidthPx: Integer;
var
  R: TRect;
begin
  R := ContentRect;
  Result := R.Right - R.Left;
  if Result < 1 then
    Result := 1;
end;

function TLogView.MaxLeftPx: Integer;
begin
  Result := FMaxLen * FCharWidth + TextMarginX * 2 - ContentWidthPx;
  if Result < 0 then
    Result := 0;
end;

function TLogView.VBarRect: TRect;
begin
  Result := ClientRect;
  Result.Left := Result.Right - BarSize;
  if NeedHBar then
    Dec(Result.Bottom, BarSize);
end;

function TLogView.HBarRect: TRect;
begin
  Result := ClientRect;
  Result.Top := Result.Bottom - BarSize;
  if NeedVBar then
    Dec(Result.Right, BarSize);
end;

function TLogView.VThumbRect: TRect;
var
  Bar: TRect;
  TrackH, ThumbH, Span: Integer;
begin
  Bar := VBarRect;
  TrackH := Bar.Bottom - Bar.Top;
  Span := MaxTopLine;
  if (Span <= 0) or (FLines.Count <= 0) then
    Exit(Bar);

  ThumbH := Round(TrackH * VisibleLines / FLines.Count);
  if ThumbH < MinThumb then
    ThumbH := MinThumb;
  if ThumbH > TrackH then
    ThumbH := TrackH;

  Result := Bar;
  Result.Top := Bar.Top + Round((TrackH - ThumbH) * FTopLine / Span);
  Result.Bottom := Result.Top + ThumbH;
end;

function TLogView.HThumbRect: TRect;
var
  Bar: TRect;
  TrackW, ThumbW, Span, Total: Integer;
begin
  Bar := HBarRect;
  TrackW := Bar.Right - Bar.Left;
  Span := MaxLeftPx;
  Total := FMaxLen * FCharWidth + TextMarginX * 2;
  if (Span <= 0) or (Total <= 0) then
    Exit(Bar);

  ThumbW := Round(TrackW * ContentWidthPx / Total);
  if ThumbW < MinThumb then
    ThumbW := MinThumb;
  if ThumbW > TrackW then
    ThumbW := TrackW;

  Result := Bar;
  Result.Left := Bar.Left + Round((TrackW - ThumbW) * FLeftPx / Span);
  Result.Right := Result.Left + ThumbW;
end;

procedure TLogView.SetTopLine(AValue: Integer);
begin
  if AValue > MaxTopLine then
    AValue := MaxTopLine;
  if AValue < 0 then
    AValue := 0;
  if AValue = FTopLine then
    Exit;
  FTopLine := AValue;
  { Держимся конца только когда стоим на конце. }
  FFollowTail := FTopLine >= MaxTopLine;
  Invalidate;
end;

procedure TLogView.SetLeftPx(AValue: Integer);
begin
  if AValue > MaxLeftPx then
    AValue := MaxLeftPx;
  if AValue < 0 then
    AValue := 0;
  if AValue = FLeftPx then
    Exit;
  FLeftPx := AValue;
  Invalidate;
end;

procedure TLogView.RecalcMaxLen;
var
  I, L: Integer;
begin
  FMaxLen := 0;
  for I := 0 to FLines.Count - 1 do
  begin
    L := UTF8Length(FLines[I]);
    if L > FMaxLen then
      FMaxLen := L;
  end;
end;

{ Текст с переносами разбивается на строки. Многострочное поле делало это
  само, и без этого сообщение из двух предложений слипалось в одно, а сам
  перенос показывался квадратиком. }
procedure TLogView.Add(const AText: string);
var
  Rest, Line: string;
  P: Integer;
begin
  Rest := AText;
  repeat
    P := 1;
    while (P <= Length(Rest)) and (Rest[P] <> #10) and (Rest[P] <> #13) do
      Inc(P);
    Line := Copy(Rest, 1, P - 1);
    AddLine(Line);
    if P > Length(Rest) then
      Break;
    { Пара #13#10 считается одним переносом, иначе выйдет пустая строка. }
    if (Rest[P] = #13) and (P < Length(Rest)) and (Rest[P + 1] = #10) then
      Inc(P);
    Rest := Copy(Rest, P + 1, Length(Rest));
  until False;
end;

procedure TLogView.AddLine(const AText: string);
var
  L: Integer;
  Dropped: Boolean;
begin
  FLines.Add(AText);
  L := UTF8Length(AText);
  if L > FMaxLen then
    FMaxLen := L;

  Dropped := False;
  while FLines.Count > FMaxLines do
  begin
    FLines.Delete(0);
    Dropped := True;
    if FTopLine > 0 then
      Dec(FTopLine);
  end;
  { Самая длинная строка могла оказаться выброшенной, и тогда ширина
    посчитана с запасом. Пересчёт по 800 строкам стоит копейки, а мерить
    надо длину в знаках, что и делает RecalcMaxLen. }
  if Dropped then
    RecalcMaxLen;

  if FFollowTail then
    ScrollToBottom;
  Invalidate;
end;

procedure TLogView.SetText(const AText: string);
begin
  Clear;
  Add(AText);
  { Заменённый разом текст читают с начала, а не с конца: это не журнал
    событий, а ответ на вопрос. }
  ScrollToTop;
end;

procedure TLogView.Clear;
begin
  FLines.Clear;
  FTopLine := 0;
  FLeftPx := 0;
  FMaxLen := 0;
  FHasSel := False;
  FFollowTail := True;
  Invalidate;
end;

procedure TLogView.ScrollToTop;
begin
  FTopLine := 0;
  FLeftPx := 0;
  FFollowTail := False;
  Invalidate;
end;

procedure TLogView.ScrollToBottom;
begin
  FTopLine := MaxTopLine;
  FFollowTail := True;
  Invalidate;
end;

procedure TLogView.Paint;
var
  R, Bar, Thumb: TRect;
  I, Y, X, Line: Integer;
  SelA, SelB: TPoint;
  HasSel: Boolean;
  S: string;
  StartCol, EndCol: Integer;
begin
  UpdateMetrics;
  R := ContentRect;

  Canvas.Brush.Color := Color;
  Canvas.Brush.Style := bsSolid;
  Canvas.FillRect(ClientRect);

  HasSel := NormalizedSel(SelA, SelB);

  Canvas.Font.Assign(Font);
  Y := R.Top;
  for I := 0 to VisibleLines do
  begin
    Line := FTopLine + I;
    if Line >= FLines.Count then
      Break;
    S := FLines[Line];
    X := R.Left + TextMarginX - FLeftPx;

    { Подсветка выделенного куска строки. Столбцы переводятся в пиксели
      умножением: шрифт моноширинный. }
    if HasSel and (Line >= SelA.Y) and (Line <= SelB.Y) then
    begin
      if Line = SelA.Y then
        StartCol := SelA.X
      else
        StartCol := 0;
      if Line = SelB.Y then
        EndCol := SelB.X
      else
        EndCol := UTF8Length(S) + 1;

      if EndCol > StartCol then
      begin
        Canvas.Brush.Color := ThemeSelection;
        Canvas.FillRect(X + StartCol * FCharWidth, Y,
          X + EndCol * FCharWidth, Y + FLineHeight);
      end;
    end;

    Canvas.Brush.Style := bsClear;
    Canvas.Font.Color := Font.Color;
    Canvas.TextOut(X, Y + 1, S);

    Inc(Y, FLineHeight);
    if Y >= R.Bottom then
      Break;
  end;

  { Полосы рисуются последними: они закрывают текст, вылезший под них. }
  Canvas.Brush.Style := bsSolid;

  if NeedVBar then
  begin
    Bar := VBarRect;
    Canvas.Brush.Color := ThemeWindow;
    Canvas.FillRect(Bar);
    Thumb := VThumbRect;
    Canvas.Brush.Color := ThemeButton;
    Canvas.FillRect(Thumb.Left + 2, Thumb.Top + 1,
      Thumb.Right - 2, Thumb.Bottom - 1);
  end;

  if NeedHBar then
  begin
    Bar := HBarRect;
    Canvas.Brush.Color := ThemeWindow;
    Canvas.FillRect(Bar);
    Thumb := HThumbRect;
    Canvas.Brush.Color := ThemeButton;
    Canvas.FillRect(Thumb.Left + 1, Thumb.Top + 2,
      Thumb.Right - 1, Thumb.Bottom - 2);
  end;

  { Угол между полосами. }
  if NeedVBar and NeedHBar then
  begin
    Canvas.Brush.Color := ThemeWindow;
    Canvas.FillRect(ClientWidth - BarSize, ClientHeight - BarSize,
      ClientWidth, ClientHeight);
  end;
end;

function TLogView.PointToCell(X, Y: Integer): TPoint;
var
  R: TRect;
begin
  R := ContentRect;
  Result.Y := FTopLine + (Y - R.Top) div FLineHeight;
  if Result.Y < 0 then
    Result.Y := 0;
  if Result.Y > FLines.Count - 1 then
    Result.Y := FLines.Count - 1;
  if Result.Y < 0 then
    Result.Y := 0;

  { Полтолщины знака добавляется, чтобы щелчок в правой половине буквы
    ставил границу за ней, а не перед: так ведёт себя любой текстовый
    редактор. }
  Result.X := (X - R.Left - TextMarginX + FLeftPx + FCharWidth div 2)
    div FCharWidth;
  if Result.X < 0 then
    Result.X := 0;
end;

function TLogView.NormalizedSel(out AFrom, ATo: TPoint): Boolean;
begin
  Result := FHasSel;
  AFrom := FSelFrom;
  ATo := FSelTo;
  if not Result then
    Exit;
  if (ATo.Y < AFrom.Y) or ((ATo.Y = AFrom.Y) and (ATo.X < AFrom.X)) then
  begin
    AFrom := FSelTo;
    ATo := FSelFrom;
  end;
  Result := (AFrom.Y <> ATo.Y) or (AFrom.X <> ATo.X);
end;

procedure TLogView.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Thumb: TRect;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Button <> mbLeft then
    Exit;
  if CanFocus then
    SetFocus;

  if NeedVBar and PtInRect(VBarRect, Point(X, Y)) then
  begin
    Thumb := VThumbRect;
    if PtInRect(Thumb, Point(X, Y)) then
    begin
      FDragKind := DragVThumb;
      FDragOffset := Y - Thumb.Top;
    end
    else if Y < Thumb.Top then
      SetTopLine(FTopLine - VisibleLines)
    else
      SetTopLine(FTopLine + VisibleLines);
    Exit;
  end;

  if NeedHBar and PtInRect(HBarRect, Point(X, Y)) then
  begin
    Thumb := HThumbRect;
    if PtInRect(Thumb, Point(X, Y)) then
    begin
      FDragKind := DragHThumb;
      FDragOffset := X - Thumb.Left;
    end
    else if X < Thumb.Left then
      SetLeftPx(FLeftPx - ContentWidthPx)
    else
      SetLeftPx(FLeftPx + ContentWidthPx);
    Exit;
  end;

  FDragKind := DragSelect;
  FSelFrom := PointToCell(X, Y);
  FSelTo := FSelFrom;
  FHasSel := True;
  Invalidate;
end;

procedure TLogView.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  Bar: TRect;
  TrackH, TrackW, ThumbH, ThumbW: Integer;
begin
  inherited MouseMove(Shift, X, Y);

  case FDragKind of
    DragVThumb:
      begin
        Bar := VBarRect;
        TrackH := Bar.Bottom - Bar.Top;
        ThumbH := VThumbRect.Bottom - VThumbRect.Top;
        if TrackH > ThumbH then
          SetTopLine(Round((Y - FDragOffset - Bar.Top) * MaxTopLine /
            (TrackH - ThumbH)));
      end;
    DragHThumb:
      begin
        Bar := HBarRect;
        TrackW := Bar.Right - Bar.Left;
        ThumbW := HThumbRect.Right - HThumbRect.Left;
        if TrackW > ThumbW then
          SetLeftPx(Round((X - FDragOffset - Bar.Left) * MaxLeftPx /
            (TrackW - ThumbW)));
      end;
    DragSelect:
      begin
        { Выделение за краем окна подматывает содержимое: иначе нельзя
          выделить больше того, что видно. }
        if Y < ContentRect.Top then
          SetTopLine(FTopLine - 1)
        else if Y > ContentRect.Bottom then
          SetTopLine(FTopLine + 1);
        FSelTo := PointToCell(X, Y);
        Invalidate;
      end;
  end;
end;

procedure TLogView.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  FDragKind := DragNone;
  inherited MouseUp(Button, Shift, X, Y);
end;

function TLogView.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  MousePos: TPoint): Boolean;
begin
  UpdateMetrics;
  if ssShift in Shift then
  begin
    if WheelDelta > 0 then
      SetLeftPx(FLeftPx - WheelChars * FCharWidth)
    else
      SetLeftPx(FLeftPx + WheelChars * FCharWidth);
  end
  else
  begin
    if WheelDelta > 0 then
      SetTopLine(FTopLine - WheelLines)
    else
      SetTopLine(FTopLine + WheelLines);
  end;
  Result := True;
end;

procedure TLogView.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if ssCtrl in Shift then
  begin
    case Key of
      VK_C:
        begin
          CopyToClipboard;
          Key := 0;
        end;
      VK_A:
        begin
          SelectAll;
          Key := 0;
        end;
    end;
    Exit;
  end;

  case Key of
    VK_UP: begin SetTopLine(FTopLine - 1); Key := 0; end;
    VK_DOWN: begin SetTopLine(FTopLine + 1); Key := 0; end;
    VK_PRIOR: begin SetTopLine(FTopLine - VisibleLines); Key := 0; end;
    VK_NEXT: begin SetTopLine(FTopLine + VisibleLines); Key := 0; end;
  end;
end;

procedure TLogView.FontChanged(Sender: TObject);
begin
  inherited FontChanged(Sender);
  UpdateMetrics;
  Invalidate;
end;

procedure TLogView.Resize;
begin
  inherited Resize;
  if FFollowTail then
    FTopLine := MaxTopLine;
  Invalidate;
end;

procedure TLogView.SelectAll;
begin
  if FLines.Count = 0 then
    Exit;
  FSelFrom := Point(0, 0);
  FSelTo := Point(UTF8Length(FLines[FLines.Count - 1]), FLines.Count - 1);
  FHasSel := True;
  Invalidate;
end;

function TLogView.SelectedText: string;
var
  A, B: TPoint;
  I, StartCol, EndCol: Integer;
  S: string;
  Res: TStringList;
begin
  Result := '';
  if not NormalizedSel(A, B) then
    Exit;

  Res := TStringList.Create;
  try
    for I := A.Y to B.Y do
    begin
      if (I < 0) or (I >= FLines.Count) then
        Continue;
      S := FLines[I];
      if I = A.Y then
        StartCol := A.X
      else
        StartCol := 0;
      if I = B.Y then
        EndCol := B.X
      else
        EndCol := UTF8Length(S);
      if EndCol < StartCol then
        EndCol := StartCol;
      { Резать надо по знакам, а не по байтам: иначе кириллица развалится
        пополам. }
      Res.Add(UTF8Copy(S, StartCol + 1, EndCol - StartCol));
    end;
    Result := Res.Text;
    { TStringList.Text добавляет перевод строки в конце; для одной
      выделенной строки он лишний. }
    if (Res.Count = 1) and (Length(Result) >= Length(LineEnding)) then
      SetLength(Result, Length(Result) - Length(LineEnding));
  finally
    Res.Free;
  end;
end;

procedure TLogView.CopyToClipboard;
var
  S: string;
begin
  S := SelectedText;
  { Ничего не выделено — берём весь журнал: чаще всего копировать хотят
    именно его целиком. }
  if S = '' then
    S := FLines.Text;
  if S <> '' then
    Clipboard.AsText := S;
end;

initialization
  RegisterClass(TLogView);

end.