{------------------------------------------------------------------------------}
{
   Unit Name: kCheck
   Purpose  : An general check -component to help making checkable controls
   Author   : Vesa Lappalainen
   Date     : 10.09.2000
   Changed  : 30.12.2000
    + OnGetValue-event for TLimitCheck for easier use with different type
      components
   Changed  : 15.9.2001/vl
    + VCL/CLX compiling (define const CLX)
   ToDo     :

 Using TCheckLegal
  TCheckLegal is an base class for legal checks.

  Properties:
    property OK : boolean
      - is value OK or not
    property Reason : string
      - the explanation why value is not leagal
    property WarningColor : TColor
      - the color for Owner-control in case not OK.  If 0 the no color used
    property ShowHint : Boolean
      - show Reason in Owner-control's hint or not
    property OnCheck : TNotifyEvent read FOnCheck write FOnCheck;
      - which function to call when method DoCheck is called
        This method should set the OK value true or false and set
        also the Reason
    property Owner : TControl
      - read only

  Methods:
    constructor Create(AOwner:TControl); virtual;
    function DoCheck : boolean; virtual;
      - this method first calls OnCheck-method if assigned.
        Then WarningColor and Hint is used if needed
    procedure FormatReason(const fmt:string;const Args: array of const);
      - by this it is possible to set Reason using Delphis Format-function.
        Before calling Format-function, the parameter fmt is run thru
        StringCheckTranslate - function ptr pointing function.
        As a default this function pointer points to function NoTranslate
        that just returns the string as it is.  But if needed, the pointer
        can be changed to point any translator function

 Using TCheckLimit
  This is an example class of inherited TCheckLegal class.
  Checks that the value is between two values.

  Properties:
    property Min : double
      - min leagal value, check is made when this is changed
    property Max : double
      - max leagal value, check is made when this is changed

  Methods:
    constructor Create(AOwner:TControl); override;
    function DoDoubleCheck(d:double) : boolean; virtual;
      - returns if d is in [min,max]
    procedure OnDoubleCheck(sender:TObject); virtual;
      - "event" to be called from inherited class when DoCheck is called

  Global types:
    TStringCheckTranslate = function (const s:string):string;
      - function pointer to function doing translations

  Global variables:
    StringCheckTranslate : TStringCheckTranslate = NoTranslate;
      - pointer to function doing all translations in this module

  Global functions:
    function NoTranslate(const s:string):string;
      - to be used as no-translating function

    function CheckLegalDoCheck(comp:TComponent;stop:
            boolean=true;sp:pstring=nil):TControl; overload;
      - do check for all controls with property Check and return
        the first illegal control.  If stop = true, then check only
        until first illegal.  Othrewise check anytway all.
        is sp <> nil then collect resons to sp^ separated by cr lf.
        
    function ComponentDoAllCheckLegal(comp:TControl;legalfunc:TLegalFunc;
                                       stop:boolean):TControl;
      - to be used to made checks for all controls having "Check"-property
}
{------------------------------------------------------------------------------}
unit kCheck;

interface

uses SysUtils, classes,
{$ifdef CLX}
  QControls,QGraphics;
{$else}
  Windows,
  Controls,Graphics;
{$endif}

type
  TStringCheckTranslate = function (const s:string):string;
  TCheckGetValue = function ():double of object;

  TCheckLegal = class(TPersistent)
  private
    FOK: boolean;
    FReason: string;
    FOnCheck: TNotifyEvent;
    FOwner : TControl;
    FWarningColor: TColor;
    FOldColor : TColor;
    FParentColor : boolean;
    FParentShowHint : boolean;
    FOldHint : string;
    FShowHint: Boolean;
  protected
    procedure SetOK(const Value: boolean);

  public
    constructor Create(AOwner:TControl); virtual;
    property OnCheck : TNotifyEvent read FOnCheck write FOnCheck;
    function DoCheck : boolean; virtual;
    procedure FormatReason(const fmt:string;const Args: array of const);
    property Owner : TControl read FOwner;
    property OK : boolean read FOK; // write SetOK;
  published
    property Reason : string read FReason write FReason;
    property WarningColor : TColor read FWarningColor write FWarningColor default 0;
    property ShowHint : Boolean read FShowHint write FShowHint default false;
  end;

  TCheckLimit = class(TCheckLegal)
  private
    FMin: double;
    FMax: double;
    FOnGetValue: TCheckGetValue;
  protected
    procedure SetMax(const Value: double); virtual;
    procedure SetMin(const Value: double); virtual;
    function GetValue: double;             virtual;
  public
    constructor Create(AOwner:TControl); override;
    function DoDoubleCheck(d:double) : boolean; virtual;
    procedure OnDoubleCheck(sender:TObject); virtual;
    property OnGetValue: TCheckGetValue read FOnGetValue write FOnGetValue;
    property Value : double read GetValue;
  published
    property Min : double read FMin write SetMin nodefault;
    property Max : double read FMax write SetMax nodefault;
  end;

