{************************************************************}
{                   Delphi VCL Extensions                    }
{                                                            }
{                    Export CAD to PDF                       }
{                                                            }
{      Copyright (c) 2002-2013 SoftGold software company     }
{                                                            }
{************************************************************}
unit CADtoPDF;
{$INCLUDE SGDXF.INC}

interface

uses Windows, SysUtils, Classes, Graphics, CADExport, CADImage, DXFConv, SGBitmap, MVFont,
  sgConsts, sgFunction
{$IFDEF SGDEL_XE2}
  , System.Types
{$ENDIF}
  ;

type
  TASCII85 = class
  private
    FContainer: TStrings;
    FValue: string;
    FBuf: Integer;
    FCount: Byte;
  public
    procedure PutByte(Value: Byte);
    procedure PutChar(Value: Byte);
    procedure Flush;
    procedure Complete;
  end;

  TpdfStream = class(TMemoryStream)
  public
    procedure SetSize(NewSize: LongInt); override;
  end;

  TpdfStrings = class(TStringList)
  protected
    FStream: TpdfStream;
    FStreamIndex: Integer;
    procedure BeginStream;
    procedure EndStream;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SaveToStream(Stream: TStream); override;
    function Add(const S: String): Integer; override;
    procedure AddStringsArray(const AStrings: array of string);
    procedure AddXref(const ABlockLast: TpdfStrings; var Len, Cnt: Integer);
  end;

  TFlate = class
  private
    FContainer: TpdfStrings;
    FIndex: Integer;
  public
    procedure PutByte(Value: Byte);
    procedure PutChar(Value: Byte);
  end;

  TsgPDFExport = class(TsgSimpleExport)
  private
    FData: TpdfStrings;
    FResources: TpdfStrings;
    FImages: TpdfStrings;
    FImgNum: Integer;
    FCompressor: TFlate;
    FQuality: Double;
    FPageWidth: Double;
    FPageHeight: Double;
    FUserWidth: Double;
    FUserHeight: Double;
    FMargins: TF2DRect;
    FTmpLW: Double;
    FAuthor: string;
    FProducer: string;
    FCreator: string;
    FTitle: string;
    FSubject: string;
    FKeywords: string;
    FNotPages: Boolean;
    function GetLayoutsCount: Integer;
    procedure PolyPoints(const Points; const ACount: Integer);
    procedure ProcRgn(P: PRect; Count: Integer);
    procedure DoSetColor(AColor: TColor; const S: string);
    procedure PutRGBs(Ptr: Pointer; Count,Delta: Integer);
    procedure PutBytes(Ptr: Pointer; Count: Integer);
    procedure PutWords(Ptr: Pointer; Count,Sh: Integer);
    procedure PutPalette(Ptr: Pointer; Count: Integer);
    procedure ResetLW;
    procedure SetQuality(const Value: Double);
    procedure SetMargin(const Value: Double);
    procedure SetAuthor(const Value: string);
    procedure SetCreator(const Value: string);
    procedure SetProducer(const Value: string);
    procedure SetTitle(const Value: string);
    procedure SetSubject(const Value: string);
    procedure SetKeywords(const Value: string);
    procedure SetMargins(const Value: TF2DRect);
  protected
    procedure CorrectQuality;
    function GetExportRect: TRect; override;
    function GetMmToPixelX: Double; override;
    procedure ExpPolyline(const Points; Count: Integer); override;
    procedure ExpPolygon(const Points; Count: Integer); override;
    procedure ExpPolyPolyline(const Points; const Counts; Count: Integer); override;
    procedure ExpPolyPolygon(const Points; const Counts; Count: Integer); override;
    procedure ExpFillRgn(P: PRect; Count: Integer); override;
    procedure ExpClipRgn(P: PRect; Count: Integer); override;
    procedure ExpSaveDC; override;
    procedure ExpRestoreDC; override;
    procedure ExpImage(const R: TRect; AImage: TGraphic); override;
    procedure ExpImageUV(const APoint1, APoint2, APoint3,  APoint4: TPoint;
      AImage: TGraphic); override;
    procedure PageStart(N: Integer); override;
    procedure PageEnd(N: Integer); override;
    procedure SetStrokeColor(AColor: TColor); override;
    procedure SetFillColor(AColor: TColor); override;
    procedure ExpCloseFigure; override;
    function Flipping: Boolean; override;
    procedure SaveToStreamCustom(S: TStream); override;
  public
    constructor Create(ACADImage: TsgCADImage); override;
    destructor Destroy; override;
    procedure ApplyParams(const AExportParams: TsgExportParams); override;
    property Title: string read FTitle write SetTitle;
    property Author: string read FAuthor write SetAuthor;
    property Creator: string read FCreator write SetCreator;
    property Producer: string read FProducer write SetProducer;
    property Subject: string read FSubject write SetSubject;
    property Keywords: string read FKeywords write SetKeywords;
    property LayoutsCount: Integer read GetLayoutsCount;
    property PageWidth: Double read FPageWidth;
    property PageHeight: Double read FPageHeight;
    property UserWidth: Double read FUserWidth write FUserWidth;
    property UserHeight: Double read FUserHeight write FUserHeight;
    property Quality: Double read FQuality write SetQuality;
    property Margins: TF2DRect read FMargins write SetMargins;
  end;

