unit DdhSemaL;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  Controls, Forms, Dialogs, DdhLed, ExtCtrls;

{$R *.DCR}

  type
  // States enumeration
  TSemState = (scRed, scGreen, scYellow, scOff, scPulse);

  // method pointer type for events
  TLightClickEvent = procedure (
    Sender: TObject; var Active: Boolean) of object;

  TDdhLoadedSemaphore = class (TCustomControl)
  private
    // the three semaphore lights
    fGreenL, fYellowL, fRedL: TDDHLed;

    fSemState: TSemState; // status
    fTimer: TTimer; // timer for pulse
    fInterval: Integer; // timer interval

    // light click events
    fGreenClick, fRedClick, fYellowClick:
      TLightClickEvent;

    procedure TimerOnTimer (Sender: TObject);
    procedure TurnOff;
    procedure StartPulse;
    procedure StopPulse;

    // led click response methods
    procedure fGreenLedClick (Sender: TObject);
    procedure fRedLedClick (Sender: TObject);
    procedure fYellowLedClick (Sender: TObject);
  protected
    // property access methods
    procedure SetSemState (Value: TSemState);
    procedure SetInterval (Value: Integer);
  public
    constructor Create (Owner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure SetBounds (ALeft, ATop,
      AWidth, AHeight : Integer); override;
    procedure Loaded; override;
  published
    // new properties
    property SemState: TSemState
      read fSemState write SetSemState default scOff;
    property Interval: Integer
      read fInterval write SetInterval default 500;

    // inherited properties with defaults
    property Width default 30;
    property Height default 90;

    // custom events
    property GreenClick: TLightClickEvent
      read fGreenClick write fGreenClick;
    property RedClick: TLightClickEvent
      read fRedClick write fRedClick;
    property YellowClick: TLightClickEvent
      read fYellowClick write fYellowClick;
  end;

procedure Register;

implementation

constructor TDdhLoadedSemaphore.Create (Owner: TComponent);
begin
  inherited Create (Owner);

  // create the leds and set their color
  fGreenL := TDDHLed.Create (self);
  fGreenL.Parent := self;
  fGreenL.Color := clLime; // light green
  fGreenL.OnClick := fGreenLedClick;

  fYellowL := TDDHLed.Create (self);
  fYellowL.Parent := self;
  fYellowL.Color := clYellow;
  fYellowL.OnClick := fYellowLedClick;

  fRedL := TDDHLed.Create (self);
  fRedL.Parent := self;
  fRedL.Color := clRed;
  fRedL.OnClick := fRedLedClick;

  // set default values
  SetBounds (Left, Top, 30, 90);
  fSemState := scOff;
  TurnOff;
  fInterval := 500;
end;

procedure TDdhLoadedSemaphore.Paint;
var
  LedSize: Integer;
begin
  // compute the actual size
  // of the semaphore image
  if Width * 3 > Height then
    LedSize := Height div 3
  else
    LedSize := Width;

  // draw the background
  Canvas.Brush.Color := clBlack;
  Canvas.FillRect (Rect (0, 0,
    LedSize, LedSize * 3));
end;

procedure TDdhLoadedSemaphore.SetBounds (
  ALeft, ATop, AWidth, AHeight : Integer);
var
  LedSize: Integer;
begin
  // set a minimum size
  if AWidth < 20 then
    AWidth := 20;
  if AHeight < 60 then
    AHeight := 60;

  // compute the actual size
  // of the semaphore image
  if AWidth * 3 > AHeight then
    LedSize := AHeight div 3
  else
    LedSize := AWidth;

  // set component size
  if not (csReading in ComponentState) then
    inherited SetBounds (ALeft, ATop,
      LedSize, LedSize * 3)
  else
    inherited SetBounds (ALeft, ATop,
      AWidth, AHeight);

  // set the led position and size
  LedSize := LedSize - 2;
  fRedL.SetBounds (1, 1,
    LedSize, LedSize);
  fYellowL.SetBounds (1, LedSize + 3,
    LedSize, LedSize);
  fGreenL.SetBounds (1, LedSize * 2 + 5,
    LedSize, LedSize);
end;

procedure TDdhLoadedSemaphore.Loaded;
begin
  // double-check if size is OK
  if (Width * 3) <> Height then
    SetBounds (Left, Top, Width, Height);
end;

procedure TDdhLoadedSemaphore.SetSemState (Value: TSemState);
begin
  if Value <> fSemState then
  begin
    TurnOff;
    if fSemState = scPulse then
      StopPulse;
    case Value of
      scRed: fRedL.Status := lsOn;
      scGreen: fGreenL.Status := lsOn;
      scYellow: fYellowL.Status := lsOn;
      scPulse: StartPulse;
      // scOff: nothing to do
    end;
    fSemState := Value;
  end;
end;

procedure TDdhLoadedSemaphore.TurnOff;
begin
  fRedL.Status := lsOff;
  fGreenL.Status := lsOff;
  fYellowL.Status := lsOff;
end;

procedure TDdhLoadedSemaphore.StartPulse;
begin
  fTimer := TTimer.Create (self);
  fTimer.Interval := fInterval;
  fTimer.OnTimer := TimerOnTimer;
  fTimer.Enabled := True;
end;

procedure TDdhLoadedSemaphore.StopPulse;
begin
  fTimer.Enabled := False;
  fTimer.Free;
  fTimer := nil;
end;

procedure TDdhLoadedSemaphore.TimerOnTimer (Sender: TObject);
begin
  if fRedL.Status = lsOn then
    fRedL.Status := lsOff
  else
    fRedL.Status := lsOn;
end;

destructor TDdhLoadedSemaphore.Destroy;
begin
  if fSemState = scPulse then
    StopPulse;
  inherited Destroy;
end;

procedure TDdhLoadedSemaphore.SetInterval (Value: Integer);
begin
  if Value <> fInterval then
  begin
    fInterval := Value;
    if Assigned (fTimer) then
      fTimer.Interval := fInterval;
  end;
end;

// led Onclick event handlers,
// raising semaphore events

procedure TDdhLoadedSemaphore.fGreenLedClick (Sender: TObject);
var
  Status: Boolean;
begin
  if Assigned (fGreenClick) then
  begin
    Status := (fGreenL.Status = lsOn);
    fGreenClick (self, Status);
    if Status then
      SemState := scGreen;
  end;
end;

procedure TDdhLoadedSemaphore.fRedLedClick (Sender: TObject);
var
  Status: Boolean;
begin
  if Assigned (fRedClick) then
  begin
    Status := (fRedL.Status = lsOn);
    fRedClick (self, Status);
    if Status then
      SemState := scRed;
  end;
end;

procedure TDdhLoadedSemaphore.fYellowLedClick (Sender: TObject);
var
  Status: Boolean;
begin
  if Assigned (fYellowClick) then
  begin
    Status := (fYellowL.Status = lsOn);
    fYellowClick (self, Status);
    if Status then
      SemState := scYellow;
  end;
end;

procedure Register;
begin
  RegisterComponents ('DDHB', [TDdhLoadedSemaphore]);
end;

end.