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

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

type

  THpglStrings = class(TPersistent)
  private
    FList: TList;
    FStream: TStream;
    FBuffPos: PAnsiChar;
    FBuffBase: PAnsiChar;
    function GetCount: Integer;
    function GetStrings(Index: Integer): AnsiString;
    procedure SetStrings(Index: Integer; const Value: AnsiString);
    procedure DoWriteBuffer;{$IFDEF SG_INLINE} inline;{$ENDIF}
  protected
    function Extract(Index: Integer): AnsiString;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Add(const S: AnsiString): Integer;
    procedure Clear;
    procedure Delete(Index: Integer);
    procedure Flip;
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream);
    property Count: Integer read GetCount;
    property Strings[Index: Integer]: AnsiString read GetStrings
      write SetStrings; default;
  end;

  TsgCADtoHPGL = class(TsgSimpleExport)
  private
    FData: THpglStrings;
    FClips: THpglStrings;
    FClip: AnsiString;
    FCurPen: TColor;
    FStrokePen: TColor;
    FFillPen: TColor;
    FPt0: TPoint;
    FHd: Double;
    FWd: Double;
    FByPageCoordMaxStrLen: Integer;
    FIsOleExport: Boolean;
    FBuff: PAnsiChar;
    procedure PolyPoints(const Points; Count: Integer);
    procedure SetPen(Pen: TColor);
    function GetLineA(const APreamble: AnsiString; AInts: array of Integer): AnsiString;
    function FillBuff(const AStr: AnsiString): Integer;{$IFDEF SG_INLINE} inline;{$ENDIF}
//    function GetLineW(const APreamble: string; AInts: array of Integer): string;
  protected
//    function GetExportRect: TRect; 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: TsgDXFImage); override;
    destructor Destroy; override;
  end;

  TsgHPGLExport = TsgCADtoHPGL;

implementation

const
  // 1 plu = 0,025 mm
  // 40 plu = 1 mm
  // 1016 plu = 1 inch

  MMPerInch = 25.4;
  cnstDefaultPageWidth = 210.0; //mm
  cnstDefaultPageHeight = 297.0; //mm
  cnstDefaultPageHeightIn = (cnstDefaultPageHeight * 40) / 1016;
  cnstDefaultPageWidthIn = (cnstDefaultPageWidth * 40) / 1016;
  cnstDPI = 300;

  cnstMaxIntValueLenWithTail = 12;

type
  TsgBitmapAccess = class(TsgBitmap);

{$IFDEF SG_CPUX86}
{$IFDEF SG_DXF_EXPORT_OPTIMIZE}
function _itosA(AValue: Integer; var ABuff): PAnsiChar; register; assembler;
asm
  push ebx // buffer
  push edi // divider 10
  push esi // temp register

  push edx // save buffer address

  mov ebx,[edx] // save data begining
  mov ecx,ebx   //

  mov esi,eax   // check sign
  or eax,eax
  jns @positive // if negative
  neg eax       // eax = Abs(AValue)

@positive:
  mov edi,10    // init divider

@divide:
  xor edx,edx   // clear :EDX
  div edi       // divide
  add edx,'0'   // do symbol
  mov byte ptr [ebx],dl // fill data
  inc ebx       // next data position
  test eax,eax  // test tail on zero
  jnz @divide   // loop

  or esi,esi    // test fill sign
  jns @positive1
  mov byte ptr [ebx],'-'
  inc ebx

@positive1:

  mov eax,ebx   // save end of buffer
  mov edi,eax

// swap      '54321-' => '-12345'
  dec ebx
@swap:
  mov dl,byte ptr[ebx]
  xchg byte ptr[ecx],dl
  mov byte ptr[ebx],dl
  dec ebx
  inc ecx
  cmp ebx,ecx
  jae @swap

  pop edx         // restore buffer address
  mov [edx],edi   // set new buffer position

  pop esi
  pop edi
  pop ebx
end;
{$ENDIF}
{$ENDIF}

function itoa(AValue: Integer): AnsiString;{$IFDEF SG_INLINE} inline;{$ENDIF}
begin
  Result := AnsiString(IntToStr(AValue));
end;

{ TsgHPGLExport }

