Plancia/uGauge.pas

unit uGauge;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, System.Types,
  Vcl.Controls, Vcl.Graphics;

const
  // Valori sentinella: soglia di allarme non impostata.
  GAUGE_NO_WARN_LO = -1E30;
  GAUGE_NO_WARN_HI = 1E30;

type
  /// Dati necessari a disegnare una colonna: raccolti in un record cosi' lo
  /// stesso disegno e' riusabile da qualunque controllo, non solo da
  /// TTankGauge (lo usa anche l'elemento gauge della plancia).
  TGaugeInfo = record
    Title: string;
    Units: string;
    MinValue: Double;
    MaxValue: Double;
    Value: Double;
    WarnBelow: Double;
    WarnAbove: Double;
    TickCount: Integer;
    Valid: Boolean;
    BackColor: TColor;
    /// Colonna e scritte abbassate, per non abbagliare in navigazione notturna.
    NightMode: Boolean;
    /// Fattore di zoom: scala le misure fisse del disegno (titolo, colonna,
    /// tacche). 0 o assente equivale a 1.
    Scale: Double;
  end;

/// Disegna la colonna dentro ABounds, in coordinate del canvas ricevuto.
procedure PaintTankGauge(ACanvas: TCanvas; const ABounds: TRect;
  const AInfo: TGaugeInfo);

type
  /// <summary>
  ///   Indicatore verticale a colonna, tipo termometro o livello serbatoio.
  ///   Disegnato a mano su TGraphicControl: nessuna dipendenza da package
  ///   esterni, quindi non serve installare nulla nell'IDE.
  /// </summary>
  TTankGauge = class(TGraphicControl)
  private
    FMinValue: Double;
    FMaxValue: Double;
    FValue: Double;
    FUnits: string;
    FTitle: string;
    FWarnBelow: Double;
    FWarnAbove: Double;
    FTickCount: Integer;
    FValid: Boolean;
    procedure SetValue(const AValue: Double);
    procedure SetValid(const AValue: Boolean);
    procedure SetTitle(const AValue: string);
    procedure SetUnits(const AValue: string);
    function GaugeInfo: TGaugeInfo;
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    /// Imposta il fondo scala in unita' ingegneristiche e il numero di tacche.
    procedure SetRange(const AMin, AMax: Double; ATickCount: Integer = 5);
    /// Sotto ABelow o sopra AAbove la colonna diventa rossa.
    procedure SetWarnings(const ABelow, AAbove: Double);
    /// Assegnare Value marca automaticamente il dato come valido.
    property Value: Double read FValue write SetValue;
    /// A False la colonna resta vuota e il valore mostra '--'.
    property Valid: Boolean read FValid write SetValid;
    property Title: string read FTitle write SetTitle;
    property Units: string read FUnits write SetUnits;
    property MinValue: Double read FMinValue;
    property MaxValue: Double read FMaxValue;
  published
    property Color;
    property Font;
    property ParentFont;
    property Visible;
  end;

implementation

const
  TITLE_H = 18;
  VALUE_H = 20;
  BODY_W = 28;
  TICK_LEN = 4;
  CLR_OK = TColor($0050AF4C);
  CLR_ALARM = TColor($002F2FD3);
  // Modalita' notturna: stessa frazione e stesso ambra usati dalla plancia,
  // altrimenti un gauge stonerebbe in mezzo ai comandi.
  GAUGE_NIGHT_DIM = 0.34;
  GAUGE_NIGHT_INK = TColor($003796EB);

constructor TTankGauge.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 130;
  Height := 200;
  Color := clBtnFace;
  FMinValue := 0;
  FMaxValue := 100;
  FValue := 0;
  FTickCount := 5;
  FValid := False;
  FWarnBelow := GAUGE_NO_WARN_LO;
  FWarnAbove := GAUGE_NO_WARN_HI;
end;

procedure TTankGauge.SetRange(const AMin, AMax: Double; ATickCount: Integer);
begin
  FMinValue := AMin;
  FMaxValue := AMax;
  if ATickCount < 2 then
    FTickCount := 2
  else
    FTickCount := ATickCount;
  Invalidate;
end;

procedure TTankGauge.SetWarnings(const ABelow, AAbove: Double);
begin
  FWarnBelow := ABelow;
  FWarnAbove := AAbove;
  Invalidate;
end;

procedure TTankGauge.SetValue(const AValue: Double);
begin
  if (FValue = AValue) and FValid then
    Exit;
  FValue := AValue;
  FValid := True;
  Invalidate;
end;

procedure TTankGauge.SetValid(const AValue: Boolean);
begin
  if FValid = AValue then
    Exit;
  FValid := AValue;
  Invalidate;
end;

procedure TTankGauge.SetTitle(const AValue: string);
begin
  if FTitle = AValue then
    Exit;
  FTitle := AValue;
  Invalidate;
end;

procedure TTankGauge.SetUnits(const AValue: string);
begin
  if FUnits = AValue then
    Exit;
  FUnits := AValue;
  Invalidate;
end;

function GaugeValueText(const AInfo: TGaugeInfo): string;
begin
  if not AInfo.Valid then
    Exit('--');
  Result := FormatFloat('0.#', AInfo.Value);
  if AInfo.Units <> '' then
    Result := Result + ' ' + AInfo.Units;
end;

