{**********************************************}
{   TeeMaps - ESRI ShapeFiles importer         }
{   Copyright (c) 2003-2020 by Steema Software }
{**********************************************}
unit TeeSHP;
{$I TeeDefs.inc}

interface

uses
  {$IFDEF FMX}
  FMXTee.Series.Map, FMXTee.Canvas, FMXTee.Procs, FMXTee.Engine,
  {$ELSE}
  TeeMapSeries, TeCanvas, TeeProcs, TeEngine,
  {$ENDIF}

  DB, Classes;

type
  TSHPHeader=packed record
    FileCode : Integer;
    Unused1  : Integer;
    Unused2  : Integer;
    Unused3  : Integer;
    Unused4  : Integer;
    Unused5  : Integer;
    FileLength : Integer;
    Version    : Integer;  // 1000
    ShapeType  : Integer;
    XMin       : Double;
    YMin       : Double;
    XMax       : Double;
    YMax       : Double;
    ZMin       : Double;
    ZMax       : Double;
    MMin       : Double;  // Measured
    MMax       : Double;
  end;

  TSHPRecordHeader=packed record
    RecordNumber : Integer;
    RecordLength : Integer;
  end;

const
  SHP_NULL       = 0;
  SHP_POINT      = 1;
  SHP_POLYLINE   = 3;
  SHP_POLYGON    = 5;
  SHP_MULTIPOINT = 8;
  SHP_POINTZ     = 11;
  SHP_POLYLINEZ  = 13;
  SHP_POLYGONZ   = 15;
  SHP_MULTIPOINTZ = 18;
  SHP_POINTM     = 21;
  SHP_POLYLINEM  = 23;
  SHP_POLYGONM   = 25;
  SHP_MULTIPOINTM = 28;
  SHP_MULTIPATCH = 31;

procedure LoadMap( const Series:TMapSeries; const FileName:String;
                   const ADataset:TDataSet=nil; const FieldName:String='';
                   const FieldValue:String='';
                   ClearSeries:Boolean=True;
                   const FieldSize:String=''); overload;

procedure LoadMap( const Series:TMapSeries; const ShpStream,ShxStream:TStream;
                   const ADataset:TDataSet=nil; const FieldName:String='';
                   const FieldValue:String='';
                   ClearSeries:Boolean=True;
                   const FieldSize:String=''); overload;

Const TeeSHPMaxRandom=1000000;

implementation

uses
  SysUtils;

type
  // Warning SHP data is in Double (8 bytes) format.
  // Not in Float (Single, 4 bytes)
  TDoublePoint=record
    X,Y: Double;
  end;

  TDoublePoints=Array of TDoublePoint;

// Add points "the fast way", setting the Value arrays directly
procedure SetPoints(const APolygon:TPolygonSeries; const APoints:TDoublePoints);

  procedure ResizeValueList(const AList:TChartValueList; const ACount:Integer);
  begin
    SetLength(AList.Value,ACount);
    AList.Count:=ACount;
  end;

var tmp,
    t : Integer;

    tmpX,
    tmpY : TChartValues;
begin
  tmp:=Length(APoints);

  ResizeValueList(APolygon.XValues,tmp);
  tmpX:=APolygon.XValues.Value;

  ResizeValueList(APolygon.YValues,tmp);
  tmpY:=APolygon.YValues.Value;

  for t:=0 to tmp-1 do
  begin
    tmpX[t]:=APoints[t].X;
    tmpY[t]:=APoints[t].Y;
  end;
end;

type
  TIntegerBytes=Array[0..3] of Byte;

  TTeePolygonAccess=class(TTeePolygon);