type TLegalFunc = function (legal:TCheckLegal):boolean;



function ComponentDoAllCheckLegal(comp:TComponent;legalfunc:TLegalFunc;stop:boolean=true;sp:pstring=nil):TControl;
function CheckLegalDoCheck(comp:TComponent;stop:boolean=true;sp:pstring=nil):TControl; overload;
function NoTranslate(const s:string):string;

var StringCheckTranslate : TStringCheckTranslate = NoTranslate;

implementation
uses kPropFunc;

function ComponentDoAllCheckLegal(comp:TComponent;legalfunc:TLegalFunc;stop:boolean; sp:pstring):TControl;
var i:integer; c: TComponent; o: TObject; legal : TCheckLegal; var sep:string;
begin
  if ( sp <> nil ) then sp^ := '';
  sep := '';
  Result := nil;
  for i:=0 to comp.ComponentCount-1 do begin
    c := comp.Components[i];
    o := GetObjProperty(c,'Check');
    if not ( o is TCheckLegal ) then continue;
    legal := TCheckLegal(o);
    if not legalfunc(legal) then begin
      if Result = nil then Result := legal.Owner;
      if ( sp <> nil ) then sp^ := sp^ + sep + legal.Reason;
      if ( stop ) then exit;
      sep := #13#10;
    end;
  end;
end;

function CheckLegalDoCheck(legal:TCheckLegal):boolean; overload;
begin
  Result := legal.DoCheck;
end;

function CheckLegalDoCheck(comp:TComponent;stop:boolean; sp:pstring):TControl;
begin
  Result := ComponentDoAllCheckLegal(comp,CheckLegalDoCheck,stop,sp);
end;

{ TCheckLegal }
function NoTranslate(const s:string):string;
begin
  Result := s;
end;  

type TColorControl = class(TControl)
  published
    property Color;
    property ParentColor;
    property Hint;
    property ParentShowHint;
    property ShowHint;
  end;

constructor TCheckLegal.Create(AOwner:TControl);
begin
  inherited Create;
  FOwner := AOwner;
  FReason := '';
  FOK := true;
end;

function TCheckLegal.DoCheck: boolean;
var oldOK : boolean; c : TColorControl;  OldReason : string;
begin
  Result := true;
  if ( Owner = nil ) or ( csDesigning in Owner.ComponentState ) then exit;
  oldOK := OK;
  oldReason := Reason;
  if ( Assigned(OnCheck) ) then OnCheck(self);
  Result := OK;
  if ( Owner = nil ) then exit;
  c := TColorControl(Owner);
  if ( WarningColor <> 0 ) and ( not OK ) and ( oldOK ) then begin
    FParentColor := c.ParentColor;;
    FOldColor := c.Color;
    c.Color := WarningColor;
  end;
  if ( WarningColor <> 0 ) and ( OK ) and ( not oldOK ) then begin
    if ( FParentColor ) then c.ParentColor := FParentColor
    else  c.Color := FOldColor;
  end;

  if ( ShowHint ) and ( not OK ) and ( oldOK ) then begin
    FParentShowHint := c.ParentShowHint;
    FOldHint := c.Hint;
  end;

  if ( ShowHint ) and ( not OK ) and ( Reason <> oldReason ) then begin
    c.ShowHint := true;
    c.Hint := FOldHint + ' ' + Reason;
  end;

  if ( ShowHint ) and ( OK ) and ( not oldOK ) then begin
    c.Hint := FOldHint;
    c.ParentShowHint := FParentShowHint;
  end;
end;

procedure TCheckLegal.FormatReason(const fmt: string;
  const Args: array of const);
begin
  Reason := Format(StringCheckTranslate(fmt),Args);
end;

procedure TCheckLegal.SetOK(const Value: boolean);
begin
  FOK := Value;
end;

{ TCheckLimit }

constructor TCheckLimit.Create(AOwner:TControl);
begin
  inherited;
  fmin := 0;
  fmax :=  1e100;
  OnCheck := OnDoubleCheck;
end;

function TCheckLimit.DoDoubleCheck(d:double): boolean;
begin
  if ( min=0 ) and ( max=0 ) then begin
    Result := true;
  end else begin
    Result := ( min <= d ) and ( d <= max );
  end;
end;

function TCheckLimit.GetValue: double;
begin
  Result := 0;
  if ( Assigned(OnGetValue) ) then Result := OnGetValue();
end;

procedure TCheckLimit.OnDoubleCheck(sender: TObject);
begin
  SetOK(DoDoubleCheck(Value));
  if ( OK ) then
    Reason := ''
  else
    FormatReason('Not in range [%g,%g]',[min,max]); // TRANSLATE
end;

procedure TCheckLimit.SetMax(const Value: double);
begin
  FMax := Value;
  DoCheck;
end;

procedure TCheckLimit.SetMin(const Value: double);
begin
  FMin := Value;
  DoCheck;
end;



end.