{------------------------------------------------------------------------------}
{
   Unit Name: kExtraCtl
   Purpose  : Extra components for dynamic load and programs to run.
              Espacially for Kave2000
   Author   : Vesa Lappalainen
   Date     : 12.3.1999
   Changed  :

   ToDo     : How to get a different FormProg for every component?
              Like in Service-prog-case.
}
{------------------------------------------------------------------------------}
{$define DEBUGEXTRA} // define this to get errorlog

unit kExtraCtl;

interface
uses classes, kIniSave,kIniComp,stdctrls,extctrls,progc,forms,
     kcomp, kparam,comctrls,kButtons,Controls,SysUtils,kconcomp;

type  ExplArray = array[0..100] of string;
      PExplArray = ^ExplArray;

type TCmpProg = class (TPersistent)
  private
    FNames : TStrings;
    FNotRun : integer;
    FECount : integer;
    FPExpl : PExplArray;
    FOwner : TComponent;
    FLogError : boolean;
    FFormProg : TFormProg;

    function GetName(i: integer): string;
    procedure SetName(i: integer; const Value: string);
    function GetCount: integer;
    function GetExpl(i: integer): string; // Index of the last method that could not be run
  protected
    procedure SetNames(const Value: TStrings); virtual;
  public
    constructor Create(AOwner:TComponent;ecount:integer; ept:PExplArray); virtual;
    destructor Destroy; override;
    Procedure Run(i:integer); virtual;
    function Str(i:integer):string; virtual;
    procedure Add(i:integer;const s:string);
    procedure FillExpl(str:TStrings);
    property Name[i:integer]:string read GetName write SetName;
    property Expl[i:integer]:string read GetExpl;
  published
    procedure RunUnRun; virtual;
    property Names:TStrings read FNames write SetNames;
    property Count : integer read GetCount;
    property ExplCount : integer read FECount;
    property Owner : TComponent read FOwner;
    property LogError : boolean read FLogError write FLogError default true;
    property FormProg : TFormProg read FFormProg write FFormProg;
end;

type TkProgCheckBox = class(TCheckBoxIni)
  private
    FProgs : TCmpProg;
    FPanel : TPanel;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    Procedure Click; override;
    procedure SetParent(c:TWinControl); override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;

type TkProgTabSheet = class(TTabSheet)
  private
    FProgs : TCmpProg;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    Procedure DoShow; override;
    Procedure DoHide; override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;

type TkProgButton = class(TkSpeedButton)
  private
    FProgs : TCmpProg;
    FIni : TIniSave;
    InMouseUp : boolean;
    FLinkComponent: TComponent;
  protected  
    procedure HandleForced(toDown:boolean); override;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    Procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    Procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Loaded; override;
    procedure   SetAsString(s:string);     virtual;
    function    GetAsString:string;        virtual;
 published
    property Ini : TIniSave read FIni write FIni;
    property AsString : string read GetAsString write SetAsString stored false;
    property Progs : TCmpProg read FProgs write FProgs;
    property LinkComponent : TComponent read FLinkComponent write FLinkComponent default nil;
end;

type TkProgCounter = class(TCounter)
  private
    FProgs : TCmpProg;
  published
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure SetValue(d:double); override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;

type TkProgEncoder = class(TcEncoder)
  private
    FProgs : TCmpProg;
  published
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure SetValue(d:double); override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;

type TkProgParam = class(TkParam)
  private
    FProgs : TCmpProg;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure SetValue(d:double); override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;


type TProgInverter = class(TcInverter)
  private
    FProgs : TCmpProg;
  public
    constructor Create(AOwner:TComponent); override;
    destructor Destroy; override;
    procedure SetValue(d:double); override;
  published
    property Progs : TCmpProg read FProgs write FProgs;
end;

procedure Register;
function GetCmpProgProperty(comp:TObject; const propname:string) : TCmpProg;
function FillExtraControls(form:TForm; str:TStrings; clr:boolean=true):integer;  overload;
procedure FillExtraExplanations(c:TObject;str:TStrings);
function GetCurrentExtraProgram(c:TObject; i:integer):string;
procedure SetCurrentExtraProgram(c:TObject; i:integer; const s:string; form:TForm=nil);

