ezstrarru.pas

很管用的GIS控件

  FQuantum := Quantum;
  If FList <> Nil Then
    FreeAndNil( FList );
  FList := TSparsePointerArray.Create( Quantum )
End;

Procedure TSparseList.Pack;
Var
  i: Integer;
Begin
  For i := FCount - 1 Downto 0 Do
    If Items[i] = Nil Then
      Delete( i )
End;

Procedure TSparseList.Put( Index: Integer; Item: Pointer );
Begin
  If Index < 0 Then
    Error;
  FList[Index] := Item;
  FCount := FList.HighBound + 1
End;

Function TSparseList.Remove( Item: Pointer ): Integer;
Begin
  Result := IndexOf( Item );
  If Result <> -1 Then
    Delete( Result )
End;

{ TStringSparseList }

Constructor TStringSparseList.Create( Quantum: TSPAQuantum );
Begin
  Inherited Create;
  FList := TSparseList.Create( Quantum )
End;

Destructor TStringSparseList.Destroy;
Begin
  If FList <> Nil Then
  Begin
    Clear;
    FreeAndNil( FList );
  End;
  Inherited Destroy;
End;

Procedure TStringSparseList.ReadData( Reader: TReader );
Var
  i: Integer;
Begin
  With Reader Do
  Begin
    i := Integer( ReadInteger );
    While i > 0 Do
    Begin
      InsertObject( Integer( ReadInteger ), ReadString, Nil );
      Dec( i )
    End
  End
End;

Procedure TStringSparseList.WriteData( Writer: TWriter );
Var
  itemCount: Integer;

  Function CountItem( TheIndex: Integer; TheItem: Pointer ): Integer; Far;
  Begin
    Inc( itemCount );
    Result := 0
  End;

  Function StoreItem( TheIndex: Integer; TheItem: Pointer ): Integer; Far;
  Begin
    With Writer Do
    Begin
      WriteInteger( TheIndex ); { Item index }
      WriteString( PStrItem( TheItem )^.FString );
    End;
    Result := 0
  End;

Begin
  With Writer Do
  Begin
    itemCount := 0;
    FList.ForAll( @CountItem );
    WriteInteger( itemCount );
    FList.ForAll( @StoreItem );
  End
End;

Procedure TStringSparseList.DefineProperties( Filer: TFiler );
Begin
  Filer.DefineProperty( 'List', ReadData, WriteData, True );
End;

Function TStringSparseList.Get( Index: Integer ): String;
Var
  p: PStrItem;
Begin
  p := PStrItem( FList[Index] );
  If p = Nil Then
    Result := ''
  Else
    Result := p^.FString
End;

Function TStringSparseList.GetCount: Integer;
Begin
  Result := FList.Count
End;

Function TStringSparseList.GetObject( Index: Integer ): TObject;
Var
  p: PStrItem;
Begin
  p := PStrItem( FList[Index] );
  If p = Nil Then
    Result := Nil
  Else
    Result := p^.FObject
End;

Procedure TStringSparseList.Put( Index: Integer; Const S: String );
Var
  p: PStrItem;
  obj: TObject;
Begin
  p := PStrItem( FList[Index] );
  If p = Nil Then
    obj := Nil
  Else
    obj := p^.FObject;
  If ( S = '' ) And ( obj = Nil ) Then { Nothing left to store }
    FList[Index] := Nil
  Else
    FList[Index] := NewStrItem( S, obj );
  If p <> Nil Then
    DisposeStrItem( p );
  Changed
End;

Procedure TStringSparseList.PutObject( Index: Integer; AObject: TObject );
Var
  p: PStrItem;
Begin
  p := PStrItem( FList[Index] );
  If p <> Nil Then
    p^.FObject := AObject
  Else If AObject <> Nil Then
    Error;
  Changed
End;

Procedure TStringSparseList.Changed;
Begin
  If Assigned( FOnChange ) Then
    FOnChange( Self )
End;

Procedure TStringSparseList.Error;
Begin
  Raise EStringSparseListError.Create( 'Put Object Error!' )
End;

Procedure TStringSparseList.Delete( Index: Integer );
Var
  p: PStrItem;
Begin
  p := PStrItem( FList[Index] );
  If p <> Nil Then
    DisposeStrItem( p );
  FList.Delete( Index );
  Changed
End;

Procedure TStringSparseList.Exchange( Index1, Index2: Integer );
Begin
  FList.Exchange( Index1, Index2 );
End;

Procedure TStringSparseList.Insert( Index: Integer; Const S: String );
Begin
  FList.Insert( Index, NewStrItem( S, Nil ) );
  Changed
End;

Procedure TStringSparseList.Clear;

  Function ClearItem( TheIndex: Integer; TheItem: Pointer ): Integer; Far;
  Begin
    DisposeStrItem( PStrItem( TheItem ) ); { Item guaranteed non-nil }
    Result := 0
  End;