implementation

uses SGZip, math;

const
  MMPerInch = 25.4;
  MMPerPDFUnit = MMPerInch / 72; // 0,35277777777777777777777777777778
  cnstDefaultPDFPageWidth = 210.0;
  cnstDefaultPDFPageHeight = 297.0;
  cnstMinRectSize = 3000;
  cnstDroppingSize = 8 * 1024 * 1024;

const

  cnstSG = 'SoftGold';
  cnstSGPDFExporter = cnstCompanyCST;
  cnstStartCount = 4;

  PDFHead: array[0..9] of String =
  ( '%PDF-1.4',
    '1 0 obj',
    '<< /Type /Catalog',
    '/ViewerPreferences << /PrintScaling /None >>',
    '/Pages 2 0 R',
    '>>',
    'endobj',
    '2 0 obj',
    '<< /Type /Pages',
    '/Kids');

  PDFFoot: array[0..6] of String =
  ( 'trailer',
    '',
    '/Root 1 0 R',
    '/Info 3 0 R',
    '>>',
    'startxref',
    '');

{$IFDEF SG_CPUX64}
  sBinToHex: AnsiString = '0123456789ABCDEF';
{$ENDIF}
function HexDigit(Value: Byte): AnsiChar;
asm
{$IFDEF SG_CPUX64}
        AND     rcx,$F
        ADD     rcx,sBinToHex
        MOV     al,byte ptr [rcx]
{$ELSE}
        AND     AL,$F
        ADD     AL,$90
        DAA
        ADC     AL,$40
        DAA
{$ENDIF}
end;

procedure DivMod(Dividend, Divisor: Integer; var Result, Remainder: Integer);
asm
{$IFDEF SG_CPUX64}
        MOV     EAX,ECX
        MOV     ECX,EDX
        XOR     EDX,EDX
        DIV     ECX
        MOV     [Result],EAX
        MOV     [Remainder],EDX
{$ELSE}

        PUSH    EBX
        MOV     EBX,EDX
        XOR     EDX,EDX
        DIV     EBX
        MOV     EBX,Remainder
        MOV     [ECX],EAX
        MOV     [EBX],EDX
        POP     EBX
{$ENDIF}
end;

procedure PutByte(var S: string; Value: Byte);
begin
  S := S + Char(HexDigit(Value shr 4));
  S := S + Char(HexDigit(Value));
end;

procedure PutRGB(var S: string; P: PByte);
begin
  Inc(P,2); PutByte(S, P^);
  Dec(P); PutByte(S, P^);
  Dec(P); PutByte(S, P^);
end;

{ TpdfStream }

procedure TpdfStream.SetSize(NewSize: LongInt);
begin
  if Capacity < NewSize then Capacity := NewSize;
  SetPointer(Memory,NewSize);
  Seek(NewSize,0);
end;

{ TpdfStrings }

constructor TpdfStrings.Create;
begin
  inherited Create;
  FStream := TpdfStream.Create;
end;

destructor TpdfStrings.Destroy;
begin
  FStream.Free;
  inherited Destroy;
end;

function TpdfStrings.Add(const S: string): Integer;
var
  Sz: Integer;
  P: PAnsiChar;
  vAnsi: AnsiString;
begin
  if FStreamIndex = 0 then
    Result := inherited Add(S)
  else
  begin
{$IFDEF SGDEL_2009}
    vAnsi := AnsiString(S);
{$ELSE}
    vAnsi := S;
{$ENDIF}
    Sz := FStream.Size + Length(vAnsi) + 2;
    while FStream.Capacity < Sz do
      FStream.Capacity := FStream.Capacity + FStream.Capacity shr 2 + Sz;
    P := PAnsiChar(FStream.Memory);
    Inc(P, FStream.Size);
    System.Move(PAnsiChar(vAnsi)^, P^, Length(vAnsi));
    Inc(P, Length(vAnsi));
    P^ := #13;
    Inc(P);
    P^ := #10;
    FStream.Size := FStream.Size + Length(vAnsi) + 2;
    Result := Count;
  end;