implementation
uses kPropFunc
{$ifdef DEBUGEXTRA}
 ,kErrors
{$endif}
  ,BackroundImage, kPageControl, TransparentPanel
;

{$ifdef DEBUGEXTRA}
var ceExtraCompDebug : TCommError;
{$endif}

procedure Register;
begin
  RegisterComponents('KaveExt', [TkProgCheckBox,TkProgTabSheet,TkProgButton]);
  RegisterComponents('KaveExt', [TkProgCounter,TkProgParam,TProgInverter]);
end;



//------------------------------------------------------------------------------
// TCmpProg
//------------------------------------------------------------------------------


{------------------------------------------------------------------------------}
function GetCmpProgProperty(comp:TObject; const propname:string) : TCmpProg;
var
  o: TObject;
begin
  Result := nil;
  o := GetObjProperty(comp,propname);
  if not ( o is TCmpProg ) then exit;
  Result := TCmpProg(o);
end;

procedure FillExtraControls(startname:string;fo:TComponent;strs:TStrings); overload;
var i:integer; c:TComponent; prg : TCmpProg;
begin
  for i:=0 to fo.ComponentCount-1 do begin
    c := fo.Components[i];
    if ( c is TFrame ) then begin
      FillExtraControls(startname+c.Name+'.',c,strs);
      continue;
    end;
    prg := GetCmpProgProperty(c,'Progs');
    if ( prg = nil ) then continue;
    strs.AddObject(startname+c.Name,c);
  end;
end;


function FillExtraControls(form:TForm; str:TStrings; clr:boolean=true):integer;
begin
  Result := 0;
  if clr then str.Clear;
  FillExtraControls('',form,str);
end;


procedure FillExtraExplanations(c:TObject;str:TStrings);
var prg : TCmpProg;
begin
  prg := GetCmpProgProperty(c,'Progs');
  if ( prg = nil ) then exit;
  prg.FillExpl(str);
end;

function GetCurrentExtraProgram(c:TObject; i:integer):string;
var prg : TCmpProg;
begin
  Result := '';
  prg := GetCmpProgProperty(c,'Progs');
  if ( prg = nil ) then exit;
  Result := prg.Name[i];
end;

procedure SetCurrentExtraProgram(c:TObject; i:integer; const s:string; form:TForm=nil);
var prg : TCmpProg;
begin
  prg := GetCmpProgProperty(c,'Progs');
  if ( prg = nil ) then exit;
  prg.Name[i] := s;
  if ( form is TFormProg ) then
    prg.FormProg := TFormProg(form);
end;

procedure TCmpProg.Add(i: integer; const s: string);
var j:integer;
begin
  if ( i < 0 ) then exit;
  if ( i >= Names.Count ) or ( i >= ExplCount ) then begin
    for j := Names.Count to i do Names.Add('');
  end;
  Names[i] := s;
  for i:= Names.Count-1 downto 0 do begin
    if ( Names[i] <> '' ) then exit;
    Names.Delete(i);
  end;
end;

constructor TCmpProg.Create(AOwner:TComponent;ecount:integer; ept:PExplArray);
begin
  inherited Create;
  FOwner := AOwner;
  FNames := TStringList.Create;
  FNotRun := -1;
  FPExpl := ept;
  FECount := ecount;
  FLogError := true;
end;


destructor TCmpProg.Destroy;
begin
  Names.Free;
  inherited;
end;

procedure TCmpProg.FillExpl(str: TStrings);
var i:integer;
begin
  str.Clear;
  for i:=0 to ExplCount-1 do begin
    str.Add(Expl[i]);
  end;
end;

function TCmpProg.GetCount: integer;
begin
  Result := Names.Count;
end;

function TCmpProg.GetExpl(i: integer): string;
begin
  Result := 'Not implemented';
  if ( i < 0 ) or ( i >= FECount ) or ( FPexpl = nil ) then exit;
  Result := FPExpl^[i];
end;

