Квадратные кнопки со значками, журнал перестал уезжать из-под курсора

Двойной щелчок по кнопке журнала. Причина оказалась не в кнопке: журнал
лежал ниже полосы состояния. Спрятали журнал — полоса уехала вниз на сто
тридцать пикселей, кнопка ушла из-под курсора, и следующий щелчок в то же
место попадал уже мимо. Порядок исправлен: полоса состояния теперь самая
нижняя, журнал над ней, и при переключении ничего не движется.

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

Значки рисуются кодом, а не берутся из файла: программа не должна
зависеть от того, лежит ли рядом с ней картинка. Рисунки придуманы в
icons/*.svg — оттуда их можно перегнать в png чем угодно, проверено
командой convert.

Свойства из файлов форм теперь проверяются отдельной программой по
сведениям о типах. Файл формы разбирается при запуске, а не при сборке:
опечатка в имени свойства или в значении перечисления даёт не ошибку
компиляции, а падение окна на старте. Проверка включена в build.sh.

.gitignore

@@ -43,6 +43,10 @@ shot*.png
 # Журнал последнего запуска
 /nlve.log
 
+# Проверка свойств из файлов форм.
+/tests/lfmcheck/lfmcheck
+/tests/lfmcheck/units/
+
 # Проверка хода полоски: двоичный файл и промежуточные модули.
 /tests/progress/progtest
 /tests/progress/*.o

build.sh

@@ -123,6 +123,22 @@ run_tests() {
     status=1
   fi
 
+  # Свойства, записанные в файлах форм, проверяются по сведениям о типах.
+  # Файл формы разбирается при запуске, а не при сборке: опечатка в имени
+  # свойства даёт не ошибку компиляции, а падение окна на старте.
+  note "Проверка свойств из файлов форм"
+  if "$LAZBUILD" --primary-config-path="$LAZCONF" \
+       "$HERE/tests/lfmcheck/lfmcheck.lpi" >/dev/null 2>&1; then
+    if "$HERE/tests/lfmcheck/lfmcheck"; then
+      :
+    else
+      status=1
+    fi
+  else
+    echo "не собралось" >&2
+    status=1
+  fi
+
   # Ход полоски выполнения проверяется отдельной программой: расчёт вынесен
   # в uAppTypes именно затем, чтобы его можно было прогнать числами.
   note "Проверка хода полоски выполнения"

icons/log.svg

@@ -0,0 +1,11 @@
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 24 24" width="24" height="24">
+  <!-- Журнал: полоса с сообщениями. Строки разной длины, как настоящий
+       текст: одинаковые читались бы как таблица. -->
+  <rect x="2" y="3" width="20" height="18" fill="none"
+        stroke="currentColor" stroke-width="2"/>
+  <g stroke="currentColor" stroke-width="2" stroke-linecap="square">
+    <line x1="6" y1="8" x2="18" y2="8"/>
+    <line x1="6" y1="12" x2="18" y2="12"/>
+    <line x1="6" y1="16" x2="13" y2="16"/>
+  </g>
+</svg>

icons/ripple.svg

@@ -0,0 +1,9 @@
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 24 24" width="24" height="24">
+  <!-- Схлопывание: дыра между кусками закрывается, правый кусок
+       переезжает влево. Пунктир — то место, которое исчезнет. -->
+  <rect x="1" y="7" width="7" height="10" fill="currentColor"/>
+  <rect x="16" y="7" width="7" height="10" fill="currentColor"/>
+  <line x1="9" y1="12" x2="15" y2="12" stroke="currentColor"
+        stroke-width="2" stroke-dasharray="2 2"/>
+  <polygon points="10,12 15,8 15,16" fill="currentColor"/>
+</svg>

icons/snap.svg

@@ -0,0 +1,14 @@
+<svg xmlns="http://www.w3.org/2000/svg" viewBox="0 0 24 24" width="24" height="24">
+  <!-- Прилипание: два края притягиваются к общей линии.
+       Линия посередине — граница, к которой прилипает край клипа;
+       треугольники по бокам показывают притяжение с обеих сторон. -->
+  <g fill="none" stroke="currentColor" stroke-width="2" stroke-linecap="square">
+    <line x1="12" y1="2" x2="12" y2="22"/>
+    <line x1="2" y1="6" x2="2" y2="18"/>
+    <line x1="22" y1="6" x2="22" y2="18"/>
+  </g>
+  <g fill="currentColor">
+    <polygon points="9,12 5,8 5,16"/>
+    <polygon points="15,12 19,8 19,16"/>
+  </g>
+</svg>

src/uMainForm.lfm

@@ -16,7 +16,7 @@ object MainForm: TMainForm
   object memoLog: TLogView
     Left = 0
     Height = 130
-    Top = 770
+    Top = 730
     Width = 1600
     Align = alBottom
     Font.Height = -11
@@ -27,7 +27,7 @@ object MainForm: TMainForm
   object pnlBottom: TPanel
     Left = 0
     Height = 40
-    Top = 730
+    Top = 860
     Width = 1600
     Align = alBottom
     BevelOuter = bvNone
@@ -56,24 +56,24 @@ object MainForm: TMainForm
       ShowHint = True
     end
     object btnRipple: TThemedButton
-      Left = 470
+      Left = 326
       Height = 28
       Top = 6
-      Width = 280
-      Caption = 'Схлопывание: текущая дорожка'
+      Width = 28
+      Icon = tiRipple
       OnClick = btnRippleClick
       ShowHint = True
     end
     object btnRippleMenu: TThemedButton
-      Left = 752
+      Left = 356
       Height = 28
       Top = 6
-      Width = 26
+      Width = 22
       Arrow = True
       OnClick = btnRippleMenuClick
     end
     object lblStatus: TLabel
-      Left = 790
+      Left = 428
       Height = 20
       Top = 10
       Width = 840

src/uMainForm.pas

@@ -568,6 +568,13 @@ procedure TMainForm.BuildMenu;
 var
   MFile, MEdit, MView, MProject: TMenuItem;
 begin
+  { Подсказки всплывают почти сразу: на кнопке со значком они не
+    украшение, а единственный способ узнать, что она делает. Держатся
+    долго — читать там больше, чем одно слово. }
+  Application.ShowHint := True;
+  Application.HintPause := 100;
+  Application.HintHidePause := 15000;
+
   BuildJobIndicator;
   FMenu := TMainMenu.Create(Self);
 
@@ -650,7 +657,8 @@ end;
 procedure TMainForm.BuildJobIndicator;
 const
   JobWidth = 330;
-  LogButtonWidth = 100;
+  LogButtonWidth = 28;
+  LogButtonLeft = 388;
 begin
   FJobLabel := TLabel.Create(Self);
   FJobLabel.Parent := pnlBottom;
@@ -674,19 +682,18 @@ begin
     рассказала. }
   FLogButton := TThemedButton.Create(Self);
   FLogButton.Parent := pnlBottom;
-  FLogButton.Anchors := [akTop, akRight];
-  FLogButton.SetBounds(pnlBottom.ClientWidth - JobWidth - LogButtonWidth - 20,
-    6, LogButtonWidth, 28);
-  FLogButton.Caption := 'Журнал';
+  { Рядом с прилипанием и схлопыванием: три переключателя читаются как
+    один набор, а не как случайно разбросанные значки. }
+  FLogButton.SetBounds(LogButtonLeft, 6, LogButtonWidth, 28);
+  FLogButton.Icon := tiLog;
   FLogButton.Down := True;
   FLogButton.OnClick := @LogButtonClick;
   FLogButton.ShowHint := True;
-  FLogButton.Hint := 'Спрятать или показать нижнюю полосу с сообщениями';
+  FLogButton.Hint := 'Журнал: спрятать или показать полосу с сообщениями';
 
   { Строка состояния ужимается, чтобы её длинные сообщения не залезали
     под показатель и под кнопку. }
-  lblStatus.Width := pnlBottom.ClientWidth - lblStatus.Left - JobWidth -
-    LogButtonWidth - 32;
+  lblStatus.Width := pnlBottom.ClientWidth - lblStatus.Left - JobWidth - 24;
 
   { Сто миллисекунд, а не триста: полоска должна ползти, а не дёргаться
     ступеньками. }
@@ -715,8 +722,13 @@ end;
 procedure TMainForm.ApplyLogVisible(AVisible: Boolean);
 begin
   memoLog.Visible := AVisible;
-  if Assigned(FLogButton) then
-    FLogButton.Down := AVisible;
+  if not Assigned(FLogButton) then
+    Exit;
+  FLogButton.Down := AVisible;
+  if AVisible then
+    FLogButton.Hint := 'Журнал виден. Нажмите, чтобы спрятать.'
+  else
+    FLogButton.Hint := 'Журнал спрятан. Нажмите, чтобы показать.';
 end;
 
 { Как растёт полоска.
@@ -1815,10 +1827,15 @@ begin
     ModeText := 'все дорожки'
   else
     ModeText := 'текущая дорожка';
-  btnRipple.Caption := 'Схлопывание: ' + ModeText;
   btnRipple.Down := FProject.RippleEnabled;
-  btnRipple.Hint := 'Ctrl+K — включить или выключить. ' +
-    'Режим действует и при выключенном автосхлопывании: по нему работает Ctrl+Shift+R.';
+  if FProject.RippleEnabled then
+    btnRipple.Hint := 'Автосхлопывание включено, режим: ' + ModeText + '.'
+  else
+    btnRipple.Hint := 'Автосхлопывание выключено, режим: ' + ModeText + '.';
+  btnRipple.Hint := btnRipple.Hint + LineEnding +
+    'Ctrl+K — включить или выключить. Режим действует и при выключенном ' +
+    'автосхлопывании: по нему работает Ctrl+Shift+R.';
+  btnRippleMenu.Hint := 'Выбрать режим схлопывания';
 end;
 
 { Прилипание краёв клипов друг к другу.
@@ -1826,14 +1843,20 @@ end;
   Shift работает как переключатель наоборот: при включённом прилипании
   временно отключает его, при выключенном — временно включает. Так одна
   клавиша полезна в обоих режимах, и не нужно помнить, какой сейчас. }
+{ Кнопка со значком не может сказать словами, что она делает и в каком
+  она состоянии. Слова переезжают в подсказку — целиком, вместе с
+  состоянием: иначе о состоянии пришлось бы догадываться по цвету. }
 procedure TMainForm.UpdateSnapButton;
+var
+  State: string;
 begin
   btnSnap.Down := FTimeline.SnapEnabled;
   if FTimeline.SnapEnabled then
-    btnSnap.Caption := 'Прилипание: вкл'
+    State := 'включено'
   else
-    btnSnap.Caption := 'Прилипание: выкл';
-  btnSnap.Hint := 'Shift во время перетаскивания меняет решение на противоположное.';
+    State := 'выключено';
+  btnSnap.Hint := 'Прилипание: ' + State + '.' + LineEnding +
+    'Shift во время перетаскивания меняет решение на противоположное.';
 end;
 
 procedure TMainForm.btnSnapClick(Sender: TObject);

src/uTheme.pas

@@ -31,7 +31,7 @@ interface
 
 uses
   Classes, SysUtils, Types, Controls, Graphics, Forms, StdCtrls, ExtCtrls,
-  ComCtrls, Grids, Menus, Dialogs, LCLType, LCLIntf, LCLProc;
+  ComCtrls, Grids, Menus, Dialogs, Math, LCLType, LCLIntf, LCLProc;
 
 const
   { Порядок байт в TColor — $00BBGGRR, а не привычный RGB. У серых цветов
@@ -53,6 +53,18 @@ const
   ThemeGridLine    = TColor($3A3A3A);
 
 type
+  { Значок на кнопке.
+
+    Рисуется кодом, а не берётся из файла: программа не должна зависеть
+    от того, лежит ли рядом с ней картинка. Рисунки повторяют icons/*.svg
+    — там они и придуманы, оттуда их можно перегнать в png для чего
+    угодно ещё. }
+  TThemedIcon = (
+    tiNone,
+    tiSnap,     // прилипание: края притягиваются к общей линии
+    tiRipple,   // схлопывание: дыра между кусками закрывается
+    tiLog       // журнал: полоса с сообщениями
+  );
 
   { Полоска выполнения, которая рисует себя сама.
 
@@ -82,6 +94,7 @@ type
   TThemedButton = class(TCustomControl)
   private
     FArrow: Boolean;
+    FIcon: TThemedIcon;
     FFlat: Boolean;
     FDown: Boolean;
     FHover: Boolean;
@@ -90,6 +103,8 @@ type
     FCancel: Boolean;
     FModalResult: TModalResult;
     procedure SetArrow(AValue: Boolean);
+    procedure SetIcon(AValue: TThemedIcon);
+    procedure DrawIcon(const ARect: TRect; AColor: TColor);
     procedure SetFlat(AValue: Boolean);
     procedure SetDown(AValue: Boolean);
     procedure SetDefault(AValue: Boolean);
@@ -122,6 +137,9 @@ type
     property Arrow: Boolean read FArrow write SetArrow default False;
     property Cancel: Boolean read FCancel write SetCancel default False;
     property Caption;
+    { Значок вместо надписи. Надпись при этом не пропадает зря: её место —
+      подсказка, которая всплывает по наведению. }
+    property Icon: TThemedIcon read FIcon write SetIcon default tiNone;
     property Default: Boolean read FDefault write SetDefault default False;
     property Down: Boolean read FDown write SetDown default False;
     property Enabled;
@@ -357,6 +375,101 @@ begin
   Result.cy := 28;
 end;
 
+procedure TThemedButton.SetIcon(AValue: TThemedIcon);
+begin
+  if FIcon = AValue then
+    Exit;
+  FIcon := AValue;
+  Invalidate;
+end;
+
+{ Значки рисуются по клетке 24 на 24 — той же, что в icons/*.svg, — и
+  переносятся в заданный прямоугольник. Так рисунок один и тот же при
+  любом размере кнопки, и правится он в одном месте. }
+procedure TThemedButton.DrawIcon(const ARect: TRect; AColor: TColor);
+var
+  Side, X0, Y0: Integer;
+
+  function PX(AValue: Integer): Integer;
+  begin
+    Result := X0 + Round(AValue * Side / 24);
+  end;
+
+  function PY(AValue: Integer): Integer;
+  begin
+    Result := Y0 + Round(AValue * Side / 24);
+  end;
+
+  procedure Line(X1, Y1, X2, Y2: Integer);
+  begin
+    Canvas.Line(PX(X1), PY(Y1), PX(X2), PY(Y2));
+  end;
+
+  procedure Box(X1, Y1, X2, Y2: Integer; AFilled: Boolean);
+  begin
+    if AFilled then
+      Canvas.Brush.Style := bsSolid
+    else
+      Canvas.Brush.Style := bsClear;
+    Canvas.Rectangle(PX(X1), PY(Y1), PX(X2), PY(Y2));
+  end;
+
+  { Треугольник остриём влево или вправо. Не Arrow: так называется
+    свойство самой кнопки. }
+  procedure Tri(ATipX, ABaseX, ACenterY, AHalf: Integer);
+  begin
+    Canvas.Brush.Style := bsSolid;
+    Canvas.Polygon([Types.Point(PX(ATipX), PY(ACenterY)),
+      Types.Point(PX(ABaseX), PY(ACenterY - AHalf)),
+      Types.Point(PX(ABaseX), PY(ACenterY + AHalf))]);
+  end;
+
+begin
+  if FIcon = tiNone then
+    Exit;
+
+  Side := Min(ARect.Right - ARect.Left, ARect.Bottom - ARect.Top) - 6;
+  if Side < 8 then
+    Exit;
+  X0 := (ARect.Left + ARect.Right - Side) div 2;
+  Y0 := (ARect.Top + ARect.Bottom - Side) div 2;
+
+  Canvas.Pen.Color := AColor;
+  Canvas.Pen.Width := Max(1, Side div 12);
+  Canvas.Brush.Color := AColor;
+
+  case FIcon of
+    tiSnap:
+      begin
+        { Средняя линия — граница, к которой прилипает край; по бокам
+          края, притягивающиеся к ней. }
+        Line(12, 2, 12, 22);
+        Line(2, 6, 2, 18);
+        Line(22, 6, 22, 18);
+        Tri(9, 5, 12, 4);
+        Tri(15, 19, 12, 4);
+      end;
+    tiRipple:
+      begin
+        { Два куска и дыра между ними; стрелка показывает, что правый
+          переедет влево. }
+        Box(1, 7, 8, 17, True);
+        Box(16, 7, 23, 17, True);
+        Tri(10, 15, 12, 4);
+      end;
+    tiLog:
+      begin
+        Box(2, 3, 22, 21, False);
+        Line(6, 8, 18, 8);
+        Line(6, 12, 18, 12);
+        Line(6, 16, 13, 16);
+      end;
+  end;
+
+  Canvas.Pen.Width := 1;
+  Canvas.Brush.Style := bsClear;
+end;
+
 procedure TThemedButton.Paint;
 var
   R: TRect;
@@ -422,6 +535,8 @@ begin
     Canvas.Polygon([Point(CX - 5, CY - 2), Point(CX + 5, CY - 2),
       Point(CX, CY + 4)]);
   end
+  else if FIcon <> tiNone then
+    DrawIcon(R, Fore)
   else
   begin
     Canvas.Font.Assign(Font);

tests/lfmcheck/lfmcheck.lpi

@@ -0,0 +1,37 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <CompatibilityMode Value="True"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="lfmcheck"/>
+    </General>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="lfmcheck.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="lfmcheck"/>
+    </Target>
+    <SearchPaths>
+      <OtherUnitFiles Value="../../src"/>
+      <UnitOutputDirectory Value="units"/>
+    </SearchPaths>
+  </CompilerOptions>
+</CONFIG>

tests/lfmcheck/lfmcheck.lpr

@@ -0,0 +1,67 @@
+{
+  Проверка того, что свойства, записанные в файле формы, у наших
+  элементов действительно есть.
+
+  Зачем отдельно. Файл формы разбирается при запуске, а не при сборке:
+  опечатка в имени свойства или в значении перечисления даёт не ошибку
+  компиляции, а падение окна на старте. Здесь то же самое проверяется без
+  окна — по сведениям о типах.
+}
+program lfmcheck;
+
+{$mode objfpc}{$H+}
+
+uses
+  { Interfaces нужен только для сборки: без него не связывается вся LCL.
+    Окно при этом не создаётся — Application.Initialize мы не зовём. }
+  Interfaces, SysUtils, TypInfo, uTheme;
+
+var
+  Failed: Integer = 0;
+
+procedure CheckProp(AClass: TClass; const AName: string);
+begin
+  if GetPropInfo(AClass, AName) <> nil then
+    WriteLn('  ok   ', AClass.ClassName, '.', AName)
+  else
+  begin
+    WriteLn('  ПЛОХО ', AClass.ClassName, '.', AName, ' — свойства нет');
+    Inc(Failed);
+  end;
+end;
+
+procedure CheckEnum(ATypeInfo: PTypeInfo; const AName: string);
+begin
+  if GetEnumValue(ATypeInfo, AName) >= 0 then
+    WriteLn('  ok   значение ', AName)
+  else
+  begin
+    WriteLn('  ПЛОХО значение ', AName, ' — такого нет');
+    Inc(Failed);
+  end;
+end;
+
+begin
+  WriteLn('Свойства из файлов форм');
+  WriteLn;
+
+  CheckProp(TThemedButton, 'Icon');
+  CheckProp(TThemedButton, 'Down');
+  CheckProp(TThemedButton, 'Arrow');
+  CheckProp(TThemedButton, 'Caption');
+  CheckProp(TThemedButton, 'ShowHint');
+
+  CheckEnum(TypeInfo(TThemedIcon), 'tiSnap');
+  CheckEnum(TypeInfo(TThemedIcon), 'tiRipple');
+  CheckEnum(TypeInfo(TThemedIcon), 'tiLog');
+  CheckEnum(TypeInfo(TThemedIcon), 'tiNone');
+
+  WriteLn;
+  if Failed = 0 then
+    WriteLn('ВЕРДИКТ: все проверки пройдены')
+  else
+  begin
+    WriteLn('ВЕРДИКТ: не пройдено проверок: ', Failed);
+    Halt(1);
+  end;
+end.