end;

procedure TpdfStrings.AddStringsArray(const AStrings: array of string);
var
  I: Integer;
begin
  for I := Low(AStrings) to High(AStrings) do
    Add(AStrings[I]);
end;

procedure TpdfStrings.AddXref(const ABlockLast: TpdfStrings; var Len, Cnt: Integer);
var
  I,L: Integer;
  S: string;
begin
  for I := 0 to Count-1 do
  begin
    if Objects[I] = nil then
    begin
      S := Strings[I];
      if S = 'xref' then Exit;
      L := Length(S);
      if (L > 6) and (Copy(S,L-5,6) = ' 0 obj') then
      begin
        ABlockLast.Add(Format('%.10d 00000 n', [Len]));
        Inc(Cnt);
      end;
    end
    else
      L := Integer(Objects[I]);
    Inc(Len, L + 2);
  end;
end;

procedure TpdfStrings.BeginStream;
begin
  FStreamIndex := Count;
  inherited Add('');
  inherited Add('>>');
  inherited Add('stream');
  FStream.Size := 0;
end;

procedure TpdfStrings.EndStream;
var
  S: AnsiString;
  W: string;
begin
  Compress(FStream);
  SetString(S, PAnsiChar(FStream.Memory), FStream.Size);
  SetLength(W, FStream.Size div SizeOf(Char) + 1);
  CopyMemory(@W[1], @S[1], Length(S));
  inherited AddObject(W, Pointer(FStream.Size));
  Strings[FStreamIndex] := '/Filter /FlateDecode /Length ' + IntToStr(Length(S));
  FStreamIndex := 0;
  Add('endstream');
  Add('endobj');
end;

procedure TpdfStrings.SaveToStream(Stream: TStream);
var
  I, J: Integer;
  vStr: string;
  vRaw, vBuffer: sgRawByteString;
begin
  //inherited;
  vBuffer := '';
  for I := 0 to Count - 1 do
  begin
    vStr := Strings[I];
    if Objects[I] = nil then
    begin
      SetLength(vRaw, Length(vStr));
      for J := 1 to Length(vStr) do
        vRaw[J] := AnsiChar(vStr[J]);
    end
    else
    begin
      SetLength(vRaw, Integer(Objects[I]));
      CopyMemory(@vRaw[1], @vStr[1], Length(vRaw));
    end;
    vBuffer := vBuffer + vRaw + AnsiString(sLineBreak);
    if Length(vBuffer) > cnstDroppingSize then
    begin
      Stream.Write(PByte(@vBuffer[1])^, Length(vBuffer));
      vBuffer := '';
    end;
  end;
  if Length(vBuffer) > 0 then
    Stream.Write(PByte(@vBuffer[1])^, Length(vBuffer));
end;

{ TASCII85 }

procedure TASCII85.PutByte(Value: Byte);
begin
  FBuf := FBuf shl 8 or Value;
  Inc(FCount,8);
  if FCount >= 32 then Flush;
end;

procedure TASCII85.PutChar(Value: Byte);
begin
  FBuf := FBuf shl 4 or Value and $F;
  Inc(FCount,4);
  if FCount >= 32 then Flush;
end;

procedure TASCII85.Flush;
var
  I,AMod: Integer;
  Data: array[0..5] of Char;
begin
  if FCount = 0 then Exit;
  if FCount > 32 then raise EIntOverflow.Create('ACSII85 overflow');
  if (FCount=32) and (FBuf=0) then FValue := FValue + 'z'
  else begin
    if FCount < 32 then FBuf := FBuf shl (32 - FCount);
    FCount := (FCount + 15) shr 3;
    for I := 4 downto 0 do begin
      DivMod(FBuf,85,FBuf,AMod);
      Data[I] := Chr(AMod + $21);
    end;
    Data[FCount] := #0;
    FValue := FValue + Data;
  end;
  FBuf := 0; FCount := 0;
  if (FContainer <> nil) and (Length(FValue) > 1000) then begin
    FContainer.Add(FValue);
    FValue := '';
  end;
end;

