unit statisticsWin;

interface

uses
  Windows, Messages, SysUtils, Variants, Types, Classes, Graphics, Controls,
  Forms, Dialogs, TextEditor, StdCtrls, ActnList, Menus, System.Actions,
  Vcl.ExtCtrls;

type
  TBarChartCtl = class(TCustomControl)
  strict private
    FData: TArray<integer>;
    FBarRects: TArray<TRect>;
    FHotBarIdx: Integer;
    FActiveBarIdx: Integer;
  private
    procedure SetData(const Value: TArray<Integer>);
    procedure InvalidateBar(Index: Integer);
  protected
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure Click; override;
  public
    constructor Create(AOwner: TComponent); override;
    property Data: TArray<Integer> read FData write SetData;
  end;

  TstatisticsFrm = class(TForm)
    btnClose: TButton;
    Shape2: TShape;
    btnMore: TButton;
    pnClient: TPanel;
    teWordFreqs: TTextEditor;
    btnOptions: TButton;
    pmOptions: TPopupMenu;
    mnuSourceCodeMode: TMenuItem;
    mnuCaseSensitive: TMenuItem;
    mnuSort: TMenuItem;
    mnuSortByFrequency: TMenuItem;
    mnuSortByName: TMenuItem;
    mnuSortByNameCaseSensitively: TMenuItem;
    mnuSortByLength: TMenuItem;
    N1: TMenuItem;
    pnStats: TPanel;
    teStats: TTextEditor;
    pnBarChartCtlParent: TPanel;
    mnuGraphUnique: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure btnMoreClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure mnuSourceCodeModeClick(Sender: TObject);
    procedure mnuCaseSensitiveClick(Sender: TObject);
    procedure pmOptionsPopup(Sender: TObject);
    procedure btnOptionsClick(Sender: TObject);
    procedure teWordFreqsSelChange(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure mnuSortByClick(Sender: TObject);
    procedure mnuGraphUniqueClick(Sender: TObject);
  private
  type
    TSortOrder = (soByFrequency, soByName, soByNameWithCase, soByLength);
  var
    FSourceCodeMode: Boolean;
    FCaseSensitiveMode: Boolean;
    FExpanded: Boolean;
    FHasComputedWordFreqs: Boolean;
    FSF: TFileStatisticsFlags;
    FS: TFileStatistics;
    FWordFreqs: TWordFreqDict;
    FSortOrder: TSortOrder;
    FStatHorzExtent: Integer;
    FBarChart: TBarChartCtl;
    FGraphUniqueWords: Boolean;
    FEditor: TTextEditor;
    procedure LoadStatistics;
    procedure PopulateWordFreqList;
    function GetUniqueWordsLengthDistr: TArray<Integer>;
    function GetAverageWordLengthOfUniqueWords: Double;
  protected
    procedure DoAfterMonitorDpiChanged(OldDPI: Integer; NewDPI: Integer); override;
  public
    property Editor: TTextEditor read FEditor write FEditor;
  end;

implementation

uses
  Math, Clipbrd, Generics.Defaults, Generics.Collections;

{$R *.dfm}

function Line(const AName, AValue: string; ALineWidth: Integer = 24): string; overload;
begin
  Result := AName + StringOfChar(#32, Max(1, ALineWidth - AName.Length - AValue.Length)) + AValue;
end;

function Line(const AName: string; AValue: integer; ALineWidth: Integer = 24): string; overload;
begin
  Result := Line(AName, AValue.ToString, ALineWidth);
end;

function Line(const AName: string; AValue: Int64; ALineWidth: Integer = 24): string; overload;
begin
  Result := Line(AName, AValue.ToString, ALineWidth);
end;

function Line(const AName: string; const AValue: Double; ALineWidth: Integer = 24): string; overload;
begin
  Result := Line(AName, FormatFloat('0.##', AValue), ALineWidth);
end;

procedure TstatisticsFrm.btnMoreClick(Sender: TObject);
begin

  if WindowState = wsMaximized then
    WindowState := wsNormal;

  if not FExpanded then
  begin
    pnStats.Align := alLeft;
    pnStats.Width := Self.Constraints.MinWidth - (Self.Width - Self.ClientWidth);
    teWordFreqs.Align := alClient;
    teWordFreqs.Visible := True;
    Self.Width := Round(2.25 * Self.Constraints.MinWidth);
    FExpanded := True;
    btnMore.Caption := '◀';
    btnMore.Hint := 'Displays less statistics.';
    if not FHasComputedWordFreqs then
      LoadStatistics;
  end
  else
  begin
    teWordFreqs.Visible := False;
    Self.Width := Self.Constraints.MinWidth;
    pnStats.Align := alClient;
    FExpanded := False;
    btnMore.Caption := '▶';
    btnMore.Hint := 'Displays more statistics.';
  end;

end;

procedure TstatisticsFrm.btnOptionsClick(Sender: TObject);
begin
  with btnOptions.ClientToScreen(Point(0, btnOptions.Height)) do
    pmOptions.Popup(X, Y);
end;

procedure TstatisticsFrm.DoAfterMonitorDpiChanged(OldDPI, NewDPI: Integer);
begin

  inherited;

  if Assigned(teStats) then
  begin
    teStats.MarginTop := ScaleValue(20);
    teStats.MarginLeft := ScaleValue(20);
    teStats.MarginRight := ScaleValue(3);
    teStats.MarginBottom := ScaleValue(3);
  end;

  if Assigned(teWordFreqs) then
  begin
    teWordFreqs.MarginTop := ScaleValue(20);
    teWordFreqs.MarginLeft := ScaleValue(20);
    teWordFreqs.MarginRight := ScaleValue(3);
    teWordFreqs.MarginBottom := ScaleValue(3);
  end;

  if Assigned(pnBarChartCtlParent) then
    pnBarChartCtlParent.Margins.Left := teStats.MarginLeft;

  var NonClientHeight := Self.Height - Self.ClientHeight;
  var NonClientWidth := Self.Width - Self.ClientWidth;

  var MinClientHeight := teStats.TotalVerticalExtent +
    2 * teStats.MarginTop + pnBarChartCtlParent.Constraints.MinHeight +
    2 * btnClose.Height;
  var MinHeight := MinClientHeight + NonClientHeight;
  Self.Constraints.MinHeight := MinHeight;

  var MinClientWidth := teStats.TotalHorizontalExtent + 2 * teStats.MarginLeft + ScaleValue(4);
  var MinWidth := MinClientWidth + NonClientWidth;
  Self.Constraints.MinWidth := MinWidth;

  teStats.ClientHeight := teStats.TotalVerticalExtent + 2 * teStats.MarginTop + ScaleValue(1);

end;

procedure TstatisticsFrm.FormCreate(Sender: TObject);
begin
  FBarChart := TBarChartCtl.Create(Self);
  FBarChart.Parent := pnBarChartCtlParent;
  FBarChart.Align := alClient;
end;

procedure TstatisticsFrm.FormDestroy(Sender: TObject);
begin
  FreeAndNil(FWordFreqs);
end;

procedure TstatisticsFrm.FormShow(Sender: TObject);
begin
  LoadStatistics;
  Self.Width := Self.Constraints.MinWidth;
end;

function TstatisticsFrm.GetAverageWordLengthOfUniqueWords: Double;
begin

  Result := 0.0;

  if FWordFreqs = nil then
    Exit;

  if FWordFreqs.Count = 0 then
    Exit;

  for VAR Pair in FWordFreqs do
    Result := Result + Pair.Key.Length / FWordFreqs.Count;

end;

function TstatisticsFrm.GetUniqueWordsLengthDistr: TArray<Integer>;
begin

  Result := nil;

  if FS.WordLengthDistr = nil then
    Exit;

  if FS.MaxWordLength = 0 then
    Exit;

  if FWordFreqs = nil then
    Exit;

  SetLength(Result, FS.MaxWordLength);
  for VAR Pair in FWordFreqs do
    Inc(Result[Pair.Key.Length - 1]);

end;

procedure TstatisticsFrm.LoadStatistics;
var
  NonClientHeight,
  NonClientWidth,
  MinClientHeight,
  MinClientWidth,
  MinHeight,
  MinWidth: Integer;
begin

  FBarChart.Data := nil;
  FreeAndNil(FWordFreqs);

  Screen.Cursor := crHourGlass;
  try

    teStats.Perform(WM_SETREDRAW, 0, 0);
    try

      FSF := FILE_STAT_ALL;
      if FSourceCodeMode then
        Include(FSF, fsSourceCode);
      if FCaseSensitiveMode then
        Include(FSF, fsCaseSensitive);

      if FExpanded or FGraphUniqueWords then
        FWordFreqs := TObjectDictionary<string, TWordFreqItem>.Create([doOwnsValues]);

      FS := FEditor.TextFile.GetFileStatistics(FSF, FWordFreqs);

      teStats.TextFile.StrictReadOnly := False;
      teStats.EditMode := emText;
      teStats.NewFile;
      teStats.LoadDefaultClasses;
      teStats.MultiSize := True;

      teStats.BeginAddLine;
      try

        teStats.AddLine('Lines', 'Heading 2');
        teStats.AddLine(Line('Count', FS.NumLines));
        teStats.AddLine(Line('Max line length', FS.MaxLineLength));
        teStats.AddLine(Line('Avg. line length', FS.AvgLineLength));

        teStats.AddLine;
        teStats.AddLine('Characters', 'Heading 2');
        teStats.AddLine(Line('Total', FS.NumChars));
        teStats.AddLine(Line('Letters', FS.NumLetters));
        teStats.AddLine(Line('Digits', FS.NumDigits));
        teStats.AddLine(Line('Whitespace', FS.NumWhitespace));
        teStats.AddLine(Line('Punctuation', FS.NumPunctuation));

        teStats.AddLine;
        teStats.AddLine('Words', 'Heading 2');
        teStats.AddLine(Line('Count', FS.NumWords));
        if Assigned(FWordFreqs) then
          teStats.AddLine(Line('Unique', FWordFreqs.Count));
        teStats.AddLine(Line('Max word length', FS.MaxWordLength));
        teStats.AddLine(Line('Avg. word length', FS.AvgWordLength));
        if Assigned(FWordFreqs) then
          teStats.AddLine(Line('Avg. of unique', GetAverageWordLengthOfUniqueWords));

      finally
        teStats.EndAddLine;
      end;

      teStats.EditMode := emReadOnly;
      teStats.TextFile.StrictReadOnly := True;
      teStats.TextFile.UseLineClasses := True;
      teStats.TextFile.GotoSOF;
      teStats.MarginTop := ScaleValue(20);
      teStats.MarginLeft := ScaleValue(20);
      teStats.MarginRight := ScaleValue(3);
      teStats.MarginBottom := ScaleValue(3);

      teStats.MakeUndoRoot;

    finally
      teStats.Perform(WM_SETREDRAW, 1, 0);
      teStats.Invalidate;
    end;

    NonClientHeight := Self.Height - Self.ClientHeight;
    NonClientWidth := Self.Width - Self.ClientWidth;

    MinClientHeight := teStats.TotalVerticalExtent +
      2 * teStats.MarginTop + pnBarChartCtlParent.Constraints.MinHeight +
      2 * btnClose.Height;
    MinHeight := MinClientHeight + NonClientHeight;
    Self.Constraints.MinHeight := MinHeight;

    MinClientWidth := teStats.TotalHorizontalExtent + 2 * teStats.MarginLeft + ScaleValue(4);
    MinWidth := MinClientWidth + NonClientWidth;
    Self.Constraints.MinWidth := MinWidth;

    teStats.ClientHeight := teStats.TotalVerticalExtent + 2 * teStats.MarginTop + ScaleValue(1);

    PopulateWordFreqList;
    pnBarChartCtlParent.Margins.Left := teStats.MarginLeft;
    FStatHorzExtent := teStats.TotalHorizontalExtent;

    if FGraphUniqueWords then
      FBarChart.Data := GetUniqueWordsLengthDistr
    else
      FBarChart.Data := TArray<Integer>(Copy(FS.WordLengthDistr, 1));

  finally
    Screen.Cursor := crDefault;
  end;

end;

procedure TstatisticsFrm.mnuCaseSensitiveClick(Sender: TObject);
begin
  FCaseSensitiveMode := not FCaseSensitiveMode;
  LoadStatistics;
end;

procedure TstatisticsFrm.mnuGraphUniqueClick(Sender: TObject);
begin

  FGraphUniqueWords := not FGraphUniqueWords;

  if FGraphUniqueWords and (FWordFreqs = nil) then
  begin
    LoadStatistics;
    Exit;
  end;

  if FGraphUniqueWords then
    FBarChart.Data := GetUniqueWordsLengthDistr
  else
    FBarChart.Data := TArray<Integer>(Copy(FS.WordLengthDistr, 1));

end;

procedure TstatisticsFrm.mnuSortByClick(Sender: TObject);
begin
  if (Sender is TMenuItem) and InRange(TMenuItem(Sender).Tag, Ord(Low(TSortOrder)), Ord(High(TSortOrder))) then
  begin
    FSortOrder := TSortOrder(TMenuItem(Sender).Tag);
    PopulateWordFreqList;
  end;
end;

procedure TstatisticsFrm.mnuSourceCodeModeClick(Sender: TObject);
begin
  FSourceCodeMode := not FSourceCodeMode;
  LoadStatistics;
end;

procedure TstatisticsFrm.pmOptionsPopup(Sender: TObject);
begin
  mnuSourceCodeMode.Checked := FSourceCodeMode;
  mnuCaseSensitive.Checked := FCaseSensitiveMode;
  mnuGraphUnique.Checked := FGraphUniqueWords;
  mnuSortByFrequency.Checked := FSortOrder = soByFrequency;
  mnuSortByName.Checked := FSortOrder = soByName;
  mnuSortByNameCaseSensitively.Checked := FSortOrder = soByNameWithCase;
  mnuSortByLength.Checked := FSortOrder = soByLength;
end;

procedure TstatisticsFrm.teWordFreqsSelChange(Sender: TObject);
begin
  teWordFreqs.LineHighlight := teWordFreqs.CaretPos.Y >= 2;
end;

procedure TstatisticsFrm.PopulateWordFreqList;
begin

  if Assigned(FWordFreqs) then
  begin

    teWordFreqs.Perform(WM_SETREDRAW, 0, 0);
    try

      teWordFreqs.TextFile.StrictReadOnly := False;
      teWordFreqs.EditMode := emText;
      teWordFreqs.NewFile;
      teWordFreqs.LoadDefaultClasses;
      teWordFreqs.MultiSize := True;

      teWordFreqs.BeginAddLine;
      try

        teWordFreqs.AddLine('Word list', 'Heading 2');
        teWordFreqs.AddLine;

        VAR WordFreqArr := FWordFreqs.ToArray;
        TArray.Sort<TPair<string, TWordFreqItem>>(
          WordFreqArr,
          TComparer<TPair<string, TWordFreqItem>>.Construct(
            function(const Left, Right: TPair<string, TWordFreqItem>): Integer
            begin
              case FSortOrder of
                soByFrequency:
                  begin
                    Result := -CompareValue(Left.Value.Count, Right.Value.Count) {descending};
                    if Result = 0 then
                      Result := CompareText(Left.Value.InNaturalCase, Right.Value.InNaturalCase);
                  end;
                soByName:
                  begin
                    Result := CompareText(Left.Value.InNaturalCase, Right.Value.InNaturalCase);
                    if Result = 0 then
                      Result := -CompareValue(Left.Value.Count, Right.Value.Count) {descending};
                  end;
                soByNameWithCase:
                  begin
                    Result := CompareStr(Left.Value.InNaturalCase, Right.Value.InNaturalCase);
                    if Result = 0 then
                      Result := -CompareValue(Left.Value.Count, Right.Value.Count) {descending};
                  end;
                soByLength:
                  begin
                    Result := CompareValue(Left.Key.Length, Right.Key.Length);
                    if Result = 0 then
                      Result := -CompareValue(Left.Value.Count, Right.Value.Count) {descending};
                    if Result = 0 then
                      Result := CompareText(Left.Value.InNaturalCase, Right.Value.InNaturalCase);
                  end;
              else
                Result := 0;
              end;
            end
          )
        );

        for VAR i := 0 to High(WordFreqArr) do
          teWordFreqs.AddLine(Line(WordFreqArr[i].Value.InNaturalCase, WordFreqArr[i].Value.Count));

      finally
        teWordFreqs.EndAddLine;
      end;

      teWordFreqs.EditMode := emReadOnly;
      teWordFreqs.TextFile.StrictReadOnly := True;
      teWordFreqs.TextFile.UseLineClasses := True;
      teWordFreqs.TextFile.GotoSOF;
      teWordFreqs.MarginTop := ScaleValue(20);
      teWordFreqs.MarginLeft := ScaleValue(20);
      teWordFreqs.MarginRight := ScaleValue(3);
      teWordFreqs.MarginBottom := ScaleValue(3);

      teWordFreqs.MakeUndoRoot;

      if GetSysColor(COLOR_WINDOW) <> DWORD(clWhite) then
        teWordFreqs.LineHighlightColor := FEditor.LineHighlightColor;

    finally
      teWordFreqs.Perform(WM_SETREDRAW, 1, 0);
      teWordFreqs.Invalidate;
    end;

    FHasComputedWordFreqs := True;

  end
  else
  begin
    FHasComputedWordFreqs := False;
    teWordFreqs.TextFile.StrictReadOnly := False;
    teWordFreqs.EditMode := emText;
    teWordFreqs.NewFile;
    teWordFreqs.EditMode := emReadOnly;
    teWordFreqs.TextFile.StrictReadOnly := True;
  end;

end;

{ TBarChartCtl }

procedure TBarChartCtl.Click;
begin
  var ClickedBarIdx := FHotBarIdx;
  if InRange(ClickedBarIdx, 0, High(FData)) then
  begin
    FActiveBarIdx := ClickedBarIdx;
    try
      InvalidateBar(ClickedBarIdx);
      if FData[FHotBarIdx] = 1 then
        ShowMessageFmt('There is a single word of length %d.', [FHotBarIdx + 1])
      else
        ShowMessageFmt('There are %d words of length %d.', [FData[FHotBarIdx], FHotBarIdx + 1]);
    finally
      FActiveBarIdx := -1;
      InvalidateBar(ClickedBarIdx);
    end;
  end;
end;

procedure TBarChartCtl.CMMouseLeave(var Message: TMessage);
begin
  var OldIdx := FHotBarIdx;
  FHotBarIdx := -1;
  InvalidateBar(OldIdx);
end;

constructor TBarChartCtl.Create(AOwner: TComponent);
begin
  inherited;
  FHotBarIdx := -1;
  FActiveBarIdx := -1;
end;

procedure TBarChartCtl.InvalidateBar(Index: Integer);
begin
  if InRange(Index, 0, High(FBarRects)) then
    InvalidateRect(Handle, FBarRects[Index], False);
end;

procedure TBarChartCtl.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  var NewIdx := -1;
  for var i := 0 to High(FBarRects) do
    if FBarRects[i].Contains(Point(X, Y)) then
    begin
      NewIdx := i;
      Break;
    end;
  if NewIdx <> FHotBarIdx then
  begin
    var OldIdx := FHotBarIdx;
    FHotBarIdx := NewIdx;
    InvalidateBar(OldIdx);
    InvalidateBar(NewIdx);
  end;
end;

procedure TBarChartCtl.Paint;
var
  BottomMargin, TopMargin, BarWidth, BarSpaceWidth: Integer;
  BarSpacingFactor: double;
  FullHeight, MaxFreq: integer;

  function BarRect(AIndex, AValue: integer): TRect;
  begin
    Result.Left := AIndex * BarSpaceWidth;
    Result.Right := Result.Left + BarWidth;
    Result.Bottom := Self.ClientHeight - BottomMargin;
    Result.Top := Result.Bottom - Round((AValue / MaxFreq) * FullHeight);
  end;

begin

  inherited;

  FBarRects := nil;

  var C := Self.Canvas;

  var N := Length(FData);
  BottomMargin := ScaleValue(4);
  TopMargin := ScaleValue(4);
  BarSpacingFactor := 0.2;

  BarWidth := Max(0, Floor(ClientWidth / (N + (N - 1) * BarSpacingFactor)));
  BarSpaceWidth := Floor((1 + BarSpacingFactor) * BarWidth);

  C.Brush.Color := clWhite;
  C.FillRect(ClientRect);

  FullHeight := Max(0, ClientHeight - TopMargin - BottomMargin);

  MaxFreq := 0;
  for var i := 0 to N - 1 do
    if FData[i] > MaxFreq then
      MaxFreq := FData[i];

  if MaxFreq = 0 then
    Exit;

  C.Pen.Color := clNavy;
  C.MoveTo(0, ClientHeight - BottomMargin);
  C.LineTo(ClientWidth, ClientHeight - BottomMargin);

  SetLength(FBarRects, N);
  for var i := 0 to N - 1 do
    FBarRects[i] := BarRect(i, FData[i]);

  for var i := 0 to N - 1 do
  begin
    if i = FActiveBarIdx then
      C.Brush.Color := clRed
    else if i = FHotBarIdx then
      C.Brush.Color := IfThen(GetSysColor(COLOR_HOTLIGHT) = DWORD(clNavy), clRed, clHotLight)
    else
      C.Brush.Color := clNavy;
    C.FillRect(FBarRects[i]);
  end;

end;

procedure TBarChartCtl.SetData(const Value: TArray<Integer>);
begin
  FData := Value;
  Invalidate;
end;

procedure TBarChartCtl.WMEraseBkgnd(var Message: TMessage);
begin
  Message.Result := 1;
end;

end.