procedure LoadMap( const Series:TMapSeries; const ShpStream,ShxStream:TStream;
                   const ADataset:TDataSet=nil; const FieldName:String='';
                   const FieldValue:String='';
                   ClearSeries:Boolean=True;
                   const FieldSize:String=''); overload;

   function AddNewShape(out AIndex:Integer; const Closed:Boolean):TTeePolygon;
   begin
     AIndex:=Series.AddXY(0,0);
     result:=Series.Shapes[AIndex];
     result.Closed:=Closed;
   end;

  procedure SetZAndLabel(const AIndex:Integer; const Z:Double; const AText:String);
  begin
    Series.ZValues.Value[AIndex]:=Z;
    Series.Labels[AIndex]:=AText;
  end;
  
  Function BytesToStr(const Value:Integer):String;
  var B : TIntegerBytes;
  begin
    B:=TIntegerBytes(Value);
    result:=IntToStr(B[0])+' '+IntToStr(B[1])+' '+IntToStr(B[2])+' '+IntToStr(B[3]);
  end;

  procedure DoRaise(const Error:String);
  begin
    raise Exception.Create(Error);
  end;
  
  procedure VerifySignature(const Value:Integer);
  var B : TIntegerBytes;
  begin
    B:=TIntegerBytes(Value);

    if (B[0]<>0) or (B[1]<>0) or (B[2]<>$27) or
       ( (B[3]<>$0A) and (B[3]<>$0D) ) then
          DoRaise('Invalid shape file signature.');
  end;

  Function RecordCount(const SHPHeader:TSHPHeader):Integer;
  var B : TIntegerBytes;
  begin
    B:=TIntegerBytes(SHPHeader.FileLength);
    result:=B[3] + (B[2] * 256) + (B[1]*256*256) + (B[0]* 256 * 256 * 256);

    result:=Trunc((result*2 - 100)*0.125);  // (Malformed?) SHP files can return fraction counts

    //result:=(result*2 - 100) div 8;
  end;

  Function Reverse(const Value:Integer):Integer;
  var B : TIntegerBytes;
  begin
    B:=TIntegerBytes(Value);
    result:=(B[0]*256*256*256)+(B[1]*256*256)+(B[2]*256)+B[3];
  end;

  procedure ReadRecordHeader(const s:TStream; var Header:TSHPRecordHeader);
  begin
    s.ReadBuffer(Header,SizeOf(TSHPRecordHeader));

    Header.RecordNumber:=Reverse(Header.RecordNumber);
    Header.RecordLength:=Reverse(Header.RecordLength);
  end;

var
  tmpHasDataset : Boolean;

  tmpNameField : TField;
  tmpValueField : TField;
  tmpSizeField : TField;

  procedure GetTableFields(out Text:String; out Z,Size:Double);
  begin
    if Assigned(tmpNameField) then
       Text:=tmpNameField.AsString
    else
       Text:='';

    if Assigned(tmpValueField) then
       Z:=tmpValueField.AsFloat
    else
       Z:=Random(TeeSHPMaxRandom);

    if Assigned(tmpSizeField) then
       Size:=tmpSizeField.AsFloat
    else
       Size:=0;

    ADataset.Next;
  end;

  procedure SetFields(const AShape:TTeePolygon; const AIndex:Integer);
  var tmpText:String;
      tmpSize,
      tmpZ : Double;
  begin
    GetTableFields(tmpText,tmpZ,tmpSize);
    SetZAndLabel(AIndex,tmpZ,tmpText);
    AShape.Size:=tmpSize;
  end;

  procedure LoadShape(const AType:Integer);
  var po : Integer;

    function ReadPoints(const UpTo:Integer):TDoublePoints;
    var tmpCount  : Integer;
    begin
      tmpCount:=UpTo-po;

      SetLength(result,tmpCount);
      ShpStream.Read(result[0],tmpCount*SizeOf(TDoublePoint));

      po:=UpTo;
    end;

  const
      MaxNumParts = 10000;

  var NumParts,
      NumPoints: Integer;
      Parts : Array[0..MaxNumParts-1] of Integer;

    procedure RaiseMaxParts;
    begin
      DoRaise('Maximum number of parts exceeded: '+IntToStr(NumParts));
    end;

    procedure ReadBoxAndParts;
    var Box : Array[0..3] of Double;
    begin
      ShpStream.ReadBuffer(Box,SizeOf(Box));
      ShpStream.ReadBuffer(NumParts,SizeOf(NumParts));
      ShpStream.ReadBuffer(NumPoints,SizeOf(NumPoints));

      if NumParts>MaxNumParts then
         RaiseMaxParts;

      ShpStream.ReadBuffer(Parts,SizeOf(Integer)*NumParts);
    end;

    procedure ReadZPoints;
    var ZRange : Array[0..1] of Double;
        ZPoints: TDoubleArray;
    begin
      ShpStream.ReadBuffer(ZRange,SizeOf(ZRange));

      SetLength(ZPoints,NumPoints);
      ShpStream.Read(ZPoints[0],NumPoints*SizeOf(Double));
    end;

    procedure ReadPoly(const Closed:Boolean);
    var tmpText : String;
        tmpSize,
        tmpZ    : Double;
        p       : Integer;
        tmpIndex : Integer;

        tmpParent : TTeePolygon;
        tmpShape : TTeePolygon;
    begin
      ReadBoxAndParts;

      if tmpHasDataset then
         GetTableFields(tmpText,tmpZ,tmpSize);

      po:=0;

      tmpParent:=nil;

      for p:=1 to NumParts do
      begin
        tmpShape:=AddNewShape(tmpIndex,Closed);

        if p=1 then
           tmpParent:=tmpShape
        else
           TTeePolygonAccess(tmpShape).ParentShape:=tmpParent;

        if tmpHasDataset then
           SetZAndLabel(tmpIndex,tmpZ,tmpText);

        if p=NumParts then
           SetPoints(tmpShape.Points,ReadPoints(NumPoints))
        else
           SetPoints(tmpShape.Points,ReadPoints(Parts[p]));
      end;
    end;

    procedure RaiseInvalidType(const AType:Integer);
    begin
      DoRaise('Invalid ShapeType '+IntToStr(AType));
    end;

    procedure ReadPoint;
    var tmpIndex : Integer;
        tmpShape : TTeePolygon;
    begin
      tmpShape:=AddNewShape(tmpIndex,True);

      if tmpHasDataset then
         SetFields(tmpShape,tmpIndex);

      po:=0;
      SetPoints(tmpShape.Points,ReadPoints(1));
    end;

  begin
    case AType of
      SHP_NULL: ;
      SHP_POINT: ReadPoint;

      SHP_POLYLINE,
      SHP_POLYGON: ReadPoly(AType=SHP_POLYGON);

      SHP_POLYLINEZ,
      SHP_POLYGONZ:
       begin
         ReadPoly(AType=SHP_POLYGONZ);
         ReadZPoints;
       end;

      SHP_POLYLINEM,
      SHP_POLYGONM:
       begin
         ReadPoly(AType=SHP_POLYGONM);
         ReadZPoints;
         ReadZPoints; // Again
       end;

    else
      RaiseInvalidType(AType);
    end;
  end;

  procedure GetDatasetFields;
  begin
    tmpNameField:=nil;
    tmpValueField:=nil;
    tmpSizeField:=nil;

    tmpHasDataset:=Assigned(ADataset) and ADataset.Active;

    if tmpHasDataset then
    begin
      if FieldName<>'' then
         tmpNameField:=ADataset.FieldByName(FieldName);

      if FieldValue<>'' then
         tmpValueField:=ADataset.FieldByName(FieldValue);

      if FieldSize<>'' then
         tmpSizeField:=ADataset.FieldByName(FieldSize);
    end;
  end;

  procedure ReadAllRecords(const ACount:Integer);
  var t : Integer;
      SHPRecordHeader : TSHPRecordHeader;
      tmpType : Integer;
  begin
    for t:=1 to ACount do
    begin
      ReadRecordHeader(ShxStream,SHPRecordHeader);

      ShpStream.Position:=2*SHPRecordHeader.RecordNumber;
      ReadRecordHeader(ShpStream,SHPRecordHeader);

      ShpStream.Read(tmpType,SizeOf(tmpType));
      LoadShape(tmpType);
    end;
  end;

  function ReadHeader:Integer;
  var SHPHeader : TSHPHeader;
  begin
    ShpStream.ReadBuffer(SHPHeader,SizeOf(TSHPHeader));
    VerifySignature(SHPHeader.FileCode);

    ShxStream.ReadBuffer(SHPHeader,SizeOf(TSHPHeader));
    VerifySignature(SHPHeader.FileCode);

    result:=RecordCount(SHPHeader);
  end;