function TCmpProg.GetName(i: integer): string;
begin
  Result := '';
  if ( i < 0 ) or ( i >= Names.Count ) then exit;
  Result := Names[i];
end;


Procedure TCmpProg.Run(i: integer);
begin
  if ( i < 0 ) then exit;
{$ifdef DEBUGEXTRA}
  if ( LogError ) then
    ceExtraCompDebug.Add(Owner.Name+':'+IntToStr(i));
{$endif}
  FNotRun := i;
  if ( i >= Names.Count ) then exit;
  if ( Names[i] = '' ) then exit;
//  Form1.Memo1.Lines.Add('Prog ' + IntToStr(i) + ' ' + Names[i]);
  if ( FormProg = nil ) then begin
    FormProg := progc.FormProg;
    if ( FormProg = nil ) then exit;
  end;
  FormProg.Run(Names[i]);
  FNotRun := -1;
end;

procedure TCmpProg.RunUnRun;
begin
  if ( FNotRun >= 0 ) then Run(FNotRun);
end;

procedure TCmpProg.SetName(i: integer; const Value: string);
begin
  Add(i,Value);
end;

procedure TCmpProg.SetNames(const Value: TStrings);
begin
  FNames.Assign(Value);
end;

function TCmpProg.Str(i: integer): string;
begin
  Result := '';
  if ( i < 0 ) or ( i >= Names.Count ) then exit;
  Result := Names[i];
end;

//------------------------------------------------------------------------------
// TFramePanel
//------------------------------------------------------------------------------
type
  TFramePanel = class(TPanel)
  private
    Client : TControl;
  public
    procedure SetParent(c:TWinControl); override;
    destructor Destroy; override;
  end;

{ TFramePanel }


procedure TFramePanel.SetParent(c: TWinControl);
begin
  inherited;
end;


destructor TFramePanel.Destroy;
begin
  if ( Owner <> nil ) then TControl(Owner).Parent := nil;
  inherited;
end;

//------------------------------------------------------------------------------
// TkProgCheckBox
//------------------------------------------------------------------------------
const explcb : array[0..1] of string = ('Not checked','Checked');

Procedure TkProgCheckBox.Click;
var i:integer;
begin
  inherited;
  i := Ord(State);
  Progs.Run(i);
//  Caption := Progs.Str(i);
end;

constructor TkProgCheckBox.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  FProgs := TCmpProg.Create(self,2,@explcb);
end;


destructor TkProgCheckBox.Destroy;
begin
  FProgs.Free;
  if ( FPanel <> nil ) then FPanel.Parent := nil;
  inherited SetParent(nil);
  inherited Destroy;
end;

procedure TkProgCheckBox.SetParent(c: TWinControl);
begin
  inherited;
  exit;
  if ( c = nil ) then begin
    if ( FPanel <> nil ) then begin
      FPanel.Parent := nil;
      if not ( csDestroying in FPanel.ComponentState ) then FPanel.Free;
      FPanel := nil;
    end;
    inherited SetParent(nil);
    exit;
  end;

  if ( FPanel <> nil ) then begin
    FPanel.Parent := c;
    Exit;
  end;
  if ( c <> nil ) then begin
    FPanel := TFramePanel.Create(self);
    FPanel.Parent := c;
    inherited SetParent(FPanel);
    exit;
  end;

end;


//------------------------------------------------------------------------------
// TkProgTabSheet
//------------------------------------------------------------------------------
const expltabsheet : array[0..1] of string = ('Hide','Show');

constructor TkProgTabSheet.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  FProgs := TCmpProg.Create(self,2,@expltabsheet);
end;


destructor TkProgTabSheet.Destroy;
begin
  FProgs.Free;
  inherited Destroy;
end;

Procedure TkProgTabSheet.DoHide;
begin
  inherited;
  Progs.Run(0);
end;

Procedure TkProgTabSheet.DoShow;
begin
  inherited;
  Progs.Run(1);
end;

//------------------------------------------------------------------------------
{ TkProgButton }
//------------------------------------------------------------------------------
const explbutton : array[0..3] of string =
('Mouse up, button up','Mouse down, button down','Mouse up, stays down','Mouse down, follows up');

