nlve/src/uProgressForm.pas

{
  uProgressForm — окно хода долгой операции.

  Показывается модально, пока работает рабочий поток. Поток шлёт сюда
  состояние через Synchronize, поэтому все методы этого окна вызываются
  из потока интерфейса и никакой защиты не требуют.

  Кнопка одна и меняет назначение: пока идёт работа — «Отмена», после
  завершения — «Закрыть». Так окно нельзя закрыть, не остановив работу,
  и не приходится гадать, что стало с процессом.
}
unit uProgressForm;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, ComCtrls, StdCtrls, ExtCtrls,
  uTheme, uLogView;

type

  { TProgressForm }

  TProgressForm = class(TForm)
    btnAction: TThemedButton;
    lblStage: TLabel;
    lblEta: TLabel;
    memoLog: TLogView;
    { Полоса своя, а не системная: TProgressBar под gtk2 рисуется
      ступеньками, по восемь кусков на всю ширину, и ход работы в ней
      виден рывками. Эта заполняется сплошь, как та, что внизу главного
      окна. }
    pbBar: TThemedProgress;
    pnlTop: TPanel;
    procedure btnActionClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormCreate(Sender: TObject);
  private
    FFinished: Boolean;
    FCancelRequested: Boolean;
    FOnCancelRequest: TNotifyEvent;
    { Когда началась работа и какую долю показывали в прошлый раз: по ним
      считается, сколько осталось. }
    FStartedAt: TDateTime;
    FLastFraction: Double;
    function FormatSpan(const ASeconds: Double): string;
  public
    procedure SetStage(const AText: string);
    procedure SetFraction(AValue: Double);
    procedure AddLog(const AText: string);
    { Переводит окно в завершённое состояние: прогресс на месте, кнопка
      становится «Закрыть». }
    procedure Finish(ASuccess: Boolean; const AMessage: string);

    property Finished: Boolean read FFinished;
    property OnCancelRequest: TNotifyEvent read FOnCancelRequest
      write FOnCancelRequest;
  end;

implementation

{$R *.lfm}

{ TProgressForm }

procedure TProgressForm.FormCreate(Sender: TObject);
begin
  { Цвета задаём сами: системная тема может быть светлой, и тогда
    тёмный таймлайн оказался бы в белой рамке. }
  ApplyDarkTheme(Self);
  pbBar.Fraction := 0;
  memoLog.Clear;
  btnAction.Caption := 'Отмена';
  FStartedAt := Now;
  FLastFraction := 0;
  lblEta.Caption := '';
end;

procedure TProgressForm.SetStage(const AText: string);
begin
  lblStage.Caption := AText;
end;

{ Время в виде «3 мин 20 с»: секунды сотнями человек не читает. }
function TProgressForm.FormatSpan(const ASeconds: Double): string;
var
  Total, M, S: Integer;
begin
  Total := Round(ASeconds);
  if Total < 0 then
    Total := 0;
  M := Total div 60;
  S := Total mod 60;
  if M >= 60 then
    Result := Format('%d ч %d мин', [M div 60, M mod 60])
  else if M > 0 then
    Result := Format('%d мин %d с', [M, S])
  else
    Result := Format('%d с', [S]);
end;

{ Сколько прошло и сколько осталось.

  Осталось считается по простому правилу: если четверть пути заняла
  минуту, весь путь займёт четыре. На деле скорость меняется — куски,
  которые копируются, идут мгновенно, а те, что пересобираются,
  медленно, — поэтому число называется «примерно» и пересчитывается на
  каждом шаге. Даже такая оценка отвечает на главный вопрос: успею ли я
  сходить за чаем. }
procedure TProgressForm.SetFraction(AValue: Double);
var
  { Не Left: так называется свойство формы. }
  Elapsed, Remain: Double;
begin
  if AValue < 0 then
    AValue := 0;
  if AValue > 1 then
    AValue := 1;
  pbBar.Fraction := AValue;
  FLastFraction := AValue;

  Elapsed := (Now - FStartedAt) * SecsPerDay;
  { Пока сделано меньше сотой доли, оценка была бы гаданием: первые
    секунды уходят на запуск ffmpeg, а не на работу. }
  if (AValue > 0.01) and (Elapsed > 1) then
  begin
    Remain := Elapsed * (1 - AValue) / AValue;
    lblEta.Caption := Format('Прошло %s, осталось примерно %s (%d%%)',
      [FormatSpan(Elapsed), FormatSpan(Remain), Round(AValue * 100)]);
  end
  else
    lblEta.Caption := 'Прошло ' + FormatSpan(Elapsed);
end;

procedure TProgressForm.AddLog(const AText: string);
begin
  { Свой журнал сам держится конца, пока пользователь не отмотал назад, и
    сам обрезает старые строки. }
  memoLog.Add(AText);
end;

procedure TProgressForm.Finish(ASuccess: Boolean; const AMessage: string);
begin
  FFinished := True;
  btnAction.Caption := 'Закрыть';
  lblStage.Caption := AMessage;
  { На месте оценки — итог: сколько всё это заняло. }
  lblEta.Caption := 'Заняло ' + FormatSpan((Now - FStartedAt) * SecsPerDay);
  if ASuccess then
    lblStage.Font.Color := clDefault
  else
    lblStage.Font.Color := clRed;
end;

procedure TProgressForm.btnActionClick(Sender: TObject);
begin
  if FFinished then
  begin
    Close;
    Exit;
  end;

  { Повторное нажатие ничего не даёт: остановка не мгновенна, надо
    дождаться, пока ffmpeg завершится. }
  if FCancelRequested then
    Exit;

  FCancelRequested := True;
  btnAction.Enabled := False;
  lblStage.Caption := 'Останавливаю...';
  if Assigned(FOnCancelRequest) then
    FOnCancelRequest(Self);
end;

procedure TProgressForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  { Пока работа идёт, закрытие окна означало бы оставить ffmpeg работать
    без всякого присмотра. Вместо этого запрашиваем остановку. }
  CanClose := FFinished;
  if not CanClose then
    btnActionClick(nil);
end;

end.