procedure TASCII85.Complete;
begin
  Flush;
  FValue := FValue + '~>';
  if FContainer <> nil then begin
    FContainer.Add(FValue);
    FValue := '';
  end;
end;

{ TFlate }

procedure TFlate.PutByte(Value: Byte);
var P: PByte;
begin
  P := PByte(TpdfStrings(FContainer).FStream.Memory);
  Inc(P, FIndex shr 1);
  P^ := Value;
  Inc(FIndex,2);
end;

procedure TFlate.PutChar(Value: Byte);
var P: PByte;
begin
  P := PByte(TpdfStrings(FContainer).FStream.Memory);
  Inc(P, FIndex shr 1);
  if FIndex and 1 = 0 then
    Value := Value shl 4
  else
    Value := Value and $0F or P^;
  P^ := Value;
  Inc(FIndex);
end;

{ TsgPDFExport }

procedure TsgPDFExport.ApplyParams(const AExportParams: TsgExportParams);
begin
  inherited ApplyParams(AExportParams);
  FUserWidth := AExportParams.PageWidth;
  FUserHeight := AExportParams.PageHeight;
  SetMargin(AExportParams.Margin);
  Quality := AExportParams.Quality;
  Title := AExportParams.Title;
  Author := AExportParams.Author;
  Subject := AExportParams.Subjct;
  Keywords := AExportParams.Keywords;
  UsePlotSetting := AExportParams.UseExtentsFromPlotSettings;
  CorrectQuality;
//  Creator := GetProgNameAndVer(True);
//  Producer := 'Soft Gold';
end;

constructor TsgPDFExport.Create(ACADImage: TsgCADImage);
begin
  inherited Create(ACADImage);
  FNotPages := True;
  FData := TpdfStrings.Create;
  FResources := TpdfStrings.Create;
  FImages := TpdfStrings.Create;
  FCompressor := TFlate.Create;
  FCompressor.FContainer := FImages;
  LayoutExportMode := lemAllPaperSpaces;
  FQuality := DefExportParams.Quality; // Quality
  FUserWidth := cnstDefaultPDFPageWidth;
  FUserHeight := cnstDefaultPDFPageHeight;
  FPageWidth := cnstDefaultPDFPageWidth;   // mm
  FPageHeight := cnstDefaultPDFPageHeight; // mm

  SetMargin(DefExportParams.Margin);   // mm
  FTitle := 'Layout';
  FAuthor := cnstSG;
  FCreator := cnstSGPDFExporter;
  FProducer := cnstSGPDFExporter;
end;

destructor TsgPDFExport.Destroy;
begin
  FCompressor.Free;
  FData.Free;
  FResources.Free;
  FImages.Free;
  inherited Destroy;
end;

procedure TsgPDFExport.CorrectQuality;
var
  vMargins: TF2DRect;
  vHeight,vWidth,vPageSize: Double;
  vMax: Integer;
  vExportRect: TRect;
begin
  vMargins := Margins;
  vWidth := FPageWidth - Abs(vMargins.Left + vMargins.Right);
  vHeight := FPageHeight - Abs(vMargins.Top + vMargins.Bottom);
  vPageSize := Max(vWidth, vHeight);
  XSize := Round(vPageSize / FQuality);
  vExportRect := inherited GetExportRect;
  vMax := Max(vExportRect.Right - vExportRect.Left,
    vExportRect.Bottom - vExportRect.Top);
  if vMax < cnstMinRectSize then
    FQuality := FQuality * vMax / cnstMinRectSize;
end;

function TsgPDFExport.GetExportRect: TRect;
var
  vExtentsRatio: Double;
  vExtents: TFRect;
  vMargins: TF2DRect;

  function DoPageCentered(const ARect: TRect): TRect;
  var
    W, H: Integer;
    vCenter: TPoint;
    vPageCenter: TPoint;
  begin
    Result := ARect;
    W := Result.Right - Result.Left;
    H := Result.Bottom - Result.Top;
    vPageCenter.X := Round(FPageWidth / MMPerPDFUnit / FQuality / 2);
    vPageCenter.Y := Round(FPageHeight / MMPerPDFUnit / FQuality / 2);
    vCenter.X := Round((Result.Right + Result.Left) / 2);
    vCenter.Y := Round((Result.Bottom + Result.Top) / 2);
    Result.Left := vPageCenter.X - vCenter.X;
    Result.Top := vPageCenter.Y - vCenter.Y;
    Result.Right := Result.Left + W;
    Result.Bottom := Result.Top + H;
  end;

  function DoRectByPageSize(const APageSize: Double): TRect;
  begin
    XSize := Round(APageSize / FQuality);
    Result := inherited GetExportRect;
  end;

