type
TQSheme = class
private
FParcelsClass : TParcelsClass;
FStepCount : integer;
FSysPeriod : TCustTime;
FStepPeriod : TCustTime;
FSysTime : TCustTime;
FElements : TList;
FFinishElements : TList;
FLastElements : TList;
FSourceElements : TList;
FParcels : TList;
FOrderElementCount : integer;
FEventQueue : TList;
FOrder : array [0..MaxElementCount-1] of integer;
FDiagram : TPaintBox;
protected
function GetElement(Index : integer): TElement;
function GetElementCount: integer;
procedure InitAnalize;
procedure FreeAnalize;
procedure InitEmulation;
procedure FreeEmulation;
procedure FindFinishElements;
procedure GetRecipientsOrder;
procedure Step;
procedure TakeParcelsFromFinishElements;
function IsFinishElement(Element : TElement): Boolean;
function FastestStepPeriod : TCustTime;
procedure ClearParcelList;
procedure ClearEventQueue;
function GetCounts(Index : integer): integer;
function GetParcelCount: integer;
procedure DrawElementLines;
procedure DisplayEvents;
public
function NewParcel: Pointer;
procedure NewEvent(AEvent : integer; ASender, ASource : TObject; AInfo : TInfo);
procedure RedrawDiagram;
procedure Emulation;
procedure Analize;
constructor Create;
destructor Destroy; override;
procedure AddElement(Element : TElement);
procedure GetOrder;
procedure DelElement(Element : TElement);
property SysTime : TCustTime read FSysTime;
property SysPeriod: TCustTime read FSysPeriod write FSysPeriod;
property StepPeriod : TCustTime read FStepPeriod write FStepPeriod;
property Counts[Index : integer]:integer read GetCounts;
property BornParcelCount : integer index 0 read GetCounts;
property StoreParcelCount : integer index 1 read GetCounts;
property WorkParcelCount : integer index 2 read GetCounts;
property PassedParcelCount : integer index 3 read GetCounts;
property RefusedParcelCount : integer index 4 read GetCounts;
property ParcelCount:integer read GetParcelCount;
property StepCount : integer read FStepCount write FStepCount;
property ParcelsClass : TParcelsClass read FParcelsClass write FParcelsClass;
published
property Diagram : TPaintBox read FDiagram write FDiagram;
property ElementCount : integer read GetElementCount;
property Elements[Index : integer] : TElement read GetElement;
end;
implementation
uses MainFrm;
constructor TQSheme.Create;
begin
FElements := TList.Create;
FParcelsClass := TParcel;
FParcels := TList.Create;
FEventQueue := TList.Create;
end;
destructor TQSheme.Destroy;
begin
FElements.Free;
ClearEventQueue;
FEventQueue.Free;
ClearParcelList;
FParcels.Free;
inherited;
end;
function TQSheme.GetElement(Index : integer): TElement;
begin
Result := FElements[Index];
end;
function TQSheme.GetElementCount: integer;
begin
Result := FElements.Count
end;
procedure TQSheme.AddElement(Element: TElement);
begin
if Assigned(Element) then begin
FElements.Add(Element);
Element.Sheme := Self;
end;
end;
procedure TQSheme.DelElement(Element: TElement);
var i,j : integer;
begin
if Assigned(Element) then begin
for i := 0 to ElementCount - 1 do
for j:= Elements[i].SourceCount-1 downto 0 do
if Elements[i].Sources[j] = Element then
Elements[i].DelSource(Element);
FElements.Remove(Element);
end;
end;
function TQSheme.IsFinishElement(Element: TElement):Boolean;
var j,s : integer;
begin
Result := False;
for j := 0 to ElementCount-1 do begin
for s := 0 to Elements[j].SourceCount-1 do begin
if Element = Elements[j].Sources[s] then Exit;
end;
end;
Result := True;
end;
procedure TQSheme.FindFinishElements;
var i : integer;
begin
for i := 0 to ElementCount-1 do
if IsFinishElement(Elements[i]) then begin
FFinishElements.Add(Elements[i]);
FLastElements.Add(Elements[i]);
end;
end;
function TQSheme.FastestStepPeriod: TCustTime;
var i : integer;
Min : TCustTime;
begin
Min := FSysPeriod;
for i := 0 to ElementCount-1 do
if (Elements[i] is TShop) then
with TShop(Elements[i]).Generator do
if Mean-Disp < Min then Min := Mean-Disp;
{$ifndef Precision}
Result := Min;
{$else}
Result := Min div 10;
{$endif}
end;
procedure TQSheme.InitAnalize;
begin
FSysTime := 0;
FStepCount := 0;
FOrderElementCount := 0;
FLastElements := TList.Create;
FSourceElements := TList.Create;
end;
procedure TQSheme.FreeAnalize;
begin
FLastElements.Free;
FSourceElements.Free;
end;
procedure TQSheme.GetRecipientsOrder;
var i,s : integer;
LastElement : TElement;
begin
if FLastElements.Count = 0 then Exit;
for i := 0 to FLastElements.Count-1 do begin
LastElement := TElement(FLastElements[i]);
FOrder[FOrderElementCount] := FElements.IndexOf(LastElement);
Inc(FOrderElementCount);
for s := 0 to LastElement.SourceCount - 1 do
if FSourceElements.IndexOf(LastElement.Sources[s])<0 then
FSourceElements.Add(LastElement.Sources[s]);
end;
SwapPointers(Pointer(FSourceElements),Pointer(FLastElements));
FSourceElements.Clear;
GetRecipientsOrder;
end;
procedure TQSheme.GetOrder;
begin
FindFinishElements;
GetRecipientsOrder;
end;
procedure TQSheme.TakeParcelsFromFinishElements;
var i : integer;
Parcel : TParcel;
begin
for i := 0 to FFinishElements.Count-1 do
with TElement(FFinishElements[i]) do
if CanDrop then begin
Parcel := Container;
NewEvent(EV_PASS,nil,FFinishElements[i],Parcel.Info);
DoBeforeDrop(FFinishElements[i]);
DropParcel;
DoAfterDrop(FFinishElements[i]);
Parcel.State := psPassed;
end;
end;
procedure TQSheme.Step;
var i : integer;
begin
TakeParcelsFromFinishElements;
for i := 0 to FOrderElementCount-1 do Elements[FOrder[i]].AskForParcel;
Form1.Gauge1.Progress := Round(FSysTime/FSysPeriod*100);
Inc(FSysTime,FStepPeriod);
Inc(FStepCount);
end;
procedure TQSheme.Analize;
begin
try
try
InitAnalize;
GetOrder;
FStepPeriod := FastestStepPeriod;
finally
FreeAnalize;
end;
except
on EInvalidPointer do raise;
end;
end;
procedure TQSheme.ClearEventQueue;
var i : integer;
begin
if Assigned(FEventQueue) then begin
for i := 0 to FEventQueue.Count - 1 do FreeMem(FEventQueue[i],SizeOf(TEventRec));
FEventQueue.Clear;
end;
end;
procedure TQSheme.ClearParcelList;
var i : integer;
begin
if Assigned(FParcels) then begin
for i := 0 to FParcels.Count - 1 do TParcel(FParcels[i]).Free;
FParcels.Clear;
end;
end;
procedure TQSheme.InitEmulation;
var i : integer;
begin
ClearParcelList;
ClearEventQueue;
for i := 0 to ElementCount - 1 do
Elements[i].ClearContainer;
FFinishElements := TList.Create;
end;
procedure TQSheme.FreeEmulation;
begin
FFinishElements.Free;
end;
procedure TQSheme.Emulation;
begin
try
InitEmulation;
Analize;
while FSysTime < FSysPeriod do Step;
Form1.Gauge1.Progress := 100;
//RedrawDiagram;
finally
FreeEmulation;
end;
end;
function TQSheme.NewParcel: Pointer;
var P : Pointer;
begin
P := FParcelsClass.Create;
FParcels.Add(P);
Result := P;
end;
procedure TQSheme.NewEvent(AEvent : Integer; ASender, ASource: TObject; AInfo : TInfo);
var P : PEventRec;
begin
GetMem(P,SizeOf(TEventRec));
with P^ do begin
Event := AEvent;
Sender := ASender;
Source := ASource;
Info := AInfo;
SysTime := FSysTime;
end;
FEventQueue.Add(P);
end;
function TQSheme.GetCounts(Index : integer): integer;
var i : integer;
begin
Result := 0;
for i := 0 to FParcels.Count-1 do
if Ord(TParcel(FParcels[i]).State) = Index then Inc(Result);
end;
function TQSheme.GetParcelCount: integer;
begin
Result := FParcels.Count;
end;
const //DrawConstants
Top = 20;
Left = 20;
Interval = 20;
procedure TQSheme.DrawElementLines;
var i : integer;
Y : integer;
begin
for i := 0 to ElementCount-1 do begin
Y :=Top + interval *i;
with Diagram.Canvas do begin
TextOut(0,Y + Font.Height,Elements[i].Name);
MoveTo(0,Y);
LineTo(Diagram.ClientWidth,Y)
end;
end;
end;
procedure TQSheme.DisplayEvents;
{var i : integer;
s : string;}
begin
{Form1.mResults.Items.Clear;
for i := 0 to FEventQueue.Count - 1 do begin
with TEventRec(FEventQueue[i]^) do begin
case Event of
EV_TAKE: S := '+++:';
EV_REFUSE: S := '------:';
EV_PASS: S := 'PASS:';
end;
S := S + IntToStr(Info);
S := S + '['+IntToStr(SysTime)+ '] ';
if Assigned(Source) then S := S + TElement(Source).Name
else S := S+'nil';
S := S + '->';
if Assigned(Sender) then S := S + TElement(Sender).Name
else S := S+'nil';
end;
Form1.mResults.Items.Add(S);
end;}
end;
procedure TQSheme.RedrawDiagram;
//var i : integer;
begin
//Diagram.Canvas.FillRect(Rect(0,0,Diagram.Width,Diagram.Height));
//DrawElementLines;
DisplayEvents;
end;
initialization
Randomize;
end.
unit QSObjs;
interface
uses Classes,QSTypes,SysUtils, Utils;
type
TElement = class;
TIsRightElement = function(Element : TElement): Boolean of object;//far;
TBeforeAfterAction = procedure (Sender : TElement) of object;
TElement = class
private
FId : integer;
FName : string;
FSources : TList;
FSheme : TObject;
FContainer : TParcel;
FOnSourceValidate : TIsRightElement;
FOnDestinationValidate : TIsRightElement;
FBeforeTake: TBeforeAfterAction;
FAfterTake: TBeforeAfterAction;
FBeforeDrop: TBeforeAfterAction;
FAfterDrop: TBeforeAfterAction;
procedure SetSheme(ASheme : TObject);
function GetSourceCount: integer;
function GetSource(Index : integer): TElement;
function GetParcelPresent: Boolean;
function GetCanDropParcelFor(Destination : TElement): Boolean;
function GetCanTakeParcelFrom(Source: TElement): Boolean;
procedure Pass(SourceIndex : integer); virtual;
protected
function GetCanTake: Boolean; virtual; abstract;
function GetCanDrop : Boolean; virtual; abstract;
public
constructor Create;virtual;
destructor Destroy; override;
procedure AddSource(Element : TElement);
procedure DelSource(Element : TElement);
procedure AskForParcel; virtual;
procedure ClearContainer; virtual;
procedure RefuseParcel(SourceIndex : integer);
procedure DropParcel;virtual;
procedure TakeParcel(SourceIndex : integer); virtual;
procedure DoBeforeDrop(Sender : TElement);
procedure DoBeforeTake(Sender : TElement);
procedure DoAfterDrop(Sender : TElement);
procedure DoAfterTake(Sender : TElement);
property CanDropParcelFor[Destination : TElement]: Boolean read GetCanDropParcelFor;
property CanTakeParcelFrom[Source : TElement]: Boolean read GetCanTakeParcelFrom;
property Container : TParcel read FContainer write FContainer;
property ParcelPresent : Boolean read GetParcelPresent;
property CanTake : Boolean read GetCanTake;
property CanDrop : Boolean read GetCanDrop;
property Id: integer read FId write FId;
published
property Name : string read FName write FName;
property Sheme: TObject read FSheme write SetSheme;
property SourceCount : integer read GetSourceCount;
property Sources[Index : integer]: TElement read GetSource;
property OnSourceValidate : TIsRightElement read FOnSourceValidate write FOnSourceValidate;
property OnDestinationValidate : TIsRightElement read FOnDestinationValidate write FOnDestinationValidate;
property BeforeTake: TBeforeAfterAction read FBeforeTake write FBeforeTake;
property AfterTake: TBeforeAfterAction read FAfterTake write FAfterTake;
property BeforeDrop: TBeforeAfterAction read FBeforeDrop write FBeforeDrop;
property AfterDrop: TBeforeAfterAction read FAfterDrop write FAfterDrop;
end;
TElementClass = class of TElement;
TGenerator = class
private
FMean : TCustTime;
FDisp : TCustTime;
FRandomType : TRandomType;
function GetRandom: TCustTime;
public
constructor Create;
property Mean : TCustTime read FMean write FMean;
property Disp : TCustTime read FDisp write FDisp;
property RandomType : TRandomType read FRandomType write FRandomType;
property Time : TCustTime read GetRandom;
end;
TShop = class(TElement)
private
FGenerator : TGenerator;
FEndWorkTime : TCustTime;
procedure Pass(SourceIndex : integer); override;
function GetProcessed: Boolean;
protected
function GetCanTake : Boolean; override;
function GetCanDrop : Boolean; override;
property EndWorkTime : TCustTime read FEndWorkTime write FEndWorkTime;
public
constructor Create; override;
destructor Destroy;override;
procedure DropParcel; override;
property Generator : TGenerator read FGenerator;
property Processed : Boolean read GetProcessed;
procedure Work; virtual;
end;
TChannel = class(TShop)
public
procedure Pass(SourceIndex : integer); override;
end;
TSource = class(TShop)
private
procedure TakeParcel(SourceIndex: integer);override;
public
procedure Pass(SourceIndex : integer); override;
procedure AskForParcel; override;
end;
TAccumulator = class(TElement)
private
FParcels : TList;
FLimited : Boolean;
FCapacity : integer;
function GetParcel(Index : integer): TParcel;
function GetFreeSpacePresent : Boolean;
function GetEmpty: Boolean;
procedure SetCapacity(Value : integer);
function GetCapacity : integer;
function GetParcelCount : integer;
procedure Pass(SourceIndex : integer); override;
function GetCanTake : Boolean; override;
function GetCanDrop : Boolean; override;
public
constructor Create; override;
destructor Destroy; override;
procedure ClearContainer; override;
procedure DropParcel; override;
property ParcelCount : integer read GetParcelCount;
property Parcels[Index : integer]: TParcel read GetParcel;
property FreeSpacePresent: Boolean read GetFreeSpacePresent;
property Empty : Boolean read GetEmpty;
procedure TakeParcel(Index : integer); override;
published
property Capacity : integer read GetCapacity write SetCapacity;
property Limited : Boolean read FLimited write FLimited;
end;
TAccumulatorClass = class of TAccumulator;
implementation
uses QSheme;
constructor TElement.Create;
begin
FSources := TList.Create;
end;
destructor TElement.Destroy;
begin
FSources.Free;
inherited;
end;
procedure TElement.SetSheme(ASheme : TObject);
begin
if Assigned(ASheme) then FSheme := ASheme;
end;
procedure TElement.AddSource(Element : TElement);
begin
if Assigned(Element) then FSources.Add(Element);
end;
procedure TElement.DelSource(Element: TELement);
begin
if Assigned(Element) then FSources.Remove(Element);
end;
function TElement.GetSourceCount: integer;
begin
Result := FSources.Count;
end;
function TElement.GetSource(Index: integer): TElement;
begin
Result := FSources[Index];
end;
procedure TElement.TakeParcel(SourceIndex : integer);
begin
FContainer := Sources[SourceIndex].FContainer;
TQSheme(Sheme).NewEvent(EV_TAKE,Self,Sources[SourceIndex],FContainer.Info);
Sources[SourceIndex].DropParcel;
end;