Begin
  FList.ForAll( @ClearItem );
  FList.Clear;
  Changed
End;

{ TStringArrayStrings }

{ AIndex < 0 is a column (for column -AIndex - 1)
  AIndex > 0 is a row (for row AIndex - 1)
  AIndex = 0 denotes an empty row or column }

Constructor TStringArrayStrings.Create( AGrid: TStringArray; AIndex: Longint );
Begin
  Inherited Create;
  FGrid := AGrid;
  FIndex := AIndex;
End;

Procedure TStringArrayStrings.Assign( Source: TPersistent );
Var
  I, Max: Integer;
Begin
  If Source Is TStrings Then
  Begin
    BeginUpdate;
    Max := TStrings( Source ).Count - 1;
    If Max >= Count Then
      Max := Count - 1;
    Try
      For I := 0 To Max Do
      Begin
        Put( I, TStrings( Source ).Strings[I] );
        PutObject( I, TStrings( Source ).Objects[I] );
      End;
    Finally
      EndUpdate;
    End;
    Exit;
  End;
  Inherited Assign( Source );
End;

Procedure TStringArrayStrings.CalcXY( Index: Integer; Var X, Y: Integer );
Begin
  If FIndex = 0 Then
  Begin
    X := -1;
    Y := -1;
  End
  Else If FIndex > 0 Then
  Begin
    X := Index;
    Y := FIndex - 1;
  End
  Else
  Begin
    X := -FIndex - 1;
    Y := Index;
  End;
End;

{ Changes the meaning of Add to mean copy to the first empty string }

Function TStringArrayStrings.Add( Const S: String ): Integer;
Var
  I: Integer;
Begin
  For I := 0 To Count - 1 Do
    If Strings[I] = '' Then
    Begin
      Strings[I] := S;
      Result := I;
      Exit;
    End;
  Result := -1;
End;

Procedure TStringArrayStrings.Clear;
Var
  SSList: TStringSparseList;
  I: Integer;

  Function BlankStr( TheIndex: Integer; TheItem: Pointer ): Integer; Far;
  Begin
    Objects[TheIndex] := Nil;
    Strings[TheIndex] := '';
    Result := 0;
  End;

Begin
  If FIndex > 0 Then
  Begin
    SSList := TStringSparseList( TSparseList( FGrid.FData )[FIndex - 1] );
    If SSList <> Nil Then
      SSList.List.ForAll( @BlankStr );
  End
  Else If FIndex < 0 Then
    For I := Count - 1 Downto 0 Do
    Begin
      Objects[I] := Nil;
      Strings[I] := '';
    End;
End;

Function TStringArrayStrings.Get( Index: Integer ): String;
Var
  X, Y: Integer;
Begin
  CalcXY( Index, X, Y );
  If X < 0 Then
    Result := ''
  Else
    Result := FGrid.Cells[X, Y];
End;

Function TStringArrayStrings.GetCount: Integer;
Begin
  { Count of a row is the column count, and vice versa }
  If FIndex = 0 Then
    Result := 0
  Else If FIndex > 0 Then
    Result := Integer( FGrid.ColCount )
  Else
    Result := Integer( FGrid.RowCount );
End;

Function TStringArrayStrings.GetObject( Index: Integer ): TObject;
Var
  X, Y: Integer;
Begin
  CalcXY( Index, X, Y );
  If X < 0 Then
    Result := Nil
  Else
    Result := FGrid.Objects[X, Y];
End;

Procedure TStringArrayStrings.Put( Index: Integer; Const S: String );
Var
  X, Y: Integer;
Begin
  CalcXY( Index, X, Y );
  FGrid.Cells[X, Y] := S;
End;

Procedure TStringArrayStrings.PutObject( Index: Integer; AObject: TObject );
Var
  X, Y: Integer;
Begin
  CalcXY( Index, X, Y );
  FGrid.Objects[X, Y] := AObject;
End;

Procedure TStringArrayStrings.Delete( Index: Integer );
Begin
End;

Procedure TStringArrayStrings.Insert( Index: Integer; Const S: String );
Begin
End;

{ TStringArray }

Constructor TStringArray.Create( ARowCount, AColCount: longint );
Begin
  Inherited Create;
  FRowCount := ARowCount;
  FColCount := AColCount;
  Initialize;
End;

Procedure TStringArray.Clear;
  Function FreeItem( TheIndex: Integer; TheItem: Pointer ): Integer; Far;
  Begin
    TObject( TheItem ).Free;
    Result := 0;
  End;