constructor TkProgButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FProgs := TCmpProg.Create(self,4,@explbutton);
  FIni          := TIniSave.Create(self);
  Ini.AutoSave  := false;
  AllowAllUp    := true;
end;

destructor TkProgButton.Destroy;
begin
  Ini.DoAutoSave;
  FIni.Free;
  FProgs.Free;
  inherited Destroy;
end;

function TkProgButton.GetAsString: string;
begin
  Result := IntToStr(Ord(Down));
end;

procedure TkProgButton.HandleForced(toDown:boolean);
begin
  inherited;
  if ( not InMouseUp ) then
    Progs.Run(Ord(toDown));
end;

procedure TkProgButton.Loaded;
begin
  inherited;
  Ini.Read;
  Progs.Run(Ord(Down));
end;

// ha + b alas = 1    load
// ha + b nou nostolla ylös = 3
// hy + jää = 2
// hy + nou = 0    load

Procedure TkProgButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited;
  Progs.Run(Ord(Down)*2+1);
  Ini.DoAutoSave;
end;

Procedure TkProgButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  InMouseUp := true;
  inherited;
  Progs.Run(Ord(Down)*2);
  InMouseUp := false;
  Ini.DoAutoSave;
end;

procedure TkProgButton.SetAsString(s: string);
begin
   Down := Boolean(StrToIntDef(s,0));
end;

//------------------------------------------------------------------------------
{ TkProgCounter }
//------------------------------------------------------------------------------

const expldouble : array[0..5] of string =
('comes to 0','comes positive','comes negative','increase','decrease','change' );

constructor TkProgCounter.Create(AOwner: TComponent);
begin
  inherited;
  FProgs := TCmpProg.Create(self,6,@expldouble);
  Progs.LogError := false;
end;

destructor TkProgCounter.Destroy;
begin
  FProgs.Free;
  inherited;
end;

procedure TkProgCounter.SetValue(d: double);
{$i ExtraCmpInc.pas}

//------------------------------------------------------------------------------

{ TkProgEncoder }

constructor TkProgEncoder.Create(AOwner: TComponent);
begin
  inherited;
  FProgs := TCmpProg.Create(self,6,@expldouble);
  Progs.LogError := false;
end;


destructor TkProgEncoder.Destroy;
begin
  FProgs.Free;
  inherited;
end;

procedure TkProgEncoder.SetValue(d: double);
{$i ExtraCmpInc.pas}

//------------------------------------------------------------------------------
{ TkProgParam }
//------------------------------------------------------------------------------

constructor TkProgParam.Create(AOwner: TComponent);
begin
  inherited;
  FProgs := TCmpProg.Create(self,6,@expldouble);
end;

destructor TkProgParam.Destroy;
begin
  FProgs.Free;
  inherited;
end;

procedure TkProgParam.SetValue(d: double);
{$i ExtraCmpInc.pas}

{ TProgInverter }

constructor TProgInverter.Create(AOwner: TComponent);
begin
  inherited;
  FProgs := TCmpProg.Create(self,5,@expldouble);
end;

destructor TProgInverter.Destroy;
begin
  FProgs.Free;
  inherited;
end;

procedure TProgInverter.SetValue(d: double);
{$i ExtraCmpInc.pas}





initialization begin
  RegisterClass(TGroupBox);
  RegisterClass(TPanel);
  RegisterClass(TkPageControl);
  RegisterClass(TTransparentPanel);
  RegisterClass(TBackroundImage);
  RegisterClass(TCounter);
  RegisterClass(TkParam);
  RegisterClass(TkProgCheckBox);
  RegisterClass(TkProgTabSheet);
  RegisterClass(TkProgButton);
  RegisterClass(TkProgCounter);
  RegisterClass(TkProgEncoder);
  RegisterClass(TkProgParam);
  RegisterClass(TProgInverter);
{$ifdef DEBUGEXTRA}
  RegisterError(ceExtraCompDebug   ,'ex', 'Extra component debug');
{$endif}  
end;

end.