unit cirqueue;
{$mode ObjFPC}{$H+}
{$Interfaces COM}
{-$define dbg}
interface
uses classes, sysutils;
const
cqVersion = '1.04.01.2025';
cqGrowFactor = 1.618; { the golden ratio :o) }
type
{ callback proc to dispose of data in the 'Clear'ing methods when freeing the container
sig: procedure FreePtr(aPtr: pointer); }
TDisposeProc = procedure(aPtr: pointer);
{$if fpc_fullversion <= 30202} RTLString = ansistring; {$endif} { introduced in trunk }
{ TCirQueue ~ enqueues on tail & dequeues on head }
TCirQueue = class(TInterfacedObject{,ICirQueue})
private
fCount,fHead,fTail: ptrint;
fDispose: TDisposeProc; { for use in Clear }
fQue: TFPList;
procedure Grow;
public
constructor Create(aCapacity: ptrint;aDisposeProc: TDisposeProc = nil);
destructor Destroy;override;
function Capacity: ptrint;
procedure Clear;
function Count: ptrint;
function Dequeue: pointer;
procedure Enqueue(aData: pointer);
function IsEmpty: boolean;
function Peek: pointer;
function ToString: RTLString; override;
end;
implementation
procedure DummyDisp(aPtr: pointer); // null-proc
begin
if aPtr = nil then ; { do absolutely nothing }
end;
{$Region 'TCirQueue'}
{ TCirQueue }
procedure TCirQueue.Grow;
var li,lt: ptrint;
begin { we'll expand with the golden ratio items added ~ 61,8 % }
li:= trunc(fQue.Count * cqGrowFactor);
fQue.Count:= li;
if (fHead = 0) then fTail:= fCount { only enqueueing has been done, no dequeueing }
else begin { tail caught up, make room in between tail and head again, }
lt:= fQue.Count; { afterall we're growing due to lack of space }
for li:= fCount-1 downto fHead do begin
dec(lt);
fQue[lt]:= fQue[li];
end;
fHead:= lt;
end;
end;
constructor TCirQueue.Create(aCapacity: ptrint;aDisposeProc: TDisposeProc);
begin
inherited Create;
{ assign our disposeproc, if nil then we'll just use a dummy 'null' proc }
if aDisposeProc <> nil then fDispose:= aDisposeProc else fDispose:= @DummyDisp;
fQue:= TFPList.Create;
if (aCapacity <= 1) then aCapacity:= 32;
fQue.Count:= aCapacity;
fHead:= 0; fTail:= fHead; fCount:= 0;
end;
destructor TCirQueue.Destroy;
begin
Clear;
fQue.Free;
{$ifdef dbg}writeln('TCirQueue Destroyed');{$endif}
inherited Destroy;
end;
function TCirQueue.Capacity: ptrint;
begin
Result:= fQue.Capacity;
end;
procedure TCirQueue.Clear;
begin { we only clear the residue active items left in the queue }
while not IsEmpty do fDispose(Dequeue);
fHead:= 0; fTail:= fHead; fCount:= 0; { here fTail:= fHead; means empty }
end;
function TCirQueue.Count: ptrint;
begin
Result:= fCount;
end;
function TCirQueue.Dequeue: pointer;
begin
if fCount = 0 then exit(nil);
Result:= fQue[fHead];
fHead:= (fHead + 1) mod fQue.Count; { inc but make sure it's still valid }
dec(fCount);
end;
procedure TCirQueue.Enqueue(aData: pointer);
begin
fQue[fTail]:= aData;
fTail:= (fTail + 1) mod fQue.Count;
inc(fCount);
if (fTail = fHead) then Grow; { here this means full, so we'll grow it a bit }
end;
function TCirQueue.IsEmpty: boolean;
begin
Result:= (fCount = 0);
end;
function TCirQueue.Peek: pointer;
begin { a small test-case, to see if direct access is snappier }
if fCount > 0 then Result:= fQue[fHead] else Result:= nil;
end;
function TCirQueue.ToString: RTLString;
begin
Result:= 'I/TCirQueue v '+cqVersion+', a circular self-growing queue '+LineEnding+
'(c) 2025 Copyright Benny Christensen a.k.a. cdbc, All rights reserved';
end;
{$EndRegion 'TCirQueue'}
end.