constructor TsgCADtoHPGL.Create(ACADImage: TsgDXFImage);
begin
  inherited Create(ACADImage);
  FData := THpglStrings.Create;
  FClips := THpglStrings.Create;
  FClip := 'IW;';
  FCurPen := clNone; FStrokePen := clNone; FFillPen := clNone;
  FIsOleExport := False;
  LayoutExportMode := lemAllPaperSpaces;
  FByPageCoordMaxStrLen := cnstMaxIntValueLenWithTail; //max length('[sign]Coord[endval]') <= 12
end;

destructor TsgCADtoHPGL.Destroy;
begin
  FData.Free;
  FClips.Free;
  inherited Destroy;
end;

procedure _FillIntA(const AValue: Integer; var ABuff: PAnsiChar; AEoln: AnsiChar);{$IFDEF SG_INLINE} inline;{$ENDIF}
var
  vStr: AnsiString;
  Len: Integer;
begin
  vStr := itoa(AValue);
  Len := Length(vStr);
  Move(PPointer(vStr)^, ABuff^, Len);
  ABuff[Len] := AEoln;
  Inc(Len);
  Inc(ABuff, Len);
end;

procedure FillIntA(const AValue: Integer; var ABuff: PAnsiChar; AEoln: AnsiChar);{$IFDEF SG_INLINE} inline;{$ENDIF}
begin
{$IFDEF SG_DXF_EXPORT_OPTIMIZE}
{$IFDEF SG_CPUX86}
  _itosA(AValue, ABuff);
  ABuff^ := AEoln;
  Inc(ABuff);
{$ELSE}
  _FillIntA(AValue, ABuff, AEoln);
{$ENDIF}
{$ELSE}
  _FillIntA(AValue, ABuff, AEoln);
{$ENDIF}
end;

function FillIntW(const AValue: Integer; var ABuff: PChar; AEoln: Char): Integer;{$IFDEF SG_INLINE} inline;{$ENDIF}
var
  vStr: string;
begin
  vStr := IntToStr(AValue);
  Result := Length(vStr);
  Move(PPointer(vStr)^, ABuff^, Result * SizeOf(Char));
  ABuff[Result] := AEoln;
  Inc(Result);
  Inc(ABuff, Result);
end;

{function TsgCADtoHPGL.GetLineW(const APreamble: string; AInts: array of Integer): string;
var
  I: Integer;
  BuffBase, Buff: PChar;
  Len: Integer;
begin
  Len := Length(APreamble);
  BuffBase := StrAlloc(Len + (FByPageCoordMaxStrLen shl 1) * Length(AInts));
  try
    Buff := BuffBase;
    StrLCopy(Buff, PChar(APreamble), Len);
    Inc(Buff, Len);
    I := Low(AInts);
    while I < High(AInts) do
    begin
      FillIntW(AInts[I], Buff, ',');
      Inc(I);
    end;
    FillIntW(AInts[I], Buff, ';');
    Len := (TsgNativeUInt(Buff) - TsgNativeUInt(BuffBase)) div SizeOf(Buff[0]);
    SetString(Result, BuffBase, Len);
  finally
    StrDispose(BuffBase);
  end;
end;}

function TsgCADtoHPGL.GetLineA(const APreamble: AnsiString; AInts: array of Integer): AnsiString;
var
  I: Integer;
  BuffBase, Buff: PAnsiChar;
  Len: Integer;
begin
  Len := Length(APreamble);
  BuffBase := AnsiStrAlloc(Len + (FByPageCoordMaxStrLen shl 1) * Length(AInts));
  try
    Buff := BuffBase;
    {$IFDEF SGDEL_XE4}AnsiStrings.{$ENDIF}StrLCopy(Buff, PAnsiChar(APreamble), Len);
    Inc(Buff, Len);
    I := Low(AInts);
    while I < High(AInts) do
    begin
      FillIntA(AInts[I], Buff, ',');
      Inc(I);
    end;
    FillIntA(AInts[I], Buff, ';');
    Len := (TsgNativeUInt(Buff) - TsgNativeUInt(BuffBase)) div SizeOf(Buff[0]);
    SetString(Result, BuffBase, Len);
  finally
    {$IFDEF SGDEL_XE4}AnsiStrings.{$ENDIF}StrDispose(BuffBase);
  end;
end;

procedure TsgCADtoHPGL.SetPen(Pen: TColor);
type
  PRGBA = ^TRGBA;
  TRGBA = record
    R, G, B, A: Byte;
  end;
var
  vRGBA: TRGBA absolute Pen;