var NumRecords : Integer;
    Old : Boolean;
begin
  if not Assigned(ShpStream) then
     DoRaise('Cannot load map: ShapeFile Stream is nil');

  if not Assigned(ShxStream) then
     DoRaise('Cannot load map: Index ShapeFile Stream is nil');

  ShpStream.Position:=0;

  NumRecords:=ReadHeader;

  GetDatasetFields;

  if ClearSeries then
     Series.Clear;

  Series.BeginUpdate;

  if Assigned(Series.ParentChart) then
  begin
    Old:=Series.ParentChart.AutoRepaint;
    Series.ParentChart.AutoRepaint:=False;
  end
  else
    Old:=True;

  ReadAllRecords(NumRecords);

  Series.EndUpdate;

  if Assigned(Series.ParentChart) then
     Series.ParentChart.AutoRepaint:=Old;
end;

procedure LoadMap(const Series:TMapSeries; const FileName:String;
                  const ADataset:TDataSet=nil; const FieldName:String='';
                  const FieldValue:String='';
                  ClearSeries:Boolean=True;
                  const FieldSize:String='');
var fx: TFileStream;
    f : TFileStream;
    tmpName : String;
begin
  tmpName:=FileName;

  if ExtractFileExt(tmpName)='' then
     tmpName:=tmpName+'.shp';

  f:=TFileStream.Create(tmpName,fmOpenRead);
  try
    tmpName:=ChangeFileExt(FileName,'.shx');

    fx:=TFileStream.Create(tmpName,fmOpenRead);
    try
      LoadMap(Series,f,fx,ADataset,FieldName,FieldValue,ClearSeries,FieldSize);
    finally
      fx.Free;
    end;
  finally
    f.Free;
  end;
end;

end.
