unit ULPrgu;{v0.22}{v0.46}
{
  (C) 2000 - 2001 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://www.jindrich.com
                      http://orgchem.natur.cuni.cz/Chromulan/
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

interface
uses
  SysUtils, ULRecTyp, ULObju, ULObjUsru,
  UPRSType, UPRSObju,
  UPRGType, UPRGObju,
  UPEPType, UPEPObju,
  UPESType, UPESObju,
  UPEXType, UPEXObju,
  UPSSType, UPSSObju,
  UPSTType, UPSTObju,
  UPAPType, UPAPObju,
  UPASType, UPASObju,
  UPAVType, UPAVObju,
  UPACType, UPACObju
  ;

type

  TULPrgs = class(TULObjUsr)
  private
  protected
    function ChildCreate(AChildObj:TULObj): TULObjUsr; override;
    class function GetClassRecID: TULRecID; override;
  public
    constructor Create;reintroduce;
  end;

  TULPrgSteps = class;
    TULPrgStep = class;
  TULExpPool = class;
    TULExpSet = class;
      TULExp = class;


  TULActionPool = class;
    TULActionSet = class;
      TULActionSetValue = class;
      TULActionCommand = class;

  TULPrg = class(TULObjUsr)
  private
    FPrgSteps: TULPrgSteps;
    FExpPool: TULExpPool;
    FActionPool: TULActionPool;
    {FUPSS: TUPSSObj;
    FUPEP: TUPEPObj;}
    function GetPrgSteps: TULPrgSteps;
    function GetExpPool: TULExpPool;
    function GetActionPool: TULActionPool;
  protected
    function ChildCreate(AChildObj:TULObj): TULObjUsr; override;
    class function GetClassRecID: TULRecID; override;
    procedure ClassFieldsCreate; override;
    procedure ChildDestroyed(AChild: TULObjUsr); override;
  public
    constructor Create(AOwner: TULObjUsr; AObj:TULObj; ARecID: TULRecID);reintroduce;
    destructor Destroy;override;
    property PrgSteps: TULPrgSteps read GetPrgSteps;
    property ExpPool: TULExpPool read GetExpPool;
  end;

  TULPrgSteps = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
    function GetPrgStep(Index: integer): TULPrgStep;
    function GetPrgStepCount: integer;
  public
    property PrgSteps[Index:integer]: TULPrgStep read GetPrgStep; default;
  end;

  TULPrgStep = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
  end;

  TULExpPool = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
  end;

  TULExpSet = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
  end;

  TULExp = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
  end;

  TULActionPool = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
  end;

  TULActionSet = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
  end;


  TULActionSetValue = class(TULObjUsr)
  private
    function GetUPAV: TUPAVObj;
  protected
    class function GetClassRecID: TULRecID; override;
    procedure ValuesSourceNeeded; override;
  public
    property UPAV: TUPAVObj read GetUPAV;
  end;

  TULActionCommand = class(TULObjUsr)
  protected
    class function GetClassRecID: TULRecID; override;
  end;

function ULPrgs: TULPrgs;

implementation
uses
  ModuType, Modulu;

{TULPrg}
constructor TULPrg.Create(AOwner: TULObjUsr; AObj:TULObj; ARecID: TULRecID);
begin
  inherited Create(AOwner, AObj, ARecID);
  {FUPSS := TUPSSObj(Obj.FindOrAdd(UPSSID, ''));
    FUPSS.SetFlag(rfCantDelete, true);
  ChildAdd(FUPSS, 0, '');
  FUPEP := TUPEPObj(Obj.FindOrAdd(UPEPID, ''));
    FUPEP.SetFlag(rfCantDelete, true);
  ChildAdd(FUPEP, 0, '');}
end;

function TULPrg.GetPrgSteps: TULPrgSteps;
begin
  if FPrgSteps = nil then
    FPrgSteps := TULPrgSteps(ChildFindOrAdd(UPSSID, ''));
  Result := FPrgSteps;
end;

function TULPrg.GetExpPool: TULExpPool;
begin
  if FExpPool = nil then
    FExpPool := TULExpPool(ChildFindOrAdd(UPEPID, ''));
  Result := FExpPool;
end;

function TULPrg.GetActionPool: TULActionPool;
begin
  if FActionPool = nil then
    FActionPool := TULActionPool(ChildFindOrAdd(UPAPID, ''));
  Result := FActionPool;
end;

class function TULPrg.GetClassRecID: TULRecID;
begin
  Result := UPRGID;
end;

function TULPrg.ChildCreate(AChildObj:TULObj): TULObjUsr;
var ou: TULObjUsr;
begin
  case AChildObj.RecID of
    UPEPID: ou := TULExpPool.Create(Self, AChildObj, 0);
    UPSSID: ou := TULPrgSteps.Create(Self, AChildObj, 0);
    UPAPID: ou := TULActionPool.Create(Self, AChildObj, 0);
  else
    raise Exception.Create('TULPrg.ChildCreate Invalid RecID ' + AChildObj.RecIDStr);
  end;
  Result := ou;
end;

procedure TULPrg.ChildDestroyed(AChild: TULObjUsr);
begin
  if AChild = FPrgSteps then
    FPrgSteps := nil
  else if AChild = FExpPool then
    FExpPool := nil;
end;

procedure TULPrg.ClassFieldsCreate;
begin
  inherited;
  GetPrgSteps;
  GetExpPool;
  GetActionPool;
end;

destructor TULPrg.Destroy;
begin
{  if FUPEP <> nil then
    FUPEP.SetFlag(rfCantDelete, false);
  if FUPSS <> nil then
    FUPSS.SetFlag(rfCantDelete, false);}
  inherited Destroy;
end;
{/TULPrg}

{TULPrgSteps}
class function TULPrgSteps.GetClassRecID: TULRecID;
begin
  Result := UPSSID;
end;

function TULPrgSteps.ChildCreate(AChildObj: TULObj): TULObjUsr;
var
  ou: TULObjUsr;
begin
  case AChildObj.RecID of
    UPSTID: ou := TULPrgStep.Create(Self, AChildObj, 0);
  else
    raise Exception.Create('TULPrgSteps.ChildCreate Invalid RecID ' + AChildObj.RecIDStr);
  end;
  Result := ou;
end;

function TULPrgSteps.GetPrgStep(Index: integer): TULPrgStep;
begin
  Result := TULPrgStep(Childs[Index]);
end;

function TULPrgSteps.GetPrgStepCount: integer;
begin
  Result := ChildCount;
end;
{/TULPrgSteps.}

{TULPrgStep.}
class function TULPrgStep.GetClassRecID: TULRecID;
begin
  Result := UPSTID;
end;
{/TULPrgStep.}

{TULPrgs}
constructor TULPrgs.Create;
begin
  inherited Create(nil, nil, UPRSID);
end;

class function TULPrgs.GetClassRecID: TULRecID;
begin
  Result := UPRSID;
end;

function TULPrgs.ChildCreate(AChildObj:TULObj): TULObjUsr;
begin
  Result := TULPrg.Create(Self, AChildObj, UPRGID);
end;
{/TULPrgs}

{TExpPool}
class function TULExpPool.GetClassRecID: TULRecID;
begin
  Result := UPEPID;
end;

function TULExpPool.ChildCreate(AChildObj: TULObj): TULObjUsr;
begin
  Result := TULExpSet.Create(Self, AChildObj, UPESID);
end;
{/TExpPool}

{TULExpSet.}
class function TULExpSet.GetClassRecID: TULRecID;
begin
  Result := UPESID;
end;

function TULExpSet.ChildCreate(AChildObj: TULObj): TULObjUsr;
begin
  Result := TULExp.Create(Self, AChildObj, UPEXID);
end;
{/TULExpSet.}


{TULExp.}
class function TULExp.GetClassRecID: TULRecID;
begin
  Result := UPEXID;
end;
{/TULExp.}

{TActionPool}
class function TULActionPool.GetClassRecID: TULRecID;
begin
  Result := UPAPID;
end;

function TULActionPool.ChildCreate(AChildObj: TULObj): TULObjUsr;
var
  ou: TULObjUsr;
begin
  case AChildObj.RecID of
    UPASID: ou := TULActionSet.Create(Self, AChildObj, 0);
  else
    raise Exception.Create('TULActionPool.ChildCreate Invalid RecID ' + AChildObj.RecIDStr);
  end;
  Result := ou;
end;

{/TActionPool}

{TULActionSet.}
class function TULActionSet.GetClassRecID: TULRecID;
begin
  Result := UPASID;
end;

function TULActionSet.ChildCreate(AChildObj: TULObj): TULObjUsr;
var
  ou: TULObjUsr;
begin
  case AChildObj.RecID of
    UPAVID: ou := TULActionSetValue.Create(Self, AChildObj, 0);
    UPACID: ou := TULActionCommand.Create(Self, AChildObj, 0);
  else
    raise Exception.Create('TULActionSet.ChildCreate Invalid RecID ' + AChildObj.RecIDStr);
  end;
  Result := ou;
end;
{/TULActionSet.}

{TULActionSetValue.}
function TULActionSetValue.GetUPAV: TUPAVObj;
begin
  Result := TUPAVObj(Obj);
end;

class function TULActionSetValue.GetClassRecID: TULRecID;
begin
  Result := UPAVID;
end; {upavtype}

{procedure TULActionSetValue.FieldChangedInBrowser(AField: TULObjField);
begin
end;}

procedure TULActionSetValue.ValuesSourceNeeded;
var
  m: TModule;
begin
  if Modules.FindModuleWithPropVal(piDeviceName, UPAV.DeviceName, m) then begin
    UPAV.PropDesc_Src_Ptr := longint(m.ULDR);
  end else begin
    UPAV.PropDesc_Src_Ptr := 0;
  end;
end;

{/TULActionSetValue.}

{TULActionCommand.}
class function TULActionCommand.GetClassRecID: TULRecID;
begin
  Result := UPACID;
end;
{/TULActionCommand.}

const
  FULPrgs: TULPrgs = nil;

function ULPrgs: TULPrgs;
begin
  if FULPrgs = nil then
    FULPrgs := TULPrgs.Create;
  Result := FULPrgs;
end;

end.