begin
  XScale := 1 / MMPerPDFUnit;
  vMargins := Margins;
  if HasClippingRect then
    vExtents := ClippingRect
  else
  begin
    vExtents := Extents;
    if CADImage.UsePlotSetting then
      vMargins := MakeF2DRect(0, 0, 0, 0)
  end;
  vExtentsRatio := vExtents.Bottom - vExtents.Top;
  if vExtentsRatio <> 0 then
    vExtentsRatio := (vExtents.Right - vExtents.Left) /
      Abs(vExtentsRatio)
  else vExtentsRatio := 1.0;
  if (FPageWidth / vExtentsRatio) < (FPageHeight * vExtentsRatio) then
  begin
    Result := DoRectByPageSize(FPageWidth - Abs(vMargins.Left + vMargins.Right));
    if (Result.Bottom - Result.Top) * FQuality * MMPerPDFUnit > FPageHeight then
      Result := DoRectByPageSize(FPageHeight - Abs(vMargins.Top + vMargins.Bottom));
  end
  else
  begin
    Result := DoRectByPageSize(FPageHeight - Abs(vMargins.Top + vMargins.Bottom));
    if (Result.Right - Result.Left) * FQuality * MMPerPDFUnit > FPageWidth then
      Result := DoRectByPageSize(FPageWidth - Abs(vMargins.Left + vMargins.Right));
  end;
  if not CADImage.UsePlotSetting then
    Result := DoPageCentered(Result);
  FData.Insert(FData.Count - 9, Format('/MediaBox [0 0 %f %f]',
    [FPageWidth / MMPerPDFUnit, FPageHeight  / MMPerPDFUnit]));
  Inc(TpdfStrings(FData).FStreamIndex);
end;

function TsgPDFExport.GetLayoutsCount: Integer;
begin
  Result := LayoutsExportCount;
end;

function TsgPDFExport.GetMmToPixelX: Double;
begin
  Result := MMPerPDFUnit;
end;

procedure TsgPDFExport.PolyPoints(const Points; const ACount: Integer);
var
  vCnt: Integer;
  PrevPt: TPoint;
  P: PPoint;
  S: Char;
  vTmpLW: Double;
begin

  vTmpLW := PenWidth;

  if FTmpLW <> vTmpLW then
  begin
    FData.Add(Format('%f w', [vTmpLW]));
    FTmpLW := vTmpLW;
  end;

  P := @Points;
  PrevPt := Point(MaxInt, MaxInt);
  S := 'm';
  vCnt := ACount;
  while vCnt > 0 do
  begin
    if (P^.X <> PrevPt.X) or (P^.Y <> PrevPt.Y) or (ACount <= 2) then
    begin
      FData.Add(Format('%f %f %s', [FQuality * P^.X, FQuality * P^.Y, S]));
      PrevPt := P^;
    end;
    Inc(P);
    S := 'l';
    Dec(vCnt);
  end;
end;

procedure TsgPDFExport.ExpPolyline(const Points; Count: Integer);
begin
  PolyPoints(Points,Count);
  FData.Add('S');
  ResetLW;
end;

procedure TsgPDFExport.ExpPolygon(const Points; Count: Integer);
begin
  PolyPoints(Points,Count);
  FData.Add('f');
  FData.Add('s');
  ResetLW;
end;

procedure TsgPDFExport.ExpPolyPolyline(const Points; const Counts; Count: Integer);
var
  PP,PC: PInteger;
  C: Integer;
begin
  PP := @Points;
  PC := @Counts;
  while Count > 0 do begin
    C := PC^; Inc(PC);
    ExpPolyline(PP^,C);
    Inc(PP, C*2);
    Dec(Count);
  end;
end;

procedure TsgPDFExport.ExpPolyPolygon(const Points; const Counts; Count: Integer);
var
  PP,PC: PInteger;
  C: Integer;
begin
  PP := @Points;
  PC := @Counts;
  while Count > 0 do begin
    C := PC^; Inc(PC);
    PolyPoints(PP^,C);
    FData.Add('h');
    Inc(PP, C*2);
    Dec(Count);
  end;
  FData.Add('f*');
  ResetLW;
end;