Begin
  If FRows <> Nil Then
  Begin
    TSparseList( FRows ).ForAll( @FreeItem );
    TSparseList( FRows ).Free;
  End;
  If FCols <> Nil Then
  Begin
    TSparseList( FCols ).ForAll( @FreeItem );
    TSparseList( FCols ).Free;
  End;
  If FData <> Nil Then
  Begin
    TSparseList( FData ).ForAll( @FreeItem );
    TSparseList( FData ).Free;
  End;
  FRows := Nil;
  FCols := Nil;
  FData := Nil;
  Initialize;
End;

Destructor TStringArray.Destroy;
Begin
  Clear;
  Inherited Destroy;
End;

Procedure TStringArray.ColumnMove( FromIndex, ToIndex: Longint );

  Function MoveColData( Index: Integer; ARow: TStringSparseList ): integer; Far;
  Begin
    ARow.Move( FromIndex, ToIndex );
    Result := 0;
  End;

Begin
  TSparseList( FData ).ForAll( @MoveColData );
End;

Procedure TStringArray.RowMove( FromIndex, ToIndex: Longint );
Begin
  TSparseList( FData ).Move( FromIndex, ToIndex );
  {Invalidate;
  inherited RowMove(FromIndex, ToIndex);}
End;

Procedure TStringArray.Initialize;
Var
  quantum: TSPAQuantum;
Begin
  If FCols = Nil Then
  Begin
    If ColCount > 512 Then
      quantum := SPALarge
    Else
      quantum := SPASmall;
    FCols := TSparseList.Create( quantum );
  End;
  If RowCount > 256 Then
    quantum := SPALarge
  Else
    quantum := SPASmall;
  If FRows = Nil Then
    FRows := TSparseList.Create( quantum );
  If FData = Nil Then
    FData := TSparseList.Create( quantum );
End;

Function TStringArray.EnsureColRow( Index: Integer; IsCol: Boolean ):
  TStringArrayStrings;
Var
  RCIndex: Integer;
  PList: ^TSparseList;
Begin
  If IsCol Then
    PList := @FCols
  Else
    PList := @FRows;
  Result := TStringArrayStrings( PList^[Index] );
  If Result = Nil Then
  Begin
    If IsCol Then
      RCIndex := -Index - 1
    Else
      RCIndex := Index + 1;
    Result := TStringArrayStrings.Create( Self, RCIndex );
    PList^[Index] := Result;
  End;
End;

Function TStringArray.EnsureDataRow( ARow: Integer ): Pointer;
Var
  quantum: TSPAQuantum;
Begin
  Result := TStringSparseList( TSparseList( FData )[ARow] );
  If Result = Nil Then
  Begin
    If ColCount > 512 Then
      quantum := SPALarge
    Else
      quantum := SPASmall;
    Result := TStringSparseList.Create( quantum );
    TSparseList( FData )[ARow] := Result;
  End;
End;

Function TStringArray.GetCells( ACol, ARow: Integer ): String;
Var
  ssl: TStringSparseList;
Begin
  ssl := TStringSparseList( TSparseList( FData )[ARow] );
  If ssl = Nil Then
    Result := ''
  Else
    Result := ssl[ACol];
End;

Function TStringArray.GetCols( Index: Integer ): TStrings;
Begin
  Result := EnsureColRow( Index, True );
End;

Function TStringArray.GetObjects( ACol, ARow: Integer ): TObject;
Var
  ssl: TStringSparseList;
Begin
  ssl := TStringSparseList( TSparseList( FData )[ARow] );
  If ssl = Nil Then
    Result := Nil
  Else
    Result := ssl.Objects[ACol];
End;

Function TStringArray.GetRows( Index: Integer ): TStrings;
Begin
  Result := EnsureColRow( Index, False );
End;

Procedure TStringArray.SetCells( ACol, ARow: Integer; Const Value: String );
Begin
  TStringArrayStrings( EnsureDataRow( ARow ) )[ACol] := Value;
  EnsureColRow( ACol, True );
  EnsureColRow( ARow, False );
End;

Procedure TStringArray.SetCols( Index: Integer; Value: TStrings );
Begin
  EnsureColRow( Index, True ).Assign( Value );
End;

Procedure TStringArray.SetObjects( ACol, ARow: Integer; Value: TObject );
Begin
  TStringArrayStrings( EnsureDataRow( ARow ) ).Objects[ACol] := Value;
  EnsureColRow( ACol, True );
  EnsureColRow( ARow, False );
End;

Procedure TStringArray.SetRows( Index: Integer; Value: TStrings );
Begin
  EnsureColRow( Index, False ).Assign( Value );
End;

Procedure TStringArray.SetColCount( Value: longint );
Begin
  If Value <> FColCount Then
  Begin
    FColCount := Value;
    Initialize;
  End;
End;

Procedure TStringArray.SetRowCount( Value: longint );
Begin
  If Value <> FRowCount Then
  Begin
    FRowCount := Value;
    Initialize;
  End;
End;

End.