begin
  if Pen <> FCurPen then
  begin
    FCurPen := Pen;
    FData.Add(GetLineA('PC1,', [vRGBA.R,vRGBA.G,vRGBA.B]));
  end;
end;

procedure TsgCADtoHPGL.PolyPoints(const Points; Count: Integer);
var
  vInts: PIntegerArray;
begin
  if Count > 0 then
  begin
    vInts := @Points;
    FPt0 := PPoint(@vInts^[0])^;
    FData.Add(GetLineA('PU', Slice(vInts^, 2)));
    Inc(PByte(vInts), 2 * SizeOf(Integer));
    Dec(Count);
    if Count > 0 then
      FData.Add(GetLineA('PD', Slice(vInts^, Count shl 1)));
  end;
end;

procedure TsgCADtoHPGL.ExpPolyline(const Points; Count: Integer);
begin
  SetPen(FStrokePen);
  PolyPoints(Points,Count);
end;

procedure TsgCADtoHPGL.ExpPolygon(const Points; Count: Integer);
begin
  SetPen(FFillPen);
  PolyPoints(Points,1);
  FData.Add('PM0;');
  PolyPoints(Points,Count);
  FData.Add('PM1;PM2;FP;');
end;

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

procedure TsgCADtoHPGL.ExpPolyPolygon(const Points; const Counts; Count: Integer);
var
  PP,PC: PInteger;
  C: Integer;
begin
  SetPen(FFillPen);
  PolyPoints(Points,1);
  PP := @Points;
  PC := @Counts;
  FData.Add('PM0;');
  while Count > 0 do
  begin
    C := PC^; Inc(PC);
    PolyPoints(PP^,C);
    FData.Add('PU;PM1;');
    Inc(PP, C*2);
    Dec(Count);
  end;
  FData.Add('PM2;FP;');
end;

procedure TsgCADtoHPGL.ExpClipRgn(P: PRect; Count: Integer);
begin
  Dec(P);
  FClip := GetLineA('IW', [P.Left, P.Top, P.Right, P.Bottom]);
  FData.Add(FClip);
end;

procedure TsgCADtoHPGL.ExpSaveDC;
begin
  FClips.Add(FClip);
end;

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

procedure TsgCADtoHPGL.ExpRestoreDC;
begin
  if FClips.Count > 0 then
  begin
    FClip := FClips[FClips.Count-1];
    FClips.Delete(FClips.Count-1);
    FData.Add(FClip);
  end;
end;

procedure TsgCADtoHPGL.ExpCloseFigure;
begin
  FData.Add(GetLineA('PD', [FPt0.X, FPt0.Y]));
end;

procedure TsgCADtoHPGL.SetStrokeColor(AColor: TColor);
begin
  FStrokePen := AColor;
end;

procedure TsgCADtoHPGL.SetFillColor(AColor: TColor);
begin
  FFillPen := AColor;
end;

procedure TsgCADtoHPGL.PageStart(N: Integer);
var
  vRect: TRect;
  W, H, I, Digits: Integer;
begin
  if N > 0 then FData.Add('PG;');
  vRect := GetExportRect;
  W := vRect.Right-vRect.Left;
  H := vRect.Bottom-vRect.Top;
  FHd := H / cnstDefaultPageHeightIn; // points in one in.
  FWd := W / cnstDefaultPageWidthIn;

  I := MaxI(W, H);
  if I >= 10000 then
    if I >= 1000000 then
      if I >= 100000000 then
        Digits := 9 + Ord(I >= 1000000000)
      else
        Digits := 7 + Ord(I >= 10000000)
    else
      Digits := 5 + Ord(I >= 100000)
  else
    if I >= 100 then
      Digits := 3 + Ord(I >= 1000)
    else
      Digits := 1 + Ord(I >= 10);

  Digits := Digits + Ord((vRect.Left < 0) or (vRect.Top < 0) or
    (vRect.Right < 0) or (vRect.Bottom < 0));
  FByPageCoordMaxStrLen := Digits + 1;// length('[+/-]Coord,') <= 12
end;

procedure TsgCADtoHPGL.ExpImage(const R: TRect; AImage: TGraphic);
begin
  FIsOleExport := True;
  ExpImageUV(R.TopLeft, Point(R.Right,R.Top),R.BottomRight,
    Point(R.Left,R.Bottom), AImage);
  FIsOleExport := False;