procedure TsgPDFExport.ProcRgn(P: PRect; Count: Integer);
begin
  while Count > 0 do begin
    FData.Add(Format('%f %f %f %f re',
                    [FQuality*P.Left, FQuality*P.Top, FQuality*(P.Right-P.Left), FQuality*(P.Bottom-P.Top)]));
    Inc(P);
    Dec(Count);
  end;
end;

procedure TsgPDFExport.ExpFillRgn(P: PRect; Count: Integer);
begin
  ProcRgn(P,Count);
  FData.Add('f');
end;

procedure TsgPDFExport.ExpClipRgn(P: PRect; Count: Integer);
begin
  ProcRgn(P,Count);
  FData.Add('W n');
end;

procedure TsgPDFExport.ExpSaveDC;
begin
  FData.Add('q');
end;

function TsgPDFExport.Flipping: Boolean;
begin
  Result := True;
end;

procedure TsgPDFExport.ExpRestoreDC;
begin
  FData.Add('Q');
end;

procedure TsgPDFExport.DoSetColor(AColor: TColor; const S: string);
var
  R,G,B: Integer;
begin
  B := AColor shr 16 and $FF;
  G := AColor shr 8 and $FF;
  R := AColor and $FF;
  FData.Add(Format('%f %f %f %s', [R/255, G/255, B/255, S]));
end;

procedure TsgPDFExport.SetStrokeColor(AColor: TColor);
begin
  DoSetColor(AColor, 'RG');
end;

procedure TsgPDFExport.SetSubject(const Value: string);
begin
  FSubject := Value;
end;

procedure TsgPDFExport.SetAuthor(const Value: string);
begin
  FAuthor := Value;
end;

procedure TsgPDFExport.SetCreator(const Value: string);
begin
  FCreator := Value;
end;

procedure TsgPDFExport.SetTitle(const Value: string);
begin
  FTitle := Value;
end;

procedure TsgPDFExport.SetFillColor(AColor: TColor);
begin
  DoSetColor(AColor, 'rg');
end;

procedure TsgPDFExport.SetKeywords(const Value: string);
begin
  FKeywords := Value;
end;

procedure TsgPDFExport.SetMargin(const Value: Double);
begin
  FMargins.Left := Value;
  FMargins.Right := Value;
  FMargins.Top := Value;
  FMargins.Bottom := Value;
end;

procedure TsgPDFExport.SetMargins(const Value: TF2DRect);
begin
  FMargins := Value;
end;

procedure TsgPDFExport.SetProducer(const Value: string);
begin
  FProducer := Value;
end;

procedure TsgPDFExport.SetQuality(const Value: Double);
begin
  FQuality := Value;
end;

procedure TsgPDFExport.ResetLW;
begin
  if FTmpLW > 0 then
  begin
    FData.Add('0 w');
    FTmpLW := 0;
  end;
end;

procedure TsgPDFExport.ExpCloseFigure;
begin
  with TpdfStrings(FData).FStream do Size := Size-3;
  FData.Add('h');
  FData.Add('S');
end;

procedure TsgPDFExport.PutRGBs(Ptr: Pointer; Count,Delta: Integer);
var P: PByte absolute Ptr;
begin
  while Count > 0 do begin
    Inc(P,2);
    FCompressor.PutByte(P^);
    Dec(P);
    FCompressor.PutByte(P^);
    Dec(P);
    FCompressor.PutByte(P^);
    Inc(P,Delta);
    Dec(Count);
  end;
end;

procedure TsgPDFExport.PutBytes(Ptr: Pointer; Count: Integer);
var P: PByte absolute Ptr;
begin
  while Count > 0 do begin
    FCompressor.PutByte(P^);
    Inc(P);
    Dec(Count);
  end;
end;

procedure TsgPDFExport.PutWords(Ptr: Pointer; Count,Sh: Integer);
var
  P: PWord absolute Ptr;
  Fill: Boolean;
begin
  Fill := Count and 1 <> 0;
  while Count > 0 do begin
    FCompressor.PutChar(P^ shr (Sh+5));
    FCompressor.PutChar(P^ shr Sh);
    FCompressor.PutChar(P^ shr 1);
    Inc(P);
    Dec(Count);
  end;
  if Fill then FCompressor.PutChar(0);
end;

procedure TsgPDFExport.PutPalette(Ptr: Pointer; Count: Integer);
var
  P: PByte absolute Ptr;
  S: string;
  Mask: Byte;
