FastReport_2022_VCL/Source/frxStorage.pas

{******************************************}
{                                          }
{             FastReport VCL               }
{             Data Structures              }
{                                          }
{         Copyright (c) 1998-2021          }
{            by Fast Reports Inc.          }
{                                          }
{******************************************}

unit frxStorage;

{$I frx.inc}

interface

uses
  Classes,
  {$IFNDEF FPC}
  Windows,
  {$ELSE}
  LCLType, LCLIntf, LCLProc, LazHelper,
  {$ENDIF}
  SysUtils, Graphics;

type

  { Old Delphi versions don't declare these classes }

  ENotImplemented = class(Exception);
  ENotSupportedException = class(Exception);

  { Provides the TStream interface to a piece of a stream }

  TProxyStream = class(TStream)
  private
    FStream: TStream;
    FOffset: Longint;
    FPos: Longint;
    FSize: Longint;

    procedure Init(Stream: TStream; Offset, Size: Longint);
    function AdjustRange(var Len: Integer): Boolean;
  public
    constructor Create(Stream: TStream; Offset, Size: Longint);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;

    property Offset: Longint read FOffset;
    property BaseStream: TStream read FStream;
  end;

  { Provides additional functions for writing
    to an already existing stream. }

  TFmtStream = class(TStream)
  private
    FOutput: TStream;
    FOwn: Boolean;
    FFormatted: Boolean;
    FIndent: Integer;
  public
    constructor Create(Output: TStream; Own: Boolean);
    destructor Destroy; override;

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;

    procedure PutsRawA(const s: AnsiString); overload;
    procedure PutsRaw(const s: string); overload;
    procedure PutsRawA(const Fmt: AnsiString; const Args: array of const); overload;
    procedure PutsRaw(const Fmt: string; const Args: array of const); overload;

    procedure PutsA(const s: AnsiString); overload;
    procedure Puts(const s: string = ''); overload;
    procedure PutsA(const Fmt: AnsiString; const Args: array of const); overload;
    procedure Puts(const Fmt: string; const Args: array of const); overload;

    procedure IncIndent(Step: Integer);

    property Formatted: Boolean read FFormatted write FFormatted;
    property Indent: Integer read FIndent write FIndent;
  end;

  { List of objects.

    This class assumes that it contains a list
    of TObject instances. When it's destroyed,
    it also destroys all contained objects. }

  TObjList = class(TList)
    procedure Clear; override;
  end;

  { Encodes an input stream and writes the result to an output stream.
    After sending the whole input stream to the encoder, it must be
    destroyed in order to force the encoder to write special ending bytes
    to the output stream. Example:

      ms := TMemoryStream.Create;

      s := 'data:image/jpeg;base64,';
      ms.Write(s[1], Length(s));

      with TBase64Encoder.Create(ms) do
      try
        Picture.SaveToStream(This)
      finally
        Free
      end; }

  TBase64Encoder = class(TStream)
  private

    FOutput: TStream;
    FCache, FUsed: Integer;
    FMap: array[0..63] of Byte;

  protected

    procedure InitMap;
    procedure Encode(a, n: Integer);
    procedure Finalise;

  public

    constructor Create(Output: TStream);
    destructor Destroy; override;

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;

    function This: TBase64Encoder;

  end;

  { Performs simple hex encoding: each input byte is replaced with a 2-byte
    string containing the hexadecimal value of that byte. }

  THexEncoder = class(TStream)
  private
    FOutput: TStream;
  public
    constructor Create(Output: TStream);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
  end;

  { Writes the end-of-line char after every specified number of bytes }

  TLineSplitter = class(TStream)
  private
    FSep: AnsiString;
    FOutput: TStream;
    FLength: Integer;
    FWritten: Integer;
  public
    constructor Create(Output: TStream; Length: Integer; Sep: AnsiString = #13#10);

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
  end;

  { Block stream.

    This class virtually divides all data into
    equally sized blocks, except for the last
    block that can has less size. }

  TBlockStream = class(TMemoryStream)
  private

    FBlockShift: LongInt;

    function GetBlocksCount: LongInt;
    function GetBlockData(i: LongInt): Pointer;
    function GetBlockSize(i: LongInt): LongInt;
    function GetCurrentBlock: LongInt;

  public

    constructor Create(BlockSizeShift: LongInt = 4);

    { Writes a specified count of bytes from a
      specified value and returns a pointer to
      the written data. }

    function Imm(Value, Count: LongInt): Pointer;

    { Fills a specified count of bytes with a specified
      value. }

    procedure Fill(Value: Byte; Count: LongInt);

    { Fills the remaining space of the current block
      with a specified value. }

    procedure EndBlock(Value: Byte);

    { The data of the stream is virtually split into
      equally sized blocks (except for the last block,
      that can have less size). }

    property BlocksCount: LongInt read GetBlocksCount;
    property BlockData[i: LongInt]: Pointer read GetBlockData;
    property BlockSize[i: LongInt]: LongInt read GetBlockSize;

    { Returns an index to a block where the next byte
      will be written. }

    property CurrentBlock: LongInt read GetCurrentBlock;

    property BlockShift: LongInt read FBlockShift;

  end;

  { Cached stream.

    This class is a layer on another (file)stream and
    implements the interface of a write-only stream.

    It uses an intermediate small cache in physical memory
    to avoid calling the underlying stream for writing
    small data blocks. }

  TCachedStream = class(TStream)
  private

    FStream: TStream;
    FDeleteOnDestroy: Boolean;
    FChunk: array of Byte;
    FUsed: Integer;

    function GetCacheSize: Integer;
    procedure SetCacheSize(Size: Integer);

  protected

    procedure FlushCache;

  public

    constructor Create(Stream: TStream; DeleteOnDestroy: Boolean);
    destructor Destroy; override;

    property CacheSize: Integer read GetCacheSize write SetCacheSize;

    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;

    function Seek(Offset: Longint; Origin: Word): Longint; override;
  end;

  { Pointer-to-Pointer map interface }

  TMap = class
  protected
    procedure SetItemExistence(Key: Pointer; b: Boolean); virtual; abstract;
    function  ItemExists(Key: Pointer): Boolean; virtual; abstract;
    function  GetItem(Key: Pointer): Pointer; virtual; abstract;
    procedure SetItem(Key: Pointer; Value: Pointer); virtual; abstract;
  public
    property Exists[Key: Pointer]: Boolean read ItemExists write SetItemExistence;
    property Items[Key: Pointer]: Pointer read GetItem write SetItem; default;
  end;

  TOrderedMap = class(TMap)
  public
    { Gets all key-value pairs. Keys will be sorted by ascending.
      Either Keys or Values can be nil - in this case the corresponding information
      will not be gathered. }

    procedure GetKeysAndValues(Keys, Values: TList); virtual; abstract;
  end;

  { B-tree is a balanced search tree which can insert, delete and find a key
    for O(log n) time. Its keys are always sorted, so it can return all key value
    pairs sorted by key.

    The order of a b-tree is the maximum number of subnodes each node can have. }

  TBTreeNode = class;

  TBTree = class(TOrderedMap)
  private
    FOrder: Integer;
    FRoot: TBTreeNode;

    function  CreateNode(LNode: TBTreeNode = nil): TBTreeNode;
    function  IsFull(Node: TBTreeNode): Boolean;
    procedure InsertKey(Node: TBTreeNode; i: Integer; Key, Value: Pointer; LNode, RNode: TBTreeNode);
    procedure SplitTree(Node: TBTreeNode; i: Integer);
    function  FindIndex(Node: TBTreeNode; Key: Pointer): Integer;
    function  FindKey(Key: Pointer; out KeyIndex: Integer): TBTreeNode;
    function  GetHeight: Integer;
    function  GetKeysCount: Integer;
  protected
    { Returns True if the key was inserted. Otherwise, the key was already there. }
    function  Insert(Key: Pointer; Value: Pointer): Boolean;
    function  ItemExists(Key: Pointer): Boolean; override;
    function  GetItem(Key: Pointer): Pointer; override;
    procedure SetItem(Key: Pointer; Value: Pointer); override;
    procedure SetItemExistence(Key: Pointer; b: Boolean); override;

    property Root: TBTreeNode read FRoot;
    property Height: Integer read GetHeight;
    property KeysCount: Integer read GetKeysCount;
    property Order: Integer read FOrder;
  public
    constructor Create(Order: Integer = 4);
    destructor Destroy; override;

    procedure GetKeysAndValues(Keys, Values: TList); override;
  end;

  TBTreeNode = class
  private
    FLen: Integer;
    FKeys: array of Pointer;
    FRefs: array of TBTreeNode;
    FVals: array of Pointer;

    procedure SetLen(n: Integer);

    function GetKey(i: Integer): Pointer;
    function GetRef(i: Integer): TBTreeNode;
    function GetVal(i: Integer): Pointer;
    procedure SetKey(i: Integer; k: Pointer);
    procedure SetRef(i: Integer; r: TBTreeNode);
    procedure SetVal(i: Integer; v: Pointer);
  public
    constructor Create(MaxLen: Integer);

    property Len: Integer read FLen write SetLen;

    property Keys[i: Integer]: Pointer read GetKey write SetKey;
    property Refs[i: Integer]: TBTreeNode read GetRef write SetRef;
    property Vals[i: Integer]: Pointer read GetVal write SetVal;
  end;

  { AVL tree is a balanced search tree which can insert, delete and find a key
    for O(log n) time. Its keys are always sorted, so it can return all key value
    pairs sorted by key.

    AVL tree inserts new keys slower than B-tree, but performs lookup faster. }

  TAVLTreeNode = class;

  TAVLTree = class(TMap)
  private
    FRoot: TAVLTreeNode;

    function  FindKey(Key: Pointer; out Node: TAVLTreeNode): Boolean;
    procedure Insert(Parent, Node: TAVLTreeNode; Key, Value: Pointer);
    procedure LiftChild(R, N: TAVLTreeNode; Leaf: Boolean);
  protected
    procedure SetItemExistence(Key: Pointer; b: Boolean); override;
    function  ItemExists(Key: Pointer): Boolean; override;
    function  GetItem(Key: Pointer): Pointer; override;
    procedure SetItem(Key: Pointer; Value: Pointer); override;

    property Root: TAVLTreeNode read FRoot;
  public
    destructor Destroy; override;
  end;

  TAVLTreeNode = class
  private
    FKey, FValue: Pointer;
    FHeight: Byte;
    FLeafs: array[Boolean] of TAVLTreeNode;

    function  GetChild(Leaf: Boolean): TAVLTreeNode;
    procedure SetChild(Leaf: Boolean; Node: TAVLTreeNode);
    function  GetHeight: Byte;
  public
    constructor Create(Key, Value: Pointer);
    destructor Destroy; override;

    procedure UpdateHeight;

    property Key: Pointer read FKey;
    property Value: Pointer read FValue write FValue;
    property Height: Byte read GetHeight write FHeight;
    property Child[Leaf: Boolean]: TAVLTreeNode read GetChild write SetChild; default;
  end;

  { Hash table

    This is a base hash table class }

  THashTable = class
  protected

    procedure SetValueInternal(Key:Integer; Value: Pointer);

  public

    { Returns a value by a specified key.
      Returns zero if the value doesn't exist. }

    function GetValue(Key: Integer): Pointer; virtual; abstract;

    { Sets a value corresponding to a specified key.
      If the value for this key already exists, the routine
      doesn't change the previous value and returns it.
      If the value doesn't exist, the routine changes the value for
      the key and returns zero. }

    function SetValue(Key: Integer; Value: Pointer): Pointer; virtual; abstract;

    { Performs a self test.
      Arguments:

        <20> RS  - randomly choosen value
        <20> n   - a count of iterations }

    function SelfTest(RS, n: Integer): Boolean;

    property Items[Key: Integer]: Pointer read GetValue write SetValueInternal; default;

  end;

  { Hash table

    This is a "classic" implementation of a hash table. }

  TLhtEntry = packed record

    Next: Pointer;
    Key:  Integer;
    Data: Pointer;

  end;

  PLhtEntry = ^TLhtEntry;

  TListHashTable = class(THashTable)
  private

    FBushes: Pointer; // List of pointers to TLhtEntry
    FHeap: THandle;

    function CreateEntry(Key: Integer): PLhtEntry;

  public

    { Returns a value by a specified key.
      Returns zero if the value doesn't exist. }

    function GetValue(Key: Integer): Pointer; override;

    { Sets a value corresponding to a specified key. }

    function SetValue(Key: Integer; Value: Pointer): Pointer; override;

    constructor Create;
    destructor Destroy; override;

  end;

  TListBaseHashTable = class
  public
    ListKeys: TStringList;

    constructor Create;
    destructor Destroy; override;
  end;

  TListStringHashTable = class(TListBaseHashTable)
  public
    ListValues :TStringList;

    function GetValue(Key: String): String;
    procedure SetValue(Key: String; Value: String);
    procedure Clear();

    constructor Create;
    destructor Destroy; override;
  end;

  TListStreamHashTable = class(TListBaseHashTable)
  public
    ListValues :array of TStream;

    function GetValue(Key: String): TStream;
    procedure SetValue(Key: String; Value: TStream);
    procedure Clear();

    constructor Create;
    destructor Destroy; override;
  end;

  TfrxDataHashMap = class
  private
    ListKeys: TStringList;
    ListValues :TList;

  public
    constructor Create;
    destructor Destroy; override;
    function Count: Integer;
    procedure Clear;
    procedure AddPicture(md5s: String); overload;
    procedure AddPicture(md5s: String; i1: Integer); overload;
    function FindPicture(md5s: String): Integer;
    function GetData(ind: Integer): Integer;
  end;

  TPictureHashMapResultType = (phmIndex, phmData);
  TFindOrAddGraphic = function (g: TGraphic; ResultType: TPictureHashMapResultType; IntData: Integer = -1): Integer of object;
  TGetIsLastNew = function: Boolean of object;

  TfrxPictureHashMap = class
  private
    //For Real
    FfrxDataHashMap: TfrxDataHashMap;
    FIsLastNew: Boolean;
    //For Fake
    FCount: Integer;

    FRealHash: Boolean;
    FFindOrAddGraphic: TFindOrAddGraphic;
    FGetIsLastNew: TGetIsLastNew;

    function RealFindOrAddGraphic(g: TGraphic; ResultType: TPictureHashMapResultType; IntData: Integer = -1): Integer;
    function RealGetIsLastNew: Boolean;
    function FakeFindOrAddGraphic(g: TGraphic; ResultType: TPictureHashMapResultType; IntData: Integer = -1): Integer;
    function FakeGetIsLastNew: Boolean;

    procedure SetRealHash(RealHash: Boolean);

  public
    constructor Create(RealHash: Boolean);
    destructor Destroy; override;

    property FindOrAddGraphic: TFindOrAddGraphic read FFindOrAddGraphic;
    property IsLastNew: TGetIsLastNew read FGetIsLastNew;
    property RealHash: Boolean read FRealHash write SetRealHash;
  end;

  { Cache.

    This class provides caching features for storing
    a big list of objects. The cache provides a transparent
    access to objects by indexes. There're two requirements
    that objects must satisfy if they are kept in the cache:

      <20> Any object can save itself to a stream and can load
        itself from a stream

      <20> The cache must not contain two identical references
        at a time }

  TLcWriteObj = procedure(Stream: TStream; Obj: TObject);
  TLcReadObj = function(Stream: TStream): TObject;

  TLcObject = record

    Offset: Int64;
    Size:   Int64;

  end;

  TLcCreateParams = record

    CacheStream:    TStream;
    ObjectsStream:  TStream;
    QueueSize:      Integer;

  end;

  TLcLoadedObject = record

    Reference: TObject;
    Index: Integer;

  end;

  TListCache = class
  private

    { TListCache can work as a usual list without
      caching. In this mode the objects are stored
      in this list. }

    FObjects: TObjList;

    { This stream contains a sequence of serialized objects.
      Normally, this stream is a disk file. }

    FCacheStream: TStream;

    { This stream contains TLcObject structures.
      The i-th structure describes the object at the i-th
      index.

        <20> TLcObject.Offset

          The index to the first byte in FCacheStream where
          the object is stored.

        <20> TLcObject.Size

          The number of bytes occupied in FCacheStream by the
          stored object. }

    FObjectsStream: TStream;

    { This list contains indexes to recently loaded objects.
      The first item of this list refers to the most recent object.
      Access to this queue must be performed via PushObject. }

    FCacheQueue: array of TLcLoadedObject;

    { If enabled, objects that are unloaded will be written to the
      cache stream even if they were already written to the stream
      in past. }

    FUpdate: Boolean;

    { Protects objects from overwriting }

    FProtect: Boolean;

    { If False, unloaded objects are written to the end of the
      cache stream. This greatly increases size of the stream,
      but this has to be done for objects with dynamic size. }

    FStaticSize: Boolean;

    { If these names of files are specified, then the destructor
      must close the two streams and delete the files. }

    FCacheFile: string;
    FObjFile:   string;

  protected

    function IsCaching: Boolean;

    { Calls destructor for all objects in the queue and
      then makes the queue empty. }

    procedure ClearQueue;

    { Access to list of objects must be peformed via
      two routines:

        <20> GetObject( Index )

          Finds a specified object. If the object is presented
          in physical memory, its returned. If the object is
          not in physical memory its loaded from a cache stream
          and returned.

        <20> SetObject( Index, Object )

          Writes a specified object to a specified location.
          Maybe, the routine moves some objects from physical memory
          to a cache stream. }

    function GetObject(Index: Integer): TObject;
    procedure SetObject(Index: Integer; Obj: TObject);

    { Adds a specified object to the head of the queue. If the queue
      is full, then an object in the tail of the queue is unloaded
      to the cache stream. }

    procedure PushObject(Obj: TObject; Index: Integer);

    procedure UnloadObject(Obj: TObject; Index: Integer);

    function GetObjectsCount: Integer;
    procedure SetObjectsCount(NewCount: Integer);

    { This routine is called by constructors for initialization }

    procedure Initialize(Params: TLcCreateParams);

  public

    WriteObj: TLcWriteObj;
    ReadObj: TLcReadObj;

    { This constructor creates TListCache that works
      as a usual TObjList without caching. }

    constructor Create; overload;

    { Creates a cache.
      Arguments:

        <20> Params.CacheStream

          A stream that will contain temporarily
          unloaded objects.

        <20> Params.QueueSize

          A number of objects that can be presented in
          physical memory at a time.

        <20> Params.ObjectsStream

          This stream will contain a list of TLcObject structures.
          The number of these structures equals the number of objects. }

    constructor Create(Params: TLcCreateParams); overload;

    { This constructor creates two files with the specified names
      and uses them as CacheStream and ObjectsStream. When the destructor
      is called, these files are closed and deleted. }

    constructor Create(CacheFile, ObjFile: string; QueueSize: Integer = 4); overload;

    destructor Destroy; override;

    procedure Clear;
    procedure Exchange(Index1, Index2: Integer);
    function First: TObject;
    function Last: TObject;
    function Add(Obj: TObject): Integer;

    { Access to objects by indexes.

      When a caller attempts to write an object at a non existing
      index, the internal list is extended and the object is correctly
      written.

      When a caller attempts to overwrite an existing object,
      and exception is raised. }

    property Objects[Index: Integer]: TObject read GetObject write SetObject; default;

    { Returns a number of references to objects.
      Some references can be zero. }

    property Count: Integer read GetObjectsCount write SetObjectsCount;

    { The cache keeps only a few objects in memory at a time.
      When a caller attempts to load an object that is not in memory,
      it's loaded into memory. After that the cache may have to
      unload another object back to a cache stream. The object that is
      going to be unloaded can differ from its copy in the cache stream.
      In this case the object must be written to the cache stream again.
      This property controls the behaviour of the cache in this situation:

        <20> Option enabled

          The object that's goigng to be unloaded will be written to
          the cache stream, even if it already has a copy in the cache stream.
          This option must be enabled if the object has been changed
          since a time when it was written to the cache stream.

        <20> Option disabled

          The object that's going to be unloaded will be removed from
          memory and will not be written to the cache stream. This option
          must be disabled if the object has not been changed since the last
          time when it was written to the cache stream. }

    property UpdateWhenUnload: Boolean read FUpdate write FUpdate; {default True}

    { When a caller attempts to put an object to a specified location,
      like as follows:

        Objects[777] := Obj

      it can turn out that the specified location is already occupied by another
      object. When this option is enabled, the cache will raise an exception
      for these cases. }

    property Protect: Boolean read FProtect write FProtect; {default False}

    { If WriteObj routine can write different number of bytes for the
      same object, then this property must be set to False. }

    property StaticSize: Boolean read FStaticSize write FStaticSize; {default False}

  end;

  { Data block }

  TDataBlock = class
  public

    Data: Pointer;
    Size: Integer;

    constructor Create(Size: Integer; Zero: Boolean = True);
    destructor Destroy; override;

  end;

  { This function returns a negative integer when x < y and
    returns a non-negative integer in other cases. }

  TSimpleCompareFunction = function(const x, y: Pointer): Integer;

  { Array interface }

  TfrxArray = class
  protected
    function GetZero: Boolean; virtual; abstract;
    procedure SetZero(f: Boolean); virtual; abstract;

    function GetItemSize: Integer; virtual; abstract;

    function GetCount: Integer; virtual; abstract;
    procedure SetCount(Value: Integer); virtual; abstract;

    function GetItemData(Index: Integer): Pointer; virtual; abstract;

    procedure GetItem(Index: Integer; var Item);
    procedure SetItem(Index: Integer; const Item);

    procedure Insert(Index: Integer; const Value);
    procedure Append(const Value);

    procedure VerifyIndex(Index: Integer);
    procedure ResetItems(Min, Max: Integer);

    property ItemData[Index: Integer]: Pointer read GetItemData;
    property ItemSize: Integer read GetItemSize;

  public
    destructor Destroy; override;
    procedure Clear; virtual;
    procedure Exchange(Index1, Index2: Integer); virtual;
    procedure Delete(Index: Integer); virtual;
    procedure Sort(Compare: TSimpleCompareFunction; Min, Max: Integer); virtual;

    property Count: Integer read GetCount write SetCount;

    { If set, all newly created items are filled with zeros.
      If not set, bits of all new blocks are set to 1. }

    property Zero: Boolean read GetZero write SetZero;

  end;

  TfrxBaseArray = class(TfrxArray)
  protected
    FCapacity: Integer;
    FSorted: Boolean;
    FCount: Integer;
    procedure Grow; virtual;
    procedure SetCount(Value: Integer); override;
    function GetCount: Integer; override;
    procedure SetNewCapacity(Value: Integer); virtual;
  public
    procedure Clear; override;
  end;

  { Cached array of equal sized structures }

  TfrxCachedArray = class(TfrxArray)
  private

    FCount: Integer;  // number of items
    FBlock: Integer;  // number of items in a block
    FStorage: TListCache;
    FItemSize: Integer;
    FZero: Boolean;

    function CreateBlock: TDataBlock;
    procedure Initialize;

  protected

    function GetZero: Boolean; override;
    procedure SetZero(f: Boolean); override;
    function GetItemSize: Integer; override;
    function GetCount: Integer; override;
    procedure SetCount(Value: Integer); override;
    function GetItemData(Index: Integer): Pointer; override;

  public

    { TCachedArray is based on TListCache, so its constructor
      has similar arguments.

        <20> DataStream

          This stream is used as a temporary storage for array elements.
          The size of the stream is quite equal to the size of the array.
          This stream is created and deleted by a client, this class only uses it
          and doesn't delete.

        <20> ServStream

          This stream is used for some service information required by TListCache.
          The size of this stream is rather small.
          It's created and deleted by a client, this class doesn't delete it.

        <20> DataFile

          This is the name of a file that will be created and used as DataStream.
          The destructor of this class deletes the created file.

        <20> ServFile

          This is the name of a file that will be created and used as ServStream.
          The destructor of this class deletes the created file.

        <20> Block

          All the elements of the array will be grouped into blocks of this size.
          Any block can either be in physical memory or in the DataStream.
          This value means the number of bytes in each block. }

    constructor Create(DataStream, ServStream: TStream; Block, ItemSize: Integer); overload;
    constructor Create(DataFile, ServFile: string; Block, ItemSize: Integer); overload;

    destructor Destroy; override;

    procedure Sort(Compare: TSimpleCompareFunction; Min, Max: Integer); override;

  end;

  { Abstract array of Integers }

  TfrxIntArrayBase = class(TfrxBaseArray)
  protected

    function GetItem(Index: Integer): Integer; virtual; abstract;
    procedure SetItem(Index: Integer; Value: Integer); virtual; abstract;

    function GetItemSize: Integer; override;

  public

    procedure Insert(Index: Integer; Value: Integer);
    procedure Append(Value: Integer);

    property Items[Index: Integer]: Integer read GetItem write SetItem; default;

  end;

  { Array of Integers }

  TfrxIntArray = class(TfrxIntArrayBase)
  private

    FArray: array of Integer;
    FZero: Boolean;

  protected

    function GetZero: Boolean; override;
    procedure SetZero(f: Boolean); override;

    function GetItem(Index: Integer): Integer; override;
    procedure SetItem(Index: Integer; Value: Integer); override;

    function GetItemData(Index: Integer): Pointer; override;
    procedure SetNewCapacity(Value: Integer); override;
  end;

  { Cached array of Integers }

  TfrxCachedIntArray = class(TfrxIntArrayBase)
  private

    FArray: TfrxCachedArray;

  protected

    function GetZero: Boolean; override;
    procedure SetZero(f: Boolean); override;

    function GetItem(Index: Integer): Integer; override;
    procedure SetItem(Index: Integer; Value: Integer); override;

    function GetCount: Integer; override;
    procedure SetCount(Value: Integer); override;
    function GetItemData(Index: Integer): Pointer; override;

  public

    constructor Create(DataStream, ServStream: TStream; Block: Integer); overload;
    constructor Create(DataFile, ServFile: string; Block: Integer); overload;

    destructor Destroy; override;

  end;

  { Abstract array of Integers }

  TfrxExtArrayBase = class(TfrxBaseArray)
  protected

    function GetItem(Index: Integer): Extended; virtual; abstract;
    procedure SetItem(Index: Integer; Value: Extended); virtual; abstract;

    function GetItemSize: Integer; override;

  public

    procedure Insert(Index: Integer; Value: Extended);
    procedure Append(Value: Extended);

    property Items[Index: Integer]: Extended read GetItem write SetItem; default;

  end;

  { Array of Integers }

  TfrxExtArray = class(TfrxExtArrayBase)
  private

    FArray: array of Extended;
    FZero: Boolean;

  protected

    function GetZero: Boolean; override;
    procedure SetZero(f: Boolean); override;

    function GetItem(Index: Integer): Extended; override;
    procedure SetItem(Index: Integer; Value: Extended); override;
    function GetItemData(Index: Integer): Pointer; override;
    procedure SetNewCapacity(Value: Integer); override;
  end;

  TfrxExtendedObjectList = class(TfrxExtArray)
  private
    FObjectList: array of TObject;
    FFreeObjects: Boolean;
    function GetObject(Index: Integer): TObject;
    procedure SetObject(Index: Integer; const Value: TObject);
  protected
    procedure SetNewCapacity(Value: Integer); override;
  public
    procedure AppendObject(Value: Extended; aObject: TObject);
    procedure Clear; override;
    procedure InsertObject(Index: Integer; Value: Extended; aObject: TObject);
    procedure Exchange(Index1, Index2: Integer); override;
    procedure Delete(Index: Integer); override;
    procedure SortList;
    property Objects[Index: Integer]: TObject read GetObject write SetObject;
    property FreeObjects: Boolean read FFreeObjects write FFreeObjects;
  end;

  { Cached array of Integers }

  TfrxCachedExtArray = class(TfrxExtArrayBase)
  private

    FArray: TfrxCachedArray;

  protected

    function GetZero: Boolean; override;
    procedure SetZero(f: Boolean); override;

    function GetItem(Index: Integer): Extended; override;
    procedure SetItem(Index: Integer; Value: Extended); override;

    function GetCount: Integer; override;
    procedure SetCount(Value: Integer); override;
    function GetItemData(Index: Integer): Pointer; override;

  public

    constructor Create(DataStream, ServStream: TStream; Block: Integer); overload;
    constructor Create(DataFile, ServFile: string; Block: Integer); overload;

    destructor Destroy; override;

  end;

  { This class writes and reads various data types
    to an arbitrary stream }

  TStreamRW = class
  private

    FStream: TStream;
    FSecure: Boolean;

    function GetBoolType: Integer;
    function GetIntType: Integer;
    function GetExtType: Integer;
    function GetStrType: Integer;

    procedure WriteType(t: Integer);
    procedure ReadType(t: Integer);

  public

    { If Secure = True then any value will be written right after
      a 4-byte code that describe its type. When a value is to be read,
      the leading 4-byte code is read and compared with the type of
      the value and if the two 4-byte codes don't match, an
      exception is raised. }

    constructor Create(Stream: TStream; Secure: Boolean = False);

    procedure WriteBool(x: Boolean);
    procedure WriteInt(x: Integer);
    procedure WriteExt(x: Extended);
    procedure WriteStr(x: WideString);

    function ReadBool: Boolean;
    function ReadInt: Integer;
    function ReadExt: Extended;
    function ReadStr: WideString;

  end;

  { Array of bits }

  TBitArray = class
  private

    FLength: Integer;
    FData: array of Byte;

    function GetBit(Index: Integer): Boolean;
    procedure SetBit(Index: Integer; Value: Boolean);
    procedure SetBitsLength(NewLength: Integer);
    procedure Trunc;

  public

    function Clone: TBitArray;

    procedure ResetBits;  // make all bits equal 0
    procedure SetBits;    // make all bits equal 1

    procedure SaveToStream(Stream: TStream);

    function GetNumOfSetBits: Integer;
    function GetRightmostBitIndex: Integer;

    procedure BitOr(Src: TBitArray);  // Self := Self or Src
    procedure BitAnd(Src: TBitArray); // Self := Self and Src
    procedure BitXor(Src: TBitArray); // Self := Self xor Src

    property Bits[Index: Integer]: Boolean read GetBit write SetBit; default;
    property Length: Integer read FLength write SetBitsLength;

  end;

{ Finds an entry with a specified key.
  If there's no such an entry, the routine
  returns the last entry in the list. }

function LhtFindEntry(e: PLhtEntry; Key: Integer): PLhtEntry; cdecl;

{ Get/set an entry by its index. }

function LhtGetEntry(Base: Pointer; Index: Integer): PLhtEntry; cdecl;
procedure LhtSetEntry(Base: Pointer; Index: Integer; Entry: PLhtEntry); cdecl;

{ Serializing and deserializing routines for TDataBlock }

function DbRead(Stream: TStream): TObject;
procedure DbWrite(Stream: TStream; Block: TObject);

implementation

uses
  RTLConsts, Math, frxmd5;

function GraphicToMD5(aGraphic: TGraphic): String;
var
  mem: TMemoryStream;
begin
  mem := TMemoryStream.Create;
  try
    aGraphic.SaveToStream(mem);
    Result := String(MD5Stream(mem));
  finally
    mem.Free;
  end;
end;

var
  NumSetBits: array[0..255] of Byte; // NumSetBits[b] = the number of "1" bits in b
type
{$IFDEF DELPHI16}
  frxInteger = NativeInt;
  frxCardinal = UInt64;
{$ELSE}
  frxInteger = {$IFDEF FPC}PtrInt{$ELSE}Integer{$ENDIF};
  frxCardinal = {$IFDEF FPC}Cardinal{$ELSE}Cardinal{$ENDIF};
{$ENDIF}
procedure InitNumSetBits;

  function GetNSB(b: Byte): Byte;
  begin
    Result := 0;

    while b > 0 do
    begin
      Inc(Result);
      b := b and (b - 1);
    end;
  end;

var
  b: Byte;
begin
  for b := 0 to 255 do
    NumSetBits[b] := GetNSB(b)
end;

procedure LhtSetEntry(Base: Pointer; Index: Integer; Entry: PLhtEntry);
begin
{$IFDEF WIN64}
  Move(Entry, Pointer(Int64(Base) + Index*SizeOf(PLhtEntry))^, SizeOf(PLhtEntry));
{$ELSE}
  Move(Entry, Pointer(Integer(Base) + Index*SizeOf(PLhtEntry))^, SizeOf(PLhtEntry));
{$ENDIF}
end;

function LhtGetEntry(Base: Pointer; Index: Integer): PLhtEntry;
begin
{$IFDEF WIN64}
  Move(Pointer(Int64(Base) + Index*SizeOf(PLhtEntry))^, Result, SizeOf(PLhtEntry));
{$ELSE}
  Move(Pointer(Integer(Base) + Index*SizeOf(PLhtEntry))^, Result, SizeOf(PLhtEntry));
{$ENDIF}
end;

function LhtFindEntry(e: PLhtEntry; Key: Integer): PLhtEntry;
begin
  while (e <> nil) and (e^.Key <> Key) do
    e := e^.Next;

  Result := e;
end;

function AllocPage: Pointer;
begin
  Result := VirtualAlloc(nil, 4096, MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
end;

function DeallocPage(Page: POinter): Boolean;
begin
  Result := VirtualFree(Page, 0, MEM_RELEASE);
end;

procedure CheckBounds(i, Min, Max: LongInt);
begin
  if (i < Min) or (i > Max) then
    raise Exception.CreateFmt('%d is out of bounds [%d, %d]', [i, Min, Max])
end;

{ TObjList }

procedure TObjList.Clear;
var
  i: LongInt;
begin
  for i := 0 to Count - 1 do
    TObject(Items[i]).Free;

  inherited;
end;

{ TBlockStream }

constructor TBlockStream.Create(BlockSizeShift: LongInt);
begin
  inherited Create;
  CheckBounds(BlockSizeShift, 1, 12);
  FBlockShift := BlockSizeShift;
end;

function TBlockStream.GetCurrentBlock: LongInt;
begin
  Result := Size shr FBlockShift;
end;

procedure TBlockStream.EndBlock(Value: Byte);
var
  n, m: LongInt;
begin
  n := 1 shl FBlockShift;
  m := Size and (n - 1);
  if m > 0 then
    Fill(Value, n - m);
end;

procedure TBlockStream.Fill(Value: Byte; Count: LongInt);
begin
  CheckBounds(Count, 1, MaxLongint);

  { todo: an efficient implementation
    can be done using a buffer in the thread stack. }

  while Count > 0 do
  begin
    Write(Value, 1);
    Dec(Count);
  end;
end;

function TBlockStream.GetBlocksCount: LongInt;
begin
  Result := Size shr FBlockShift;
  if Size and (1 shl FBlockShift - 1) <> 0 then
    Inc(Result);
end;

function TBlockStream.GetBlockData(i: LongInt): Pointer;
begin
  CheckBounds(i, 0, BlocksCount - 1);
  Result := Pointer(NativeInt(Memory) + i shl FBlockShift);
end;

function TBlockStream.GetBlockSize(i: LongInt): LongInt;
begin
  CheckBounds(i, 0, BlocksCount - 1);

  Result := Size - i shl FBlockShift;
  if Result < 1 shl FBlockShift then
    Exit;

  Result := 1 shl FBlockShift;
end;

function TBlockStream.Imm(Value, Count: LongInt): Pointer;
begin
  CheckBounds(Count, 1, SizeOf(Value));
  Write(Value, Count);
  Result := Pointer(NativeInt(Memory) + Size - Count);
end;

{ THashTable }

function THashTable.SelfTest(RS, n: Integer): Boolean;
var
  i: Integer;
  x: Pointer;
begin
  RandSeed := RS;
  for i := 1 to n do
  begin
    x := Pointer(Random($7fffffff));
    Items[Integer(x)] := x;

    if Items[Integer(x)] <> x then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;
end;

procedure THashTable.SetValueInternal(Key:Integer; Value: Pointer);
begin
  SetValue(Key, Value);
end;

{ TListHashTable }

constructor TListHashTable.Create;
begin
{$IFDEF WIN64}
  FBushes := VirtualAlloc(nil, $10000 * sizeof(NativeInt), MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
{$ELSE}
  FBushes := VirtualAlloc(nil, $10000 * sizeof(Integer), MEM_COMMIT or MEM_RESERVE, PAGE_READWRITE);
{$ENDIF}
  FHeap := HeapCreate(5{HEAP_GENERATE_EXCEPTIONS or HEAP_NO_SERIALIZE}, 0, 0);

  if FBushes = nil then
    raise Exception.Create('Failed to allocate memory');
end;

destructor TListHashTable.Destroy;
begin
  VirtualFree(FBushes, 0, MEM_RELEASE);
  HeapDestroy(FHeap);
end;

function TListHashTable.CreateEntry(Key: Integer): PLhtEntry;
begin
  Result := HeapAlloc(FHeap, 0, SizeOf(TLhtEntry));
  Result^.Key := Key;
  Result^.Next := nil;
end;

function TListHashTable.GetValue(Key: Integer): Pointer;
var
  e: PLhtEntry;
begin
  e := LhtGetEntry(FBushes, Key and $ffff);
  e := LhtFindEntry(e, Key);

  if (e = nil) or (e^.Key <> Key) then
    Result := nil
  else
    Result := e^.Data;
end;

function TListHashTable.SetValue(Key: Integer; Value: Pointer): Pointer;
var
  e, e2: PLhtEntry;
begin
  e := LhtGetEntry(FBushes, Key and $ffff);
  e := LhtFindEntry(e, Key);

  if (e <> nil) and (e^.Key = Key) then
  begin
    Result := e^.Data;
    Exit;
  end;

  e2 := CreateEntry(Key);
  e2^.Data := Pointer(Value);

  if e = nil then
    LhtSetEntry(FBushes, Key and $ffff, e2)
  else
    e^.Next := e2;

  Result := nil;
end;

{ TListStringHashTable }

constructor TListBaseHashTable.Create;
begin
  ListKeys := TStringList.Create();
end;

destructor TListBaseHashTable.Destroy;
begin
  ListKeys.Free();
end;

{ TListStringHashTable }

function TListStringHashTable.GetValue(Key: String):  String;
var
  i: Integer;
begin
  i := ListKeys.IndexOf(Key);
  if (i = -1) then
    result := ''
  else
    result := ListValues[i];
end;

procedure TListStringHashTable.SetValue(Key: String; Value: String);
begin
  if (GetValue(Key) = '') then
  begin
    ListKeys.Add(Key);
    ListValues.Add(Value);
  end
  else
    ListValues[ListKeys.IndexOf(Key)] := Value;
end;

procedure TListStringHashTable.Clear();
begin
  ListKeys.Clear();
  ListValues.Clear();
end;

constructor TListStringHashTable.Create;
begin
  Inherited;
  ListValues := TStringList.Create();
end;

destructor TListStringHashTable.Destroy;
begin
  Inherited;
  ListValues.Free();
end;

{ TListStreamHashTable }

function TListStreamHashTable.GetValue(Key: String):  TStream;
var
  i: Integer;
begin
  i := ListKeys.IndexOf(Key);
  if (i = -1) then
    result := nil
  else
    result := ListValues[i];
end;

procedure TListStreamHashTable.SetValue(Key: String; Value: TStream);
begin
  if (GetValue(Key) = nil) then
  begin
    ListKeys.Add(Key);
    SetLength(ListValues, ListKeys.Count);
    ListValues[ListKeys.Count - 1] := Value;
  end
  else
    ListValues[ListKeys.IndexOf(Key)] := Value;
end;

procedure TListStreamHashTable.Clear();
var
  i: Integer;
begin
  ListKeys.Clear();
  for i := 0 to Length(ListValues) -1 do
    ListValues[i].Free();
  SetLength(ListValues, 0);
end;

constructor TListStreamHashTable.Create;
begin
  Inherited;
end;

destructor TListStreamHashTable.Destroy;
begin
  Clear();
  Inherited;
end;

{ TfrxDataHashMap }

constructor TfrxDataHashMap.Create;
begin
  ListKeys := TStringList.Create;
  ListValues := TList.Create;
end;

destructor TfrxDataHashMap.Destroy;
begin
  Clear;
  ListKeys.Free;
  ListValues.Free;
  inherited;
end;

function TfrxDataHashMap.Count: Integer;
begin
  Result := ListKeys.Count;
end;

procedure TfrxDataHashMap.Clear;
begin
  ListKeys.Clear();
  ListValues.Clear();
end;

procedure TfrxDataHashMap.AddPicture(md5s: String);
begin
  AddPicture(md5s, -1);
end;

procedure TfrxDataHashMap.AddPicture(md5s: String; i1: Integer);
var
  i: Integer;
begin
  i := FindPicture(md5s);
  if (i = -1) then
  begin
    ListKeys.Add(md5s);
    ListValues.Add(Pointer(i1));
  end;
end;

function TfrxDataHashMap.FindPicture(md5s: String): Integer;
begin
  Result := ListKeys.IndexOf(md5s);
end;

function TfrxDataHashMap.GetData(ind: Integer): Integer;
begin
  Result := -1;
  if (ind < ListValues.Count) then
    Result := Integer(ListValues[ind]);
end;

{ TfrxPictureHashMap }

constructor TfrxPictureHashMap.Create(RealHash: Boolean);
begin
  SetRealHash(RealHash);
end;

destructor TfrxPictureHashMap.Destroy;
begin
  FreeAndNil(FfrxDataHashMap);
  inherited;
end;

procedure TfrxPictureHashMap.SetRealHash(RealHash: Boolean);
begin
  if RealHash and (FfrxDataHashMap = nil) then
  begin
    FfrxDataHashMap := TfrxDataHashMap.Create;
    FFindOrAddGraphic := RealFindOrAddGraphic;
    FGetIsLastNew := RealGetIsLastNew;
  end
  else
  begin
    FreeAndNil(FfrxDataHashMap);
    FFindOrAddGraphic := FakeFindOrAddGraphic;
    FGetIsLastNew := FakeGetIsLastNew;
  end;
end;

function TfrxPictureHashMap.RealFindOrAddGraphic(g: TGraphic; ResultType: TPictureHashMapResultType; IntData: Integer = -1): Integer;
var
  md5s: String;
  IndexImg: Integer;
begin
  md5s := GraphicToMD5(g);
  IndexImg := FfrxDataHashMap.FindPicture(md5s);
  FIsLastNew := (IndexImg = -1);
  if (FIsLastNew) then
  begin
    if (ResultType = phmIndex) then
      Result := FfrxDataHashMap.Count
    else
      Result := IntData;
    FfrxDataHashMap.AddPicture(md5s, IntData);
  end
  else
  begin
    if (ResultType = phmIndex) then
      Result := IndexImg
    else
      Result := FfrxDataHashMap.GetData(IndexImg);
  end;
end;

function TfrxPictureHashMap.RealGetIsLastNew: Boolean;
begin
  Result := FIsLastNew;
end;

function TfrxPictureHashMap.FakeFindOrAddGraphic(g: TGraphic; ResultType: TPictureHashMapResultType; IntData: Integer = -1): Integer;
begin
  Result := FCount;
  FCount := FCount + 1;
end;

function TfrxPictureHashMap.FakeGetIsLastNew: Boolean;
begin
  Result := True;
end;

{ TListCache }

constructor TListCache.Create;
begin
  FObjects := TObjList.Create;
end;

constructor TListCache.Create(Params: TLcCreateParams);
begin
  Initialize(Params);
end;

constructor TListCache.Create(CacheFile, ObjFile: string; QueueSize: Integer);
var
  p: TLcCreateParams;
begin
  FCacheFile := CacheFile;
  FObjFile := ObjFile;

  p.CacheStream := TFileStream.Create(CacheFile, fmCreate);
  p.ObjectsStream := TFileStream.Create(ObjFile, fmCreate);
  p.QueueSize := QueueSize;

  Initialize(p);
end;

destructor TListCache.Destroy;
begin
  if FObjFile <> '' then
  begin
    FObjectsStream.Free;
    DeleteFile(FObjFile);
  end;

  if FCacheFile <> '' then
  begin
    FCacheStream.Free;
    DeleteFile(FCacheFile);
  end;

  FObjects.Free;
  ClearQueue;
end;

procedure TListCache.Initialize(Params: TLcCreateParams);
var
  i: Integer;
begin
  if Params.CacheStream = Params.ObjectsStream then
    raise Exception.Create('Caching stream and objects stream must be different streams');

  FUpdate := True;
  FCacheStream := Params.CacheStream;
  FObjectsStream := Params.ObjectsStream;
  SetLength(FCacheQueue, Params.QueueSize);

  for i := 0 to Length(FCacheQueue) - 1 do
    FCacheQueue[i].Reference := nil;
end;

procedure TListCache.Clear;
begin
  if not IsCaching then
  begin
    FObjects.Clear;
    Exit;
  end;

  FCacheStream.Size := 0;
  FObjectsStream.Size := 0;

  ClearQueue;
end;

procedure TListCache.ClearQueue;
var
  i: Integer;
begin
  for i := 0 to Length(FCacheQueue) - 1 do
  with FCacheQueue[i] do
  begin
    Reference.Free;
    Reference := nil;
  end;
end;

procedure TListCache.Exchange(Index1, Index2: Integer);
var
  i, j: Integer;
  r1, r2: TLcObject;
begin
  if not IsCaching then
  begin
    FObjects.Exchange(Index1, Index2);
    Exit;
  end;

  with FObjectsStream do
  begin
    Seek(Index1 * SizeOf(TLcObject), soFromBeginning);
    Read(r1, SizeOf(TLcObject));

    Seek(Index2 * SizeOf(TLcObject), soFromBeginning);
    Read(r2, SizeOf(TLcObject));

    Seek(Index2 * SizeOf(TLcObject), soFromBeginning);
    Write(r1, SizeOf(TLcObject));

    Seek(Index1 * SizeOf(TLcObject), soFromBeginning);
    Write(r2, SizeOf(TLcObject));
  end;

  for i := 0 to Length(FCacheQueue) - 1 do
  begin
    j := FCacheQueue[i].Index;

    if j = Index1 then
      FCacheQueue[i].Index := Index2;

    if j = Index2 then
      FCacheQueue[i].Index := Index1;
  end;
end;

function TListCache.First: TObject;
begin
  Result := Objects[0];
end;

function TListCache.Last: TObject;
begin
  Result := Objects[Count - 1];
end;

function TListCache.Add(Obj: TObject): Integer;
begin
  Result := Count;
  Objects[Count] := Obj;
end;

function TListCache.IsCaching: Boolean;
begin
  Result := FCacheStream <> nil;
end;

function TListCache.GetObjectsCount: Integer;
begin
  if IsCaching then
    Result := FObjectsStream.Size div SizeOf(TLcObject)
  else
    Result := FObjects.Count;
end;

procedure TListCache.SetObjectsCount(NewCount: Integer);
var
  n, i: Integer;
begin
  n := Count;

  { The case when the new size is greater than the current }

  if NewCount > n then
  begin
    SetObject(NewCount - 1, nil);
    Exit;
  end;

  { If the new size is smaller, remove the tail items from the queue }

  for i := 0 to Length(FCacheQueue) - 1 do
    with FCacheQueue[i] do
      if Index >= NewCount then
      begin
        Reference.Free;
        Reference := nil;
      end;

  { Remove descriptions of the tail items }

  FObjectsStream.Size := NewCount * SizeOf(TLcObject);
end;

function TListCache.GetObject(Index: Integer): TObject;
var
  i: Integer;
  r: TLcLoadedObject;
  x: TLcObject;
begin
  if (Index < 0) or (Index >= Count) then
  begin
    Result := nil;
    Exit;
  end;

  if not IsCaching then
  begin
    Result := FObjects[Index];
    Exit;
  end;

  { Check whether the object is in memory }

  for i := 0 to Length(FCacheQueue) - 1 do
  begin
    r := FCacheQueue[i];

    if (r.Index = Index) and (r.Reference <> nil) then
    begin
      Result := r.Reference;
      Exit;
    end;
  end;

  { If the required object is not in memory,
    load it from the cache stream. }

  FObjectsStream.Seek(Index * SizeOf(TLcObject), soFromBeginning);
  FObjectsStream.Read(x, SizeOf(TLcObject));

  { Some objects stored by a client via SetObject can
    be nil. For these objects zero TLcObject entry corresponds. }

  if x.Size = 0 then
  begin
    Result := nil;
    Exit;
  end;

  { If the object is not nil, load it. }

  FCacheStream.Seek(x.Offset, soFromBeginning);
  Result := ReadObj(FCacheStream);

  { This exception occurs when an object was stored to the
    cache stream some time before and now it's been read, but
    the reading routine reads another number of bytes that
    the writing routine wrote.

    This exception indicates that the read object
    is possibly garbage. }

  if FCacheStream.Position <> x.Offset + x.Size then
    raise Exception.Create('The read object does not match the written object');

  { Put the loaded object to the queue of objects which
    are located in the physical memory. }

  PushObject(Result, Index);
end;

procedure TListCache.SetObject(Index: Integer; Obj: TObject);
var
  i: Integer;
  x: TLcObject;
begin   
  if Index < 0 then
    raise Exception.Create('Cannot store an object an a negative index');

  if not IsCaching then
  begin
    if Index >= Count then
      FObjects.Count := Index + 1;

    FObjects[Index] := Obj;
    Exit;
  end;

  { Prevent overwriting of objects }

  if FProtect and (Index < Count) then
  begin
    FObjectsStream.Seek(Index * SizeOf(TLcObject), soFromBeginning);
    FObjectsStream.Read(x, SizeOf(TLcObject));

    if x.Size > 0 then
      raise Exception.Create('Attempt to overwrite an existing object');
  end;

  { If the index is out of bounds, expand the storage of objects }

  if Index >= Count then
  begin
    i := Index - Count + 1;
    ZeroMemory(@x, SizeOf(x));
    FObjectsStream.Seek(0, soFromEnd);

    while i > 0 do
    begin
      FObjectsStream.Write(x, SizeOf(x));
      Dec(i);
    end;
  end;

  { Notify the system that the object is in memory }

  if Obj <> nil then
    PushObject(Obj, Index);
end;

procedure TListCache.UnloadObject(Obj: TObject; Index: Integer);
var
  x: TLcObject;
begin
  FObjectsStream.Seek(Index * SizeOf(x), soFromBeginning);
  FObjectsStream.Read(x, SizeOf(x));

  { If an object has not been cached yet or
    size of objects can change dynamically,
    it must be cached now or again }

  if not FStaticSize or (x.Size = 0) then
  begin
    x.Offset := FCacheStream.Seek(0, soFromEnd);
    WriteObj(FCacheStream, Obj);
    x.Size := FCacheStream.Position - x.Offset;
    FObjectsStream.Seek(Index * SizeOf(x), soFromBeginning);
    FObjectsStream.Write(x, SizeOf(x));
  end

  { If an object has been cached, it either can be
    cached again or just discarded }

  else if FUpdate then
  begin
    FCacheStream.Seek(x.Offset, soFromBeginning);
    WriteObj(FCacheStream, Obj);

    { This exception occurs when the writing routine attempts
      to write data over bounds that were assigned with the
      object before. The writing routine must write the same
      number of bytes for the same object every time.

      This exception may lead to corruption of consequent objects. }

    if x.Offset + x.Size <> FCacheStream.Position then
      raise Exception.Create('The written object corrupted the consequent object');
  end;

  { Remove the object from memory }

  Obj.Free;
end;

procedure TListCache.PushObject(Obj: TObject; Index: Integer);
var
  i: Integer;
  Tail: TLcLoadedObject;
begin

  { If the queue is full, serialize tail
    objects and remove them from memory }

  Tail := FCacheQueue[Length(FCacheQueue) - 1];
  if Tail.Reference <> nil then
    UnloadObject(Tail.Reference, Tail.Index);

  { Remove the tail from the queue and
    insert the new object index to the head
    of the queue }

  for i := Length(FCacheQueue) - 1 downto 1 do
    FCacheQueue[i] := FCacheQueue[i - 1];

  FCacheQueue[0].Reference := Obj;
  FCacheQueue[0].Index := Index;
end;

{ TArray }

procedure TfrxArray.Append(const Value);
begin
  Count := Count + 1;
  SetItem(Count - 1, Value)
end;

procedure TfrxArray.Clear;
begin
  Count := 0
end;

procedure TfrxArray.Delete(Index: Integer);
var
  i: Integer;
begin
  VerifyIndex(Index);

  for i := Index to Count - 2 do
    Move(ItemData[i + 1]^, ItemData[i]^, ItemSize);

  Count := Count - 1;
end;

destructor TfrxArray.Destroy;
begin
  Clear;
  inherited;
end;

procedure TfrxArray.Exchange(Index1, Index2: Integer);
var
  p0, p1, p2: Pointer;
begin
  p1 := ItemData[Index1];
  p2 := ItemData[Index2];

  GetMem(p0, ItemSize);

  try
    Move(p1^, p0^, ItemSize);
    Move(p2^, p1^, ItemSize);
    Move(p0^, p2^, ItemSize);
  finally
    FreeMem(p0, ItemSize)
  end;
end;

procedure TfrxArray.Insert(Index: Integer; const Value);
var
  i: Integer;
begin
  VerifyIndex(Index);
  Count := Count + 1;

  for i := Count - 2 downto Index do
    Move(ItemData[i]^, ItemData[i + 1]^, ItemSize);

  Move(Value, ItemData[Index]^, ItemSize);
end;

procedure TfrxArray.GetItem(Index: Integer; var Item);
begin
  VerifyIndex(Index);
  Move(GetItemData(Index)^, Item, ItemSize);
end;

procedure TfrxArray.SetItem(Index: Integer; const Item);
begin
  VerifyIndex(Index);
  Move(Item, GetItemData(Index)^, ItemSize);
end;

procedure TfrxArray.Sort(Compare: TSimpleCompareFunction; min, max: Integer);
var
  x: array of Byte;
  i, j: Integer;
begin
  if min >= max then
    Exit;

  System.SetLength(x, ItemSize);
  GetItem((min + max) div 2, x[0]);

  i := min;
  j := max;

  while i <= j do
  begin
    while Compare(GetItemData(i), @x[0]) < 0 do
      Inc(i);

    while Compare(@x[0], GetItemData(j)) < 0 do
      Dec(j);

    if i <= j then
    begin
      Exchange(i, j);
      Inc(i);
      Dec(j);
    end;
  end;

  if min < j then
    Sort(Compare, min, j);

  if i < max then
    Sort(Compare, i, max);
end;

procedure TfrxArray.VerifyIndex(Index: Integer);
begin
  Assert((Index >= 0) and (Index < Count), 'Index out of bounds')
end;

procedure TfrxArray.ResetItems(Min, Max: Integer);
var
  i: Integer;
begin
  if Zero then
    for i := Min to Max do
      ZeroMemory(ItemData[i], ItemSize)
  else
    for i := Min to Max do
      FillMemory(ItemData[i], ItemSize, $ff)
end;

{ TCachedArray }

constructor TfrxCachedArray.Create(DataStream, ServStream: TStream; Block, ItemSize: Integer);
var
  p: TLcCreateParams;
begin
  FBlock := Block;
  FItemSize := ItemSize;

  p.CacheStream := DataStream;
  p.ObjectsStream := ServStream;
  p.QueueSize := 8;

  FStorage := TListCache.Create(p);

  Initialize;
end;

constructor TfrxCachedArray.Create(DataFile, ServFile: string; Block, ItemSize: Integer);
begin
  FBlock := Block;
  FItemSize := ItemSize;

  FStorage := TListCache.Create(DataFile, ServFile, 8);

  Initialize;
end;

destructor TfrxCachedArray.Destroy;
begin
  FStorage.Free
end;

procedure TfrxCachedArray.Initialize;
begin
  FStorage.ReadObj := DbRead;
  FStorage.WriteObj := DbWrite;
  FStorage.StaticSize := True;

  FZero := True;
end;

procedure TfrxCachedArray.Sort(Compare: TSimpleCompareFunction; Min, Max: Integer);

  procedure GetBlockBounds(Index: Integer; var min, max: Integer);
  begin
    min := Index * FBlock;
    max := min + FBlock - 1;

    if max >= Count then
      max := Count - 1;
  end;

  procedure SortBlock(Index: Integer);
  var
    min, max, i, j: Integer;
    x, y: Pointer;
  begin
    GetBlockBounds(Index, min, max);

    for i := min to max do
      for j := i + 1 to max do
      begin
        x := GetItemData(i);
        y := GetItemData(j);

        if Compare(x, y) >= 0 then
          Exchange(i, j);
      end;
  end;

  function BinSearch(const x: Pointer; min, max: Integer): Integer;
  var
    i: Integer;
  begin
    if min = max then
    begin
      Result := min;
      Exit;
    end;

    i := (min + max) div 2;

    if Compare(x, GetItemData(i)) < 0 then
      Result := BinSearch(x, min, i)
    else if i <> min then
      Result := BinSearch(x, i, max)
    else
      Result := i;
  end;

  procedure MergeBlock(Index: Integer);
  var
    i, j, min, max: Integer;
    x, y: array of Byte;
  begin
    GetBlockBounds(Index, min, max);
    System.SetLength(x, ItemSize);
    System.SetLength(y, ItemSize);
    GetItem(min, y[0]);

    for i := BinSearch(@y[0], 0, min - 1) to min - 1 do
    begin
      GetItem(i, x[0]);

      if Compare(@x[0], @y[0]) < 0 then
        Continue;

      SetItem(i, y[0]);
      j := min + 1;

      while j <= max do
      begin
        GetItem(j, y[0]);

        if Compare(@x[0], @y[0]) < 0 then
          Break;

        SetItem(j - 1, y[0]);
        Inc(j);
      end;

      SetItem(j - 1, x[0]);
      GetItem(min, y[0]);
    end;
  end;

var
  i: Integer;
begin
  if (Min <> 0) or (Max <> Count - 1) then
  begin
    inherited Sort(Compare, 0, Count - 1);
    Exit;
  end;

  if FStorage.Count < 1 then
    Exit;

  SortBlock(0);

  for i := 1 to FStorage.Count - 1 do
  begin
    SortBlock(i);
    MergeBlock(i);
  end;
end;

function TfrxCachedArray.GetCount: Integer;
begin
  Result := FCount
end;

procedure TfrxCachedArray.SetCount(Value: Integer);
var
  i, n: Integer;
begin
  n := (Value + FBlock - 1) div FBlock;

  if Value > Count then
    for i := FStorage.Count to n - 1 do
      FStorage[i] := CreateBlock
  else
    FStorage.Count := n;

  FCount := Value;
end;

procedure TfrxCachedArray.SetZero(f: Boolean);
begin
  FZero := f
end;

function TfrxCachedArray.GetItemData(Index: Integer): Pointer;
var
  b: TDataBlock;
begin
  b := FStorage[Index div FBlock] as TDataBlock;
  Result := Pointer(frxInteger(b.Data) + (Index mod FBlock) * ItemSize);
end;

function TfrxCachedArray.GetItemSize: Integer;
begin
  Result := FItemSize
end;

function TfrxCachedArray.GetZero: Boolean;
begin
  Result := FZero
end;

function TfrxCachedArray.CreateBlock: TDataBlock;
begin
  Result := TDataBlock.Create(FBlock * ItemSize, Zero)
end;

{ TDataBlock }

constructor TDataBlock.Create(Size: Integer; Zero: Boolean);
begin
  if Size = 0 then
    Exit;

  GetMem(Data, Size);

  if Zero then
    ZeroMemory(Data, Size)
  else
    {$IFNDEF FPC}FillMemory{$ELSE}FillByte{$ENDIF}(Data, Size, $ff);

  Self.Size := Size;
end;

destructor TDataBlock.Destroy;
begin
  FreeMem(Data, Size)
end;

function DbRead(Stream: TStream): TObject;
var
  n: Integer;
  b: TDataBlock;
begin
  Stream.ReadBuffer(n, SizeOf(n));
  b := TDataBlock.Create(n);
  Stream.ReadBuffer(b.Data^, n);
  Result := b;
end;

procedure DbWrite(Stream: TStream; Block: TObject);
var
  b: TDataBlock;
begin
  b := Block as TDataBlock;

  Stream.WriteBuffer(b.Size, SizeOf(b.Size));

  if b.Size > 0 then
    Stream.WriteBuffer(b.Data^, b.Size)
end;

{ TIntArrayBase }

procedure TfrxIntArrayBase.Append(Value: Integer);
begin
  if FCapacity < Count + 1 then
    Grow;
  Count := Count + 1;
  Items[Count - 1] := Value;
end;

function TfrxIntArrayBase.GetItemSize: Integer;
begin
  Result := SizeOf(Items[0])
end;

procedure TfrxIntArrayBase.Insert(Index, Value: Integer);
begin
  if FCapacity < Count + 1 then
    Grow;
  inherited Insert(Index, Value)
end;

{ TIntArray }

function TfrxIntArray.GetItem(Index: Integer): Integer;
begin
  Result := FArray[Index]
end;

procedure TfrxIntArray.SetItem(Index: Integer; Value: Integer);
begin
  FArray[Index] := Value
end;

procedure TfrxIntArray.SetNewCapacity(Value: Integer);
var
  n: Integer;
begin
  n := Count;
  SetLength(FArray, Value);
  ResetItems(n, Value - 1);
  Inherited;
end;

procedure TfrxIntArray.SetZero(f: Boolean);
begin
  FZero := f
end;

function TfrxIntArray.GetItemData(Index: Integer): Pointer;
begin
  Result := @FArray[Index]
end;

function TfrxIntArray.GetZero: Boolean;
begin
  Result := FZero
end;

{ TCachedIntArray }

constructor TfrxCachedIntArray.Create(DataStream, ServStream: TStream; Block: Integer);
begin
  FArray := TfrxCachedArray.Create(DataStream, ServStream, Block, ItemSize)
end;

constructor TfrxCachedIntArray.Create(DataFile, ServFile: string; Block: Integer);
begin
  FArray := TfrxCachedArray.Create(DataFile, ServFile, Block, ItemSize)
end;

destructor TfrxCachedIntArray.Destroy;
begin
  FArray.Free;
  inherited;
end;

function TfrxCachedIntArray.GetCount: Integer;
begin
  Result := FArray.Count
end;

function TfrxCachedIntArray.GetItem(Index: Integer): Integer;
begin
  FArray.GetItem(Index, Result)
end;

function TfrxCachedIntArray.GetItemData(Index: Integer): Pointer;
begin
  Result := FArray.ItemData[Index]
end;

function TfrxCachedIntArray.GetZero: Boolean;
begin
  Result := FArray.Zero
end;

procedure TfrxCachedIntArray.SetCount(Value: Integer);
begin
  FArray.Count := Value
end;

procedure TfrxCachedIntArray.SetItem(Index, Value: Integer);
begin
  FArray.SetItem(Index, Value)
end;

procedure TfrxCachedIntArray.SetZero(f: Boolean);
begin
  FArray.Zero := f
end;

{ TExtArrayBase }

procedure TfrxExtArrayBase.Append(Value: Extended);
begin
  if FCapacity < Count + 1 then
    Grow;
  Count := Count + 1;
  Items[Count - 1] := Value;
end;

function TfrxExtArrayBase.GetItemSize: Integer;
begin
  Result := SizeOf(Items[0])
end;

procedure TfrxExtArrayBase.Insert(Index: Integer; Value: Extended);
begin
  if FCapacity < Count + 1 then
    Grow;
  inherited Insert(Index, Value)
end;

{ TExtArray }

function TfrxExtArray.GetItem(Index: Integer): Extended;
begin
  Result := FArray[Index]
end;

procedure TfrxExtArray.SetItem(Index: Integer; Value: Extended);
begin
  FArray[Index] := Value
end;

procedure TfrxExtArray.SetNewCapacity(Value: Integer);
var
  n: Integer;
begin
  n := Count;
  SetLength(FArray, Value);
  ResetItems(n, Value - 1);
  Inherited;
end;

procedure TfrxExtArray.SetZero(f: Boolean);
begin
  FZero := f
end;

function TfrxExtArray.GetItemData(Index: Integer): Pointer;
begin
  Result := @FArray[Index]
end;

function TfrxExtArray.GetZero: Boolean;
begin
  Result := FZero
end;

{ TCachedExtArray }

constructor TfrxCachedExtArray.Create(DataStream, ServStream: TStream; Block: Integer);
begin
  FArray := TfrxCachedArray.Create(DataStream, ServStream, Block, ItemSize)
end;

constructor TfrxCachedExtArray.Create(DataFile, ServFile: string; Block: Integer);
begin
  FArray := TfrxCachedArray.Create(DataFile, ServFile, Block, ItemSize)
end;

destructor TfrxCachedExtArray.Destroy;
begin
  FArray.Free;
  inherited;
end;

function TfrxCachedExtArray.GetCount: Integer;
begin
  Result := FArray.Count
end;

function TfrxCachedExtArray.GetItem(Index: Integer): Extended;
begin
  FArray.GetItem(Index, Result)
end;

function TfrxCachedExtArray.GetItemData(Index: Integer): Pointer;
begin
  Result := FArray.ItemData[Index]
end;

function TfrxCachedExtArray.GetZero: Boolean;
begin
  Result := FArray.Zero
end;

procedure TfrxCachedExtArray.SetCount(Value: Integer);
begin
  FArray.Count := Value
end;

procedure TfrxCachedExtArray.SetItem(Index: Integer; Value: Extended);
begin
  FArray.SetItem(Index, Value)
end;

procedure TfrxCachedExtArray.SetZero(f: Boolean);
begin
  FArray.Zero := f
end;

{ TStreamRW }

constructor TStreamRW.Create(Stream: TStream; Secure: Boolean);
begin
  if Stream = nil then
    raise Exception.Create('Invalid stream');

  FStream := Stream;
  FSecure := Secure;
end;

function TStreamRW.GetBoolType: Integer;
begin
  Result := $31927381;
end;

function TStreamRW.GetExtType: Integer;
begin
  Result := $11a328b2;
end;

function TStreamRW.GetIntType: Integer;
begin
  Result := -$218a9320;
end;

function TStreamRW.GetStrType: Integer;
begin
  Result := $71bcf389;
end;

function TStreamRW.ReadBool: Boolean;
begin
  ReadType(GetBoolType);
  FStream.ReadBuffer(Result, SizeOf(Result));
end;

function TStreamRW.ReadExt: Extended;
begin
  ReadType(GetExtType);
  FStream.ReadBuffer(Result, SizeOf(Result));
end;

function TStreamRW.ReadInt: Integer;
begin
  ReadType(GetIntType);
  FStream.ReadBuffer(Result, SizeOf(Result));
end;

function TStreamRW.ReadStr: WideString;
var
  n: Integer;
begin
  ReadType(GetStrType);
  n := 0;
  FStream.ReadBuffer(n, 2);

  if n = 0 then
  begin
    Result := '';
    Exit;
  end;

  SetLength(Result, n);
  FStream.ReadBuffer(Result[1], n * SizeOf(Result[1]));
end;

procedure TStreamRW.ReadType(t: Integer);
var
  x: Integer;
begin
  if not FSecure then
    Exit;

  FStream.ReadBuffer(x, SizeOf(x));

  if x <> t then
    raise Exception.Create('Incorrect data type');
end;

procedure TStreamRW.WriteBool(x: Boolean);
begin
  WriteType(GetBoolType);
  FStream.WriteBuffer(x, SizeOf(x));
end;

procedure TStreamRW.WriteExt(x: Extended);
begin
  WriteType(GetExtType);
  FStream.WriteBuffer(x, SizeOf(x));
end;

procedure TStreamRW.WriteInt(x: Integer);
begin
  WriteType(GetIntType);
  FStream.WriteBuffer(x, SizeOf(x));
end;

procedure TStreamRW.WriteStr(x: WideString);
var
  n: Integer;
begin
  WriteType(GetStrType);
  n := Length(x);
  FStream.WriteBuffer(n, 2);

  if n > 0 then
    FStream.WriteBuffer(x[1], n * SizeOf(x[1]));
end;

procedure TStreamRW.WriteType(t: Integer);
begin
  if FSecure then
    FStream.WriteBuffer(t, SizeOf(t));
end;

{ TBitArray }

procedure TBitArray.BitAnd(Src: TBitArray);
var
  i: Integer;
begin
  Assert(Length <= Src.Length);

  for i := 0 to High(FData) do
    FData[i] := FData[i] and Src.FData[i];

  Trunc;
end;

procedure TBitArray.BitOr(Src: TBitArray);
var
  i: Integer;
begin
  Assert(Length <= Src.Length);

  for i := 0 to High(FData) do
    FData[i] := FData[i] or Src.FData[i];

  Trunc;
end;

procedure TBitArray.BitXor(Src: TBitArray);
var
  i: Integer;
begin
  Assert(Length <= Src.Length);

  for i := 0 to High(FData) do
    FData[i] := FData[i] xor Src.FData[i];

  Trunc;
end;

function TBitArray.Clone: TBitArray;
begin
  Result := TBitArray.Create;

  try
    Result.Length := Length;

    if Length > 0 then
      Move(FData[0], Result.FData[0], System.Length(FData));

    Result.Trunc;
  except
    Result.Free;
    Result := nil;
  end;
end;

function TBitArray.GetNumOfSetBits: Integer;
var
  i: Integer;
begin
  Result := 0;

  for i := 0 to High(FData) do
    Inc(Result, NumSetBits[FData[i]]);
end;

function TBitArray.GetRightmostBitIndex: Integer;
begin
  for Result := Length - 1 downto 0 do
    if Bits[Result] then
      Exit;

  Result := -1;
end;

procedure TBitArray.ResetBits;
begin
  if System.Length(FData) > 0 then
    FillChar(FData[0], System.Length(FData), 0)
end;

procedure TBitArray.SaveToStream(Stream: TStream);
begin
  if System.Length(FData) > 0 then
    Stream.WriteBuffer(FData[0], System.Length(FData))
end;

procedure TBitArray.SetBit(Index: Integer; Value: Boolean);
var
  i: Integer;
begin
  Assert((Index >= 0) and (Index < Length));
  i := Index shr 3;

  if Value then
    FData[i] := FData[i] or (1 shl (Index and 7))
  else
    FData[i] := FData[i] and not (1 shl (Index and 7))
end;

function TBitArray.GetBit(Index: Integer): Boolean;
begin
  Assert((Index >= 0) and (Index < Length));
  Result := (FData[Index shr 3] and (1 shl (Index and 7))) > 0
end;

procedure TBitArray.SetBits;
begin
  if System.Length(FData) > 0 then
    FillChar(FData[0], System.Length(FData), -1);

  Trunc;
end;

procedure TBitArray.SetBitsLength(NewLength: Integer);
begin
  SetLength(FData, (NewLength + 7) shr 3);
  FLength := NewLength;
  Trunc;
end;

procedure TBitArray.Trunc;
begin
  if (Length and 7) > 0 then
    FData[High(FData)] := FData[High(FData)] and ((1 shl (Length and 7)) - 1);
end;

{ TCachedStream }

constructor TCachedStream.Create(Stream: TStream; DeleteOnDestroy: Boolean);
begin
  FStream := Stream;
  FDeleteOnDestroy := DeleteOnDestroy;
  CacheSize := 4096; // typical size of one cluster
end;

destructor TCachedStream.Destroy;
begin
  FlushCache;

  if FDeleteOnDestroy then
    FStream.Free;

  inherited
end;

procedure TCachedStream.FlushCache;
begin
  if FUsed <> FStream.Write(FChunk[0], FUsed) then
  begin
    {$IFDEF STORAGE_DEBUG}
    DbgPrint('TCachedStream.FlushCache failed'#10);
    FStream.Write(FChunk[0], FUsed);
    {$ENDIF}
  end;

  FUsed := 0;
end;

function TCachedStream.GetCacheSize: Integer;
begin
  Result := Length(FChunk)
end;

function TCachedStream.Read(var Buffer; Count: Integer): Longint;
begin
  raise Exception.CreateFmt('%s does not support reading', [ClassName])
end;

function TCachedStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
  FlushCache;
  Result := FStream.Seek(Offset, Origin);
end;

procedure TCachedStream.SetCacheSize(Size: Integer);
begin
  if FUsed > 0 then
    raise Exception.Create('Changing cache size is allowed only when the cache is empty');

  SetLength(FChunk, Size)
end;

function TCachedStream.Write(const Buffer; Count: Integer): Longint;
var
  n, p: Integer;
begin
  Result := Count;
  p := 0;

  while Count > 0 do
  begin
    n := Min(Count, Length(FChunk) - FUsed);
    Move(Pointer(frxInteger(@Buffer) + p)^, FChunk[FUsed], n);

    Inc(p, n);
    Inc(FUsed, n);
    Dec(Count, n);

    if FUsed = Length(FChunk) then
      FlushCache
  end;
end;

{ TBase64Encoder }

constructor TBase64Encoder.Create(Output: TStream);
begin
  FOutput := Output;
  InitMap;
end;

destructor TBase64Encoder.Destroy;
begin
  Finalise;
  inherited;
end;

procedure TBase64Encoder.Encode(a, n: Integer);
var
  b: Integer;
begin
  b :=
    FMap[a shr 2 and 63] or
    FMap[a shr 12 and 15 or a and 3 shl 4 and 63] shl 8 or
    FMap[a shr 22 and 3 or a shr 8 and 15 shl 2 and 63] shl 16 or
    FMap[a shr 16 and 63] shl 24;

  case n of
    1: FOutput.Write(b, 2);
    2: FOutput.Write(b, 3);
    3: FOutput.Write(b, 4);
  end;
end;

procedure TBase64Encoder.Finalise;
var
  b: Byte;
begin
  Encode(FCache, FUsed);
  b := Byte('=');

  while (FUsed > 0) and (FUsed < 3) do
  begin
    FOutput.Write(b, 1);
    Inc(FUsed);
  end;
end;

procedure TBase64Encoder.InitMap;

  procedure Map(Dest, Src, Count: Integer);
  var
    i: Integer;
  begin
    for i := 0 to Count - 1 do
      FMap[Dest + i] := Src + i
  end;

begin
  Map(0,  Byte('A'), 26); // A..Z
  Map(26, Byte('a'), 26); // a..z
  Map(52, Byte('0'), 10); // 0..9

  FMap[62] := Byte('+');  // +
  FMap[63] := Byte('/');  // /
end;

function TBase64Encoder.Read(var Buffer; Count: Integer): Longint;
begin
  raise Exception.Create('This stream is write-only')
end;

function TBase64Encoder.This: TBase64Encoder;
begin
  Result := Self
end;

function TBase64Encoder.Write(const Buffer; Count: Integer): Longint;

  function BitMask(n: Integer): Integer;
  begin
    Result := (1 shl (8*n)) - 1
  end;

var
  n: Integer;
begin
  if Count = 0 then
    {do nothing}
  else if FUsed > 0 then
  begin
    n := Min(3 - FUsed, Count);
    FCache := FCache or ((PInteger(@Buffer)^ and BitMask(n)) shl (8*FUsed));
    Inc(FUsed, n);

    if FUsed = 3 then
    begin
      Encode(FCache, 3);
      FUsed := 0;
    end;

    Write(Pointer(frxInteger(@Buffer) + n)^, Count - n);
  end
  else
  begin
    n := 0;

    while n + 3 <= Count do
    begin
      Encode(PInteger(frxInteger(@Buffer) + n)^, 3);
      Inc(n, 3);
    end;

    if n < Count then
    begin
      FCache := PInteger(frxInteger(@Buffer) + n)^ and BitMask(Count - n);
      FUsed := Count - n;
    end;
  end;

  Result := Count
end;

{ TFmtStream }

constructor TFmtStream.Create(Output: TStream; Own: Boolean);
begin
  FOutput := Output;
  FOwn := Own;
end;

destructor TFmtStream.Destroy;
begin
  if FOwn then
    FOutput.Free;

  inherited;
end;

procedure TFmtStream.IncIndent(Step: Integer);
begin
  Inc(FIndent, Step)
end;

procedure TFmtStream.PutsA(const Fmt: AnsiString; const Args: array of const);
begin
  Puts(string(Fmt), Args)
end;

procedure TFmtStream.PutsA(const s: AnsiString);
var
  i: Integer;
begin
  if Formatted then
    for i := 1 to Indent do
      PutsRawA(' ');

  PutsRawA(s);

  if Formatted then
    PutsRawA(AnsiString(#13#10))
end;

procedure TFmtStream.Puts(const Fmt: string; const Args: array of const);
begin
  Puts(Format(Fmt, Args))
end;

procedure TFmtStream.PutsRaw(const s: string);
begin
  PutsRawA(AnsiString(s))
end;

procedure TFmtStream.PutsRawA(const s: AnsiString);
begin
  if s <> '' then
    Write(s[1], Length(s))
end;

procedure TFmtStream.PutsRaw(const Fmt: string; const Args: array of const);
begin
  PutsRaw(Format(Fmt, Args))
end;

procedure TFmtStream.PutsRawA(const Fmt: AnsiString; const Args: array of const);
begin
  PutsRaw(string(Fmt), Args)
end;

procedure TFmtStream.Puts(const s: string);
begin
  PutsA(AnsiString(s))
end;

function TFmtStream.Read(var Buffer; Count: Integer): Longint;
begin
  Result := FOutput.Read(Buffer, Count)
end;

function TFmtStream.Write(const Buffer; Count: Integer): Longint;
begin
  Result := FOutput.Write(Buffer, Count)
end;

{ TProxyStream }

constructor TProxyStream.Create(Stream: TStream; Offset, Size: Integer);
begin
  Init(Stream, Offset, Size)
end;

procedure TProxyStream.Init(Stream: TStream; Offset, Size: Integer);
begin
  if Stream is TProxyStream then
    Init(TProxyStream(Stream).FStream, Offset + TProxyStream(Stream).FOffset, Size)
  else
  begin
    FStream := Stream;
    FOffset := Offset;
    FSize := Size
  end;
end;

function TProxyStream.AdjustRange(var Len: Integer): Boolean;
begin
  Result := (FPos >= 0) and (FPos < FSize);

  if FPos + Len > FSize then
    Len := FSize - FPos;
end;

function TProxyStream.Read(var Buffer; Count: Integer): Longint;
var
  p: Longint;
begin
  Result := 0;

  if not AdjustRange(Count) then
    Exit;

  p := FStream.Position;
  FStream.Position := FOffset + FPos;
  Result := FStream.Read(Buffer, Count);
  FStream.Position := p;
  FPos := FPos + Result;
end;

function TProxyStream.Write(const Buffer; Count: Integer): Longint;
var
  p: Longint;
begin
  Result := 0;

  if not AdjustRange(Count) then
    Exit;

  p := FStream.Position;
  FStream.Position := FOffset + FPos;
  Result := FStream.Write(Buffer, Count);
  FStream.Position := p;
  FPos := FPos + Result;
end;

function TProxyStream.Seek(Offset: Integer; Origin: Word): Longint;
begin
  case Origin of
    soFromBeginning: FPos := Offset;
    soFromCurrent:   FPos := FPos + Offset;
    soFromEnd:       FPos := FSize + Offset;
  end;

  Result := FPos;
end;

{ THexEncoder }

constructor THexEncoder.Create(Output: TStream);
begin
  FOutput := Output
end;

function THexEncoder.Read(var Buffer; Count: Integer): Longint;
begin
  raise ENotImplemented.Create('This stream is read-only')
end;

function THexEncoder.Write(const Buffer; Count: Integer): Longint;
const
  h: AnsiString = '0123456789abcdef';
var
  i: Integer;
  b: Byte;
  s: array[0..1] of AnsiChar;
begin
  for i := 0 to Count - 1 do
  begin
    b := PByte(frxInteger(@Buffer) + i)^;

    s[0] := h[1 + (b shr 4)];
    s[1] := h[1 + (b and $f)];

    FOutput.WriteBuffer(s[0], 2);
  end;

  Result := Count;
end;

{ TLineSplitter }

constructor TLineSplitter.Create(Output: TStream; Length: Integer; Sep: AnsiString);
begin
  Assert(Sep <> '', 'This class is useless for empty separators');

  inherited Create;

  FOutput := Output;
  FLength := Length;
  FSep := Sep;
end;

function TLineSplitter.Read(var Buffer; Count: Integer): Longint;
begin
  raise ENotSupportedException.Create('The stream is read-only')
end;

function TLineSplitter.Write(const Buffer; Count: Integer): Longint;
var
  n: Integer;
  p: Pointer;
begin
  Result := Count;
  p := @Buffer;

  while Count > 0 do
  begin
    n := Min(FLength - FWritten, Count);
    FOutput.WriteBuffer(p^, n);
    p := Pointer(frxInteger(p) + n);
    Inc(FWritten, n);
    Dec(Count, n);

    if FWritten = FLength then
    begin
      FOutput.WriteBuffer(FSep[1], Length(FSep));
      FWritten := 0;
    end;
  end;
end;

{ TBTreeNode }

constructor TBTreeNode.Create(MaxLen: Integer);
begin
  Assert(MaxLen > 0);
  SetLength(FKeys, MaxLen);
  SetLength(FVals, MaxLen);
  SetLength(FRefs, MaxLen + 1);
end;

function TBTreeNode.GetKey(i: Integer): Pointer;
begin
  Assert((i >= 0) and (i < Len));
  Result := FKeys[i]
end;

function TBTreeNode.GetRef(i: Integer): TBTreeNode;
begin
  Assert((i >= 0) and (i < Len + 1));
  Result := FRefs[i]
end;

function TBTreeNode.GetVal(i: Integer): Pointer;
begin
  Assert((i >= 0) and (i < Len));
  Result := FVals[i]
end;

procedure TBTreeNode.SetKey(i: Integer; k: Pointer);
begin
  Assert((i >= 0) and (i < Len));
  FKeys[i] := k
end;

procedure TBTreeNode.SetLen(n: Integer);
begin
  Assert((n >= 0) and (n <= Length(FKeys)));
  FLen := n;
end;

procedure TBTreeNode.SetRef(i: Integer; r: TBTreeNode);
begin
  Assert((i >= 0) and (i < Len +1));
  FRefs[i] := r
end;

procedure TBTreeNode.SetVal(i: Integer; v: Pointer);
begin
  Assert((i >= 0) and (i < Len));
  FVals[i] := v
end;

{ TBTree }

constructor TBTree.Create(Order: Integer);
begin
  Assert(Order >= 4);
  Assert(Order mod 2 = 0);
  FOrder := Order;
end;

destructor TBTree.Destroy;

  procedure DeleteNode(Node: TBTreeNode);
  var
    i: Integer;
  begin
    if Node = nil then
      Exit;

    for i := 0 to Node.Len do
      DeleteNode(Node.Refs[i]);

    Node.Free;
  end;

begin
  DeleteNode(FRoot);
  inherited;
end;

function TBTree.FindIndex(Node: TBTreeNode; Key: Pointer): Integer;

  function LinSearch(Node: TBTreeNode; Key: Pointer): Integer;
  var
    i: Integer;
  begin
    i := 0;

    with Node do
      while (i < Len) and (frxCardinal(Keys[i]) < frxCardinal(Key)) do
        Inc(i);

    Result := i;
  end;

  function BinSearch(Node: TBTreeNode; Key: Pointer): Integer;
  var
    i, j, m: Integer;
    k: Pointer;
  begin
    if Node.Len = 0 then
      Result := 0
    else
    with Node do
    begin
      i := 0;
      j := Len - 1;

      repeat
        m := (i + j) div 2; // due to i and j are small, the expression i + (j - i) div 2 can be avoided
        k := Keys[m];

        if frxCardinal(Key) < frxCardinal(k) then
          j := m - 1
        else if frxCardinal(Key) > frxCardinal(k) then
          i := m + 1
        else
          Break;
      until i > j;

      if frxCardinal(k) < frxCardinal(Key) then
        Result := m + 1
      else
        Result := m
    end;
  end;

begin
  Assert(BinSearch(Node, Key) = LinSearch(Node, Key));

  if Node.Len < 10 then
    Result := LinSearch(Node, Key)
  else
    Result := BinSearch(Node, Key)
end;

function TBTree.FindKey(Key: Pointer; out KeyIndex: Integer): TBTreeNode;
var
  Node: TBTreeNode;
  i: Integer;
begin
  if FRoot = nil then
  begin
    Result := nil;
    Exit;
  end;

  Node := FRoot;

  repeat
    Assert(Node <> nil);

    with Node do
    begin
      i := FindIndex(Node, Key);

      if (i < Len) and (Key = Keys[i]) then
      begin
        KeyIndex := i;
        Result := Node;
        Exit;
      end;

      Node := Refs[i];
    end;
  until Node = nil;

  Result := nil;
end;

function TBTree.CreateNode(LNode: TBTreeNode): TBTreeNode;
begin
  Result := TBTreeNode.Create(FOrder - 1);
  Result.Refs[0] := LNode;
end;

function TBTree.IsFull(Node: TBTreeNode): Boolean;
begin
  Result := Node.Len + 1 = FOrder
end;

function TBTree.GetHeight: Integer;
var
  Node: TBTreeNode;
begin
  Result := 0;
  Node := FRoot;

  while Node <> nil do
  begin
    Inc(Result);
    Node := Node.Refs[0];
  end;
end;

function TBTree.GetItem(Key: Pointer): Pointer;
var
  Node: TBTreeNode;
  i: Integer;
begin
  Node := FindKey(Key, i);

  if Node = nil then
    Result := nil
  else
    Result := Node.Vals[i]
end;

procedure TBTree.GetKeysAndValues(Keys, Values: TList);

  procedure Visit(Node: TBTreeNode);
  var
    i: Integer;
  begin
    if Node = nil then
      Exit;

    Visit(Node.Refs[0]);

    for i := 0 to Node.Len - 1 do
    begin
      if Keys <> nil then
        Keys.Add(Node.Keys[i]);

      if Values <> nil then
        Values.Add(Node.Vals[i]);

      Visit(Node.Refs[i + 1]);
    end;
  end;

var
  n: Integer;
begin
  n := KeysCount;

  if Keys <> nil then
    Keys.Capacity := n;

  if Values <> nil then
    Values.Capacity := n;

  if (Keys <> nil) or (Values <> nil) then
    Visit(FRoot);
end;

function TBTree.GetKeysCount: Integer;

  function Count(Node: TBTreeNode): Integer;
  var
    i: Integer;
  begin
    if Node = nil then
      Result := 0
    else
    begin
      Result := Node.Len;

      for i := 0 to Node.Len do
        Inc(Result, Count(Node.Refs[i]));
    end;
  end;

begin
  Result := Count(FRoot)
end;

procedure TBTree.SetItem(Key, Value: Pointer);
begin
  Insert(Key, Value);
end;

procedure TBTree.SetItemExistence(Key: Pointer; b: Boolean);
begin
  if b then
    Insert(Key, nil)
  else
    raise ENotImplemented.Create('Removing keys not implemented')
end;

function TBTree.ItemExists(Key: Pointer): Boolean;
var
  i: Integer;
begin
  Result := FindKey(Key, i) <> nil
end;

procedure TBTree.InsertKey(Node: TBTreeNode; i: Integer; Key, Value: Pointer; LNode, RNode: TBTreeNode);
var
  j: Integer;
begin
  Assert(not IsFull(Node));
  Assert((i >= 0) and (i <= Node.Len));

  with Node do
  begin
    Len := Len + 1;

    for j := Len - 1 downto i + 1 do
      Keys[j] := Keys[j - 1];

    for j := Len - 1 downto i + 1 do
      Vals[j] := Vals[j - 1];

    for j := Len downto i + 2 do
      Refs[j] := Refs[j - 1];

    Keys[i] := Key;
    Vals[i] := Value;
    Refs[i] := LNode;
    Refs[i + 1] := RNode;
  end;
end;

procedure TBTree.SplitTree(Node: TBTreeNode; i: Integer);
var
  LNode, RNode: TBTreeNode;
  Key, Value: Pointer;
  j, m: Integer;
begin
  Assert(not IsFull(Node));
  Assert(Node.Refs[i] <> nil);
  Assert(IsFull(Node.Refs[i]));

  LNode := Node.Refs[i];
  RNode := CreateNode;

  with LNode do
  begin
    m := Len div 2;

    Key := Keys[m];
    Value := Vals[m];

    RNode.Len := m;

    for j := 0 to m - 1 do
      RNode.Keys[j] := Keys[m + 1 + j];

    for j := 0 to m - 1 do
      RNode.Vals[j] := Vals[m + 1 + j];

    for j := 0 to m do
      RNode.Refs[j] := Refs[m + 1 + j];

    Len := m;
  end;

  with Node do
  begin
    Assert(Refs[i] = LNode);
    InsertKey(Node, i, Key, Value, LNode, RNode);
  end;
end;

function TBTree.Insert(Key: Pointer; Value: Pointer): Boolean;
var
  Node: TBTreeNode;
  i: Integer;
begin
  if FRoot = nil then
  begin
    FRoot := CreateNode;
    FRoot.Len := 1;
    FRoot.Keys[0] := Key;
    FRoot.Vals[0] := Value;
    Result := True;
    Exit;
  end;

  if IsFull(FRoot) then
  begin
    FRoot := CreateNode(FRoot);
    SplitTree(FRoot, 0);
  end;

  Result := False;
  Node := FRoot;

  repeat
    Assert(Node <> nil);

    with Node do
    begin
      i := FindIndex(Node, Key);

      if (i < Len) and (Key = Keys[i]) then
        Break;

      if (Refs[i] = nil) or not IsFull(Refs[i]) then
      begin
        if Refs[i] = nil then
        begin
          InsertKey(Node, i, Key, Value, nil, nil);
          Result := True;
        end;

        Node := Refs[i]
      end
      else
      begin
        SplitTree(Node, i);

        if Key = Keys[i] then
          Break;

        if frxCardinal(Key) < frxCardinal(Keys[i]) then
          Node := Refs[i]
        else
          Node := Refs[i + 1];
      end;
    end;
  until Node = nil;

  if Node <> nil then
    Node.Vals[i] := Value;
end;

{ TAVLTree }

procedure TAVLTree.LiftChild(R, N: TAVLTreeNode; Leaf: Boolean);
var
  A, B: TAVLTreeNode;
begin
  Assert(N <> nil);
  Assert(N[Leaf] <> nil);

  A := N[Leaf];
  B := A[not Leaf];

  A[not Leaf] := N;
  N[Leaf] := B;

  if R = nil then
    FRoot := A
  else
    R[R[True] = N] := A;

  N.UpdateHeight;
  A.UpdateHeight;
end;

procedure TAVLTree.Insert(Parent, Node: TAVLTreeNode; Key, Value: Pointer);
var
  Leaf: Boolean;
begin
  Assert(Node <> nil);

  if Node.Key = Key then
  begin
    Node.Value := Value;
    Exit;
  end;

  Leaf := frxCardinal(Key) < frxCardinal(Node.Key);

  if Node[Leaf] = nil then
  begin
    Node[Leaf] := TAVLTreeNode.Create(Key, Value);
    Node.Height := 2;
    Exit;
  end;

  Insert(Node, Node[Leaf], Key, Value);
  Node.UpdateHeight;

  if Node[Leaf].Height < 2 + Node[not Leaf].Height then
    Exit;

  if Node[Leaf][not Leaf].Height > Node[Leaf][Leaf].Height then
    LiftChild(Node, Node[Leaf], not Leaf);

  LiftChild(Parent, Node, Leaf);
end;

function TAVLTree.GetItem(Key: Pointer): Pointer;
var
  Node: TAVLTreeNode;
begin
  if FindKey(Key, Node) then
    Result := Node.Value
  else
    Result := nil
end;

procedure TAVLTree.SetItem(Key, Value: Pointer);
begin
  if FRoot = nil then
    FRoot := TAVLTreeNode.Create(Key, Value)
  else
    Insert(nil, FRoot, Key, Value)
end;

function TAVLTree.ItemExists(Key: Pointer): Boolean;
var
  Node: TAVLTreeNode;
begin
  Result := FindKey(Key, Node)
end;

procedure TAVLTree.SetItemExistence(Key: Pointer; b: Boolean);
begin
  if b then
    SetItem(Key, nil)
  else
    raise ENotImplemented.Create('Item cannot be removed')
end;

destructor TAVLTree.Destroy;
begin
  Root.Free;
  inherited;
end;

function TAVLTree.FindKey(Key: Pointer; out Node: TAVLTreeNode): Boolean;
var
  N: TAVLTreeNode;
begin
  N := FRoot;

  while (N <> nil) and (N.Key <> Key) do
    N := N[frxCardinal(Key) < frxCardinal(N.Key)];

  Node := N;
  Result := N <> nil;
end;

{ TAVLTreeNode }

constructor TAVLTreeNode.Create(Key, Value: Pointer);
begin
  FKey := Key;
  FValue := Value;
  FHeight := 1;
end;

destructor TAVLTreeNode.Destroy;
begin
  FLeafs[True].Free;
  FLeafs[False].Free;
  inherited;
end;

function TAVLTreeNode.GetChild(Leaf: Boolean): TAVLTreeNode;
begin
  Result := FLeafs[Leaf]
end;

function TAVLTreeNode.GetHeight: Byte;
begin
  if Self = nil then
    Result := 0
  else
    Result := FHeight
end;

procedure TAVLTreeNode.SetChild(Leaf: Boolean; Node: TAVLTreeNode);
begin
  FLeafs[Leaf] := Node;
end;

procedure TAVLTreeNode.UpdateHeight;
begin
  FHeight := Max(Child[True].Height, Child[False].Height) + 1
end;

{ TfrxBaseArray }

procedure TfrxBaseArray.Clear;
begin
  inherited;
  SetNewCapacity(0);
end;

function TfrxBaseArray.GetCount: Integer;
begin
  Result := FCount;
end;

procedure TfrxBaseArray.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then
    Delta := FCapacity div 4
  else
    if FCapacity > 8 then
      Delta := 16
    else
      Delta := 4;
  SetNewCapacity(FCapacity + Delta);
end;


procedure TfrxBaseArray.SetCount(Value: Integer);
begin
//  if Value < 0 then
//    Error(@SListCountError, Value);
  if Value <> Count then
  begin
    if Value > FCapacity then
      SetNewCapacity(Value);
//    if NewCount > FCount then
//      FillChar(FList[FCount], (NewCount - FCount) * SizeOf(Pointer), 0)
  end;
  FCount := Value;
end;

procedure TfrxBaseArray.SetNewCapacity(Value: Integer);
begin
  FCapacity := Value;
end;

{ TfrxExtendexObjectList }

procedure TfrxExtendedObjectList.AppendObject(Value: Extended;
  aObject: TObject);
begin
  Append(Value);
  FObjectList[Count - 1] := aObject;
end;

procedure TfrxExtendedObjectList.Clear;
var
  i: Integer;
begin
  if FFreeObjects then
    for i := 0 to Length(FObjectList) - 1 do
      if Assigned(FObjectList[i]) then
        FObjectList[i].Free;
  inherited;
end;

procedure TfrxExtendedObjectList.Delete(Index: Integer);
var
  i: Integer;
begin
  for i := Index to Count - 2 do
    FObjectList[i] := FObjectList[i + 1];
  inherited Delete(Index);
end;

procedure TfrxExtendedObjectList.Exchange(Index1, Index2: Integer);
var
  tmpObj: TObject;
begin
  inherited Exchange(Index1, Index2);
  tmpObj := FObjectList[Index1];
  FObjectList[Index1] := FObjectList[Index2];
  FObjectList[Index2] := tmpObj;
end;

function TfrxExtendedObjectList.GetObject(Index: Integer): TObject;
begin
  Result := FObjectList[Index];
end;

procedure TfrxExtendedObjectList.InsertObject(Index: Integer; Value: Extended;
  aObject: TObject);
var
  i: Integer;
begin
  if Count = 0 then
  begin
    AppendObject(Value, aObject);
    Exit;
  end;
  Insert(Index, Value);
  for i := Count - 2 downto Index do
    FObjectList[i + 1] := FObjectList[i];
  FObjectList[Index] := aObject;
end;

procedure TfrxExtendedObjectList.SetNewCapacity(Value: Integer);
begin
  inherited;
  SetLength(FObjectList, Value);
end;

procedure TfrxExtendedObjectList.SetObject(Index: Integer;
  const Value: TObject);
begin
  FObjectList[Index] := Value;
end;

  function DoCompare(const x, y: Pointer): Integer;
  var
    pX, pY: ^Extended;
  begin
    pX := x;
    pY := y;
    Result := 0;
    if Round(pX^ * 100) > Round(pY^ *100) then
      Result := 1
    else if Round(pX^ * 100) < Round(pY^ * 100) then
      Result := -1
  end;

procedure TfrxExtendedObjectList.SortList;
begin
  Sort(@DoCompare, 0, Count - 1);
end;

initialization

InitNumSetBits;

end.