Initial check in rtl

src.rtl/dpgrtl.charqueue.pas

@@ -0,0 +1,291 @@
+unit dpgrtl.charqueue;
+
+interface
+uses
+   dpgrtl.types;
+
+type
+   TCharQueue = class( TInterfacedObject)
+      private
+         fBlockLog   : integer;     // log2 of block size
+         fBlockSize  : integer;     // block size
+
+         fOffset     : integer;     // logical start of the vector
+         fCount      : integer;     // items in a vector
+         fArray      : TCharMatrix; // data
+
+      private
+         procedure   Expand( i: integer);
+
+      protected
+         function    GetItem( i:integer): AnsiChar;
+         procedure   SetItem( i:integer; Value:AnsiChar);
+
+      public
+         procedure   Clear;
+         procedure   Add(     Value : AnsiChar);
+         procedure   Remove(  ACount: integer);
+
+      public
+         procedure   AfterConstruction; override;
+         procedure   BeforeDestruction; override;
+
+      public
+         property    Count             : integer   read  fCount;
+         property    Items[i:integer]  : AnsiChar  read  GetItem  write SetItem;
+   end;
+
+implementation
+uses
+   System.Math,
+   System.SysUtils;
+
+{ TCharQueue }
+
+// @@@: construction/destruction ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+//
+//                                   construction/destruction
+//
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ================================================================================================
+// After Construction
+// ================================================================================================
+procedure TCharQueue.AfterConstruction;
+begin
+   inherited;
+
+   fBlockLog   := trunc( log2( 4096));
+   fBlockSize  := trunc( IntPower(2, fBlockLog));
+
+   fArray      := nil;
+   fOffset     := 0;
+   fCount      := 0;
+end;
+
+// ================================================================================================
+// Before Destruction
+// ================================================================================================
+procedure TCharQueue.BeforeDestruction;
+var
+   i: integer;
+
+begin
+   Clear;
+
+   for i:=Low(fArray) to High(fArray) do
+      fArray[i] := nil;
+
+   fArray := nil;
+   inherited;
+end;
+
+// @@@: Interface +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+//
+//                                           Interface
+//
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ================================================================================================
+// Add
+// ================================================================================================
+procedure TCharQueue.Add(Value: AnsiChar);
+begin
+   Items[ fCount +1] := Value
+end;
+
+// ================================================================================================
+// Remove
+//
+//    Removes 'Count' items from the beginning of the queue. If the 'Count' is bigger than the
+//    count then simply clear the Queue.
+// ================================================================================================
+procedure TCharQueue.Remove( ACount: integer);
+var
+   tmp: TCharMatrix;
+   i  : integer;
+
+begin
+   if ACount > 0 then
+   begin
+      // ------------------------------------------------------------
+      // if the removable item count > than the item count, then
+      // simply clear the queue...
+      // ------------------------------------------------------------
+      if ACount > fCount then
+         Clear
+
+
+      // ------------------------------------------------------------
+      // ...else calculate the new offset and count values. If the
+      // one or more blocks in the vector beginning is freed, then
+      // move these blocks to the end of the vector.
+      // ------------------------------------------------------------
+      else begin
+         INC( fOffset, ACount);
+         DEC( fCount,  ACount);
+
+         SetLength( tmp, 1);
+
+         // ---------------------------------------------------------
+         // Well, not so efficient, but simple
+         // ---------------------------------------------------------
+         while fOffset > fBlockSize -1 do
+         begin
+            tmp[0] := fArray[0];
+
+            // --------------------------------------------
+            // clear the free block
+            // --------------------------------------------
+            for i:=0 to High(tmp[0]) do
+               tmp[0,i] := #0;
+
+            // --------------------------------------------
+            // shift blocks down
+            // --------------------------------------------
+            for i:=0 to High(fArray)-1 do
+               fArray[i] := fArray[i+1];
+
+            // --------------------------------------------
+            // set the vector's last block
+            // --------------------------------------------
+            fArray[High(fArray)] := tmp[0];
+
+            DEC( fOffset, fBlockSize)
+         end;
+
+         tmp := nil
+      end
+   end
+end;
+
+// ================================================================================================
+// Clear
+//
+//    This is a real pain in the ass. I'm not in the mood to optimize it.
+// ================================================================================================
+procedure TCharQueue.Clear;
+var
+   i: integer;
+
+begin
+   for i:=1 to fCount do
+      Items[i] := #0;
+
+   fOffset := 0;
+   fCount  := 0;
+end;
+
+
+// @@@: Property Handlers +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+//
+//                                       Property Handlers
+//
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ================================================================================================
+// Get Item
+//
+//    Get the item specified by it's index. If the index less than 1 or bigger than the size of
+//    the queue, an ERangeError exception will be generated.
+// ================================================================================================
+function TCharQueue.GetItem(i: integer): AnsiChar;
+var
+   block: integer;
+   index: integer;
+
+begin
+   // -------------------------------------------------------------------------
+   // Check for valid index value.
+   // -------------------------------------------------------------------------
+   if i > fCount then raise ERangeError.CreateFmt( 'Index "%d" is too big', [i]);
+   if i < 1      then raise ERangeError.CreateFmt( 'Index is less than 1', []);
+
+   // -------------------------------------------------------------------------
+   // Now process the request.
+   // -------------------------------------------------------------------------
+   block  := (i -1 +fOffset) shr  fBlockLog;
+   index  := (i -1 +fOffset) and (fBlockSize -1);
+
+   result := fArray[block,index];
+end;
+
+// ================================================================================================
+// Set Item
+//
+//    Set the item specified by it's index. If the the index bigger than the count of the Queue
+//    then the Queue will be resized to hold this data. If the index less than 1 an ERangeError
+//    exception will be generated.
+// ================================================================================================
+procedure TCharQueue.SetItem(i: integer; Value: AnsiChar);
+var
+   block: integer;
+   index: integer;
+
+begin
+   // -------------------------------------------------------------------------
+   // Check for valid index value.
+   // -------------------------------------------------------------------------
+   if i < 1 then raise ERangeError.CreateFmt( 'Index is less than 1', []);
+
+   // -------------------------------------------------------------------------
+   // If the index bigger than the size of the Queue then expand the Queue.
+   // -------------------------------------------------------------------------
+   if i > fCount then
+   begin
+      Expand(i);
+      fCount := i;
+   end;
+
+   // -------------------------------------------------------------------------
+   // Now process the request.
+   // -------------------------------------------------------------------------
+   block  := (i -1 +fOffset) shr  fBlockLog;
+   index  := (i -1 +fOffset) and (fBlockSize -1);
+
+   fArray[block,index] := Value
+end;
+
+// @@@: Internals +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+//
+//                                           Internals
+//
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+// ================================================================================================
+// Expand
+//
+//    Expands the Queue. The size of expanding is always fBlockSize*n.
+// ================================================================================================
+procedure TCharQueue.Expand(i: integer);
+var
+   hi: integer;
+   bn: integer;
+   j : integer;
+
+begin
+   if (i-1)+fOffset >= (High(fArray)+1) * fBlockSize then
+   begin
+      hi := High(fArray) +1;
+      bn := (i-1+fOffset) shr fBlockLog;
+
+      SetLength( fArray, bn+1);
+
+      for j:=hi to bn do
+         SetLength( fArray[j], fBlockSize);
+   end;
+end;
+
+end.