unit Prgu;{v0.49}
{
  (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, Classes, Timer, Windows, Messages,
  ActnList, Language, ExeLogu, Msgu, UtlType,
  ULRecTyp, ULObju, ULFObju, ULObjUsru,
  {$IFNDEF CONSOLE}
  ULStringGrid,
  {$ENDIF}
  UlanType
  {
  USPType, USPObju, aaprgu
  USPLType, USPLObju};


type
  TPrgLine = class;

  TPrg = class(TULObjUsr) {common ancestor for seqprgu .TSeqPrg and aaprgu .TAAPrg }
  private
    FCurTimeLineIndex: integer;
      { index of current program line - beeing checked periodically
        (by LineReady call), if its time came, LineReady returns true
        and changes FCurTimeLineIndex to the next one, if no more lines, set
        Running to false }
    FStartTime: integer;
      { mstime at Start call [ms], 0 if not started }
    FTime: integer;
      { calculated in LineReady call as (mstime - FStartTime) }
    FNextLineTime: integer;
    FRunning: boolean;
    FEquil: boolean;
      { equilibrating? (started by StartEquil and not finished the cycle) }
    FEquilOffset: integer;
      { time in ms, of the StartEquil command (will be substracted during
        Equil run from prgline.prtime) }
    FActive: boolean;
      { is the program ready to run or running? (selected for active sample?) }
    FStartTimeChanged: boolean;
    FSuspendStartTime: integer; { <> 0 if in suspended state }
    FSuspendTotalTime: integer; { sum of all suspended periods }
    FTimeSkipAction: TAction;
    FRecalculatePrgTimes: TAction;
    FRecalculateDurations: TAction;
    procedure TimeSkip(Sender: TObject);
    procedure OnRecalculateDurations(Sender: TObject);
    procedure OnRecalculatePrgTimes(Sender: TObject);
  protected
    {function GetAAPGObj: TAAPGObj;
    function ChildCreate(AChildObj: TULObj): TULObjUsr; override;
    function GetRecID: TULRecID; override;}
    procedure ClassFieldsCreate; override;
    function CurLineTime: integer;
    function GetTotalSecTime: integer;
      { return time of last program line in seconds }
    procedure SetActive(OnOff: boolean);
    {$IFNDEF CONSOLE}
    procedure ULGridCreated(AGrid: TULStringGrid); override;
    {$ENDIF}
    {procedure DoAfterCreate; override;}
    procedure DoOnDblClick(AGrid: TObject);
    procedure TimeSkipToActiveLine;
    {$IFNDEF CONSOLE}
    procedure FirstMenuActionNeeded; override;{ulobju}
    {$ENDIF}
    {v0.50}
    function PrgLineFirst(plk: TPrgLineKind; var AIndex: integer): boolean;
    function PrgLineNext(plk: TPrgLineKind; var AIndex: integer): boolean;

    function TimeLineFirst(var AIndex: integer): boolean;
      { Set AIndex to the first IsTimeLine program line, returns
        false if no such line found }
    function TimeLineNext(var AIndex: integer): boolean;
      { Set AIndex to FCurTimeLineIndex and increases it until next IsTimeLine
        program line,  returns false if no such line found }
    {procedure IncCurTimeLineIndex; virtual;
      { Increments FCurTimeLineIndex, checks if the child IsTimeLine, if not
        increments again, until >= ChildCount }

    procedure RecalculatePrgTimes; virtual;
    procedure RecalculateDurations; virtual;

  public
    destructor Destroy; override;
    function Start: boolean; {v0.51}virtual;{/v0.51}
      { starts normal run (no equilibration) }
    {v0.51}
    function HasEquilCommand: boolean; virtual;
    {/v0.51}
    function StartEquil(var ATimeDif: integer): boolean;
      { starts at StartEquil line, goes to end and then restarts automatically
        (and clears the FEquil flag); TimeDif sets to the time if the StartEquil
        line (it will be then used in AAAu as FUsrStateTimeOffset, i.e. added
        to the StateStartTime, i.e. the time will be shown as if the program
        started from the beginning) }
    function LineReady(var ALine: TPrgLine; var AStartTime: integer): boolean;
      { checks if there is a time for next line to execute.
        if AStartTime specified (i.e. <> 0; = mstime of the program start),
        then the programs FStartTime will be adjusted to it }
    procedure ChangeTime(ATime: integer);
      { forcing new time in ms (relative to start, manual, will adjust StartTime }
    procedure Suspend;{v0.52}virtual;{/v0.52}
    procedure Resume; virtual;
    {property AAPG: TAAPGObj read GetAAPGObj;}
    property Running: boolean read FRunning;
    property Equil: boolean read FEquil;
    property Time: integer read FTime;
    property EquilOffset: integer read FEquilOffset;
    property TotalSecTime: integer read GetTotalSecTime;
    property Active: boolean read FActive write SetActive;
  end;

  TPrgClass = class of TPrg;

  TPrgLine = class(TULObjUsr)
  private
    FPrg: TULObjUsr;
  protected
    {function GetRecID: TULRecID;override;
    function GetAAPLObj: TAAPLObj;}
    procedure SetState(AState: TPrgLineState); virtual; abstract;
    function GetState: TPrgLineState; virtual; abstract;
    function GetPrgTime: TAcqTime; virtual; abstract;
    function ShouldStartEquil: boolean; virtual; abstract;
    function GetPrgLineKind: TPrgLineKind; virtual; abstract;

    function GetDuration: TAcqTime; virtual; abstract;
    procedure SetDuration(ADuration: TAcqTime); virtual; abstract;
    procedure SetPrgTime(APrgTime: TAcqTime); virtual; abstract;

    procedure DoAfterCreate; override;
    { Makes sure to set program line obj.PrgTime field to have autosort property set true }
    procedure CheckAutosort;
    procedure SetAfterSetValueHandlers;
    procedure AfterSetPrgTime(const OldVal: string; const NewVal: string);
    procedure AfterSetDuration(const OldVal: string; const NewVal: string);
    procedure SetULObjOwner(AOwner: TULObjUsr);override;
    function GetAutoSort: boolean;
    procedure SetAutoSort(OnOff: boolean);
  public
    {v0.50}
    function IsTimeLine: boolean;
    {procedure Run; virtual;}
    {/v0.50}
    {property AAPL: TAAPLObj read GetAAPLObj;}
    property State: TPrgLineState read GetState write SetState;
    property PrgTime: TAcqTime read GetPrgTime write SetPrgTime;
    {v0.50}
    property PrgLineKind: TPrgLineKind read GetPrgLineKind;


    property Duration: TAcqTime read GetDuration write SetDuration;
    property AutoSort: boolean read GetAutoSort write SetAutoSort;
  end;

{function AAPrgBrowserOpen(const AFileName: shortstring; AMode: TOpenMode): boolean;}

implementation

{TPrg}
{
function TAAPrg.GetRecID: TULRecID;
begin
  Result := AAPGID;
end;
procedure TAAPrg.DoAfterCreate;
begin
//  Obj.SetFlag(rfEditModal, false);
//  Obj.SetFlag(rfBrowseModal, false);
//  Obj.SetFlag(rfUsingColors, true);
//  Obj.SetFlag(rfAskForSave, true);
end;
}
procedure TPrg.DoOnDblClick(AGrid: TObject);
begin
  if UserMode <> umSysOp then
    exit;
  TimeSkipToActiveLine;
end;

procedure TPrg.TimeSkipToActiveLine;
var
  o: TULObjUsr;
  i: integer;
begin
  if not Active then
    exit;
  if ShowMessage(GetTxt({#}'Really skip the normal time sequence?'), smNoYes, 0) <> cmYes then
    exit;
  o := ActiveChild;
  if (o is TPrgLine) {v0.50} and (TPrgLine(o).IsTimeLine){/v0.50} then begin
    i := round(TPrgLine(o).PrgTime * 1000);
    ChangeTime(i);
  end;
end;

procedure TPrg.ChangeTime(ATime: integer);
var dif: integer;
begin
  dif := ATime - FTime;
  if dif > 0 then begin
    FStartTime := FStartTime - dif;
    FStartTimeChanged := true;
  end;
end;

procedure TPrg.ClassFieldsCreate;
begin
  inherited;
  FCurTimeLineIndex := -1;
  Obj.SetFlag(rfEditModal, false);
  Obj.SetFlag(rfBrowseModal, false);
  Obj.SetFlag(rfUsingColors, true);
  Obj.SetFlag(rfAskForSave, true);
end;
{
function TAAPrg.GetAAPGObj: TAAPGObj;
begin
  Result := TAAPGObj(Obj);
end;

function TAAPrg.ChildCreate(AChildObj: TULObj): TULObjUsr;
var id: TULRecID;
begin
  if AChildObj = nil then
    id := AAPLID
  else
    id := AChildObj.RecID;
  Result := TAAPrgLine.Create(Self, AChildObj, id);
end;
}

function TPrg.CurLineTime: integer;
begin
  Result := round(TPrgLine(Childs[FCurTimeLineIndex]).PrgTime * 1000);
end;

{v0.51}
function TPrg.HasEquilCommand: boolean;
var
  i: integer;
  pl: TPrgLine;
begin
  Result := false;
  for i := 0 to ChildCount - 1 do begin
    pl := TPrgLine(Childs[i]);
    if pl.ShouldStartEquil then begin
      Result := true;
      exit;
    end;
  end;
end;
{/v0.51}

function TPrg.StartEquil(var ATimeDif: integer): boolean;
var
  i: integer;
  pl: TPrgLine;

  procedure DoOK;
  begin
    FRunning := true;
    FEquil := true;
    FStartTime := mstime;
    ATimeDif := CurLineTime;
    FEquilOffset := ATimeDif;
    FNextLineTime := 0;{round(TAAPrgLine(Childs[FCurTimeLineIndex]).AAPL.PrgTime * 1000);}
  end;

begin
  Result := false;
  for i := 0 to ChildCount - 1 do begin
    pl := TPrgLine(Childs[i]);
    if pl.ShouldStartEquil{ = acStartEquil }then begin
      FCurTimeLineIndex := i;
      DoOK;
      Result := true;
      exit;
    end else begin
      pl.State := plsSkipped;
    end;
  end;
  if ChildCount = 0 then begin
    ExeLog.Log('PRG.StartEquil - no program lines.');
    {ExeLog.Log('PRG.StartEquil - no StartEquil command found.');}
  end else begin
    {v0.50}
    if not TimeLineFirst(FCurTimeLineIndex) then begin
      ExeLog.Log('PRG.StartEquil - no program time lines.');
      exit;
    end;
    {/v0.50
    FCurTimeLineIndex := 0;}
    DoOK;
    Result := true;
  end;
end; {ulobju}

function TPrg.Start: boolean;
begin
  Result := false;
  FEquil := false;
  FEquilOffset := 0;
  {v0.50}
  if TimeLineFirst(FCurTimeLineIndex) then begin
    FStartTime := mstime;
    FRunning := true;
    FNextLineTime := CurLineTime;
    Result := true;
    {v0.51}
    FSuspendTotalTime := 0;
    if FSuspendStartTime <> 0 then
      FSuspendStartTime := FStartTime {v0.55} - 1{/v0.55};{to prevent run the first line if has time 0}
    {/v0.51}
  end;
  {/v0.05
  if ChildCount > 0 then begin
    FCurTimeLineIndex := 0;
    FStartTime := mstime;
    FRunning := true;
    FNextLineTime := CurLineTime;
    Result := true;
  end;}
end;

function TPrg.LineReady(var ALine: TPrgLine; var AStartTime: integer): boolean;
begin
  Result := false;
  if FStartTimeChanged then begin
    AStartTime := FStartTime;
    FStartTimeChanged := false;
  end else begin
    if AStartTime <> 0 then begin
      FStartTime := AStartTime;
    end;
  end;
  if FSuspendStartTime <> 0 then begin
    FTime := FSuspendStartTime - FStartTime;
  end else begin
    FTime := mstime - FStartTime - FSuspendTotalTime;
  end;
  if not FRunning then
    exit;
  if FTime >= FNextLineTime then begin
    ALine := TPrgLine(Childs[FCurTimeLineIndex]);
    if FCurTimeLineIndex > 0 then begin
      TPrgLine(Childs[FCurTimeLineIndex - 1]).State := plsDone;
        { should be set to this state by the caller of LineReady method,
          whan finished with using ALine; here just to make it sure }
    end;
    ALine.State := plsRunning;
    Result := true;
    {v0.50}
    if not TimeLineNext(FCurTimeLineIndex) then begin
      FRunning := false;
      FCurTimeLineIndex := -1;
    end
    {/v0.50
    inc(FCurTimeLineIndex);
    if FCurTimeLineIndex >= ChildCount then begin
      FRunning := false;
      FCurTimeLineIndex := -1;
    end}
    else begin
      FNextLineTime := CurLineTime - FEquilOffset;
    end;
  end;
end;

{v0.50}
function TPrg.PrgLineFirst(plk: TPrgLineKind; var AIndex: integer): boolean;
begin
  AIndex := -1;
  Result := PrgLineNext(plk, AIndex);
end;

function TPrg.PrgLineNext(plk: TPrgLineKind; var AIndex: integer): boolean;
begin
  Result := false;
  repeat
    inc(AIndex);
    if AIndex >= ChildCount then
      break;
    if TPrgLine(Childs[AIndex]).PrgLineKind = plk then begin
      Result := true;
      break;
    end;
  until false;
end;

function TPrg.TimeLineFirst(var AIndex: integer): boolean;
begin
  Result := PrgLineFirst(plkTime, AIndex);
end;

function TPrg.TimeLineNext(var AIndex: integer): boolean;
begin
  Result := PrgLineNext(plkTime, AIndex);
end;
{/v0.50}

destructor TPrg.Destroy;
begin
  Active := false;
  inherited Destroy;
end;

function TPrg.GetTotalSecTime: integer;
begin
  Result := 0;
  if ChildCount > 0 then begin
    Result := round(TPrgLine(Childs[ChildCount - 1]).PrgTime);
  end;
end;

procedure TPrg.SetActive(OnOff: boolean);
var
  i: integer;
begin
  if FActive = OnOff then
    exit;
  Obj.DoChangeLock;
  try
    if OnOff then begin
      for i := 0 to ChildCount - 1 do begin
        TPrgLine(Childs[i]).State := plsWaiting;
      end;
    end else begin
      for i := 0 to ChildCount - 1 do begin
        TPrgLine(Childs[i]).State := plsNone;
      end;
    end;
    FActive := OnOff;
  finally
    Obj.DoChangeUnlock;
  end;
end;

{$IFNDEF CONSOLE}
procedure TPrg.ULGridCreated(AGrid: TULStringGrid);
begin
  if Active then begin
    AGrid.EditEnabled := false;
    AGrid.OnDblClick := DoOnDblClick;
  end;
end;
{$ENDIF}

procedure TPrg.Suspend;
begin
  FSuspendStartTime := mstime;
end;

procedure TPrg.Resume;
begin
  if FSuspendStartTime = 0 then
    exit;
  inc(FSuspendTotalTime , mstime - FSuspendStartTime);
  FSuspendStartTime := 0;
end;

{$IFNDEF CONSOLE}
procedure TPrg.FirstMenuActionNeeded;
begin
  if Active then begin
    ActionUpdate(FTimeSkipAction, TimeSkip, GetTxt({#}'Time Skip To Active Line'));
  end;
  ActionUpdate(FRecalculatePrgTimes, OnRecalculatePrgTimes, GetTxt({#}'Recalculate program times'));
  ActionUpdate(FRecalculateDurations, OnRecalculateDurations, GetTxt({#}'Recalculate durations'));
end;
{$ENDIF}

procedure TPrg.TimeSkip(Sender: TObject);
begin
  TimeSkipToActiveLine;
end;

procedure TPrg.RecalculatePrgTimes;
begin
end;

procedure TPrg.RecalculateDurations;
begin
end;

procedure TPrg.OnRecalculateDurations(Sender: TObject);
begin
  RecalculateDurations;
end;

procedure TPrg.OnRecalculatePrgTimes(Sender: TObject);
begin
  RecalculatePrgTimes;
end;

{/TPrg.}

{TAAPrgLine}
{function TAAPrgLine.GetRecID: TULRecID;
begin
  Result := AAPLID;
end;

function TAAPrgLine.GetAAPLObj: TAAPLObj;
begin
  Result := TAAPLObj(Obj);
end;}
{/TAAPrgLine}

{function AAPrgBrowserOpen(const AFileName: shortstring; AMode: TOpenMode): boolean;
begin
  Result := ULObjUsrBrowserOpen(TAAPrg, AAPGID, AFileName, AMode) <> nil;
end;}

{v0.50}
function TPrgLine.IsTimeLine: boolean;
begin
  Result := PrgLineKind = plkTime;
end;

procedure TPrgLine.DoAfterCreate;
begin
  inherited;
  FPrg := ULObjOwner;
  CheckAutosort;
  SetAfterSetValueHandlers;
end;

procedure TPrgLine.AfterSetPrgTime(const OldVal: string; const NewVal: string);
var
  p: TPrg;
  a: boolean;
  g: TULStringGrid;
begin
  if (ULObjOwner <> nil) then begin
    p := TPrg(ULObjOwner);
    a := AutoSort;
    AutoSort := false;
    try
      g := ULObjOwner.ActiveGrid;
      if g <> nil then begin
        TPrg(ULObjOwner).FirstMenuActionNeeded; // initialize the actions
        PostMessage(g.Handle, WM_APPMESSAGE, cmULObjUsrActionNeeded, longint(TPrg(ULObjOwner).FRecalculateDurations))
      end;
      //p.RecalculateDurations;
    finally
      AutoSort := a;
    end;
  end;
end;

procedure TPrgLine.AfterSetDuration(const OldVal: string; const NewVal: string);
var
  p: TPrg;
  a: boolean;
  g: TULStringGrid;
begin
  if (ULObjOwner <> nil) then begin
    p := TPrg(ULObjOwner);
    a := AutoSort;
    AutoSort := false;
    try
      g := ULObjOwner.ActiveGrid;
      if g <> nil then begin
        TPrg(ULObjOwner).FirstMenuActionNeeded; // initialize the actions
        PostMessage(g.Handle, WM_APPMESSAGE, cmULObjUsrActionNeeded, longint(TPrg(ULObjOwner).FRecalculatePrgTimes))
      end;
      //p.RecalculatePrgTimes;
    finally
      AutoSort := a;
    end;
  end;
end;

procedure TPrgLine.SetAfterSetValueHandlers;
var f: TULObjField;
begin
  if Obj.HasField('PrgTime', f) then
    f.AfterSetValue := AfterSetPrgTime;
  if Obj.HasField('Duration', f) then
    f.AfterSetValue := AfterSetDuration;
end;

procedure TPrgLine.CheckAutosort;
begin
  AutoSort := true;
end;

function TPrgLine.GetAutoSort: boolean;
var f: TULObjField;
begin
  Result := false;
  if Obj.HasField('PrgTime', f) then
    Result := f.AutoSort;
end;

procedure TPrgLine.SetAutoSort(OnOff: boolean);
var f: TULObjField;
begin
  if Obj.HasField('PrgTime', f) then
    f.AutoSort := OnOff;
end;

procedure TPrgLine.SetULObjOwner(AOwner: TULObjUsr);
begin
  inherited;
end;


{procedure TPrgLine.Run;
begin
end;}
{/v0.50}

initialization {methodu instrumentu}
{  RegisterClasses([TAAPrg, TAAPrgLine]);}
end.
