sparsarr.pas

TxQuery is an SQL engine implemented in a TDataSet descendant component, that can parse SQL syntax,

Unit SparsArr;

{*******************************************************}
{                                                       }
{       A Sparset TList used in GROUP BY clause         }
{                                                       }
{       Copyright (c) 1999-2002 Alfonso moreno          }
{                                                       }
{     Written/Adapted by:                               }
{       Alfonso moreno                                  }
{       Hermosillo, Sonora, Mexico.                     }
{       Internet:  [e-mail]            }
{                  [e-mail]                 }
{                  [e-mail]              }
{       http://www.sigmap.com/txquery.htm               }
{                                                       }
{*******************************************************}

{$I XQ_FLAG.INC}
Interface

Uses
  Windows, SysUtils, Classes, Controls, StdCtrls
{$IFDEF LEVEL6}
  , Variants
{$ENDIF}
  ;

Type

  PPointer = ^Pointer;

  { TSparsePointerArray class}

  { Used by TSparseList.  Based on Sparse1Array, but has Pointer elements
    and Integer index, just like TPointerList/TList, and less indirection }

    { Apply function for the applicator:
          TheIndex        Index of item in array
          TheItem         Value of item (i.e pointer element) in section
          Returns: 0 if success, else error code. }
  TSPAApply = Function( TheIndex: Integer; TheItem: Pointer ): Integer;

  TSecDir = Array[0..4095] Of Pointer; { Enough for up to 12 bits of sec }
  PSecDir = ^TSecDir;
  TSPAQuantum = ( SPASmall, SPALarge ); { Section size }

  TSparsePointerArray = Class( TObject )
  Private
    secDir: PSecDir;
    slotsInDir: Word;
    indexMask, secShift: Word;
    FHighBound: Integer;
    FSectionSize: Word;
    cachedIndex: Integer;
    cachedPointer: Pointer;
    { Return item[i], nil if slot outside defined section. }
    Function GetAt( Index: Integer ): Pointer;
    { Return address of item[i], creating slot if necessary. }
    Function MakeAt( Index: Integer ): PPointer;
    { Store item at item[i], creating slot if necessary. }
    Procedure PutAt( Index: Integer; Item: Pointer );
  Public
    Constructor Create( Quantum: TSPAQuantum );
    Destructor Destroy; Override;

    { Traverse SPA, calling apply function for each defined non-nil
      item.  The traversal terminates if the apply function returns
      a value other than 0. }
    { NOTE: must be static method so that we can take its address in
      TSparseList.ForAll }
    Function ForAll( ApplyFunction: Pointer {TSPAApply} ): Integer;

    { Ratchet down HighBound after a deletion }
    Procedure ResetHighBound;

    Property HighBound: Integer Read FHighBound;
    Property SectionSize: Word Read FSectionSize;
    Property Items[Index: Integer]: Pointer Read GetAt Write PutAt; Default;
  End;

  { TSparseList class }

  TSparseList = Class( TObject )
  Private
    FList: TSparsePointerArray;
    FCount: Integer; { 1 + HighBound, adjusted for Insert/Delete }
    FQuantum: TSPAQuantum;
    Procedure NewList( Quantum: TSPAQuantum );
  Protected
    Procedure Error; Virtual;
    Function Get( Index: Integer ): Pointer;
    Procedure Put( Index: Integer; Item: Pointer );
  Public
    Constructor Create( Quantum: TSPAQuantum );
    Destructor Destroy; Override;
    Function Add( Item: Pointer ): Integer;
    Procedure Clear;
    Procedure Delete( Index: Integer );
    Procedure Exchange( Index1, Index2: Integer );
    Function First: Pointer;
    Function ForAll( ApplyFunction: Pointer {TSPAApply} ): Integer;
    Function IndexOf( Item: Pointer ): Integer;
    Procedure Insert( Index: Integer; Item: Pointer );
    Function Last: Pointer;
    Procedure Move( CurIndex, NewIndex: Integer );
    Procedure Pack;
    Function Remove( Item: Pointer ): Integer;
    Property Count: Integer Read FCount;
    Property Items[Index: Integer]: Pointer Read Get Write Put; Default;
  End;

  { TAggSparseList class }

  TAggSparseList = Class
  Private
    FList: TSparseList; { of AggItems }
  Protected
    Function Get( Index: Integer ): Variant;
    Function GetCount( Index: Integer ): Integer;
    Procedure Put( Index: Integer; Const Value: Variant );
    Procedure PutCount( Index: Integer; Value: Integer );
    Function GetSqr( Index: Integer ): Double;
    Procedure PutSqr( Index: Integer; Const Value: Double );
    Procedure Error;
  Public
    Constructor Create( Capacity: Integer );
    Destructor Destroy; Override;
    Function HasData( Index: Integer ): Boolean;
    Procedure Delete( Index: Integer );
    Procedure Exchange( Index1, Index2: Integer );
    Procedure Insert( Index: Integer; Const Value: Variant );
    Procedure Clear;

    Property Values[Index: Integer]: Variant Read Get Write Put;
    Property SqrValues[Index: Integer]: Double Read GetSqr Write PutSqr;
    Property Count[Index: Integer]: Integer Read GetCount Write PutCount;
  End;

Implementation

Type

  { AggItem management for TAggSparseList }

  PAggItem = ^TAggItem;
  TAggItem = Record
    FValue: Variant;
    FSqrValue: Double;
    FCount: Integer;
  End;

  { Exception classes }

  EAggregateSparseListError = Class( Exception );

Function NewAggItem( Const AValue: Variant; Const ASqrValue: Double; ACount: Integer ): PAggItem;
Begin
  New( Result );
  Result^.FCount := ACount;
  If VarIsNull( AValue ) Then
    Result^.FValue := 0
  else
    Result^.FValue := AValue;
  Result^.FSqrValue := ASqrValue;
End;

Procedure DisposeAggItem( P: PAggItem );
Begin
  If P=Nil then Exit;
  VarClear( P^.FValue );
  Dispose( P );
End;

{ TSparsePointerArray }

Const
  SPAIndexMask: Array[TSPAQuantum] Of Byte = ( 15, 255 );
  SPASecShift: Array[TSPAQuantum] Of Byte = ( 4, 8 );

  { Expand Section Directory to cover at least `newSlots' slots. Returns: Possibly
    updated pointer to the Section Directory. }

Function ExpandDir( secDir: PSecDir; Var slotsInDir: Word;
  newSlots: Word ): PSecDir;
Begin
  Result := secDir;
  ReallocMem( Result, newSlots * SizeOf( Pointer ) );
  FillChar( Result^[slotsInDir], ( newSlots - slotsInDir ) * SizeOf( Pointer ), 0 );
  slotsInDir := newSlots;
End;

{ Allocate a section and set all its items to nil. Returns: Pointer to start of
  section. }

Function MakeSec( SecIndex: Integer; SectionSize: Word ): Pointer;
Var
  SecP: Pointer;
  Size: Word;
Begin
  Size := SectionSize * SizeOf( Pointer );
  GetMem( secP, size );
  FillChar( secP^, size, 0 );
  MakeSec := SecP
End;

Constructor TSparsePointerArray.Create( Quantum: TSPAQuantum );
Begin
  SecDir := Nil;
  SlotsInDir := 0;
  FHighBound := -1;
  FSectionSize := Word( SPAIndexMask[Quantum] ) + 1;
  IndexMask := Word( SPAIndexMask[Quantum] );
  SecShift := Word( SPASecShift[Quantum] );
  CachedIndex := -1
End;

Destructor TSparsePointerArray.Destroy;
Var
  i: Integer;
  size: Word;
Begin
  { Scan section directory and free each section that exists. }
  i := 0;
  size := FSectionSize * SizeOf( Pointer );
  While i < slotsInDir Do
  Begin
    If secDir^[i] <> Nil Then
      FreeMem( secDir^[i], size );
    Inc( i )
  End;

  { Free section directory. }
  If secDir <> Nil Then
    FreeMem( secDir, slotsInDir * SizeOf( Pointer ) );
End;

Function TSparsePointerArray.GetAt( Index: Integer ): Pointer;
Var
  byteP: PChar;
  secIndex: Cardinal;
Begin
  { Index into Section Directory using high order part of
    index.  Get pointer to Section. If not null, index into
    Section using low order part of index. }
  If Index = cachedIndex Then
    Result := cachedPointer
  Else
  Begin
    secIndex := Index Shr secShift;
    If secIndex >= slotsInDir Then
      byteP := Nil
    Else
    Begin
      byteP := secDir^[secIndex];
      If byteP <> Nil Then
      Begin
        Inc( byteP, ( Index And indexMask ) * SizeOf( Pointer ) );
      End
    End;
    If byteP = Nil Then
      Result := Nil
    Else
      Result := PPointer( byteP )^;
    cachedIndex := Index;
    cachedPointer := Result
  End
End;

Function TSparsePointerArray.MakeAt( Index: Integer ): PPointer;
Var
  dirP: PSecDir;
  p: Pointer;
  byteP: PChar;
  secIndex: Word;
Begin
  { Expand Section Directory if necessary. }
  secIndex := Index Shr secShift; { Unsigned shift }
  If secIndex >= slotsInDir Then
    dirP := expandDir( secDir, slotsInDir, secIndex + 1 )
  Else
    dirP := secDir;

  { Index into Section Directory using high order part of
    index.  Get pointer to Section. If null, create new
    Section.  Index into Section using low order part of index. }
  secDir := dirP;
  p := dirP^[secIndex];
  If p = Nil Then
  Begin
    p := makeSec( secIndex, FSectionSize );
    dirP^[secIndex] := p
  End;
  byteP := p;
  Inc( byteP, ( Index And indexMask ) * SizeOf( Pointer ) );
  If Index > FHighBound Then
    FHighBound := Index;
  Result := PPointer( byteP );
  cachedIndex := -1
End;

Procedure TSparsePointerArray.PutAt( Index: Integer; Item: Pointer );
Begin
  If ( Item <> Nil ) Or ( GetAt( Index ) <> Nil ) Then
  Begin
    MakeAt( Index )^ := Item;
    If Item = Nil Then
      ResetHighBound
  End
End;

Function TSparsePointerArray.ForAll( ApplyFunction: Pointer {TSPAApply} ):
  Integer;
Var
  itemP: PChar; { Pointer to item in section }
  item: Pointer;
  i, callerBP: Cardinal;
  j, index: Integer;
Begin
  { Scan section directory and scan each section that exists,
    calling the apply function for each non-nil item.
    The apply function must be a far local function in the scope of
    the procedure P calling ForAll.  The trick of setting up the stack
    frame (taken from TurboVision's TCollection.ForEach) allows the
    apply function access to P's arguments and local variables and,
    if P is a method, the instance variables and methods of P's class }
  Result := 0;
  i := 0;
  Asm
    mov   eax,[ebp]                     { Set up stack frame for local }
    mov   callerBP,eax
  End;
  While ( i < slotsInDir ) And ( Result = 0 ) Do
  Begin
    itemP := secDir^[i];
    If itemP <> Nil Then
    Begin
      j := 0;
      index := i Shl SecShift;