end;

function TsgCADtoHPGL.FillBuff(const AStr: AnsiString): Integer;
begin
  Result := Length(AStr);
  Move(Pointer(AStr)^, FBuff^, Result);
  Inc(FBuff, Result);
end;

// 0 1 3 2
procedure TsgCADtoHPGL.ExpImageUV(const APoint1, APoint2, APoint3,  APoint4: TPoint;
    AImage: TGraphic);
const
  cnstHeaderLenWithTail = 74;
var
  vAngle, vAngleY: Double;
  R: Integer;
  vBitmap: TsgBitmapAccess;
  vBitmapBig: TBitmap;
  vROP: Integer;
  vR: TRect;
  vPoint, vPoint1, vPoint2: TFPoint;
  vScale: Integer;
  I,J: Integer;
  S: AnsiString;
  P: PInteger;
  vDstW, vDstH: Integer;

  vSRTop, vSRLeft, vSDstW, vSDstH,
  vSBitmapWidth, vSBitmapHeight, vSScale, vSBitmapWidth4,
  vSBitmapLineDelim: AnsiString;

  BufferLen: Integer;

  function CalculateBufferLen: Integer;
  begin
    Result := cnstHeaderLenWithTail +
      Length(vSRTop) + Length(vSRLeft) + Length(vSDstW) + Length(vSDstH) +
      Length(vSBitmapWidth) + Length(vSBitmapHeight) + Length(vSScale) +
      vBitmapBig.Width * vBitmapBig.Height * 4 +
      vBitmapBig.Height * Length(vSBitmapLineDelim);
  end;