begin
  FImages.Add('/ColorSpace [/Indexed /DeviceRGB ' + IntToStr(Count-1));
  if Count > 16 then Mask := 15 else Mask := 3;
  S := '<';
  while Count > 0 do
  begin
    if Count and Mask = 0 then
    begin
      FImages.Add(S);
      S := '';
    end;
    S := S + ' ';
    PutRGB(S,P);
    Inc(P,4);
    Dec(Count);
  end;
  FImages.Add(S);
  FImages.Add('>]');
end;

procedure TsgPDFExport.ExpImageUV(const APoint1, APoint2, APoint3,  APoint4: TPoint;
  AImage: TGraphic);
const
  BPCs: array[TPixelFormat] of Byte = (0,1,4,8,4,4,8,8,0);
var
  I,W: Integer;
  P: Pointer;
  S: string;
  BM: TsgBMAdapter;
  Pal: array[Byte] of Integer;
  vDX, vDY: TPoint;
  vMatrix: TFMatrix;
begin
  if (AImage.Width < 6) or (AImage.Height < 6) then
    Exit;
  if IsGreatImage(AImage) then
    Exit;

  vDX := SubPoint(APoint4, APoint1);
  vDY := SubPoint(APoint2, APoint1);
  if (vDX.X = vDX.Y) or (vDY.X = vDY.Y) then
    vMatrix := cnstIdentityMat
  else
    vMatrix := FMat2DByImage(MakeFPointFromPoint(APoint1),
      MakeFPointFromPoint(vDX), MakeFPointFromPoint(vDY), 1, 1);
  BM := TsgBMAdapter.Create;
  try
    BM.Assign(AImage);
    BM.HandleType := bmDIB;
    I := BPCs[BM.PixelFormat];
    if I=0 then Exit;
    if (BM.Width < 1000) and (BM.Height < 1000)
    then BM.ROP := SRCCOPY;	// if ???
    S := IntToStr(LayoutsCount*2 +  cnstStartCount+ 1 + FImgNum);
    FResources.Add(Format(' /Im%s %s 0 R', [S,S]));
    FImages.Add(Format('%s 0 obj', [S]));
    FImages.Add(Format('<< /Type /XObject /Subtype /Image /Width %d /Height %d', [BM.Width, BM.Height]));
    FImages.Add(Format('/BitsPerComponent %d', [I]));
    if BM.PixelFormat > pf8bit then I := I*3;
    TpdfStrings(FImages).FStream.Capacity := BM.Height * (I*BM.Width shr 3 + 1);
    FCompressor.FIndex := 0;
    I := BM.GetColorTable(@Pal);
    if I > 0 then PutPalette(@Pal, I)
    else FImages.Add('/ColorSpace /DeviceRGB');
    TpdfStrings(FImages).BeginStream;
    W := BM.Width;
    for I:=0 to BM.Height-1 do begin
      P := BM.ScanLine[I];
      case BM.PixelFormat of
        pf1bit:         PutBytes(P, (W+7) shr 3);
        pf4bit:         PutBytes(P, (W+1) shr 1);
        pf8bit:         PutBytes(P,W);
        pf15bit:        PutWords(P,W,6);
        pf16bit:        PutWords(P,W,7);
        pf24bit:        PutRGBs(P,W,3);
        pf32bit:        PutRGBs(P,W,4);
      end;
    end;
    TpdfStrings(FImages).FStream.Size := (FCompressor.FIndex + 1) shr 1;
    TpdfStrings(FImages).EndStream;
    FData.Add('q');
    FData.Add(Format('%f %f %f %f %f %f cm',
                    [FQuality * vMatrix.V1[0], FQuality * vMatrix.V1[1],
                     FQuality * vMatrix.V2[0], FQuality * vMatrix.V2[1],
                     FQuality * vMatrix.V4[0], FQuality * vMatrix.V4[1]]));
    FData.Add(Format('/Im%s Do', [S]));
    FData.Add('Q');
    Inc(FImgNum);
  finally
    BM.Free;
  end;
end;

procedure TsgPDFExport.ExpImage(const R: TRect; AImage: TGraphic);
begin
  ExpImageUV(R.TopLeft, Point(R.Right,R.Top),R.BottomRight,
    Point(R.Left,R.Bottom), AImage);
end;

procedure TsgPDFExport.PageStart(N: Integer);
var
  R: TRect;
  vLayout: TsgDXFLayout;