procedure PaintTankGauge(ACanvas: TCanvas; const ABounds: TRect;
  const AInfo: TGaugeInfo);
var
  Body: TRect;
  FillTop, I, Y, TxtY, TxtH, Ticks: Integer;
  TitleH, ValueH, BodyW, TickLen: Integer;
  Frac, TickVal, Z: Double;
  S: string;

  /// Il colore come va steso: tale e quale di giorno, abbassato di notte.
  function Dusk(AColor: TColor): TColor;
  var
    C: Longint;
  begin
    if not AInfo.NightMode then
      Exit(AColor);
    C := ColorToRGB(AColor);
    Result := TColor(RGB(
      Round(GetRValue(C) * GAUGE_NIGHT_DIM),
      Round(GetGValue(C) * GAUGE_NIGHT_DIM),
      Round(GetBValue(C) * GAUGE_NIGHT_DIM)));
  end;

begin
  Ticks := AInfo.TickCount;
  if Ticks < 2 then
    Ticks := 2;
  Z := AInfo.Scale;
  if Z <= 0 then
    Z := 1;
  TitleH := Round(TITLE_H * Z);
  ValueH := Round(VALUE_H * Z);
  BodyW := Round(BODY_W * Z);
  TickLen := Round(TICK_LEN * Z);

  ACanvas.Brush.Style := bsSolid;
  ACanvas.Brush.Color := AInfo.BackColor;
  ACanvas.FillRect(ABounds);

  Body := Rect(ABounds.Left + 1, ABounds.Top + TitleH,
    ABounds.Left + 1 + BodyW, ABounds.Bottom - ValueH);
  if Body.Bottom <= Body.Top then
    Exit;

  // colonna vuota
  ACanvas.Brush.Color := Dusk(clWhite);
  ACanvas.Pen.Color := Dusk(clGray);
  ACanvas.Pen.Width := 1;
  ACanvas.Rectangle(Body);

  // riempimento proporzionale, dal basso verso l'alto
  if AInfo.Valid and (AInfo.MaxValue > AInfo.MinValue) then
  begin
    Frac := (AInfo.Value - AInfo.MinValue) / (AInfo.MaxValue - AInfo.MinValue);
    if Frac < 0 then
      Frac := 0;
    if Frac > 1 then
      Frac := 1;
    FillTop := (Body.Bottom - 1) - Round((Body.Bottom - Body.Top - 2) * Frac);
    if FillTop < Body.Bottom - 1 then
    begin
      if (AInfo.Value < AInfo.WarnBelow) or (AInfo.Value > AInfo.WarnAbove) then
        ACanvas.Brush.Color := Dusk(CLR_ALARM)
      else
        ACanvas.Brush.Color := Dusk(CLR_OK);
      ACanvas.FillRect(Rect(Body.Left + 1, FillTop, Body.Right - 1,
        Body.Bottom - 1));
    end;
  end;

  ACanvas.Brush.Style := bsClear;
  // Di notte le scritte non si abbassano, si sostituiscono: un titolo nero
  // abbassato resterebbe nero, cioe' invisibile sul fondo scuro.
  if AInfo.NightMode then
    ACanvas.Font.Color := GAUGE_NIGHT_INK
  else
    ACanvas.Font.Color := clWindowText;

  // titolo
  ACanvas.Font.Style := [];
  ACanvas.TextOut(ABounds.Left, ABounds.Top, AInfo.Title);

  // tacche della scala, dal massimo in alto al minimo in basso
  ACanvas.Pen.Color := Dusk(clGray);
  for I := 0 to Ticks - 1 do
  begin
    Y := Body.Top + Round((Body.Bottom - Body.Top) * I / (Ticks - 1));
    if Y >= Body.Bottom then
      Y := Body.Bottom - 1;
    ACanvas.MoveTo(Body.Right, Y);
    ACanvas.LineTo(Body.Right + TickLen, Y);

    TickVal := AInfo.MaxValue - (AInfo.MaxValue - AInfo.MinValue) * I / (Ticks - 1);
    S := FormatFloat('0.#', TickVal);
    TxtH := ACanvas.TextHeight(S);
    TxtY := Y - TxtH div 2;
    if TxtY < Body.Top then
      TxtY := Body.Top;
    if TxtY + TxtH > Body.Bottom then
      TxtY := Body.Bottom - TxtH;
    ACanvas.TextOut(Body.Right + TickLen + 3, TxtY, S);
  end;

  // valore corrente
  ACanvas.Font.Style := [fsBold];
  ACanvas.TextOut(ABounds.Left, ABounds.Bottom - ValueH + 2,
    GaugeValueText(AInfo));
end;

function TTankGauge.GaugeInfo: TGaugeInfo;
begin
  Result.Title := FTitle;
  Result.Units := FUnits;
  Result.MinValue := FMinValue;
  Result.MaxValue := FMaxValue;
  Result.Value := FValue;
  Result.WarnBelow := FWarnBelow;
  Result.WarnAbove := FWarnAbove;
  Result.TickCount := FTickCount;
  Result.Valid := FValid;
  Result.BackColor := Color;
  Result.Scale := 1;
end;

procedure TTankGauge.Paint;
begin
  Canvas.Font := Font;
  PaintTankGauge(Canvas, ClientRect, GaugeInfo);
end;

end.