begin
  if AImage = nil then
    Exit;
  if IsGreatImage(AImage) then
    Exit;
  vPoint := MakeFPointFromPoint(APoint1);
  vPoint1 := MakeFPointFromPoint(APoint2);
  vPoint2 := MakeFPointFromPoint(APoint4);

  vAngle := GetAngleByPoints(vPoint, vPoint1,
    False, fDoubleResolution ,1, 1);
  vAngleY :=  GetAngleByPoints(vPoint, vPoint2,
    False, fDoubleResolution, 1, 1);

  vR.TopLeft := APoint1;
  vR.BottomRight := APoint1;
  ExpandRect(vR, APoint2);
  ExpandRect(vR, APoint3);
  ExpandRect(vR, APoint4);

  vScale := 3;
  vBitmapBig := TBitmap.Create;
  try
    vBitmap := TsgBitmapAccess(TsgBitmap.Create);
    try
      vBitmap.Assign(AImage);
      if IsEqual((Round(vAngle) div 90) * 90, vAngle) then
      begin
        if (vAngle = 0) and (vAngleY = 90) then
        begin
            vBitmap.Rotate(90);
        end
        else
        begin
          R := (Round(vAngle) div 90) * 90;
          if R <> 0 then
          begin
            if FIsOleExport then
            begin
              vBitmap.Rotate(R+90);
            end
            else
            begin
              vBitmap.Rotate(360-R+90);
            end;
          end;
        end;
      end
      else
      begin
        Exit;
      end;

      vBitmapBig.PixelFormat := pf32bit;
      SetSizeGraphic(vBitmapBig, vBitmap);
      vROP := vBitmap.FROP;
      try
        vBitmap.FROP := SRCCOPY;
        vBitmapBig.Canvas.StretchDraw(vBitmapBig.Canvas.ClipRect, vBitmap);
      finally
        vBitmap.FROP := vROP;
      end;
    finally
      vBitmap.Free;
    end;

    vDstW := Abs(Round((vR.Bottom-vR.Top) - (vR.Bottom-vR.Top)/(3.39)));
    vDstH := Abs(Round((vR.Right-vR.Left) - (vR.Right-vR.Left)/(3.39)));

    vSRTop := itoa(vR.Top);
    vSRLeft := itoa(vR.Left);
    vSDstW := itoa(vDstW);
    vSDstH := itoa(vDstH);
    vSBitmapWidth := itoa(vBitmapBig.Width);
    vSBitmapHeight := itoa(vBitmapBig.Height);
    vSScale := itoa(vScale);
    vSBitmapWidth4 := itoa(vBitmapBig.Width shl 2);
    vSBitmapLineDelim := #27'*b' + vSBitmapWidth4 + 'W';

    BufferLen := CalculateBufferLen;

    SetLength(S, BufferLen);
    FBuff := PPointer(@S)^;

    FillBuff('PU;PA' + vSRLeft + ',' + vSRTop + ';');
    //HP RTL CAP is set to the HP-GL/2 pen position
    FillBuff(#27'%1A');
    // Source Transparency Mode (OFF)
    FillBuff(#27'*v1N');
    // Pattern Transparency Mode (OFF)
    FillBuff(#27'*v1O');
    // Negative Motion
    FillBuff(#27'&a1N');
    //Configure Image Data
    //                                   Bit Number
    //Byte 15                                8 7                           0   Byte
    //     0 Color Space                        Pixel Encoding Mode             1
    //     2 Number of Bits per Index           Number of Bits per Primary—Red  3
    //     4 Number of Bits per Primary—Green   Number of Bits per Primary—Blue 5
    //     6                   White Reference for Red                          7
    //     8                   White Reference for Green                        9
    //     10                  White Reference for Blue                         11
    //     12                  Black Reference for Red                          13
    //     14                  Black Reference for Green                        15
    //     16                  Black Reference for Blue                         17
    FillBuff(#27'*v6W'#0#3#8#8#8#8);
    //Move CAP Horizontal + Move CAP Vertical
    //S := S + Format(AnsiString(#27'*p%dX'#27'*p%dY'), [vR.Left, vR.Top]);
    //Source Raster Width + Source Raster Height
    FillBuff(#27'*r' + vSBitmapWidth + 'S');
    FillBuff(#27'*r' + vSBitmapHeight + 'T');
    // Destination Raster Width + Destination Raster Height
    FillBuff(#27'*t' + vSDstW + 'H');
    FillBuff(#27'*t' + vSDstH + 'V');
    //Start Raster Graphics
    FillBuff(#27'*r' + vSScale + 'A');
    //Compression Method (10 - near lossless RGB/KCMY replacement delta row encoding)
    FillBuff(#27'*b10M');
    for I := 0 to vBitmapBig.Height - 1 do
    begin
      FillBuff(vSBitmapLineDelim);
      P := PInteger(vBitmapBig.ScanLine[I]);
      for J := 0 to vBitmapBig.Width - 1 do
      begin
        PInteger(FBuff)^ := SwapWords(P^ shr 1);
        Inc(PByte(FBuff), SizeOf(Integer));
        Inc(P);
      end;
    end;
    FillBuff(#27'*rC'#27'%1BPU;');
    FData.Add(S);
  finally
    vBitmapBig.Free;
  end;
end;

procedure TsgCADtoHPGL.SaveToStreamCustom(S: TStream);
begin
  FData.Clear;
  FData.Add(#27'%-12345X@PJL SET RESOLUTION = ' + itoa(cnstDPI));
  FData.Add('@PJL SET ORIENTATION = LANDSCAPE');
  FData.Add('@PJL ENTER LANGUAGE = HPGL2');
  FData.Add(#27'%1B');
  FData.Add('BP5,1;IN;SP1;IW;PS9600,7100;TR0;IP0,0,7100,9600;SC;');
  //SC 0,1,0,1,2; Moves the origin to P1 and establishes a 1:1 ratio of user-units to plotter-units.
  inherited SaveToStreamCustom(S);
  FData.SaveToStream(S);
end;

{ THpglStrings }

function THpglStrings.Add(const S: AnsiString): Integer;
var
  vRef: AnsiString;
begin
  Result := FList.Add(Pointer(S));
  vRef := S;
  Pointer(vRef) := nil;
end;

procedure THpglStrings.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source is THpglStrings then
  begin
    Clear;
    for I := 0 to THpglStrings(Source).Count - 1 do
      Add(THpglStrings(Source)[I]);
  end
  else
    if Source is TStrings then
    begin
      Clear;
      for I := 0 to TStrings(Source).Count - 1 do
        Add(AnsiString(TStrings(Source)[I]));
    end
    else
      inherited Assign(Source);
end;

procedure THpglStrings.Clear;
begin
  while Count > 0 do
    Delete(Count - 1);
end;

constructor THpglStrings.Create;
begin
  FList := TList.Create;
end;

procedure THpglStrings.Delete(Index: Integer);
var
  S: AnsiString;
begin
  Pointer(S) := FList[Index];
  FList.Delete(Index);
end;

destructor THpglStrings.Destroy;
begin
  Clear;
  FList.Free;
  inherited Destroy;
end;

function THpglStrings.Extract(Index: Integer): AnsiString;
begin
  Result := Strings[Index];
  Delete(Index);
end;

function THpglStrings.GetCount: Integer;
begin
  Result := FList.Count;
end;

function THpglStrings.GetStrings(Index: Integer): AnsiString;
begin
  Result := AnsiString(FList[Index]);
end;

procedure THpglStrings.LoadFromStream(Stream: TStream);
var
  I: Integer;
  S: TStrings;
  vTmp: AnsiString;
begin
  S := TStringList.Create;
  try
    S.LoadFromStream(Stream);
    Clear;
    I := S.Count - 1;
    while I > 0 do
    begin
      vTmp := AnsiString(S[I]);
      Add(vTmp);
      S.Delete(I);
      Dec(I);
    end;
    Flip;
  finally
    S.Free;
  end;
end;

procedure THpglStrings.SetStrings(Index: Integer; const Value: AnsiString);
begin
  AnsiString(FList.List[Index]) := Value;
end;

procedure THpglStrings.Flip;
var
  J, C, K: Integer;
{$IFOPT O+}
  vTmp: Pointer;
{$ENDIF}
begin
  C := FList.Count;
  K := C shr 1 - 1;
{$IFOPT O+}
  Dec(C);
{$ENDIF}
  for J := 0 to K do
{$IFOPT O+}
    with FList do
    begin
      vTmp := List[J];
      List[J] := List[C];
      List[C] := vTmp;
      Dec(C);
    end;
{$ELSE}
    FList.Exchange(J, FList.Count - J - 1);
{$ENDIF}
end;

procedure THpglStrings.DoWriteBuffer;
begin
  FStream.WriteBuffer(FBuffBase^, FBuffPos - FBuffBase);
  FBuffPos := FBuffBase;
end;

procedure THpglStrings.SaveToStream(Stream: TStream);
const
  cnstEoln = $0A0D;
  cnstBufferLength = $F000;
var
  vSrc, vSrcEnd: PAnsiChar;
  vBytesWrite: Integer;
  vBuffEnd: PAnsiChar;
  S: AnsiString;

  procedure NextString(var S: AnsiString; AIndex: Integer);
  begin
    S := Extract(AIndex);
    vSrc := Pointer(S);
    vSrcEnd := vSrc;
    Inc(vSrcEnd, Length(S));
  end;

begin
  if Count > 0 then
  begin
    FStream := Stream;
    GetMem(FBuffBase, cnstBufferLength);
    try
      FBuffPos := FBuffBase;
      vBuffEnd := FBuffPos;
      Inc(vBuffEnd, cnstBufferLength);
      Flip;
      NextString(S, Count - 1);
      repeat
        while ((Count > 0) or (vSrc < vSrcEnd)) and (FBuffPos < vBuffEnd) do
        begin
          if vSrcEnd - vSrc <= vBuffEnd - FBuffPos then
            vBytesWrite := vSrcEnd - vSrc
          else
            vBytesWrite := vBuffEnd - FBuffPos;
          Move(vSrc^, FBuffPos^, vBytesWrite);
          Inc(FBuffPos, vBytesWrite);
          Inc(vSrc, vBytesWrite);
          if vSrc = vSrcEnd then
          begin
            case vBuffEnd - FBuffPos of
              0:
                begin
                  DoWriteBuffer;
                  PWord(FBuffPos)^ := cnstEoln;
                  Inc(FBuffPos, 2);
                end;
              1:
                begin
                  FBuffPos^ := #13;
                  Inc(FBuffPos);
                  DoWriteBuffer;
                  FBuffPos^ := #10;
                  Inc(FBuffPos);
                end;
              2:
                begin
                  PWord(FBuffPos)^ := cnstEoln;
                  Inc(FBuffPos, 2);
                  DoWriteBuffer;
                end;
            else
              PWord(FBuffPos)^ := cnstEoln;
              Inc(FBuffPos, 2);
            end;
            if Count > 0 then
              NextString(S, Count - 1);
          end
          else
            if FBuffPos = vBuffEnd then
              DoWriteBuffer;
        end;
      until Count <= 0;
      if FBuffPos > FBuffBase then
        DoWriteBuffer;
    finally
      FreeMem(FBuffBase);
    end;
  end;
end;

end.