begin
  FNotPages := False;
  vLayout := CADImage.CurrentLayout;
  if UsePlotSetting and vLayout.UsingPlotSettings then
  begin
    if (vLayout.PlotSettings.PlotRotation = pr90DegreesCounterCW) or
       (vLayout.PlotSettings.PlotRotation = pr90DegreesCW) then
    begin
      FPageWidth := vLayout.PlotSettings.PlotPaperSize.Y;
      FPageHeight := vLayout.PlotSettings.PlotPaperSize.X;
    end
    else
    begin
      FPageWidth := vLayout.PlotSettings.PlotPaperSize.X;
      FPageHeight := vLayout.PlotSettings.PlotPaperSize.Y;
    end;
  end
  else
  begin
    FPageWidth := FUserWidth;
    FPageHeight := FUserHeight;
  end;
  N := N shl 1 + cnstStartCount;
  FData.Add(Format('%d 0 obj', [N]));
  FData.Add('<< /Type /Page');
  FData.Add(Format('/Parent %d 0 R', [cnstStartCount - 2]));
  FData.Add(Format('/Contents %d 0 R', [N+1]));
  FData.Add(Format('/Resources %d 0 R', [LayoutsCount*2+cnstStartCount]));
  FData.Add('>>');
  FData.Add('endobj');
  FData.Add(Format('%d 0 obj', [N+1]));
  FData.Add('<<');
  FTmpLW := -1;
  TpdfStrings(FData).BeginStream;
  if BackgroundColor <> clWhite then
  begin
    R.Left := 0;
    R.Top := 0;
    R.Right := Round((FPageWidth / MMPerPDFUnit) / FQuality);
    R.Bottom := Round((FPageHeight / MMPerPDFUnit) / FQuality);
    SetFillColor(ColorToRGB(BackgroundColor));
    ExpFillRgn(@R, 1);
  end;
end;

procedure TsgPDFExport.PageEnd(N: Integer);
begin
  TpdfStrings(FData).EndStream;
end;

procedure TsgPDFExport.SaveToStreamCustom(S: TStream);
var
  I,Len,Cnt: Integer;
  DS: Char;
  vTemp: string;
  vTempAnsi: PAnsiChar;
begin
  FData.Clear;
  FResources.Clear;
  FImages.Clear;
  FImgNum := 0;
  FData.AddStringsArray(PDFHead);
  vTemp := '[';
  for I:=0 to LayoutsCount-1 do
  begin
    if I <> 0 then
      vTemp := vTemp + ' ' + Format('%d 0 R', [I+I+cnstStartCount])
    else
      vTemp := vTemp + Format('%d 0 R', [I+I+cnstStartCount])
  end;
  vTemp := vTemp + ']';
  FData.Add(vTemp);
  FData.Add(Format('/Count %d', [LayoutsCount]));
  FData.Add('>>');
  FData.Add('endobj');
  FData.Add('3 0 obj');
  FData.Add('<<');
  FData.Add(Format('/Title(%s)', [FTitle]));
  FData.Add(Format('/Author(%s)', [FAuthor]));
  FData.Add(Format('/Creator(%s)', [FCreator]));
  FData.Add(Format('/Producer(%s)', [FProducer]));
  FData.Add(Format('/Subject(%s)', [FSubject]));
  FData.Add(Format('/Keywords(%s)', [FKeywords]));
  FData.Add('>>');
  FData.Add('endobj');
  FResources.Add(Format('%d 0 obj', [LayoutsCount*2+cnstStartCount]));
  FResources.Add('<<');
  FResources.Add('/XObject');
  FResources.Add('<<');
  DS := SetDecimalSeparator('.');
  try
    inherited SaveToStreamCustom(S);
  finally
    SetDecimalSeparator(DS);
  end;
  FResources.Add('>>');
  FResources.Add('>>');
  FResources.Add('endobj');
  FImages.Add('xref');
  FImages.Add('');
  FImages.Add('0000000000 65535 f');
  Len := 0;
  Cnt := 0;
  FData.AddXref(FImages, Len, Cnt);
  FResources.AddXref(FImages, Len, Cnt);
  FImages.AddXref(FImages, Len, Cnt);
  FImages[FImages.Count - Cnt-2] := '0 ' + IntToStr(Cnt+1);
  FImages.AddStringsArray(PDFFoot);
  FImages[FImages.Count - 6] := '<< /Size ' + IntToStr(Cnt+1);
  FImages[FImages.Count - 1] := IntToStr(Len);
  FData.SaveToStream(S);
  FResources.SaveToStream(S);
  FImages.SaveToStream(S);
  vTempAnsi := '%%EOF';
  S.Write(vTempAnsi^, Length(vTempAnsi));
end;

end.
