FastReport_2022_VCL/LibD28x64/frxMapGeodataLayer.pas
2024-01-01 16:13:08 +01:00

840 lines
20 KiB
ObjectPascal

{******************************************}
{ }
{ FastReport v6.0 }
{ Map Geo Data Layer }
{ }
{ Copyright (c) 1998-2021 }
{ by Fast Reports Inc. }
{ }
{******************************************}
unit frxMapGeodataLayer;
interface
{$I frx.inc}
uses
Classes, Graphics,
frxMapLayer, frxMapHelpers, frxClass, frxMapShape;
type
TGeoDataKind = (gdWKT, gdWKB);
TfrxMapGeodataLayer = class (TfrxCustomLayer)
private
FBorderColorColumn: String;
FFillColorColumn: String;
FDataColumn: String;
FGeoDataKind: TGeoDataKind;
FMapDataSet: TfrxDataSet;
protected
function GetSelectedShapeName: String; override; // Similarly TfrxMapFileLayer
function GetSelectedShapeValue: String; override; // Similarly TfrxMapFileLayer
procedure InitialiseData; override;
procedure LoadShapes;
function IsCanGetData: Boolean; override;
function IsWideText: Boolean;
procedure LoadGeoData(MemoryStream: TMemoryStream; Tags: TStringList);
procedure AddValueList(vaAnalyticalValue: Variant); override; // Similarly TfrxMapFileLayer
function IsSpecialBorderColor(iRecord: Integer; out SpecialColor: TColor): Boolean; override;
function IsSpecialFillColor(iRecord: Integer; out SpecialColor: TColor): Boolean; override;
public
constructor Create(AOwner: TComponent); override;
procedure GetColumnList(List: TStrings); override;
procedure CopyDatasets(CustomLayer: TfrxCustomLayer); override;
published
property ShowLines;
property ShowPoints;
property ShowPolygons;
property LabelColumn;
property SpatialColumn;
property MapAccuracy;
property PixelAccuracy;
property MapDataSet: TfrxDataSet read FMapDataSet write FMapDataSet;
property BorderColorColumn: String read FBorderColorColumn write FBorderColorColumn;
property FillColorColumn: String read FFillColorColumn write FFillColorColumn;
property DataColumn: String read FDataColumn write FDataColumn;
property GeoDataKind: TGeoDataKind read FGeoDataKind write FGeoDataKind;
property SpatialValue;
end;
implementation
uses
Math, Contnrs, Types, Variants, SysUtils,
frxMap, frxAnaliticGeometry, frxDsgnIntf, frxUtils;
type
TfrxCustomDBDataSetHelper = class(TfrxCustomDBDataSet)
public
property Fields;
end;
TAnsiCharSet = set of AnsiChar;
const
Numeric: TAnsiCharSet = ['+', '-', '.', '0'..'9'];
Literal: TAnsiCharSet = ['a'..'z', 'A'..'Z'];
type
TReaderWKx = class
private
protected
FStream: TStream;
FData: TDoublePointArray;
function GetData(Index: Integer): TDoublePoint;
function GetCount: Integer; virtual; abstract;
function EndOfStream: Boolean;
public
destructor Destroy; override;
function ReadDouble: Double; virtual; abstract;
function ReadDoublePoint: TDoublePoint; virtual;
procedure ReadDoublePointArray; virtual; abstract;
property Data[Index: Integer]: TDoublePoint read GetData;
property Count: Integer read GetCount;
end;
TGeoDataLoaderWKx = class
private
protected
FStream: TStream;
FShapes: TShapeList;
FTags: TStringList;
FReaderWKx: TReaderWKx;
procedure FillShapeDataPart(ShapeData: TShapeData);
procedure ReadAddFillPart(ShapeData: TShapeData);
procedure LoadPointShape;
procedure LoadLineStringShape;
public
constructor Create(Stream: TStream; Shapes: TShapeList; Tags: TStringList);
destructor Destroy; override;
procedure LoadShapes; virtual; abstract;
end;
// WKT / WKB - http://www.opengeospatial.org/standards/sfa
TReaderWKT = class(TReaderWKx)
private
FNextChar: AnsiChar;
FCount: Integer;
protected
FWideText: Boolean;
function GetCount: Integer; override;
public
constructor Create(Stream: TStream; WideText: Boolean);
function ReadNext: AnsiChar;
function ReadWhile(Suitable: TAnsiCharSet): AnsiString;
function ReadUntil(UnSuitable: TAnsiCharSet): AnsiString;
function ReadDouble: Double; override;
function ReadDoublePoint: TDoublePoint; override;
procedure ReadDoublePointArray; override;
property NextChar: AnsiChar read FNextChar;
end;
TGeoDataLoaderWKT = class (TGeoDataLoaderWKx)
protected
function ReaderWKT: TReaderWKT;
procedure LoadMultiPointShape;
procedure LoadMultiLineStringShape;
procedure LoadPolygonShape;
procedure LoadMultiPoligonShape;
public
constructor Create(Stream: TStream; Shapes: TShapeList;
Tags: TStringList; WideText: Boolean);
procedure LoadShapes; override;
end;
TReaderWKB = class(TReaderWKx)
private
protected
FBigEndian: Boolean;
FGeometry: LongWord;
FHexString: String;
function GetCount: Integer; override;
function SwapLongWord(Value: LongWord): LongWord;
function SwapDouble(Value: Double): Double;
function ReadByte: Byte;
function ReadLongWord: LongWord;
procedure StreamToHex;
public
constructor Create(Stream: TStream);
function ReadDouble: Double; override;
procedure ReadDoublePointArray; override;
procedure ReadEndiannessAndGeomety;
end;
TGeoDataLoaderWKB = class (TGeoDataLoaderWKx)
protected
function ReaderWKB: TReaderWKB;
procedure LoadMultiPointShape;
procedure LoadMultiLineStringShape;
procedure LoadPolygonShape;
procedure LoadMultiPoligonShape;
public
constructor Create(Stream: TStream; Shapes: TShapeList; Tags: TStringList);
procedure LoadShapes; override;
end;
{ TfrxMapGeodataLayer }
procedure TfrxMapGeodataLayer.AddValueList(vaAnalyticalValue: Variant);
var
vaSpatialValue: Variant;
begin
vaSpatialValue := Report.Calc(SpatialValue);
if not VarIsNull(vaSpatialValue) then
FValuesList.AddValue(VarToStr(vaSpatialValue), vaAnalyticalValue);
end;
procedure TfrxMapGeodataLayer.CopyDatasets(CustomLayer: TfrxCustomLayer);
begin
inherited CopyDatasets(CustomLayer);
MapDataSet := TfrxMapGeodataLayer(CustomLayer).MapDataSet;
end;
constructor TfrxMapGeodataLayer.Create(AOwner: TComponent);
begin
inherited;
FLabelColumn := '';
FSpatialColumn := '';
FMapAccuracy := 0.0;
FPixelAccuracy := 0.0;
FShapes := TShapeList.Create(FConverter);
FShapes.EmbeddedData := True;
FBorderColorColumn := '';
FFillColorColumn := '';
FDataColumn := '';
end;
procedure TfrxMapGeodataLayer.GetColumnList(List: TStrings);
begin
if MapDataSet <> nil then
MapDataSet.GetFieldList(List);
end;
function TfrxMapGeodataLayer.GetSelectedShapeName: String;
begin
if (SelectedShapeIndex = Unknown) or (FShapes = nil) or (LabelColumn = '') then
Result := inherited GetSelectedShapeName
else
Result := GetShapeName(LabelColumn, SelectedShapeIndex);
end;
function TfrxMapGeodataLayer.GetSelectedShapeValue: String;
begin
if (SelectedShapeIndex = Unknown) or (FShapes = nil) then
Result := inherited GetSelectedShapeValue
else
Result := GetShapeValue(SelectedShapeIndex);
end;
procedure TfrxMapGeodataLayer.InitialiseData;
begin
inherited InitialiseData;
FShapes.Clear;
if (MapDataSet <> nil) and (Trim(DataColumn) <> '') and not IsDesigning then
LoadShapes;
end;
function TfrxMapGeodataLayer.IsCanGetData: Boolean;
begin
Result := inherited IsCanGetData
and not IsDesigning
and (Trim(SpatialValue) <> '');
end;
function TfrxMapGeodataLayer.IsSpecialBorderColor(iRecord: Integer; out SpecialColor: TColor): Boolean;
var
stColor: String;
begin
Result := (BorderColorColumn <> '');
if Result then
begin
stColor := FShapes[iRecord].Legend[BorderColorColumn];
Result := (stColor <> '') and TryStrToInt(stColor, Integer(SpecialColor));
end;
end;
function TfrxMapGeodataLayer.IsSpecialFillColor(iRecord: Integer; out SpecialColor: TColor): Boolean;
var
stColor: String;
begin
Result := (FillColorColumn <> '');
if Result then
begin
stColor := FShapes[iRecord].Legend[FillColorColumn];
Result := (stColor <> '') and TryStrToInt(stColor, Integer(SpecialColor));
end;
end;
function TfrxMapGeodataLayer.IsWideText: Boolean;
begin
Result := False;
if Assigned(MapDataSet) then
Result := MapDataSet.IsWideMemoBlobField(DataColumn);
end;
procedure TfrxMapGeodataLayer.LoadGeoData(MemoryStream: TMemoryStream; Tags: TStringList);
var
Loader: TGeoDataLoaderWKx;
begin
if (MemoryStream = nil) or (MemoryStream.Size = 0) then
Exit;
case GeoDataKind of
gdWKT:
Loader := TGeoDataLoaderWKT.Create(MemoryStream, FShapes, Tags, IsWideText);
gdWKB:
Loader := TGeoDataLoaderWKB.Create(MemoryStream, FShapes, Tags);
else
raise Exception.Create('Unknown GeoDataKind');
end;
try
Loader.LoadShapes;
finally
Loader.Free;
end;
end;
procedure TfrxMapGeodataLayer.LoadShapes;
var
MemoryStream: TMemoryStream;
Tags: TStringList;
i: Integer;
begin
MapDataSet.First;
while not MapDataSet.Eof do
begin
if (Trim(Filter) = '') or (Report.Calc(Filter) = True {Because Report.Calc: Variant}) then
if MapDataSet.IsBlobField(DataColumn) then
begin
Tags := TStringList.Create;
MapDataSet.GetFieldList(Tags);
try
for i := 0 to MapDataSet.FieldsCount - 1 do
Tags[i] := Tags[i] + Tags.NameValueSeparator + MapDataSet.DisplayText[Tags[i]];
MemoryStream := TMemoryStream.Create;
try
MapDataSet.AssignBlobTo(DataColumn, MemoryStream);
LoadGeoData(MemoryStream, Tags);
finally
MemoryStream.Free;
end;
finally
Tags.Free;
end
end;
MapDataSet.Next;
end;
FShapes.SetMapRectByData;
// FShapes.SaveToTextFile(ExtractFilePath(Paramstr(0)) + 'Shapes.txt'); { TODO : Debug }
end;
{ TGeoDataLoaderWKT }
constructor TGeoDataLoaderWKT.Create(Stream: TStream; Shapes: TShapeList; Tags: TStringList; WideText: Boolean);
begin
inherited Create(Stream, Shapes, Tags);
FReaderWKx := TReaderWKT.Create(Stream, WideText);
end;
procedure TGeoDataLoaderWKT.LoadMultiLineStringShape;
var
ShapeData: TShapeData;
begin
ReaderWKT.ReadNext; // '('
ShapeData := TShapeData.CreateEmpty(stMultiPolyLine, FTags);
repeat
ReadAddFillPart(ShapeData);
ReaderWKT.ReadNext; // Second ')' or ','
until ReaderWKT.EndOfStream or (ReaderWKT.NextChar = ')');
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKT.LoadMultiPointShape;
var
ShapeData: TShapeData;
begin
ReaderWKT.ReadNext; // '('
ShapeData := TShapeData.CreateEmpty(stMultiPoint, FTags);
ReadAddFillPart(ShapeData);
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKT.LoadMultiPoligonShape;
var
ShapeData: TShapeData;
begin
ReaderWKT.ReadNext; // '('
ShapeData := TShapeData.CreateEmpty(stMultiPolygon, FTags);
repeat
ReaderWKT.ReadNext; // Second '('
repeat
ReadAddFillPart(ShapeData);
ReaderWKT.ReadNext; // Second ')' or ','
until ReaderWKT.EndOfStream or (ReaderWKT.NextChar = ')');
ReaderWKT.ReadNext; // )' or ','
until ReaderWKT.EndOfStream or (ReaderWKT.NextChar = ')');
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKT.LoadPolygonShape;
var
ShapeData: TShapeData;
begin
ReaderWKT.ReadNext; // Second '('
ShapeData := TShapeData.CreateEmpty(stPolygon, FTags);
repeat
ReadAddFillPart(ShapeData);
ReaderWKT.ReadNext; // Second ')' or ','
until ReaderWKT.EndOfStream or (ReaderWKT.NextChar = ')');
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKT.LoadShapes;
var
Geometry: AnsiString;
begin
if ReaderWKT.EndOfStream then
Exit;
ReaderWKT.ReadUntil(Literal);
Geometry := ReaderWKT.ReadWhile(Literal);
ReaderWKT.ReadUntil(['(']);
if Geometry = 'POINT' then
LoadPointShape
else if Geometry = 'LINESTRING' then
LoadLineStringShape
else if Geometry = 'POLYGON' then
LoadPolygonShape
else if Geometry = 'MULTIPOINT' then
LoadMultiPointShape
else if Geometry = 'MULTILINESTRING' then
LoadMultiLineStringShape
else if Geometry = 'MULTIPOLYGON' then
LoadMultiPoligonShape
else
raise Exception.Create('Unknown Geometry: ' + String(Geometry));
end;
function TGeoDataLoaderWKT.ReaderWKT: TReaderWKT;
begin
Result := TReaderWKT(FReaderWKx);
end;
{ TGeoDataLoaderWKx }
constructor TGeoDataLoaderWKx.Create(Stream: TStream; Shapes: TShapeList; Tags: TStringList);
begin
FStream := Stream;
Stream.Position := 0;
FShapes := Shapes;
FTags := Tags;
end;
destructor TGeoDataLoaderWKx.Destroy;
begin
FReaderWKx.Free;
inherited;
end;
procedure TGeoDataLoaderWKx.FillShapeDataPart(ShapeData: TShapeData);
var
i, iPart: Integer;
begin
iPart := ShapeData.PartCount - 1;
for i := 0 to FReaderWKx.Count - 1 do
ShapeData.MultiLine[iPart, i] := FReaderWKx.Data[i];
end;
procedure TGeoDataLoaderWKx.LoadLineStringShape;
var
ShapeData: TShapeData;
begin
ShapeData := TShapeData.CreateEmpty(stPolyLine, FTags);
ReadAddFillPart(ShapeData);
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKx.LoadPointShape;
begin
with FReaderWKx.ReadDoublePoint do
FShapes.AddShapeData(TShapeData.CreatePoint(FTags, X, Y));
end;
procedure TGeoDataLoaderWKx.ReadAddFillPart(ShapeData: TShapeData);
begin
FReaderWKx.ReadDoublePointArray;
ShapeData.AddPart(FReaderWKx.Count);
FillShapeDataPart(ShapeData);
end;
{ TReaderWKT }
constructor TReaderWKT.Create(Stream: TStream; WideText: Boolean);
begin
FStream := Stream;
FWideText := WideText;
FStream.Position := 0;
ReadNext;
FCount := 0;
SetLength(FData, 1024);
end;
function TReaderWKT.GetCount: Integer;
begin
Result := FCount;
end;
function TReaderWKT.ReadDouble: Double;
var
Number: AnsiString;
begin
ReadUntil(Numeric);
Number := ReadWhile(Numeric);
Result := frxStrToFloat(String(Number));
end;
function TReaderWKT.ReadDoublePoint: TDoublePoint;
var
InBrackets: Boolean;
begin
InBrackets := NextChar = '(';
Result := inherited ReadDoublePoint;
if InBrackets then
ReadNext; // Skip ')'
end;
procedure TReaderWKT.ReadDoublePointArray;
begin
FCount := 0;
while not EndOfStream and (NextChar <> ')') do
begin
if Count > High(FData) then
SetLength(FData, Length(FData) * 2);
FData[Count] := ReadDoublePoint;
Inc(FCount);
end;
end;
function TReaderWKT.ReadNext: AnsiChar;
var
WCh: WideChar;
begin
if FWideText then
begin
FStream.Read(WCh, 2);
FNextChar := AnsiChar(WCh);
end
else
FStream.Read(FNextChar, 1);
Result := NextChar;
end;
function TReaderWKT.ReadUntil(UnSuitable: TAnsiCharSet): AnsiString;
begin
Result := '';
while not EndOfStream and not (NextChar in UnSuitable) do
begin
Result := Result + NextChar;
ReadNext;
end;
end;
function TReaderWKT.ReadWhile(Suitable: TAnsiCharSet): AnsiString;
begin
Result := '';
while not EndOfStream and (NextChar in Suitable) do
begin
Result := Result + NextChar;
ReadNext;
end;
end;
{ TGeoDataLoaderWKB }
constructor TGeoDataLoaderWKB.Create(Stream: TStream; Shapes: TShapeList; Tags: TStringList);
begin
inherited Create(Stream, Shapes, Tags);
FReaderWKx := TReaderWKB.Create(Stream);
end;
procedure TGeoDataLoaderWKB.LoadMultiLineStringShape;
var
ShapeData: TShapeData;
i: Integer;
NumLineStrings: LongWord;
begin
ShapeData := TShapeData.CreateEmpty(stMultiPolyLine, FTags);
NumLineStrings := ReaderWKB.ReadLongWord;
for i := 0 to NumLineStrings - 1 do
begin
ReaderWKB.ReadEndiannessAndGeomety;
ReadAddFillPart(ShapeData);
end;
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKB.LoadMultiPointShape;
var
ShapeData: TShapeData;
begin
ShapeData := TShapeData.CreateEmpty(stMultiPoint, FTags);
ReadAddFillPart(ShapeData);
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKB.LoadMultiPoligonShape;
var
ShapeData: TShapeData;
i, iRing: Integer;
NumPolygons, NumRings: LongWord;
begin
ShapeData := TShapeData.CreateEmpty(stMultiPolygon, FTags);
NumPolygons := ReaderWKB.ReadLongWord;
for i := 0 to NumPolygons - 1 do
begin
ReaderWKB.ReadEndiannessAndGeomety;
NumRings := ReaderWKB.ReadLongWord;
for iRing := 0 to NumRings - 1 do
ReadAddFillPart(ShapeData);
end;
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKB.LoadPolygonShape;
var
ShapeData: TShapeData;
iRing: Integer;
NumRings: LongWord;
begin
ShapeData := TShapeData.CreateEmpty(stPolygon, FTags);
NumRings := ReaderWKB.ReadLongWord;
for iRing := 0 to NumRings - 1 do
ReadAddFillPart(ShapeData);
FShapes.AddShapeData(ShapeData);
end;
procedure TGeoDataLoaderWKB.LoadShapes;
const
wkbPoint = 1;
wkbLineString = 2;
wkbPolygon = 3;
wkbMultiPoint = 4;
wkbMultiLineString = 5;
wkbMultiPolygon = 6;
wkbGeometryCollection = 7;
begin
ReaderWKB.ReadEndiannessAndGeomety;
case ReaderWKB.FGeometry of
wkbPoint:
LoadPointShape;
wkbLineString:
LoadLineStringShape;
wkbPolygon:
LoadPolygonShape;
wkbMultiPoint:
LoadMultiPointShape;
wkbMultiLineString:
LoadMultiLineStringShape;
wkbMultiPolygon:
LoadMultiPoligonShape;
else
raise Exception.Create('Unknown Geometry: ' + IntToStr(ReaderWKB.FGeometry));
end;
end;
function TGeoDataLoaderWKB.ReaderWKB: TReaderWKB;
begin
Result := TReaderWKB(FReaderWKx);
end;
{ TReaderWKB }
constructor TReaderWKB.Create(Stream: TStream);
begin
FStream := Stream;
SetLength(FData, 0);
FStream.Position := 0;
// StreamToHex; { TODO : Debug HexString}
end;
function TReaderWKB.GetCount: Integer;
begin
Result := Length(FData);
end;
function TReaderWKB.ReadByte: Byte;
begin
FStream.ReadBuffer(Result, SizeOf(Result));
end;
function TReaderWKB.ReadDouble: Double;
begin
FStream.ReadBuffer(Result, SizeOf(Result));
if FBigEndian then
Result := SwapDouble(Result);
end;
procedure TReaderWKB.ReadDoublePointArray;
var
i: Integer;
NumPoints: LongWord;
begin
NumPoints := ReadLongWord;
SetLength(FData, NumPoints);
for i := 0 to NumPoints - 1 do
FData[i] := ReadDoublePoint;
end;
procedure TReaderWKB.ReadEndiannessAndGeomety;
begin
FBigEndian := ReadByte = 0;
FGeometry := ReadLongWord;
end;
function TReaderWKB.ReadLongWord: LongWord;
begin
FStream.ReadBuffer(Result, SizeOf(Result));
if FBigEndian then
Result := SwapLongWord(Result);
end;
procedure TReaderWKB.StreamToHex;
var
OldPosition: Int64;
begin
OldPosition := FStream.Position;
FHexString := '';
while not EndOfStream do
FHexString := FHexString + ToHex(ReadByte);
FStream.Position := OldPosition;
end;
function TReaderWKB.SwapDouble(Value: Double): Double;
const
Len = SizeOf(Double);
type
TSwap = packed record
case Boolean of
True: (Value: Double);
False: (Bytes: array[0..Len - 1] of Byte);
end;
var
BigE, LittleE: TSwap;
i: Integer;
begin
BigE.Value := Value;
for i := Len - 1 downto 0 do
LittleE.Bytes[i] := BigE.Bytes[Len - 1 - i];
Result := LittleE.Value;
end;
function TReaderWKB.SwapLongWord(Value: LongWord): LongWord;
const
Len = SizeOf(LongWord);
type
TSwap = packed record
case Boolean of
True: (Value: LongWord);
False: (Bytes: array[0..Len - 1] of Byte);
end;
var
BigE, LittleE: TSwap;
i: Integer;
begin
BigE.Value := Value;
for i := Len - 1 downto 0 do
LittleE.Bytes[i] := BigE.Bytes[Len - 1 - i];
Result := LittleE.Value;
end;
{ TReaderWKx }
destructor TReaderWKx.Destroy;
begin
SetLength(FData, 0);
inherited;
end;
function TReaderWKx.EndOfStream: Boolean;
begin
Result := FStream.Position >= FStream.Size;
end;
function TReaderWKx.GetData(Index: Integer): TDoublePoint;
begin
Result := FData[Index];
end;
function TReaderWKx.ReadDoublePoint: TDoublePoint;
begin
Result := DoublePoint(ReadDouble, ReadDouble);
end;
initialization
frxPropertyEditors.Register(TypeInfo(String), TfrxComponent, 'DataColumn', TfrxLabelColumnProperty);
frxPropertyEditors.Register(TypeInfo(String), TfrxComponent, 'BorderColorColumn', TfrxLabelColumnProperty);
frxPropertyEditors.Register(TypeInfo(String), TfrxComponent, 'FillColorColumn', TfrxLabelColumnProperty);
RegisterClasses([TfrxMapGeodataLayer]);
frxObjects.RegisterObject1(TfrxMapGeodataLayer, nil, '', '', 0, 74, [ctNone]);
end.