diff --git a/.gitattributes b/.gitattributes index fe9128f6f6..9bb961ff79 100644 --- a/.gitattributes +++ b/.gitattributes @@ -937,6 +937,38 @@ components/fppkg/svn/test/proplist.txt svneol=native#text/plain components/fppkg/svn/test/status.xml svneol=native#text/plain components/fppkg/svn/test/testsvnclasses.pas svneol=native#text/plain components/fppkg/svn/test/testsvncommand.pas svneol=native#text/plain +components/fpvectorial/avisocncgcodereader.pas svneol=native#text/plain +components/fpvectorial/avisocncgcodewriter.pas svneol=native#text/plain +components/fpvectorial/avisozlib.pas svneol=native#text/plain +components/fpvectorial/cdrvectorialreader.pas svneol=native#text/plain +components/fpvectorial/dxfvectorialreader.pas svneol=native#text/plain +components/fpvectorial/epsvectorialreader.pas svneol=native#text/plain +components/fpvectorial/examples/fpce_mainform.lfm svneol=native#text/plain +components/fpvectorial/examples/fpce_mainform.pas svneol=native#text/plain +components/fpvectorial/examples/fpcorelexplorer.ico -text +components/fpvectorial/examples/fpcorelexplorer.lpi svneol=native#text/plain +components/fpvectorial/examples/fpcorelexplorer.lpr svneol=native#text/plain +components/fpvectorial/examples/fpvc_mainform.lfm svneol=native#text/plain +components/fpvectorial/examples/fpvc_mainform.pas svneol=native#text/plain +components/fpvectorial/examples/fpvectorialconverter.ico -text +components/fpvectorial/examples/fpvectorialconverter.lpi svneol=native#text/plain +components/fpvectorial/examples/fpvectorialconverter.lpr svneol=native#text/plain +components/fpvectorial/examples/fpvmodifytest.lpi svneol=native#text/plain +components/fpvectorial/examples/fpvmodifytest.pas svneol=native#text/plain +components/fpvectorial/examples/fpvwritetest.lpi svneol=native#text/plain +components/fpvectorial/examples/fpvwritetest.pas svneol=native#text/plain +components/fpvectorial/fpvectbuildunit.pas svneol=native#text/plain +components/fpvectorial/fpvectorial.pas svneol=native#text/plain +components/fpvectorial/fpvectorialpkg.lpk svneol=native#text/plain +components/fpvectorial/fpvectorialpkg.pas svneol=native#text/plain +components/fpvectorial/fpvtocanvas.pas svneol=native#text/plain +components/fpvectorial/fpvutils.pas svneol=native#text/plain +components/fpvectorial/pdfvectorialreader.pas svneol=native#text/plain +components/fpvectorial/pdfvrlexico.pas svneol=native#text/plain +components/fpvectorial/pdfvrsemantico.pas svneol=native#text/plain +components/fpvectorial/pdfvrsintatico.pas svneol=native#text/plain +components/fpvectorial/svgvectorialreader.pas svneol=native#text/plain +components/fpvectorial/svgvectorialwriter.pas svneol=native#text/plain components/fpweb/README.txt svneol=native#text/plain components/fpweb/demo/README.txt svneol=native#text/plain components/fpweb/fpideexteditorinsertfilenameunit.lfm svneol=native#text/plain diff --git a/components/fpvectorial/avisocncgcodereader.pas b/components/fpvectorial/avisocncgcodereader.pas new file mode 100644 index 0000000000..4ae5c53c56 --- /dev/null +++ b/components/fpvectorial/avisocncgcodereader.pas @@ -0,0 +1,236 @@ +{ +Reads AvisoCNC G-Code + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + Pedro Sol Pegorini L de Lima +} +unit avisocncgcodereader; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + fpvectorial; + +type + + { Used by tcutils.SeparateString } + T10Strings = array[0..9] of shortstring; + + { TvAvisoCNCGCodeReader } + + TvAvisoCNCGCodeReader = class(TvCustomVectorialReader) + private + LastX, LastY, LastZ: Double; + function SeparateString(AString: string; ASeparator: Char): T10Strings; + procedure ReadString(AStr: string; AData: TvVectorialPage); + function GetCoordinate(AStr: shortstring): Integer; + function GetCoordinateValue(AStr: shortstring): Double; + public + { General reading methods } + procedure ReadFromStrings(AStrings: TStrings; AData: TvVectorialDocument); override; + end; + +implementation + +const + { Coordinate constants } + + INT_COORDINATE_NONE = 0; + INT_COORDINATE_X = 1; + INT_COORDINATE_Y = 2; + INT_COORDINATE_Z = 3; + + { GCode constants } + + STR_GCODE_LINEAR_MOVE = 'G01'; + STR_GCODE_STEPPER_MOVE = 'S01'; + STR_GCODE_2DBEZIER_MOVE = 'B02'; + STR_GCODE_3DBEZIER_MOVE = 'B03'; + STR_GCODE_DRILL_UP = 'P01'; + STR_GCODE_DRILL_DOWN = 'P02'; + +{ TvAvisoCNCGCodeReader } + +{@@ + Reads a string and separates it in substring + using ASeparator to delimite them. + + Limits: + + Number of substrings: 10 (indexed 0 to 9) + Length of each substring: 255 (they are shortstrings) +} +function TvAvisoCNCGCodeReader.SeparateString(AString: string; ASeparator: Char): T10Strings; +var + i, CurrentPart: Integer; +begin + CurrentPart := 0; + + { Clears the result } + for i := 0 to 9 do Result[i] := ''; + + { Iterates througth the string, filling strings } + for i := 1 to Length(AString) do + begin + if Copy(AString, i, 1) = ASeparator then + begin + Inc(CurrentPart); + + { Verifies if the string capacity wasn't exceeded } + if CurrentPart > 9 then Exit; + end + else + Result[CurrentPart] := Result[CurrentPart] + Copy(AString, i, 1); + end; +end; + +procedure TvAvisoCNCGCodeReader.ReadString(AStr: string; + AData: TvVectorialPage); +var + AParams: T10Strings; + DestX, DestY, DestZ: Double; + i: Integer; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn('TvAvisoCNCGCodeReader.ReadString ', AStr); + {$endif} + AParams := SeparateString(AStr, ' '); + + { + Format may be: + G01 X3 + G01 X3 Y4 + G01 X3 Y4 Z2 + } + if AParams[0] = STR_GCODE_DRILL_UP then + begin + AData.AddLineToPath(LastX, LastY, 0); + LastZ := 0; + end + else if AParams[0] = STR_GCODE_DRILL_DOWN then + begin + AData.AddLineToPath(LastX, LastY, 50); + LastZ := 50; + end + else if AParams[0] = STR_GCODE_LINEAR_MOVE then + begin + DestX := LastX; + DestY := LastY; + DestZ := LastZ; + + for i := 1 to 3 do + begin + case GetCoordinate(AParams[i]) of + INT_COORDINATE_X: DestX := GetCoordinateValue(AParams[i]); + INT_COORDINATE_Y: DestY := GetCoordinateValue(AParams[i]); + INT_COORDINATE_Z: DestZ := GetCoordinateValue(AParams[i]); + else + // error + end; + end; + + AData.AddLineToPath(DestX, DestY, DestZ); + + LastX := DestX; + LastY := DestY; + LastZ := DestZ; + end + else if AParams[0] = STR_GCODE_2DBEZIER_MOVE then + begin + AData.AddBezierToPath( + GetCoordinateValue(AParams[1]), + GetCoordinateValue(AParams[2]), + GetCoordinateValue(AParams[3]), + GetCoordinateValue(AParams[4]), + GetCoordinateValue(AParams[5]), + GetCoordinateValue(AParams[6]) + ); + + LastX := GetCoordinateValue(AParams[5]); + LastY := GetCoordinateValue(AParams[6]); + end + else if AParams[0] = STR_GCODE_3DBEZIER_MOVE then + begin + AData.AddBezierToPath( + GetCoordinateValue(AParams[1]), + GetCoordinateValue(AParams[2]), + GetCoordinateValue(AParams[3]), + GetCoordinateValue(AParams[4]), + GetCoordinateValue(AParams[5]), + GetCoordinateValue(AParams[6]), + GetCoordinateValue(AParams[7]), + GetCoordinateValue(AParams[8]), + GetCoordinateValue(AParams[9]) + ); + + LastX := GetCoordinateValue(AParams[7]); + LastY := GetCoordinateValue(AParams[8]); + LastZ := GetCoordinateValue(AParams[9]); + end; + {else + begin + Ignore any of these codes: + + STR_GCODE_STEPPER_MOVE + + and anything else + end;} +end; + +function TvAvisoCNCGCodeReader.GetCoordinate(AStr: shortstring): Integer; +begin + Result := INT_COORDINATE_NONE; + + if AStr = '' then Exit + else if AStr[1] = 'X' then Result := INT_COORDINATE_X + else if AStr[1] = 'Y' then Result := INT_COORDINATE_Y + else if AStr[1] = 'Z' then Result := INT_COORDINATE_Z; +end; + +function TvAvisoCNCGCodeReader.GetCoordinateValue(AStr: shortstring): Double; +begin + Result := 0.0; + + if Length(AStr) <= 1 then Exit; + + Result := StrToFloat(Copy(AStr, 2, Length(AStr) - 1)); +end; + +{@@ + The information of each separate path is lost in G-Code files + Only one path uniting all of them is created when reading G-Code +} +procedure TvAvisoCNCGCodeReader.ReadFromStrings(AStrings: TStrings; + AData: TvVectorialDocument); +var + i: Integer; + FirstPage: TvVectorialPage; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn('TvAvisoCNCGCodeReader.ReadFromStrings AStrings = ', PtrInt(AStrings), ' AData = ', PtrInt(AData)); + {$endif} + + FirstPage := AData.AddPage(); + FirstPage.StartPath(0, 0); + + for i := 0 to AStrings.Count - 1 do + ReadString(AStrings.Strings[i], FirstPage); + + {$ifdef FPVECTORIALDEBUG} + WriteLn('AData.EndPath'); + {$endif} + FirstPage.EndPath(); +end; + +initialization + + RegisterVectorialReader(TvAvisoCNCGCodeReader, vfGCodeAvisoCNCPrototipoV5); + +end. + diff --git a/components/fpvectorial/avisocncgcodewriter.pas b/components/fpvectorial/avisocncgcodewriter.pas new file mode 100644 index 0000000000..6c8d62cf03 --- /dev/null +++ b/components/fpvectorial/avisocncgcodewriter.pas @@ -0,0 +1,119 @@ +{ +Writes AvisoCNC G-Code + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + Pedro Sol Pegorini L de Lima +} +unit avisocncgcodewriter; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, + fpvectorial; + +type + { TvAvisoCNCGCodeWriter } + + TvAvisoCNCGCodeWriter = class(TvCustomVectorialWriter) + private + procedure WritePageToStrings(AStrings: TStrings; AData: TvVectorialPage); + public + { General reading methods } + procedure WriteToStrings(AStrings: TStrings; AData: TvVectorialDocument); override; + end; + +implementation + +{ TvGCodeVectorialWriter } + +procedure TvAvisoCNCGCodeWriter.WritePageToStrings(AStrings: TStrings; + AData: TvVectorialPage); +var + i, j: Integer; + Str: string; + APath: TPath; + CurSegment: T2DSegment; + Cur3DSegment: T3DSegment; + Cur2DBezierSegment: T2DBezierSegment; + Cur3DBezierSegment: T3DBezierSegment; + lEntity: TvEntity; +begin + AStrings.Clear; + + AStrings.Add('M216 // Ligar monitor de carga'); + AStrings.Add('G28 // Ir rapidamente para posição inicial'); + AStrings.Add('G00'); + + // itera por todos os itens + for i := 0 to AData.GetEntitiesCount - 1 do + begin + lEntity := AData.GetEntity(i); + if not (lEntity is TPath) then Continue; + APath := lEntity as TPath; + + // levanta a broca + AStrings.Add('P01 // Sobe a cabeça de gravação'); + // vai para o ponto inicial + CurSegment := T2DSegment(APath.Points); + AStrings.Add(Format('G01 X%f Y%f', + [CurSegment.X, CurSegment.Y])); + AStrings.Add('P02 // Abaixa a cabeça de gravação'); + + for j := 1 to APath.Len - 1 do + begin + CurSegment := T2DSegment(CurSegment.Next); + case CurSegment.SegmentType of + st2DLine: AStrings.Add(Format('G01 X%f Y%f', + [CurSegment.X, CurSegment.Y])); + st3DLine: + begin + Cur3DSegment := T3DSegment(CurSegment); + AStrings.Add(Format('G01 X%f Y%f Z%f', + [Cur3DSegment.X, Cur3DSegment.Y, Cur3DSegment.Z])); + end; + st2DBezier: + begin + Cur2DBezierSegment := T2DBezierSegment(CurSegment); + AStrings.Add(Format('B02 X%f Y%f X%f Y%f X%f Y%f', + [Cur2DBezierSegment.X2, Cur2DBezierSegment.Y2, + Cur2DBezierSegment.X3, Cur2DBezierSegment.Y3, + Cur2DBezierSegment.X, Cur2DBezierSegment.Y])); + end; + st3DBezier: + begin + Cur3DBezierSegment := T3DBezierSegment(CurSegment); + AStrings.Add(Format('B03 X%f Y%f Z%f X%f Y%f Z%f X%f Y%f Z%f', + [Cur3DBezierSegment.X2, Cur3DBezierSegment.Y2, Cur3DBezierSegment.Z2, + Cur3DBezierSegment.X3, Cur3DBezierSegment.Y3, Cur3DBezierSegment.Z3, + Cur3DBezierSegment.X, Cur3DBezierSegment.Y, Cur3DBezierSegment.Z])); + end; + end; + end; + end; + + AStrings.Add('P01 // Sobe a cabeça de gravação'); + AStrings.Add('M30 // Parar o programa e retornar para posição inicial'); + AStrings.Add('M215 // Desligar monitor de carga'); +end; + +procedure TvAvisoCNCGCodeWriter.WriteToStrings(AStrings: TStrings; + AData: TvVectorialDocument); +var + lPage: TvVectorialPage; +begin + lPage := AData.GetPage(0); + WritePageToStrings(AStrings, lPage); +end; + +initialization + + RegisterVectorialWriter(TvAvisoCNCGCodeWriter, vfGCodeAvisoCNCPrototipoV5); + +end. + diff --git a/components/fpvectorial/avisozlib.pas b/components/fpvectorial/avisozlib.pas new file mode 100644 index 0000000000..4bef95bbf2 --- /dev/null +++ b/components/fpvectorial/avisozlib.pas @@ -0,0 +1,74 @@ +unit avisozlib; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, paszlib; + +type + Decode = class + public + procedure CHECK_ERR(err: Integer; msg: String); + procedure EXIT_ERR(const msg: String); + function test_inflate(compr: Pointer; comprLen : LongInt; + uncompr: Pointer; uncomprLen : LongInt): PChar; + constructor Create(); + end; + +implementation + +procedure Decode.CHECK_ERR(err: Integer; msg: String); +begin + if err <> Z_OK then + begin + raise Exception.Create('ERROR: ' + msg); + Halt(1); + end; +end; + +procedure Decode.EXIT_ERR(const msg: String); +begin + raise Exception.Create('ERROR: ' + msg); + Halt(1); +end; + +function Decode.test_inflate(compr: Pointer; comprLen : LongInt; + uncompr: Pointer; uncomprLen : LongInt): PChar; +var err: Integer; + d_stream: TZStream; // decompression stream +begin + StrCopy(PChar(uncompr), 'garbage'); + + d_stream.next_in := compr; + d_stream.avail_in := 0; + d_stream.next_out := uncompr; + + err := inflateInit(d_stream); + CHECK_ERR(err, 'inflateInit'); + + while (d_stream.total_out < uncomprLen) and + (d_stream.total_in < comprLen) do + begin + d_stream.avail_out := 1; // force small buffers + d_stream.avail_in := 1; + err := inflate(d_stream, Z_NO_FLUSH); + if err = Z_STREAM_END then + break; + CHECK_ERR(err, 'inflate'); + end; + + err := inflateEnd(d_stream); + CHECK_ERR(err, 'inflateEnd'); + + Result:=PChar(uncompr); +end; + +constructor Decode.Create(); +begin + inherited Create; +end; + +end. + diff --git a/components/fpvectorial/cdrvectorialreader.pas b/components/fpvectorial/cdrvectorialreader.pas new file mode 100644 index 0000000000..8c9f9b02bd --- /dev/null +++ b/components/fpvectorial/cdrvectorialreader.pas @@ -0,0 +1,180 @@ +{ +cdrvectorialreader.pas + +Reads a Corel Draw vectorial file + +CDR file format specification obtained from: + +ADOBE SYSTEMS INCORPORATED. PDF Reference: Adobe® +Portable Document Format. San Jose, 2006. (Sixth edition). + +AUTHORS: Felipe Monteiro de Carvalho + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details +} +unit cdrvectorialreader; + +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses + Classes, SysUtils, + //avisozlib, + fpvectorial; + +type + + TCDRChunk = class + Name: array[0..3] of Char; + Size: Cardinal; + ChildChunks: TFPList; + end; + + TCDRChunkClass = class of TCDRChunk; + + TvCDRInternalData = TCDRChunk; + + TCDRChunkVRSN = class(TCDRChunk) + VersionStr: string; + VersionNum: Integer; + end; + + { TvCDRVectorialReader } + + TvCDRVectorialReader = class(TvCustomVectorialReader) + private + procedure ReadVersionChunk(AStream: TStream; var AData: TCDRChunk); + function AddNewChunk(var AData: TCDRChunk; AClass: TCDRChunkClass): TCDRChunk; + public + { General reading methods } + procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override; + { File format exploring methods } + procedure ExploreFromFile(AFilename: string; out AData: TvCDRInternalData); + procedure ExploreFromStream(AStream: TStream; out AData: TvCDRInternalData); + end; + +implementation + +{ TvPDFVectorialReader } + +procedure TvCDRVectorialReader.ReadVersionChunk(AStream: TStream; + var AData: TCDRChunk); +var + lDWord: DWord; + lChunk: TCDRChunkVRSN absolute AData; + lVerBytes: array[0..1] of Byte; +begin + // Read the Chunk name + lDWord := AStream.ReadDWord(); + + // Read the Chunk size + lDWord := AStream.ReadDWord(); + + // Read the version + AStream.Read(lVerBytes, 2); + + if (lVerBytes[0] = $BC) and (lVerBytes[1] = $02) then + begin + lChunk.VersionNum := 7; + lChunk.VersionStr := 'CorelDraw 7'; + end + else if (lVerBytes[0] = $20) and (lVerBytes[1] = $03) then + begin + lChunk.VersionNum := 8; + lChunk.VersionStr := 'CorelDraw 8'; + end + else if (lVerBytes[0] = $21) and (lVerBytes[1] = $03) then + begin + lChunk.VersionNum := 8; + lChunk.VersionStr := 'CorelDraw 8bidi'; + end + else if (lVerBytes[0] = $84) and (lVerBytes[1] = $03) then + begin + lChunk.VersionNum := 9; + lChunk.VersionStr := 'CorelDraw 9'; + end + else if (lVerBytes[0] = $E8) and (lVerBytes[1] = $03) then + begin + lChunk.VersionNum := 10; + lChunk.VersionStr := 'CorelDraw 10'; + end + else if (lVerBytes[0] = $4C) and (lVerBytes[1] = $04) then + begin + lChunk.VersionNum := 11; + lChunk.VersionStr := 'CorelDraw 11'; + end + else if (lVerBytes[0] = $B0) and (lVerBytes[1] = $04) then + begin + lChunk.VersionNum := 12; + lChunk.VersionStr := 'CorelDraw 12'; + end + else if (lVerBytes[0] = $14) and (lVerBytes[1] = $05) then + begin + lChunk.VersionNum := 13; + lChunk.VersionStr := 'CorelDraw X3'; + end; +end; + +function TvCDRVectorialReader.AddNewChunk(var AData: TCDRChunk; AClass: TCDRChunkClass): TCDRChunk; +begin + if AData.ChildChunks = nil then AData.ChildChunks := TFPList.Create; + + Result := AClass.Create; + + AData.ChildChunks.Add(Result); +end; + +procedure TvCDRVectorialReader.ReadFromStream(AStream: TStream; + AData: TvVectorialDocument); +begin +end; + +procedure TvCDRVectorialReader.ExploreFromFile(AFilename: string; + out AData: TvCDRInternalData); +var + FileStream: TFileStream; +begin + FileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone); + try + ExploreFromStream(FileStream, AData); + finally + FileStream.Free; + end; +end; + +procedure TvCDRVectorialReader.ExploreFromStream(AStream: TStream; + out AData: TvCDRInternalData); +var + lRIFF: array[0..3] of Char; + lDocSize, lDWord: Cardinal; + lChild: TCDRChunk; +begin + // Create the data object + AData := TCDRChunk.Create; + + // All CorelDraw files starts with "RIFF" + AStream.Read(lRIFF, 4); + if lRIFF <> 'RIFF' then + raise Exception.Create('[TvCDRVectorialReader.ExploreFromStream] The Corel Draw RIFF file marker wasn''t found.'); + + // And then 4 bytes for the document size + lDocSize := AStream.ReadDWord(); + + // And mroe 4 bytes of other stuff + lDWord := AStream.ReadDWord(); + + // Now comes the version + lChild := AddNewChunk(AData, TCDRChunkVRSN); + ReadVersionChunk(AStream, lChild); +end; + +initialization + + RegisterVectorialReader(TvCDRVectorialReader, vfCorelDrawCDR); + +end. + diff --git a/components/fpvectorial/dxfvectorialreader.pas b/components/fpvectorial/dxfvectorialreader.pas new file mode 100644 index 0000000000..df5d3aed8d --- /dev/null +++ b/components/fpvectorial/dxfvectorialreader.pas @@ -0,0 +1,1255 @@ +{ +Reads DXF files + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + +DXF is composed by records written in ASCII with the following structure: + +0 +SECTION +section_number +SECTION_NAME + +0 +ENDSEC +0 + +after all sections there is: + +EOF + +} +unit dxfvectorialreader; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, + fpvectorial, fpimage, fpvutils; + +type + TDXFToken = class; + + TDXFTokens = TFPList;// TDXFToken; + + TDXFToken = class + GroupCode: Integer; + StrValue: string; + FloatValue: double; + IntValue: Integer; + Childs: TDXFTokens; + constructor Create; + Destructor Destroy; override; + end; + + TPolylineElement = record + X, Y: Double; + Color: TFPColor; + end; + + TSPLineElement = record + X, Y: Double; + KnotValue: Integer; + end; + + TLWPOLYLINEElement = record + X, Y: Double; + end; + + { TDXFTokenizer } + + TDXFTokenizer = class + public + Tokens: TDXFTokens; + constructor Create; + Destructor Destroy; override; + procedure ReadFromStrings(AStrings: TStrings); + function IsENTITIES_Subsection(AStr: string): Boolean; + end; + + { TvDXFVectorialReader } + + TvDXFVectorialReader = class(TvCustomVectorialReader) + private + FPointSeparator: TFormatSettings; + // HEADER data + ANGBASE: Double; + ANGDIR: Integer; + INSBASE, EXTMIN, EXTMAX, LIMMIN, LIMMAX: T3DPoint; + // Calculated HEADER data + DOC_OFFSET: T3DPoint; // The DOC_OFFSET compensates for documents with huge coordinates + // For building the POLYLINE objects which is composed of multiple records + IsReadingPolyline: Boolean; + Polyline: array of TPolylineElement; + // + procedure ReadHEADER(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_LINE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_ARC(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_CIRCLE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_DIMENSION(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_ELLIPSE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_TEXT(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_LWPOLYLINE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_SPLINE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_POLYLINE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_VERTEX(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_SEQEND(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_MTEXT(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadENTITIES_POINT(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + function GetCoordinateValue(AStr: shortstring): Double; + // + function DXFColorIndexToFPColor(AColorIndex: Integer): TFPColor; + public + { General reading methods } + Tokenizer: TDXFTokenizer; + constructor Create; override; + Destructor Destroy; override; + procedure ReadFromStrings(AStrings: TStrings; AData: TvVectorialDocument); override; + end; + +implementation + +{$ifndef Windows} +{$define FPVECTORIALDEBUG} +{$endif} + +const + // Items in the HEADER section + + // $ACADVER + DXF_AUTOCAD_2010 = 'AC1024'; // AutoCAD 2011 and 2012 too + DXF_AUTOCAD_2007 = 'AC1021'; // AutoCAD 2008 and 2009 too + DXF_AUTOCAD_2004 = 'AC1018'; // AutoCAD 2005 and 2006 too + DXF_AUTOCAD_2000 = 'AC1015'; // 1999 In some docs it is proposed as AC1500, but in practice I found AC1015 + // http://www.autodesk.com/techpubs/autocad/acad2000/dxf/ + // AutoCAD 2000i and 2002 too + DXF_AUTOCAD_R14 = 'AC1014'; // 1997 http://www.autodesk.com/techpubs/autocad/acadr14/dxf/index.htm + DXF_AUTOCAD_R13 = 'AC1012'; // 1994 + DXF_AUTOCAD_R11_and_R12 = 'AC1009'; // 1990 + DXF_AUTOCAD_R10 = 'AC1006'; // 1988 + DXF_AUTOCAD_R9 = 'AC1004'; + + // Group Codes for ENTITIES + DXF_ENTITIES_TYPE = 0; + DXF_ENTITIES_HANDLE = 5; + DXF_ENTITIES_LINETYPE_NAME = 6; + DXF_ENTITIES_APPLICATION_GROUP = 102; + DXF_ENTITIES_AcDbEntity = 100; + DXF_ENTITIES_MODEL_OR_PAPER_SPACE = 67; // default=0=model, 1=paper + DXF_ENTITIES_VISIBILITY = 60; // default=0 = Visible, 1 = Invisible + + // Obtained from http://www.generalcadd.com/pdf/LivingWithAutoCAD_v4.pdf + // Valid for DXF up to AutoCad 2004, after that RGB is available + AUTOCAD_COLOR_PALETTE: array[0..15] of TFPColor = + ( + (Red: $0000; Green: $0000; Blue: $0000; Alpha: alphaOpaque), // 0 - Black + (Red: $0000; Green: $0000; Blue: $8080; Alpha: alphaOpaque), // 1 - Dark blue + (Red: $0000; Green: $8080; Blue: $0000; Alpha: alphaOpaque), // 2 - Dark green + (Red: $0000; Green: $8080; Blue: $8080; Alpha: alphaOpaque), // 3 - Dark cyan + (Red: $8080; Green: $0000; Blue: $0000; Alpha: alphaOpaque), // 4 - Dark red + (Red: $8080; Green: $0000; Blue: $8080; Alpha: alphaOpaque), // 5 - Dark Magenta + (Red: $8080; Green: $8080; Blue: $0000; Alpha: alphaOpaque), // 6 - Dark + (Red: $c0c0; Green: $c0c0; Blue: $c0c0; Alpha: alphaOpaque), // 7 - Light Gray + (Red: $8080; Green: $8080; Blue: $8080; Alpha: alphaOpaque), // 8 - Medium Gray + (Red: $0000; Green: $0000; Blue: $ffff; Alpha: alphaOpaque), // 9 - Light blue + (Red: $0000; Green: $ffff; Blue: $0000; Alpha: alphaOpaque), // 10 - Light green + (Red: $0000; Green: $ffff; Blue: $ffff; Alpha: alphaOpaque), // 11 - Light cyan + (Red: $ffff; Green: $0000; Blue: $0000; Alpha: alphaOpaque), // 12 - Light red + (Red: $ffff; Green: $0000; Blue: $ffff; Alpha: alphaOpaque), // 13 - Light Magenta + (Red: $ffff; Green: $ffff; Blue: $0000; Alpha: alphaOpaque), // 14 - Light Yellow + (Red: $ffff; Green: $ffff; Blue: $ffff; Alpha: alphaOpaque) // 15 - White + ); + +{ TDXFToken } + +constructor TDXFToken.Create; +begin + inherited Create; + + Childs := TDXFTokens.Create; +end; + +destructor TDXFToken.Destroy; +begin + Childs.Free; + + inherited Destroy; +end; + +{ TDXFTokenizer } + +constructor TDXFTokenizer.Create; +begin + inherited Create; + + Tokens := TDXFTokens.Create; +end; + +destructor TDXFTokenizer.Destroy; +begin + Tokens.Free; + + inherited Destroy; +end; + +procedure TDXFTokenizer.ReadFromStrings(AStrings: TStrings); +var + i: Integer; + StrSectionGroupCode, StrSectionName: string; + IntSectionGroupCode: Integer; + CurTokenBase, NextTokenBase, SectionTokenBase: TDXFTokens; + NewToken: TDXFToken; + ParserState: Integer; +begin + // Tokens.ForEachCall(); deletecallback + Tokens.Clear; + + CurTokenBase := Tokens; + NextTokenBase := Tokens; + i := 0; + ParserState := 0; + + while i < AStrings.Count - 1 do + begin + CurTokenBase := NextTokenBase; + + // Now read and process the section name + StrSectionGroupCode := AStrings.Strings[i]; + IntSectionGroupCode := StrToInt(Trim(StrSectionGroupCode)); + StrSectionName := AStrings.Strings[i+1]; + + NewToken := TDXFToken.Create; + NewToken.GroupCode := IntSectionGroupCode; + NewToken.StrValue := StrSectionName; + + // Waiting for a section + if ParserState = 0 then + begin + if (StrSectionName = 'SECTION') then + begin + ParserState := 1; + NextTokenBase := NewToken.Childs; + end + else if (StrSectionName = 'EOF') then + begin + Exit; + end + else + begin + raise Exception.Create(Format( + 'TDXFTokenizer.ReadFromStrings: Expected SECTION, but got: %s', [StrSectionname])); + end; + end + // Processing the section name + else if ParserState = 1 then + begin + if (StrSectionName = 'HEADER') or + (StrSectionName = 'CLASSES') or + (StrSectionName = 'TABLES') or + (StrSectionName = 'BLOCKS') or + (StrSectionName = 'OBJECTS') or + (StrSectionName = 'THUMBNAILIMAGE') then + begin + ParserState := 2; + SectionTokenBase := CurTokenBase; + end + else if (StrSectionName = 'ENTITIES') then + begin + ParserState := 3; + SectionTokenBase := CurTokenBase; + end + else + begin + raise Exception.Create(Format( + 'TDXFTokenizer.ReadFromStrings: Invalid section name: %s', [StrSectionname])); + end; + end + // Reading a generic section + else if ParserState = 2 then + begin + if StrSectionName = 'ENDSEC' then + begin + ParserState := 0; + CurTokenBase := SectionTokenBase; + NextTokenBase := Tokens; + end; + end + // Reading the ENTITIES section + else if ParserState = 3 then + begin + if IsENTITIES_Subsection(StrSectionName) then + begin + CurTokenBase := SectionTokenBase; + NextTokenBase := NewToken.Childs; + end + else if StrSectionName = 'ENDSEC' then + begin + ParserState := 0; + CurTokenBase := SectionTokenBase; + NextTokenBase := Tokens; + end; + end; + + CurTokenBase.Add(NewToken); + + Inc(i, 2); + end; +end; + +function TDXFTokenizer.IsENTITIES_Subsection(AStr: string): Boolean; +begin + Result := + (AStr = '3DFACE') or + (AStr = '3DSOLID') or + (AStr = 'ACAD_PROXY_ENTITY') or + (AStr = 'ARC') or + (AStr = 'ATTDEF') or + (AStr = 'ATTRIB') or + (AStr = 'BODY') or + (AStr = 'CIRCLE') or + (AStr = 'DIMENSION') or + (AStr = 'ELLIPSE') or + (AStr = 'HATCH') or + (AStr = 'IMAGE') or + (AStr = 'INSERT') or + (AStr = 'LEADER') or + (AStr = 'LINE') or + (AStr = 'LWPOLYLINE') or + (AStr = 'MLINE') or + (AStr = 'MTEXT') or + (AStr = 'OLEFRAME') or + (AStr = 'OLE2FRAME') or + (AStr = 'POINT') or + (AStr = 'POLYLINE') or + (AStr = 'RAY') or + (AStr = 'REGION') or + (AStr = 'SEQEND') or + (AStr = 'SHAPE') or + (AStr = 'SOLID') or + (AStr = 'SPLINE') or + (AStr = 'TEXT') or + (AStr = 'TOLERANCE') or + (AStr = 'TRACE') or + (AStr = 'VERTEX') or + (AStr = 'VIEWPORT') or + (AStr = 'XLINE'); +end; + +{ TvDXFVectorialReader } + +procedure TvDXFVectorialReader.ReadHEADER(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i, j: Integer; + CurToken: TDXFToken; + CurField: P3DPoint; +begin + i := 0; + while i < ATokens.Count do + begin + CurToken := TDXFToken(ATokens.Items[i]); + if CurToken.StrValue = '$ANGBASE' then + begin + CurToken := TDXFToken(ATokens.Items[i+1]); + ANGBASE := StrToFloat(CurToken.StrValue, FPointSeparator); + Inc(i); + end + else if CurToken.StrValue = '$ANGDIR' then + begin + CurToken := TDXFToken(ATokens.Items[i+1]); + ANGDIR := StrToInt(CurToken.StrValue); + Inc(i); + end + // This indicates the size of the document + else if (CurToken.StrValue = '$INSBASE') or + (CurToken.StrValue = '$EXTMIN') or (CurToken.StrValue = '$EXTMAX') or + (CurToken.StrValue = '$LIMMIN') or (CurToken.StrValue = '$LIMMAX') then + begin + if (CurToken.StrValue = '$INSBASE') then CurField := @INSBASE + else if (CurToken.StrValue = '$EXTMIN') then CurField := @EXTMIN + else if (CurToken.StrValue = '$EXTMAX') then CurField := @EXTMAX + else if (CurToken.StrValue = '$LIMMIN') then CurField := @LIMMIN + else if (CurToken.StrValue = '$LIMMAX') then CurField := @LIMMAX; + + // Check the next 2 items and verify if they are the values of the size of the document + for j := 0 to 1 do + begin + CurToken := TDXFToken(ATokens.Items[i+1]); + case CurToken.GroupCode of + 10: + begin; + CurField^.X := StrToFloat(CurToken.StrValue, FPointSeparator); + Inc(i); + end; + 20: + begin + CurField^.Y := StrToFloat(CurToken.StrValue, FPointSeparator); + Inc(i); + end; + end; + end; + end; + + Inc(i); + end; + + // After getting all the data, we can try to make some sense out of it + + // Sometimes EXTMIN comes as 10^20 and EXTMAX as -10^20, which makes no sence + // In these cases we need to ignore them. + if (EXTMIN.X > 10000000000) or (EXTMIN.X < -10000000000) + or (EXTMAX.X > 10000000000) or (EXTMAX.X < -10000000000) then + begin + DOC_OFFSET.X := 0; + DOC_OFFSET.Y := 0; + + AData.Width := LIMMAX.X; + AData.Height := LIMMAX.Y; + end + else + begin + // The size of the document seams to be given by: + // DOC_SIZE = min(EXTMAX, LIMMAX) - DOC_OFFSET; + // if EXTMIN is <> -infinite then DOC_OFFSET = EXTMIN else DOC_OFFSET = (0, 0) + // We will shift the whole document so that it has only positive coordinates and + // DOC_OFFSET will be utilized for that + + if EXTMIN.X > -100 then + begin + DOC_OFFSET.X := EXTMIN.X; + DOC_OFFSET.Y := EXTMIN.Y; + end + else FillChar(DOC_OFFSET, sizeof(T3DPoint), #0); + + AData.Width := min(EXTMAX.X, LIMMAX.X) - DOC_OFFSET.X; + AData.Height := min(EXTMAX.Y, LIMMAX.Y) - DOC_OFFSET.Y; + end; +end; + +procedure TvDXFVectorialReader.ReadENTITIES(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i: Integer; + CurToken: TDXFToken; +begin + IsReadingPolyline := False; + + for i := 0 to ATokens.Count - 1 do + begin + CurToken := TDXFToken(ATokens.Items[i]); + if CurToken.StrValue = 'ARC' then ReadENTITIES_ARC(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'CIRCLE' then ReadENTITIES_CIRCLE(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'DIMENSION' then ReadENTITIES_DIMENSION(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'ELLIPSE' then ReadENTITIES_ELLIPSE(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'LINE' then ReadENTITIES_LINE(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'TEXT' then ReadENTITIES_TEXT(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'LWPOLYLINE' then ReadENTITIES_LWPOLYLINE(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'SPLINE' then ReadENTITIES_SPLINE(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'POINT' then ReadENTITIES_POINT(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'MTEXT' then ReadENTITIES_MTEXT(CurToken.Childs, AData, ADoc) + // A Polyline can have multiple child objects + else if CurToken.StrValue = 'POLYLINE' then + begin + IsReadingPolyline := True; + ReadENTITIES_POLYLINE(CurToken.Childs, AData, ADoc); + end + else if CurToken.StrValue = 'VERTEX' then ReadENTITIES_VERTEX(CurToken.Childs, AData, ADoc) + else if CurToken.StrValue = 'SEQEND' then + begin + ReadENTITIES_SEQEND(CurToken.Childs, AData, ADoc); + IsReadingPolyline := False; + end + else + begin + // ... + end; + end; +end; + +procedure TvDXFVectorialReader.ReadENTITIES_LINE(ATokens: TDXFTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + // LINE + LineStartX, LineStartY, LineStartZ: Double; + LineEndX, LineEndY, LineEndZ: Double; + LLineColor: TFPColor; +begin + // Initial values + LineStartX := 0; + LineStartY := 0; + LineStartZ := 0; + LineEndX := 0; + LineEndY := 0; + LineEndZ := 0; + LLineColor := colBlack; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 11, 21, 31, 62] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: LineStartX := CurToken.FloatValue; + 20: LineStartY := CurToken.FloatValue; + 30: LineStartZ := CurToken.FloatValue; + 11: LineEndX := CurToken.FloatValue; + 21: LineEndY := CurToken.FloatValue; + 31: LineEndZ := CurToken.FloatValue; + 62: LLineColor := DXFColorIndexToFPColor(Trunc(CurToken.FloatValue)); + end; + end; + + // Position fixing for documents with negative coordinates + LineStartX := LineStartX - DOC_OFFSET.X; + LineStartY := LineStartY - DOC_OFFSET.Y; + LineEndX := LineEndX - DOC_OFFSET.X; + LineEndY := LineEndY - DOC_OFFSET.Y; + + // And now write it + {$ifdef FPVECTORIALDEBUG} + // WriteLn(Format('Adding Line from %f,%f to %f,%f', [LineStartX, LineStartY, LineEndX, LineEndY])); + {$endif} + AData.StartPath(LineStartX, LineStartY); + AData.AddLineToPath(LineEndX, LineEndY, LLineColor); + AData.EndPath(); +end; + +{ +Arcs are always counter-clockwise in DXF + +100 Subclass marker (AcDbCircle) +39 Thickness (optional; default = 0) +10 Center point (in OCS) DXF: X value; APP: 3D point +20, 30 DXF: Y and Z values of center point (in OCS) +40 Radius +100 Subclass marker (AcDbArc) +50 Start angle (degrees) +51 End angle (degrees) +210 Extrusion direction. (optional; default = 0, 0, 1) DXF: X value; APP: 3D vector +220, 230 DXF: Y and Z values of extrusion direction (optional) +} +procedure TvDXFVectorialReader.ReadENTITIES_ARC(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + CenterX, CenterY, CenterZ, Radius, StartAngle, EndAngle: Double; + LColor: TFPColor; +begin + CenterX := 0.0; + CenterY := 0.0; + CenterZ := 0.0; + Radius := 0.0; + StartAngle := 0.0; + EndAngle := 0.0; + LColor := colBlack; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 40, 50, 51, 62] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: CenterX := CurToken.FloatValue; + 20: CenterY := CurToken.FloatValue; + 30: CenterZ := CurToken.FloatValue; + 40: Radius := CurToken.FloatValue; + 50: StartAngle := CurToken.FloatValue; + 51: EndAngle := CurToken.FloatValue; + 62: LColor := DXFColorIndexToFPColor(Trunc(CurToken.FloatValue)); + end; + end; + + // In DXF the EndAngle is always greater then the StartAngle. + // If it isn't then sum 360 to it to make sure we don't get wrong results + if EndAngle < StartAngle then EndAngle := EndAngle + 360; + + // Position fixing for documents with negative coordinates + CenterX := CenterX - DOC_OFFSET.X; + CenterY := CenterY - DOC_OFFSET.Y; + + {$ifdef FPVECTORIALDEBUG} + WriteLn(Format('Adding Arc Center=%f,%f Radius=%f StartAngle=%f EndAngle=%f', + [CenterX, CenterY, Radius, StartAngle, EndAngle])); + {$endif} + AData.AddCircularArc(CenterX, CenterY, Radius, StartAngle, EndAngle, LColor); +end; + +{ +Group codes Description +100 Subclass marker (AcDbCircle) +39 Thickness (optional; default = 0) +10 Center point (in OCS) DXF: X value; APP: 3D point +20, 30 DXF: Y and Z values of center point (in OCS) +40 Radius +210 Extrusion direction (optional; default = 0, 0, 1) DXF: X value; APP: 3D vector +220, 230 DXF: Y and Z values of extrusion direction (optional) +} +procedure TvDXFVectorialReader.ReadENTITIES_CIRCLE(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + CircleCenterX, CircleCenterY, CircleCenterZ, CircleRadius: Double; +begin + CircleCenterX := 0.0; + CircleCenterY := 0.0; + CircleCenterZ := 0.0; + CircleRadius := 0.0; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 40] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: CircleCenterX := CurToken.FloatValue; + 20: CircleCenterY := CurToken.FloatValue; + 30: CircleCenterZ := CurToken.FloatValue; + 40: CircleRadius := CurToken.FloatValue; + end; + end; + + // Position fixing for documents with negative coordinates + CircleCenterX := CircleCenterX - DOC_OFFSET.X; + CircleCenterY := CircleCenterY - DOC_OFFSET.Y; + + AData.AddCircle(CircleCenterX, CircleCenterY, CircleRadius); +end; + +{ +Group codes Description +100 Subclass marker (AcDbDimension) +2 Name of the block that contains the entities that make up the dimension picture +10 Definition point (in WCS) DXF: X value; APP: 3D point +20, 30 DXF: Y and Z values of definition point (in WCS) +11 Middle point of dimension text (in OCS) DXF: X value; APP: 3D point +21, 31 DXF: Y and Z values of middle point of dimension text (in OCS) +70 Dimension type. + Values 0-6 are integer values that represent the dimension type. + Values 32, 64, and 128 are bit values, which are added to the integer values + (value 32 is always set in R13 and later releases). + 0 = Rotated, horizontal, or vertical; 1 = Aligned; + 2 = Angular; 3 = Diameter; 4 = Radius; + 5 = Angular 3 point; 6 = Ordinate; + 32 = Indicates that the block reference (group code 2) is referenced by this dimension only. + 64 = Ordinate type. This is a bit value (bit 7) used only with integer value 6. + If set, ordinate is X-type; if not set, ordinate is Y-type. + 128 = This is a bit value (bit 8) added to the other group 70 values + if the dimension text has been positioned at a user-defined location + rather than at the default location. +71 Attachment point: + 1 = Top left; 2 = Top center; 3 = Top right; + 4 = Middle left; 5 = Middle center; 6 = Middle right; + 7 = Bottom left; 8 = Bottom center; 9 = Bottom right +72 Dimension text line spacing style (optional): + 1(or missing) = At least (taller characters will override) + 2 = Exact (taller characters will not override) +41 Dimension text line spacing factor (optional): + Percentage of default (3-on-5) line spacing to be applied. Valid values range from 0.25 to 4.00. +42 Actual measurement (optional; read-only value) +1 Dimension text explicitly entered by the user. Optional; default is the measurement. + If null or "<>", the dimension measurement is drawn as the text, + if " " (one blank space), the text is suppressed. Anything else is drawn as the text. +53 The optional group code 53 is the rotation angle of the dimension + text away from its default orientation (the direction of the dimension line) (optional). +51 All dimension types have an optional 51 group code, which indicates the + horizontal direction for the dimension entity. The dimension entity determines + the orientation of dimension text and lines for horizontal, vertical, and + rotated linear dimensions. + This group value is the negative of the angle between the OCS X axis + and the UCS X axis. It is always in the XY plane of the OCS. +210 Extrusion direction (optional; default = 0, 0, 1) DXF: X value; APP: 3D vector +220, 230 DXF: Y and Z values of extrusion direction (optional) +3 Dimension style name + +Aligned Dimension Group Codes + +100 Subclass marker (AcDbAlignedDimension) +12 Insertion point for clones of a dimension-Baseline and Continue (in OCS) DXF: X value; APP: 3D point +22, 32 DXF: Y and Z values of insertion point for clones of a dimension-Baseline and Continue (in OCS) +13 Definition point for linear and angular dimensions (in WCS) DXF: X value; APP: 3D point +23, 33 DXF: Y and Z values of definition point for linear and angular dimensions (in WCS) +14 Definition point for linear and angular dimensions (in WCS) DXF: X value; APP: 3D point +24, 34 DXF: Y and Z values of definition point for linear and angular dimensions (in WCS) + + |--text--|->10,20 + | | + | | + X->14,24 X->13,23 +} +procedure TvDXFVectorialReader.ReadENTITIES_DIMENSION(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + // DIMENSION + BaseLeft, BaseRight, DimensionRight, DimensionLeft, TmpPoint: T3DPoint; + IsAlignedDimension: Boolean = False; +begin + // Initial values + BaseLeft.X := 0; + BaseLeft.Y := 0; + BaseRight.X := 0; + BaseRight.X := 0; + DimensionRight.X := 0; + DimensionRight.Y := 0; + DimensionLeft.X := 0; + DimensionLeft.Y := 0; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 11, 21, 31, 13, 23, 33, 14, 24, 34] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: DimensionRight.X := CurToken.FloatValue; + 20: DimensionRight.Y := CurToken.FloatValue; + 30: DimensionRight.Z := CurToken.FloatValue; + 13: BaseRight.X := CurToken.FloatValue; + 23: BaseRight.Y := CurToken.FloatValue; + 33: BaseRight.Z := CurToken.FloatValue; + 14: BaseLeft.X := CurToken.FloatValue; + 24: BaseLeft.Y := CurToken.FloatValue; + 34: BaseLeft.Z := CurToken.FloatValue; + 100: + begin + if CurToken.StrValue = 'AcDbAlignedDimension' then IsAlignedDimension := True; + end; + end; + end; + + // And now write it + {$ifdef FPVECTORIALDEBUG} +// WriteLn(Format('Adding Line from %f,%f to %f,%f', [LineStartX, LineStartY, LineEndX, LineEndY])); + {$endif} + if IsAlignedDimension then + begin + // Now make sure that we actually that BaseLeft is to the left of BaseRight + if BaseRight.X < BaseLeft.X then + begin + TmpPoint := BaseRight; + BaseRight := BaseLeft; + BaseLeft := TmpPoint; + end; + + // Now check if we are a horizontal or vertical dimension + + // horizontal + // + //DL____ DR + // | | + // | | + // BL BR + if DimensionRight.X = BaseRight.X then + begin + DimensionLeft.X := BaseLeft.X; + DimensionLeft.Y := DimensionRight.Y; + end + // vertical + // + // BL ----|DR + // BR --|DL + // + // In this case we invert then DR and DL + else if DimensionRight.Y = BaseLeft.Y then + begin + DimensionLeft := DimensionRight; + DimensionRight.Y := BaseRight.Y; + end + // vertical + // + // BL ----|DL + // BR --|DR + // + else if DimensionRight.Y = BaseRight.Y then + begin + DimensionLeft.X := DimensionRight.X; + DimensionLeft.Y := BaseLeft.Y; + end; + + AData.AddAlignedDimension(BaseLeft, BaseRight, DimensionLeft, DimensionRight); + end; +end; + +{ +100 Subclass marker (AcDbEllipse) +10 Center point (in WCS) DXF: X value; APP: 3D point +20, 30 DXF: Y and Z values of center point (in WCS) +11 Endpoint of major axis, relative to the center (in WCS) DXF: X value; APP: 3D point +21, 31 DXF: Y and Z values of endpoint of major axis, relative to the center (in WCS) +210 Extrusion direction (optional; default = 0, 0, 1) DXF: X value; APP: 3D vector +220, 230 DXF: Y and Z values of extrusion direction (optional) +40 Ratio of minor axis to major axis +41 Start parameter (this value is 0.0 for a full ellipse) +42 End parameter (this value is 2pi for a full ellipse) +} +procedure TvDXFVectorialReader.ReadENTITIES_ELLIPSE(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + CenterX, CenterY, CenterZ, MajorHalfAxis, MinorHalfAxis, Angle: Double; +begin + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: CenterX := CurToken.FloatValue; + 20: CenterY := CurToken.FloatValue; + 30: CenterZ := CurToken.FloatValue; + end; + end; + + // Position fixing for documents with negative coordinates + CenterX := CenterX - DOC_OFFSET.X; + CenterY := CenterY - DOC_OFFSET.Y; + + // + AData.AddEllipse(CenterX, CenterY, MajorHalfAxis, MinorHalfAxis, Angle); +end; + +{ +100 Subclass marker (AcDbText) +39 Thickness (optional; default = 0) +10 First alignment point (in OCS) DXF: X value; APP: 3D point +20, 30 DXF: Y and Z values of first alignment point (in OCS) +40 Text height +1 Default value (the string itself) +50 Text rotation (optional; default = 0) +41 Relative X scale factor-width (optional; default = 1) + This value is also adjusted when fit-type text is used. +51 Oblique angle (optional; default = 0) +7 Text style name (optional, default = STANDARD) +71 Text generation flags (optional, default = 0): + 2 = Text is backward (mirrored in X). + 4 = Text is upside down (mirrored in Y). +72 Horizontal text justification type (optional, default = 0) integer codes (not bit-coded) + 0 = Left; 1= Center; 2 = Right + 3 = Aligned (if vertical alignment = 0) + 4 = Middle (if vertical alignment = 0) + 5 = Fit (if vertical alignment = 0) + See the Group 72 and 73 integer codes table for clarification. +11 Second alignment point (in OCS) (optional) + DXF: X value; APP: 3D point + This value is meaningful only if the value of a 72 or 73 group is nonzero (if the justification is anything other than baseline/left). +21, 31 DXF: Y and Z values of second alignment point (in OCS) (optional) +210 Extrusion direction (optional; default = 0, 0, 1) + DXF: X value; APP: 3D vector +220, 230 DXF: Y and Z values of extrusion direction (optional) +73 Vertical text justification type (optional, default = 0): integer codes (not bit- coded): + 0 = Baseline; 1 = Bottom; 2 = Middle; 3 = Top + See the Group 72 and 73 integer codes table for clarification. +} +procedure TvDXFVectorialReader.ReadENTITIES_TEXT(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + PosX: Double = 0.0; + PosY: Double = 0.0; + PosZ: Double = 0.0; + FontSize: Double = 10.0; + Str: string = ''; +begin + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 40] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 1: Str := CurToken.StrValue; + 10: PosX := CurToken.FloatValue; + 20: PosY := CurToken.FloatValue; + 30: PosZ := CurToken.FloatValue; + 40: FontSize := CurToken.FloatValue; + end; + end; + + // Position fixing for documents with negative coordinates + PosX := PosX - DOC_OFFSET.X; + PosY := PosY - DOC_OFFSET.Y; + + // + AData.AddText(PosX, PosY, '', Round(FontSize), Str); +end; + +{.$define FPVECTORIALDEBUG_LWPOLYLINE} +procedure TvDXFVectorialReader.ReadENTITIES_LWPOLYLINE(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i, curPoint: Integer; + // LINE + LWPolyline: array of TLWPOLYLINEElement; +begin + curPoint := -1; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 11, 21, 31] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + // Loads the coordinates + // With Position fixing for documents with negative coordinates + case CurToken.GroupCode of + 10: + begin + // Starting a new point + Inc(curPoint); + SetLength(LWPolyline, curPoint+1); + + LWPolyline[curPoint].X := CurToken.FloatValue - DOC_OFFSET.X; + end; + 20: LWPolyline[curPoint].Y := CurToken.FloatValue - DOC_OFFSET.Y; + end; + end; + + // And now write it + if curPoint >= 0 then // otherwise the polyline is empty of points + begin + AData.StartPath(LWPolyline[0].X, LWPolyline[0].Y); + {$ifdef FPVECTORIALDEBUG_LWPOLYLINE} + Write(Format('LWPOLYLINE ID=%d %f,%f', [AData.PathCount-1, LWPolyline[0].X, LWPolyline[0].Y])); + {$endif} + for i := 1 to curPoint do + begin + AData.AddLineToPath(LWPolyline[i].X, LWPolyline[i].Y); + {$ifdef FPVECTORIALDEBUG_LWPOLYLINE} + Write(Format(' %f,%f', [LWPolyline[i].X, LWPolyline[i].Y])); + {$endif} + end; + {$ifdef FPVECTORIALDEBUG_LWPOLYLINE} + WriteLn(''); + {$endif} + AData.EndPath(); + end; +end; + +{.$define FPVECTORIALDEBUG_SPLINE} +procedure TvDXFVectorialReader.ReadENTITIES_SPLINE(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i, curPoint: Integer; + // LINE + SPLine: array of TSPLineElement; +begin + curPoint := -1; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 11, 21, 31] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + // Loads the coordinates + // With Position fixing for documents with negative coordinates + case CurToken.GroupCode of + 10: + begin + // Starting a new point + Inc(curPoint); + SetLength(SPLine, curPoint+1); + + SPLine[curPoint].X := CurToken.FloatValue - DOC_OFFSET.X; + end; + 20: SPLine[curPoint].Y := CurToken.FloatValue - DOC_OFFSET.Y; + end; + end; + + // And now write it + if curPoint >= 0 then // otherwise the polyline is empty of points + begin + AData.StartPath(SPLine[0].X, SPLine[0].Y); + {$ifdef FPVECTORIALDEBUG_SPLINE} + Write(Format('SPLINE ID=%d %f,%f', [AData.PathCount-1, SPLine[0].X, SPLine[0].Y])); + {$endif} + for i := 1 to curPoint do + begin + AData.AddLineToPath(SPLine[i].X, SPLine[i].Y); + {$ifdef FPVECTORIALDEBUG_SPLINE} + Write(Format(' %f,%f', [SPLine[i].X, SPLine[i].Y])); + {$endif} + end; + {$ifdef FPVECTORIALDEBUG_SPLINE} + WriteLn(''); + {$endif} + AData.EndPath(); + end; +end; + +procedure TvDXFVectorialReader.ReadENTITIES_POLYLINE(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +begin + SetLength(Polyline, 0); +end; + +procedure TvDXFVectorialReader.ReadENTITIES_VERTEX(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i, curPoint: Integer; +begin + if not IsReadingPolyline then raise Exception.Create('[TvDXFVectorialReader.ReadENTITIES_VERTEX] Unexpected record: VERTEX before a POLYLINE'); + + curPoint := Length(Polyline); + SetLength(Polyline, curPoint+1); + Polyline[curPoint].X := 0; + Polyline[curPoint].Y := 0; + Polyline[curPoint].Color := colBlack; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 62] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + // Loads the coordinates + // With Position fixing for documents with negative coordinates + case CurToken.GroupCode of + 10: Polyline[curPoint].X := CurToken.FloatValue - DOC_OFFSET.X; + 20: Polyline[curPoint].Y := CurToken.FloatValue - DOC_OFFSET.Y; + 62: Polyline[curPoint].Color := DXFColorIndexToFPColor(Trunc(CurToken.FloatValue)); + end; + end; +end; + +{$define FPVECTORIALDEBUG_POLYLINE} +procedure TvDXFVectorialReader.ReadENTITIES_SEQEND(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i: Integer; +begin + if not IsReadingPolyline then raise Exception.Create('[TvDXFVectorialReader.ReadENTITIES_SEQEND] Unexpected record: SEQEND before a POLYLINE'); + + // Write the Polyline to the document + if Length(Polyline) >= 0 then // otherwise the polyline is empty of points + begin + AData.StartPath(Polyline[0].X, Polyline[0].Y); + {$ifdef FPVECTORIALDEBUG_POLYLINE} + Write(Format('POLYLINE %f,%f', [Polyline[0].X, Polyline[0].Y])); + {$endif} + for i := 1 to Length(Polyline)-1 do + begin + AData.AddLineToPath(Polyline[i].X, Polyline[i].Y, Polyline[i].Color); + {$ifdef FPVECTORIALDEBUG_POLYLINE} + Write(Format(' %f,%f', [Polyline[i].X, Polyline[i].Y])); + {$endif} + end; + {$ifdef FPVECTORIALDEBUG_POLYLINE} + WriteLn(''); + {$endif} + AData.EndPath(); + end; +end; + +procedure TvDXFVectorialReader.ReadENTITIES_MTEXT(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + PosX: Double = 0.0; + PosY: Double = 0.0; + PosZ: Double = 0.0; + FontSize: Double = 10.0; + Str: string = ''; +begin + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 40] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 1: Str := CurToken.StrValue; + 10: PosX := CurToken.FloatValue; + 20: PosY := CurToken.FloatValue; + 30: PosZ := CurToken.FloatValue; + 40: FontSize := CurToken.FloatValue; + end; + end; + + // Position fixing for documents with negative coordinates + PosX := PosX - DOC_OFFSET.X; + PosY := PosY - DOC_OFFSET.Y; + + // + AData.AddText(PosX, PosY, '', Round(FontSize), Str); +end; + +procedure TvDXFVectorialReader.ReadENTITIES_POINT(ATokens: TDXFTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + CurToken: TDXFToken; + i: Integer; + CircleCenterX, CircleCenterY, CircleCenterZ, CircleRadius: Double; +begin + CircleCenterX := 0.0; + CircleCenterY := 0.0; + CircleCenterZ := 0.0; + CircleRadius := 1.0; + + for i := 0 to ATokens.Count - 1 do + begin + // Now read and process the item name + CurToken := TDXFToken(ATokens.Items[i]); + + // Avoid an exception by previously checking if the conversion can be made + if CurToken.GroupCode in [10, 20, 30, 40] then + begin + CurToken.FloatValue := StrToFloat(Trim(CurToken.StrValue), FPointSeparator); + end; + + case CurToken.GroupCode of + 10: CircleCenterX := CurToken.FloatValue; + 20: CircleCenterY := CurToken.FloatValue; + 30: CircleCenterZ := CurToken.FloatValue; +// 40: CircleRadius := CurToken.FloatValue; + end; + end; + + // Position fixing for documents with negative coordinates + CircleCenterX := CircleCenterX - DOC_OFFSET.X; + CircleCenterY := CircleCenterY - DOC_OFFSET.Y; + + AData.AddCircle(CircleCenterX, CircleCenterY, CircleRadius); +end; + +function TvDXFVectorialReader.GetCoordinateValue(AStr: shortstring): Double; +begin + Result := 0.0; + +{ if Length(AStr) <= 1 then Exit; + + Result := StrToFloat(Copy(AStr, 2, Length(AStr) - 1));} +end; + +function TvDXFVectorialReader.DXFColorIndexToFPColor(AColorIndex: Integer): TFPColor; +begin + if (AColorIndex >= 0) and (AColorIndex <= 15) then + Result := AUTOCAD_COLOR_PALETTE[AColorIndex] + else + raise Exception.Create(Format('[TvDXFVectorialReader.DXFColorIndexToFPVColor] Invalid DXF Color Index: %d', [AColorIndex])); +end; + +constructor TvDXFVectorialReader.Create; +begin + inherited Create; + + FPointSeparator := DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := '#';// disable the thousand separator + + // Default HEADER data + ANGBASE := 0.0; // Starts pointing to the right / east + ANGDIR := 0; // counter-clock wise + + Tokenizer := TDXFTokenizer.Create; +end; + +destructor TvDXFVectorialReader.Destroy; +begin + Tokenizer.Free; + + inherited Destroy; +end; + +{@@ + The information of each separate path is lost in G-Code files + Only one path uniting all of them is created when reading G-Code +} +procedure TvDXFVectorialReader.ReadFromStrings(AStrings: TStrings; + AData: TvVectorialDocument); +var + i: Integer; + CurToken, CurTokenFirstChild: TDXFToken; + lPage: TvVectorialPage; +begin + Tokenizer.ReadFromStrings(AStrings); + + lPage := AData.AddPage(); + + for i := 0 to Tokenizer.Tokens.Count - 1 do + begin + CurToken := TDXFToken(Tokenizer.Tokens.Items[i]); + CurTokenFirstChild := TDXFToken(CurToken.Childs.Items[0]); + + if CurTokenFirstChild.StrValue = 'HEADER' then + ReadHEADER(CurToken.Childs, lPage, AData) + else if CurTokenFirstChild.StrValue = 'ENTITIES' then + ReadENTITIES(CurToken.Childs, lPage, AData); + end; +end; + +initialization + + RegisterVectorialReader(TvDXFVectorialReader, vfDXF); + +end. + diff --git a/components/fpvectorial/epsvectorialreader.pas b/components/fpvectorial/epsvectorialreader.pas new file mode 100644 index 0000000000..21b775d64e --- /dev/null +++ b/components/fpvectorial/epsvectorialreader.pas @@ -0,0 +1,2301 @@ +{ +Reads EPS files + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + +Documentation: http://www.tailrecursive.org/postscript/postscript.html + +Good reference: http://atrey.karlin.mff.cuni.cz/~milanek/PostScript/Reference/PSL2e.html +} +unit epsvectorialreader; + +{$mode objfpc}{$H+} + +{.$define FPVECTORIALDEBUG_PATHS} +{.$define FPVECTORIALDEBUG_COLORS} +{.$define FPVECTORIALDEBUG_ROLL} +{.$define FPVECTORIALDEBUG_CODEFLOW} +{.$define FPVECTORIALDEBUG_INDEX} +{.$define FPVECTORIALDEBUG_DICTIONARY} +{.$define FPVECTORIALDEBUG_CONTROL} +{.$define FPVECTORIALDEBUG_ARITHMETIC} +{.$define FPVECTORIALDEBUG_CLIP_REGION} + +interface + +uses + Classes, SysUtils, Math, contnrs, + fpimage, fpcanvas, + fpvectorial, fpvutils; + +type + TPSTokenType = (ttComment, ttFloat); + + TPSTokens = TFPList;// TPSToken; + + TPSToken = class + StrValue: string; + FloatValue: double; + IntValue: Integer; + BoolValue: Boolean; + Line: Integer; // To help debugging + function Duplicate: TPSToken; virtual; + end; + + TCommentToken = class(TPSToken) + end; + + { TProcedureToken } + + TProcedureToken = class(TPSToken) + Levels: Integer; // Used to count groups inside groups and find the end of a top-level group + Childs: TPSTokens; + Parsed: Boolean; + constructor Create; + destructor Destroy; override; + end; + + TETType = (ettNamedElement, ettOperand, ettOperator, ettDictionary); + + { TExpressionToken } + + TExpressionToken = class(TPSToken) + public + ETType: TETType; + function IsExpressionOperand: Boolean; + procedure PrepareFloatValue; + function Duplicate: TPSToken; override; + end; + + TPostScriptScannerState = (ssSearchingToken, ssInComment, ssInDefinition, ssInGroup, ssInExpressionElement); + + { TGraphicState } + + TGraphicState = class + public + Color: TFPColor; + TranslateX, TranslateY: Double; + ScaleX, ScaleY: Double; // not used currently + ClipPath: TPath; + ClipMode: TvClipMode; + OverPrint: Boolean; // not used currently + // + PenWidth: Integer; + // + function Duplicate: TGraphicState; + end; + + { TPSTokenizer } + + TPSTokenizer = class + public + Tokens: TPSTokens; + FCurLine: Integer; + constructor Create(ACurLine: Integer = -1); + destructor Destroy; override; + procedure ReadFromStream(AStream: TStream); + procedure DebugOut(); + function IsValidPostScriptChar(AChar: Byte): Boolean; + function IsPostScriptSpace(AChar: Byte): Boolean; + function IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean; + end; + + { TvEPSVectorialReader } + + TvEPSVectorialReader = class(TvCustomVectorialReader) + private + Stack: TObjectStack; + GraphicStateStack: TObjectStack; // TGraphicState + Dictionary: TStringList; + ExitCalled: Boolean; + CurrentGraphicState: TGraphicState; + // + procedure DebugStack(); + // + procedure RunPostScript(ATokens: TPsTokens; AData: TvVectorialPage; ADoc: TvVectorialDocument); + // + procedure ExecuteProcedureToken(AToken: TProcedureToken; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ExecuteOperatorToken(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument); + function ExecuteArithmeticAndMathOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecutePathConstructionOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteGraphicStateOperatorsDI(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteGraphicStateOperatorsDD(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteDictionaryOperators(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteMiscellaneousOperators(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteStackManipulationOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteControlOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecutePaintingOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteDeviceSetupAndOutputOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteArrayOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + function ExecuteStringOperator(AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; + // + procedure PostScriptCoordsToFPVectorialCoords(AParam1, AParam2: TPSToken; var APosX, APosY: Double); + function DictionarySubstituteOperator(ADictionary: TStringList; var ACurToken: TPSToken): Boolean; + public + { General reading methods } + Tokenizer: TPSTokenizer; + constructor Create; override; + Destructor Destroy; override; + procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override; + end; + +implementation + +type + TStackAccess = class(TObjectStack) + end; + +var + FPointSeparator: TFormatSettings; + +{ TGraphicState } + +function TGraphicState.Duplicate: TGraphicState; +begin + Result := TGraphicState(Self.ClassType.Create); + Result.Color := Color; + Result.TranslateX := TranslateX; + Result.TranslateY := TranslateY; + Result.ScaleX := ScaleX; + Result.ScaleY := ScaleY; + Result.ClipPath := ClipPath; + Result.ClipMode := ClipMode; + Result.OverPrint := OverPrint; + Result.PenWidth := PenWidth; +end; + +{ TPSToken } + +function TPSToken.Duplicate: TPSToken; +begin + Result := TPSToken(Self.ClassType.Create); + Result.StrValue := StrValue; + Result.FloatValue := FloatValue; + Result.IntValue := IntValue; + Result.Line := Line; +end; + +{ TProcedureToken } + +constructor TProcedureToken.Create; +begin + inherited Create; + + Childs := TPSTokens.Create; +end; + +destructor TProcedureToken.Destroy; +begin + Childs.Free; + + inherited Destroy; +end; + +{ TExpressionToken } + +function TExpressionToken.IsExpressionOperand: Boolean; +begin + if StrValue = '' then Exit(False); + Result := StrValue[1] in ['0'..'9','-']; +end; + +procedure TExpressionToken.PrepareFloatValue; +begin + //if not IsExpressionOperand() then Exit; + if ETType <> ettOperand then Exit; // faster, because this field should already be filled + + FloatValue := StrToFloat(StrValue, FPointSeparator); +end; + +function TExpressionToken.Duplicate: TPSToken; +begin + Result:=inherited Duplicate; + TExpressionToken(Result).ETType := ETType; +end; + +{$DEFINE FPVECTORIALDEBUG} + +{ TPSTokenizer } + +// ACurLine < 0 indicates that we should use the line of this list of strings +// else we use ACurLine +constructor TPSTokenizer.Create(ACurLine: Integer); +begin + inherited Create; + Tokens := TPSTokens.Create; + FCurLine := ACurLine; +end; + +destructor TPSTokenizer.Destroy; +begin + Tokens.Free; + inherited Destroy; +end; + +{@@ Rules for parsing PostScript files: + +* Coments go from the first occurence of % outside a line to the next new line +* The only accepted characters are printable ASCII ones, plus spacing ASCII chars + See IsValidPostScriptChar about that +} +procedure TPSTokenizer.ReadFromStream(AStream: TStream); +var + i: Integer; + CurChar: Char; + CurLine: Integer = 1; + State: TPostScriptScannerState = ssSearchingToken; + CommentToken: TCommentToken; + ProcedureToken: TProcedureToken; + ExpressionToken: TExpressionToken; + Len: Integer; + lIsEndOfLine: Boolean; +begin + while AStream.Position < AStream.Size do + begin + CurChar := Char(AStream.ReadByte()); +// {$ifdef FPVECTORIALDEBUG} +// WriteLn(Format('Obtained token %s', [CurChar])); +// {$endif} + if not IsValidPostScriptChar(Byte(CurChar)) then + raise Exception.Create('[TPSTokenizer.ReadFromStream] Invalid char: ' + IntToHex(Byte(CurChar), 2)); + + lIsEndOfLine := IsEndOfLine(Byte(CurChar), AStream); + if lIsEndOfLine then Inc(CurLine); + if FCurLine >= 0 then CurLine := FCurLine; + + case State of + { Searching for a token } + ssSearchingToken: + begin + if CurChar = '%' then + begin + CommentToken := TCommentToken.Create; + CommentToken.Line := CurLine; + State := ssInComment; +// {$ifdef FPVECTORIALDEBUG} +// WriteLn(Format('Starting Comment at Line %d', [CurLine])); +// {$endif} + end + else if CurChar = '{' then + begin + ProcedureToken := TProcedureToken.Create; + ProcedureToken.Levels := 1; + ProcedureToken.Line := CurLine; + State := ssInGroup; + end + else if CurChar in ['a'..'z','A'..'Z','0'..'9','-','/'] then + begin + ExpressionToken := TExpressionToken.Create; + ExpressionToken.Line := CurLine; + ExpressionToken.StrValue := ''; + if CurChar = '/' then + ExpressionToken.ETType := ettNamedElement + else + begin + ExpressionToken.StrValue := CurChar; + if ExpressionToken.IsExpressionOperand() then + ExpressionToken.ETType := ettOperand + else + ExpressionToken.ETType := ettOperator; + end; + State := ssInExpressionElement; + end + else if lIsEndOfLine then Continue + else if IsPostScriptSpace(Byte(CurChar)) then Continue + else + raise Exception.Create(Format('[TPSTokenizer.ReadFromStream] Unexpected char while searching for token: $%s in Line %d', + [IntToHex(Byte(CurChar), 2), CurLine])); + end; + + { Passing by comments } + ssInComment: + begin + CommentToken.StrValue := CommentToken.StrValue + CurChar; + if lIsEndOfLine then + begin + Tokens.Add(CommentToken); + State := ssSearchingToken; +// {$ifdef FPVECTORIALDEBUG} +// WriteLn(Format('Adding Comment "%s" at Line %d', [CommentToken.StrValue, CurLine])); +// {$endif} + end; + end; // ssInComment + + // Starts at { and ends in }, passing over nested groups + ssInGroup: + begin + if (CurChar = '{') then ProcedureToken.Levels := ProcedureToken.Levels + 1; + if (CurChar = '}') then ProcedureToken.Levels := ProcedureToken.Levels - 1; + + if ProcedureToken.Levels = 0 then + begin + Tokens.Add(ProcedureToken); + State := ssSearchingToken; + end + else + begin + // Don't add line ends, because they cause problems when outputing the debug info + // but in this case we need to add spaces to compensate, or else items separates only + // by line end might get glued together + if CurChar in [#10, #13] then + ProcedureToken.StrValue := ProcedureToken.StrValue + ' ' + else + ProcedureToken.StrValue := ProcedureToken.StrValue + CurChar; + end; + end; + + // Goes until a space comes, or { + ssInExpressionElement: + begin + if IsPostScriptSpace(Byte(CurChar)) or (CurChar = '{') then + begin + ExpressionToken.PrepareFloatValue(); + Tokens.Add(ExpressionToken); + State := ssSearchingToken; + if (CurChar = '{') then AStream.Seek(-1, soFromCurrent); + end + else + ExpressionToken.StrValue := ExpressionToken.StrValue + CurChar; + end; + + end; // case + end; // while + + // If the stream finished, there might be a token still being built + // so lets finish it + if State = ssInExpressionElement then + begin + Tokens.Add(ExpressionToken); + end; +end; + +procedure TPSTokenizer.DebugOut(); +var + i: Integer; + Token: TPSToken; +begin + for i := 0 to Tokens.Count - 1 do + begin + Token := TPSToken(Tokens.Items[i]); + + if Token is TCommentToken then + begin + WriteLn(Format('TCommentToken StrValue=%s', [Token.StrValue])); + end + else if Token is TProcedureToken then + begin + WriteLn(Format('TProcedureToken StrValue=%s', [Token.StrValue])); + end + else if Token is TExpressionToken then + begin + WriteLn(Format('TExpressionToken StrValue=%s', [Token.StrValue])); + end; + end; +end; + +{@@ Valid PostScript Chars: + +All printable ASCII: a..zA..Z0..9 plus punctuation + +Plus the following white spaces +000 00 0 Null (nul) +011 09 9 Tab (tab) +012 0A 10 Line feed (LF) +014 0C 12 Form feed (FF) +015 0D 13 Carriage return (CR) +040 20 32 Space (SP) +} +function TPSTokenizer.IsValidPostScriptChar(AChar: Byte): Boolean; +begin + Result := ((AChar > 32) and (AChar < 127)) or (AChar in [0, 9, 10, 12, 13, 32]); +end; + +function TPSTokenizer.IsPostScriptSpace(AChar: Byte): Boolean; +begin + Result := AChar in [0, 9, 10, 12, 13, 32]; +end; + +function TPSTokenizer.IsEndOfLine(ACurChar: Byte; AStream: TStream): Boolean; +var + HasNextChar: Boolean = False; + NextChar: Byte; +begin + Result := False; + + if ACurChar = 13 then + begin + if AStream.Position < AStream.Size then + begin + HasNextChar := True; + NextChar := AStream.ReadByte(); + if NextChar <> 10 then AStream.Seek(-1, soFromCurrent); // Go back if it wasnt a #13#10 + Exit(True); + end; + end; + + if ACurChar = 10 then Result := True; +end; + +{$ifndef Windows} +{$define FPVECTORIALDEBUG} +{$endif} + +{ TvEPSVectorialReader } + +procedure TvEPSVectorialReader.DebugStack(); +var + i: Integer; + lToken: TPSToken; +begin + WriteLn('===================='); + WriteLn('Stack dump'); + WriteLn('===================='); + for i := 0 to TStackAccess(Stack).List.Count - 1 do + begin + lToken := TPSToken(TStackAccess(Stack).List.Items[i]); + WriteLn(Format('Stack #%d : %s', [i, lToken.StrValue])); + end; +end; + +procedure TvEPSVectorialReader.RunPostScript(ATokens: TPsTokens; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i: Integer; + lSubstituted: Boolean; + CurToken: TPSToken; +begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.RunPostScript] START'); + {$endif} + if ExitCalled then + begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.RunPostScript] ExitCalled'); + {$endif} + Exit; + end; + for i := 0 to ATokens.Count - 1 do + begin + CurToken := TPSToken(ATokens.Items[i]); + +{ if CurToken.StrValue = 'setrgbcolor' then + begin + WriteLn('==================='); + WriteLn('CMYK__'); + WriteLn('==================='); + DebugStack(); + end;} + + if CurToken is TCommentToken then + begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TCommentToken Token: %s', [CurToken.StrValue])); + {$endif} +// ProcessCommentToken(CurToken as TCommentToken, AData); + Continue; + end; + + if CurToken is TProcedureToken then + begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TProcedureToken Token: %s', [CurToken.StrValue])); + {$endif} + Stack.Push(CurToken); + Continue; + end; + + if CurToken is TExpressionToken then + begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn(Format('[TvEPSVectorialReader.RunPostScript] Type: TExpressionToken Token: %s', [CurToken.StrValue])); + {$endif} + + if TExpressionToken(CurToken).ETType = ettOperand then + begin + Stack.Push(CurToken); + Continue; + end; + + // Now we need to verify if the operator should be substituted in the dictionary + lSubstituted := DictionarySubstituteOperator(Dictionary, CurToken); + + // Check if this is the first time that a named element appears, if yes, don't try to execute it + // just put it into the stack + if (not lSubstituted) and (TExpressionToken(CurToken).ETType = ettNamedElement) then + begin + Stack.Push(CurToken); + Continue; + end; + + if CurToken is TProcedureToken then ExecuteProcedureToken(TProcedureToken(CurToken), AData, ADoc) + else ExecuteOperatorToken(TExpressionToken(CurToken), AData, ADoc); + + if ExitCalled then Break; + end; + end; + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.RunPostScript] END'); + {$endif} +end; + +procedure TvEPSVectorialReader.ExecuteProcedureToken(AToken: TProcedureToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + ProcTokenizer: TPSTokenizer; + lStream: TMemoryStream; + lOldTokens: TPSTokens; + i: Integer; +begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] START'); + {$endif} + if ExitCalled then + begin + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] ExitCalled'); + {$endif} + Exit; + end; + + if not AToken.Parsed then + begin + ProcTokenizer := TPSTokenizer.Create(AToken.Line); + lStream := TMemoryStream.Create; + try + // Copy the string to a Stream + for i := 1 to Length(AToken.StrValue) do + lStream.WriteByte(Byte(AToken.StrValue[i])); + + // Change the Tokens so that it writes directly to AToken.Childs + lOldTokens := ProcTokenizer.Tokens; + ProcTokenizer.Tokens := AToken.Childs; + + // Now parse the procedure code + lStream.Position := 0; + ProcTokenizer.ReadFromStream(lStream); + + // Recover the old tokens for usage in .Free + ProcTokenizer.Tokens := lOldTokens; + finally + lStream.Free; + ProcTokenizer.Free; + end; + + AToken.Parsed := True; + end; + + // Now run the procedure + RunPostScript(AToken.Childs, AData, ADoc); + {$ifdef FPVECTORIALDEBUG_CODEFLOW} + WriteLn('[TvEPSVectorialReader.ExecuteProcedureToken] END'); + {$endif} +end; + +procedure TvEPSVectorialReader.ExecuteOperatorToken(AToken: TExpressionToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + Param1, Param2: TPSToken; +begin + if AToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.ProcessExpressionToken] Empty operator'); + + if ExecuteDictionaryOperators(AToken, AData, ADoc) then Exit; + + if ExecuteArithmeticAndMathOperator(AToken, AData, ADoc) then Exit; + + if ExecutePathConstructionOperator(AToken, AData, ADoc) then Exit; + + if ExecuteGraphicStateOperatorsDI(AToken, AData, ADoc) then Exit; + + if ExecuteGraphicStateOperatorsDD(AToken, AData, ADoc) then Exit; + + if ExecuteControlOperator(AToken, AData, ADoc) then Exit; + + if ExecuteStackManipulationOperator(AToken, AData, ADoc) then Exit; + + if ExecuteMiscellaneousOperators(AToken, AData, ADoc) then Exit; + + if ExecutePaintingOperator(AToken, AData, ADoc) then Exit; + + if ExecuteDeviceSetupAndOutputOperator(AToken, AData, ADoc) then Exit; + + if ExecuteArrayOperator(AToken, AData, ADoc) then Exit; + + if ExecuteStringOperator(AToken, AData, ADoc) then Exit; + + // If we got here, there the command not yet implemented + raise Exception.Create(Format('[TvEPSVectorialReader.ProcessExpressionToken] Unknown PostScript Command "%s" in Line %d', + [AToken.StrValue, AToken.Line])); + +{ File Operators + + filename access file file Open named file with specified access + datasrc|datatgt dict + param1 … paramn filtername filter file Establish filtered file + file closefile – Close file + file read int true Read one character from file + or false + file int write – Write one character to file + file string readhexstring substring bool Read hexadecimal numbers from file into + string + file string writehexstring – Write string to file as hexadecimal + file string readstring substring bool Read string from file + file string writestring – Write string to file + file string readline substring bool Read line from file into string + file token any true Read token from file + or false + file bytesavailable int Return number of bytes available to read + – flush – Send buffered data to standard output file + file flushfile – Send buffered data or read to EOF + file resetfile – Discard buffered characters + file status bool Return status of file (true = valid) + filename status pages bytes referenced created true + or false Return information about named file + filename run – Execute contents of named file + – currentfile file Return file currently being executed + filename deletefile – Delete named file + filename1 filename2 renamefile – Rename file filename1 to filename2 + template proc scratch filenameforall – Execute proc for each file name matching + template + file position setfileposition – Set file to specified position + file fileposition position Return current position in file + string print – Write string to standard output file + any = – Write text representation of any to standard + output file + any == – Write syntactic representation of any to + standard output file + any1 … anyn stack any1 … anyn Print stack nondestructively using = + any1 … anyn pstack any1 … anyn Print stack nondestructively using == + obj tag printobject – Write binary object to standard output file, + using tag + file obj tag writeobject – Write binary object to file, using tag + int setobjectformat – Set binary object format (0 = disable, + 1 = IEEE high, 2 = IEEE low, 3 = native + high, 4 = native low) + – currentobjectformat int Return binary object format +} +{ Resource Operators + + key instance category defineresource instance Register named resource instance in category + key category undefineresource – Remove resource registration + key category findresource instance Return resource instance identified by key in + category + renderingintent findcolorrendering name bool Select CIE-based color rendering dictionary + by rendering intent + key category resourcestatus status size true Return status of resource instance + or false + template proc scratch category resourceforall – Enumerate resource instances in category +} +{ Virtual Memory Operators + + – save save Create VM snapshot + save restore – Restore VM snapshot + bool setglobal – Set VM allocation mode (false = local, + true = global) + – currentglobal bool Return current VM allocation mode + any gcheck bool Return true if any is simple or in global VM, + false if in local VM + bool1 password startjob bool2 Start new job that will alter initial VM if + bool1 is true + index any defineuserobject – Define user object associated with index + index execuserobject – Execute user object associated with index + index undefineuserobject – Remove user object associated with index + – UserObjects array Return current UserObjects array defined in + userdict +} +{ Errors + + configurationerror setpagedevice or setdevparams request + cannot be satisfied + dictfull No more room in dictionary + dictstackoverflow Too many begin operators + dictstackunderflow Too many end operators + execstackoverflow Executive stack nesting too deep + handleerror Called to report error information + interrupt External interrupt request (for example, + Control-C) + invalidaccess Attempt to violate access attribute + invalidexit exit not in loop + invalidfileaccess Unacceptable access string + invalidfont Invalid Font resource name or font or + CIDFont dictionary + invalidrestore Improper restore + ioerror Input/output error + limitcheck Implementation limit exceeded + nocurrentpoint Current point undefined + rangecheck Operand out of bounds + stackoverflow Operand stack overflow + stackunderflow Operand stack underflow + syntaxerror PostScript language syntax error + timeout Time limit exceeded + typecheck Operand of wrong type + undefined Name not known + undefinedfilename File not found + undefinedresource Resource instance not found + undefinedresult Overflow, underflow, or meaningless result + unmatchedmark Expected mark not on stack + unregistered Internal error + VMerror Virtual memory exhausted +} +end; + +{ Operand Stack Manipulation Operators + + any pop – Discard top element + any1 any2 exch ==> any2 any1 Exchange top two elements + any dup ==> any any Duplicate top element + any1 … anyn n copy any1 … anyn any1 … anyn + Duplicate top n elements + anyn … any0 n index anyn … any0 anyn + Duplicate arbitrary element + anyn-1 … any0 n j roll any(j-1) mod n … any0 anyn-1 … anyj mod n + Roll n elements up j times + any1 … anyn clear Discard all elements + any1 … anyn count any1 … anyn n + Count elements on stack + – mark mark Push mark on stack + mark obj1 … objn cleartomark – + Discard elements down through mark + mark obj1 … objn counttomark mark obj1 … objn n + Count elements down to mark +} +function TvEPSVectorialReader.ExecuteStackManipulationOperator( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2, NewToken: TPSToken; + lIndexN, lIndexJ: Integer; + lTokens: array of TPSToken; + i: Integer; +begin + Result := False; + + // Discard top element + if AToken.StrValue = 'pop' then + begin + Param1 := TPSToken(Stack.Pop); + Exit(True); + end; + // Exchange top two elements + if AToken.StrValue = 'exch' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + Stack.Push(Param1); + Stack.Push(Param2); + Exit(True); + end; + // Duplicate top element + if AToken.StrValue = 'dup' then + begin + Param1 := TPSToken(Stack.Pop); + NewToken := Param1.Duplicate(); + Stack.Push(Param1); + Stack.Push(NewToken); + Exit(True); + end; + // anyn … any0 n index anyn … any0 anyn + // Duplicate arbitrary element + if AToken.StrValue = 'index' then + begin + {$ifdef FPVECTORIALDEBUG_INDEX} + WriteLn('[TvEPSVectorialReader.ExecuteStackManipulationOperator] index'); +// DebugStack(); + {$endif} + + Param1 := TPSToken(Stack.Pop); + lIndexN := Round(Param1.FloatValue); + SetLength(lTokens, lIndexN+1); + + if lIndexN < 0 then raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] index operator: n must be positive or zero'); + + // Unroll all elements necessary + + for i := 0 to lIndexN do + begin + lTokens[i] := TPSToken(Stack.Pop); + Param2 := lTokens[i]; + if Param2 = nil then + begin + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteStackManipulationOperator] Stack underflow in operation "index". Error at line %d', [AToken.Line])); + end; + end; + + // Duplicate the disired token + + NewToken := lTokens[lIndexN].Duplicate(); + + // Roll them back + + for i := lIndexN downto 0 do + begin + Stack.Push(lTokens[i]); + end; + + // Roll the duplicated element too + + Stack.Push(NewToken); + + Exit(True); + end; + // anyn-1 … any0 n j roll any(j-1) mod n … any0 anyn-1 … anyj mod n + // + // performs a circular shift of the objects anyn-1 through any0 on the operand stack + // by the amount j. Positive j indicates upward motion on the stack, whereas negative + // j indicates downward motion. + // n must be a nonnegative integer and j must be an integer. roll first removes these + // operands from the stack; there must be at least n additional elements. It then performs + // a circular shift of these n elements by j positions. + // If j is positive, each shift consists of removing an element from the top of the stack + // and inserting it between element n - 1 and element n of the stack, moving all in8.2 + // tervening elements one level higher on the stack. If j is negative, each shift consists + // of removing element n - 1 of the stack and pushing it on the top of the stack, + // moving all intervening elements one level lower on the stack. + // + // Examples N J + // (a) (b) (c) 3 -1 roll => (b) (c) (a) + // (a) (b) (c) 3 1 roll => (c) (a) (b) + // (a) (b) (c) 3 0 roll => (a) (b) (c) + if AToken.StrValue = 'roll' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + lIndexJ := Round(Param1.FloatValue); + lIndexN := Round(Param2.FloatValue); + + {$ifdef FPVECTORIALDEBUG_ROLL} + WriteLn(Format('[TvEPSVectorialReader] roll: N=%d J=%d', [lIndexN, lIndexJ])); + {$endif} + + if lIndexN < 0 then raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] rool operator: n must be positive or zero'); + + if lIndexJ = 0 then Exit; + + SetLength(lTokens, lIndexN); + + // Unroll all elements necessary + + for i := 0 to lIndexN-1 do + begin + lTokens[i] := TPSToken(Stack.Pop()); + Param2 := lTokens[i]; + if Param2 = nil then + begin + raise Exception.Create('[TvEPSVectorialReader.ExecuteStackManipulationOperator] nil element poped in operator index'); + //Exit(True); + end; + end; + + // Roll them back + + if lIndexJ > 0 then + begin + for i := lIndexJ-1 downto 0 do + begin + Stack.Push(lTokens[i]); + end; + for i := lIndexN-1 downto lIndexJ do + begin + Stack.Push(lTokens[i]); + end; + end + else + begin + lIndexJ := -lIndexJ; + + for i := lIndexN-lIndexJ-1 downto 0 do + begin + Stack.Push(lTokens[i]); + end; + for i := lIndexN-1 downto lIndexN-lIndexJ do + begin + Stack.Push(lTokens[i]); + end; + end; + + Exit(True); + end; +end; + +{ Control Operators + + any exec – Execute arbitrary object + bool proc if – Execute proc if bool is true + bool proc1 proc2 ifelse – + Execute proc1 if bool is true, proc2 if false + initial increment limit proc for – + Execute proc with values from initial by steps + of increment to limit + int proc repeat – Execute proc int times + proc loop – Execute proc an indefinite number of times + – exit – Exit innermost active loop + – stop – Terminate stopped context + any stopped bool Establish context for catching stop + – countexecstack int Count elements on execution stack + array execstack subarray Copy execution stack into array + – quit – Terminate interpreter + – start – Executed at interpreter startup + Type, Attribute, and Conversion Operators + any type name Return type of any + any cvlit any Make object literal + any cvx any Make object executable + any xcheck bool Test executable attribute + array|packedarray|file|string executeonly array|packedarray|file|string + Reduce access to execute-only + array|packedarray|dict|file|string noaccess array|packedarray|dict|file|string + Disallow any access + array|packedarray|dict|file|string readonly array|packedarray|dict|file|string + Reduce access to read-only + array|packedarray|dict|file|string rcheck bool Test read access + array|packedarray|dict|file|string wcheck bool Test write access + num|string cvi int Convert to integer + string cvn name Convert to name + num|string cvr real Convert to real + num radix string cvrs substring Convert with radix to string + any string cvs substring Convert to string +} +function TvEPSVectorialReader.ExecuteControlOperator(AToken: TExpressionToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2, Param3, Param4, CounterToken: TPSToken; + NewToken: TExpressionToken; + FloatCounter: Double; +begin + Result := False; + + // Execute proc if bool is true + if AToken.StrValue = 'if' then + begin + Param1 := TPSToken(Stack.Pop); // proc + Param2 := TPSToken(Stack.Pop); // bool + + if not (Param1 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator if requires a procedure. Error at line %d', [AToken.Line])); + + if Param2.BoolValue then ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc); + + Exit(True); + end; + // Execute proc1 if bool is true, proc2 if false + if AToken.StrValue = 'ifelse' then + begin + Param1 := TPSToken(Stack.Pop); // proc2 + Param2 := TPSToken(Stack.Pop); // proc1 + Param3 := TPSToken(Stack.Pop); // bool + + if not (Param1 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator ifelse requires a procedure. Error at line %d', [AToken.Line])); + if not (Param2 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator ifelse requires a procedure. Error at line %d', [AToken.Line])); + + if Param3.BoolValue then ExecuteProcedureToken(TProcedureToken(Param2), AData, ADoc) + else ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc); + + Exit(True); + end; + // Exit innermost active loop + if AToken.StrValue = 'exit' then + begin + ExitCalled := True; + + Exit(True); + end; + { + Establish context for catching stop + + executes any, which is typically, but not necessarily, a procedure, executable file, + or executable string object. If any runs to completion normally, stopped returns false on the operand stack. + + If any terminates prematurely as a result of executing stop, stopped returns + true on the operand stack. Regardless of the outcome, the interpreter resumes execution at the next object in normal sequence after stopped. + This mechanism provides an effective way for a PostScript language program + to "catch" errors or other premature terminations, retain control, and perhaps perform its own error recovery. + + EXAMPLE: + { ... } stopped {handleerror} if + + If execution of the procedure {...} causes an error, + the default error-reporting procedure is invoked (by handleerror). + In any event, normal execution continues at the token following the if. + + ERRORS: stackunderflow + } + if AToken.StrValue = 'stopped' then + begin + {$ifdef FPVECTORIALDEBUG_CONTROL} + WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] stopped'); +// DebugStack(); + {$endif} + + Param1 := TPSToken(Stack.Pop); + + if not (Param1 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator stopped requires a procedure. Error at line %d', [AToken.Line])); + + ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc); + + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := False; + NewToken.StrValue := 'false'; + Stack.Push(NewToken); + + Exit(True); + end; + // Execute proc an indefinite number of times + if AToken.StrValue = 'loop' then + begin + Param1 := TPSToken(Stack.Pop); + + if not (Param1 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator loop requires a procedure. Error at line %d', [AToken.Line])); + + while True do + begin + ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc); + + if ExitCalled then + begin + ExitCalled := False; + Break; + end; + end; + + Exit(True); + end; + { initial increment limit proc for - + + executes proc repeatedly, passing it a sequence of values from initial + by steps of increment to limit. The for operator expects initial, increment, + and limit to be numbers. It maintains a temporary internal variable, known as + the control variable, which it first sets to initial. Then, before each + repetition, it compares the control variable with the termination value limit. + If limit has not been exceeded, it pushes the control variable on the operand + stack, executes proc, and adds increment to the control variable. + + The termination condition depends on whether increment is positive or negative. + If increment is positive, for terminates when the control variable becomes + greater than limit. If increment is negative, for terminates when the control + variable becomes less than limit. If initial meets the termination condition, + for does not execute proc at all. If proc executes the exit operator, + for terminates prematurely. + + Usually, proc will use the value on the operand stack for some purpose. + However, if proc does not remove the value, it will remain there. + Successive executions of proc will cause successive values of the control + variable to accumulate on the operand stack. + + EXAMPLE: + 0 1 1 4 {add} for -> 10 + 1 2 6 { } for -> 1 3 5 + 3 -.5 1 {-> } for -> 3.0 2.5 2.0 1.5 1.0 + + In the first example, the value of the control variable is added to whatever + is on the stack, so 1, 2, 3, and 4 are added in turn to a running sum whose + initial value is 0. The second example has an empty procedure, so the + successive values of the control variable are left on the stack. The + last example counts backward from 3 to 1 by halves, leaving the successive + values on the stack. + + Beware of using reals instead of integers for any of the first three operands. + Most real numbers are not represented exactly. This can cause an error to + accumulate in the value of the control variable, with possibly surprising results. + In particular, if the difference between initial and limit is a multiple of + increment, as in the third line of the example, the control variable may not + achieve the limit value. + + ERRORS: stackoverflow stackunderflow, typecheck + + SEE ALSO: repeat, loop, forall, exit + } + if AToken.StrValue = 'for' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + Param3 := TPSToken(Stack.Pop); + Param4 := TPSToken(Stack.Pop); + + if not (Param1 is TProcedureToken) then + raise Exception.Create(Format('[TvEPSVectorialReader.ExecuteControlOperator] The operator for requires a procedure. Error at line %d', [AToken.Line])); + + FloatCounter := Param4.FloatValue; + while FloatCounter < Param2.FloatValue do + begin + CounterToken := Param4.Duplicate(); + CounterToken.FloatValue := FloatCounter; + Stack.Push(CounterToken); + + ExecuteProcedureToken(TProcedureToken(Param1), AData, ADoc); + + FloatCounter := FloatCounter + Param3.FloatValue; + + if ExitCalled then + begin + ExitCalled := False; + Break; + end; + end; + + Exit(True); + end; + // tests whether the operand has the executable or the literal attribute, returning true + // if it is executable or false if it is literal + if AToken.StrValue = 'xcheck' then + begin +// {$ifdef FPVECTORIALDEBUG_CONTROL} +// WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] xcheck'); +// DebugStack(); +// {$endif} + + Param1 := TPSToken(Stack.Pop); + + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := (Param1 is TProcedureToken) or + ((Param1 is TExpressionToken) and (TExpressionToken(Param1).ETType = ettOperator)); + if NewToken.BoolValue then NewToken.StrValue := 'true' + else NewToken.StrValue := 'false'; + Stack.Push(NewToken); + + Exit(True); + end; +end; + +{ Painting Operators + + – erasepage – Paint current page white + – stroke – Draw line along current path + – fill – Fill current path with current color + – eofill – Fill using even-odd rule + x y width height rectstroke – Define rectangular path and stroke + x y width height matrix rectstroke – Define rectangular path, concatenate matrix, + and stroke + numarray|numstring rectstroke – Define rectangular paths and stroke + numarray|numstring matrix rectstroke – Define rectangular paths, concatenate + matrix, and stroke + x y width height rectfill – Fill rectangular path + numarray|numstring rectfill – Fill rectangular paths + userpath ustroke – Interpret and stroke userpath + userpath matrix ustroke – Interpret userpath, concatenate matrix, and + stroke + userpath ufill – Interpret and fill userpath + userpath ueofill – Fill userpath using even-odd rule + dict shfill – Fill area defined by shading pattern + dict image – Paint any sampled image + width height bits/sample matrix datasrc image – Paint monochrome sampled image + width height bits/comp matrix + datasrc0 … datasrcncomp-1 multi ncomp colorimage – Paint color sampled image + dict imagemask – Paint current color through mask + width height polarity matrix datasrc imagemask – Paint current color through mask + Insideness-Testing Operators + x y infill bool Test whether (x, y) would be painted by fill + userpath infill bool Test whether pixels in userpath would be + painted by fill + x y ineofill bool Test whether (x, y) would be painted by eofill + userpath ineofill bool Test whether pixels in userpath would be + painted by eofill + x y userpath inufill bool Test whether (x, y) would be painted by ufill + of userpath + userpath1 userpath2 inufill bool Test whether pixels in userpath1 would be + painted by ufill of userpath2 + x y userpath inueofill bool Test whether (x, y) would be painted by + ueofill of userpath + userpath1 userpath2 inueofill bool Test whether pixels in userpath1 would be + painted by ueofill of userpath2 + x y instroke bool Test whether (x, y) would be painted by + stroke + x y userpath inustroke bool Test whether (x, y) would be painted by + ustroke of userpath + x y userpath matrix inustroke bool Test whether (x, y) would be painted by + ustroke of userpath + userpath1 userpath2 inustroke bool Test whether pixels in userpath1 would be + painted by ustroke of userpath2 + userpath1 userpath2 matrix inustroke bool Test whether pixels in userpath1 would be + painted by ustroke of userpath2 + Form and Pattern Operators + pattern matrix makepattern pattern’ Create pattern instance from prototype + pattern setpattern – Install pattern as current color + comp1 … compn pattern setpattern – Install pattern as current color + form execform – Paint form +} +function TvEPSVectorialReader.ExecutePaintingOperator(AToken: TExpressionToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; +begin + Result := False; + + if AToken.StrValue = 'stroke' then + begin + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecutePaintingOperator] stroke'); + {$endif} + AData.SetPenStyle(psSolid); + AData.SetBrushStyle(bsClear); + AData.SetPenColor(CurrentGraphicState.Color); + AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode); + AData.SetPenWidth(CurrentGraphicState.PenWidth); + AData.EndPath(); + Exit(True); + end; + + if AToken.StrValue = 'eofill' then + begin + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecutePaintingOperator] eofill'); + {$endif} + AData.SetBrushStyle(bsSolid); + AData.SetPenStyle(psSolid); + AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode); + AData.SetPenWidth(CurrentGraphicState.PenWidth); + AData.EndPath(); + + Exit(True); + end; +end; + +{ Device Setup and Output Operators + + – showpage – Transmit and reset current page + – copypage – Transmit current page + dict setpagedevice – Install page-oriented output device + – currentpagedevice dict Return current page device parameters + – nulldevice – Install no-output device + Glyph and Font Operators + key font|cidfont definefont font|cidfont Register font|cidfont in Font resource + category + key name|string|dict array composefont font Register composite font dictionary created + from CMap and array of CIDFonts or fonts + key undefinefont – Remove Font resource registration + key findfont font|cidfont Return Font resource instance identified by + key + font|cidfont scale scalefont font¢|cidfont¢ Scale font|cidfont by scale to produce + font¢|cidfont¢ + font|cidfont matrix makefont font¢|cidfont¢ Transform font|cidfont by matrix to produce + font¢|cidfont¢ + font|cidfont setfont – Set font or CIDFont in graphics state + – rootfont font|cidfont Return last set font or CIDFont + – currentfont font|cidfont Return current font or CIDFont, possibly a + descendant of rootfont + key scale|matrix selectfont – Set font or CIDFont given name and + transform + string show – Paint glyphs for string in current font + ax ay string ashow – Add (ax , ay) to width of each glyph while + showing string + cx cy char string widthshow – Add (cx , cy) to width of glyph for char while + showing string + cx cy char ax ay string awidthshow – Combine effects of ashow and widthshow + string numarray|numstring xshow – Paint glyphs for string using x widths in + numarray|numstring + string numarray|numstring xyshow – Paint glyphs for string using x and y widths + in numarray|numstring + string numarray|numstring yshow – Paint glyphs for string using y widths in + numarray|numstring + name|cid glyphshow – Paint glyph for character identified by + name|cid + string stringwidth wx wy Return width of glyphs for string in current + font + proc string cshow – Invoke character mapping algorithm and + call proc + proc string kshow – Execute proc between characters shown from + string + – FontDirectory dict Return dictionary of Font resource instances + – GlobalFontDirectory dict Return dictionary of Font resource instances + in global VM + – StandardEncoding array Return Adobe standard font encoding vector + – ISOLatin1Encoding array Return ISO Latin-1 font encoding vector + key findencoding array Find encoding vector + wx wy llx lly urx ury setcachedevice – Declare cached glyph metrics + w0x w0y llx lly urx ury + w1x w1y vx vy setcachedevice2 – Declare cached glyph metrics + wx wy setcharwidth – Declare uncached glyph metrics + Interpreter Parameter Operators + dict setsystemparams – Set systemwide interpreter parameters + – currentsystemparams dict Return systemwide interpreter parameters + dict setuserparams – Set per-context interpreter parameters + – currentuserparams dict Return per-context interpreter parameters + string dict setdevparams – Set parameters for input/output device + string currentdevparams dict Return device parameters + int vmreclaim – Control garbage collector + int setvmthreshold – Control garbage collector + – vmstatus level used maximum + Report VM status + – cachestatus bsize bmax msize mmax csize cmax blimit + Return font cache status and parameters + int setcachelimit – Set maximum bytes in cached glyph + mark size lower upper setcacheparams – Set font cache parameters + – currentcacheparams mark size lower upper + Return current font cache parameters + mark blimit setucacheparams – Set user path cache parameters + – ucachestatus mark bsize bmax rsize rmax blimit + Return user path cache status and + parameters +} +function TvEPSVectorialReader.ExecuteDeviceSetupAndOutputOperator( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; +begin + Result := False; + + if AToken.StrValue = 'showpage' then + begin + Exit(True); + end; +end; + +{ Array Operators + + int array array Create array of length int + – [ mark Start array construction + mark obj0 … objn-1 ] array End array construction + array length int Return number of elements in array + array index get any Return array element indexed by index + array index any put – Put any into array at index + array index count getinterval subarray Return subarray of array starting at index for + count elements + array1 index array2|packedarray2 putinterval – Replace subarray of array1 starting at index + by array2|packedarray2 + any0 … anyn-1 array astore array Pop elements from stack into array + array aload any0 … anyn-1 array Push all elements of array on stack + array1 array2 copy subarray2 Copy elements of array1 to initial subarray of + array2 + array proc forall – Execute proc for each element of array + Packed Array Operators + any0 … anyn-1 n packedarray packedarray Create packed array consisting of n elements + from stack + bool setpacking – Set array packing mode for { … } syntax + (true = packed array) + – currentpacking bool Return array packing mode + packedarray length int Return number of elements in packedarray + packedarray index get any Return packedarray element indexed by index + packedarray index count getinterval subarray Return subarray of packedarray starting at + index for count elements + packedarray aload any0 … anyn-1 packedarray + Push all elements of packedarray on stack + packedarray1 array2 copy subarray2 Copy elements of packedarray1 to initial + subarray of array2 + packedarray proc forall – Execute proc for each element of packedarray +} +function TvEPSVectorialReader.ExecuteArrayOperator(AToken: TExpressionToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +begin + Result := False; + +end; + +{ String Operators + + int string string Create string of length int + string length int Return number of elements in string + string index get int Return string element indexed by index + string index int put – Put int into string at index + string index count getinterval substring Return substring of string starting at index + for count elements + string1 index string2 putinterval – Replace substring of string1 starting at index + by string2 + string1 string2 copy substring2 Copy elements of string1 to initial substring + of string2 + string proc forall – Execute proc for each element of string + string seek anchorsearch post match true Search for seek at start of string + or string false + string seek search post match pre true Search for seek in string + or string false + string token post any true Read token from start of string + or false + Relational, Boolean, and Bitwise Operators + any1 any2 eq bool Test equal + any1 any2 ne bool Test not equal + num1|str1 num2|str2 ge bool Test greater than or equal + num1|str1 num2|str2 gt bool Test greater than + num1|str1 num2|str2 le bool Test less than or equal + num1|str1 num2|str2 lt bool Test less than + bool1|int1 bool2|int2 and bool3|int3 Perform logical|bitwise and + bool1|int1 not bool2|int2 Perform logical|bitwise not + bool1|int1 bool2|int2 or bool3|int3 Perform logical|bitwise inclusive or + bool1|int1 bool2|int2 xor bool3|int3 Perform logical|bitwise exclusive or + – true true Return boolean value true + – false false Return boolean value false + int1 shift bitshift int2 Perform bitwise shift of int1 (positive is left) +} +function TvEPSVectorialReader.ExecuteStringOperator(AToken: TExpressionToken; + AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; + NewToken: TExpressionToken; +begin + Result := False; + + // any1 any2 ne bool Test not equal + if AToken.StrValue = 'ne' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := Param1.StrValue = Param2.StrValue; + if NewToken.BoolValue then NewToken.StrValue := 'true' + else NewToken.StrValue := 'false'; + Stack.Push(NewToken); + + Exit(True); + end; + // num1 num2 lt bool + // string1 string2 lt bool + // pops two objects from the operand stack and pushes true if the first operand is less + // than the second, or false otherwise. If both operands are numbers, lt compares + // their mathematical values. If both operands are strings, lt compares them element + // by element, treating the elements as integers in the range 0 to 255, to determine + // whether the first string is lexically less than the second. If the operands are of + // other types or one is a string and the other is a number, a typecheck error occurs. + if AToken.StrValue = 'lt' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := Param1.FloatValue > Param2.FloatValue; + if NewToken.BoolValue then NewToken.StrValue := 'true' + else NewToken.StrValue := 'false'; + Stack.Push(NewToken); + + Exit(True); + end; +end; + +{ Arithmetic and Math Operators + + num1 num2 add sum Return num1 plus num2 + num1 num2 div quotient Return num1 divided by num2 + int1 int2 idiv quotient Return int1 divided by int2 + int1 int2 mod remainder Return remainder after dividing int1 by int2 + num1 num2 mul product Return num1 times num2 + num1 num2 sub difference Return num1 minus num2 + num1 abs num2 Return absolute value of num1 + num1 neg num2 Return negative of num1 + num1 ceiling num2 Return ceiling of num1 + num1 floor num2 Return floor of num1 + num1 round num2 Round num1 to nearest integer + num1 truncate num2 Remove fractional part of num1 + num sqrt real Return square root of num + num den atan angle Return arctangent of num/den in degrees + angle cos real Return cosine of angle degrees + angle sin real Return sine of angle degrees + base exponent exp real Raise base to exponent power + num ln real Return natural logarithm (base e) + num log real Return common logarithm (base 10) + – rand int Generate pseudo-random integer + int srand – Set random number seed + – rrand int Return random number seed +} +function TvEPSVectorialReader.ExecuteArithmeticAndMathOperator( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; + NewToken: TExpressionToken; +begin + Result := False; + + // Division + // Param2 Param1 div ==> (Param2 div Param1) + if AToken.StrValue = 'div' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.FloatValue := Param2.FloatValue / Param1.FloatValue; + NewToken.StrValue := FloatToStr(NewToken.FloatValue); + Stack.Push(NewToken); + {$ifdef FPVECTORIALDEBUG_ARITHMETIC} + WriteLn(Format('[TvEPSVectorialReader.ExecuteArithmeticAndMathOperator] %f %f div %f', [Param2.FloatValue, Param1.FloatValue, NewToken.FloatValue])); + {$endif} + Exit(True); + end; + + // Param2 Param1 mul ==> (Param2 mul Param1) + if AToken.StrValue = 'mul' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.FloatValue := Param2.FloatValue * Param1.FloatValue; + NewToken.StrValue := FloatToStr(NewToken.FloatValue); + Stack.Push(NewToken); + Exit(True); + end; + // num1 num2 sub difference Return num1 minus num2 + if AToken.StrValue = 'sub' then + begin + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + Param1 := TPSToken(Stack.Pop); // num2 + Param2 := TPSToken(Stack.Pop); // num1 + NewToken.FloatValue := Param2.FloatValue - Param1.FloatValue; + NewToken.StrValue := FloatToStr(NewToken.FloatValue); + Stack.Push(NewToken); + Exit(True); + end; +end; + +{ Path Construction Operators + + – newpath – Initialize current path to be empty + – currentpoint x y Return current point coordinates + x y moveto – Set current point to (x, y) + dx dy rmoveto – Perform relative moveto + x y lineto – Append straight line to (x, y) + dx dy rlineto – Perform relative lineto + x y r angle1 angle2 arc – Append counterclockwise arc + x y r angle1 angle2 arcn – Append clockwise arc + x1 y1 x2 y2 r arct – Append tangent arc + x1 y1 x2 y2 r arcto xt1 yt1 xt2 yt2 Append tangent arc + x1 y1 x2 y2 x3 y3 curveto – Append Bézier cubic section + dx1 dy1 dx2 dy2 dx3 dy3 rcurveto – Perform relative curveto + – closepath – Connect subpath back to its starting point + – flattenpath – Convert curves to sequences of straight lines + – reversepath – Reverse direction of current path + – strokepath – Compute outline of stroked path + userpath ustrokepath – Compute outline of stroked userpath + userpath matrix ustrokepath – Compute outline of stroked userpath + string bool charpath – Append glyph outline to current path + userpath uappend – Interpret userpath and append to current + path + – clippath – Set current path to clipping path + llx lly urx ury setbbox – Set bounding box for current path + – pathbbox llx lly urx ury Return bounding box of current path + move line curve close pathforall – Enumerate current path + bool upath userpath Create userpath for current path; include + ucache if bool is true + – initclip – Set clipping path to device default + – clip – Clip using nonzero winding number rule + – eoclip – Clip using even-odd rule + x y width height rectclip – Clip with rectangular path + numarray|numstring rectclip – Clip with rectangular paths + – ucache – Declare that user path is to be cached +} +function TvEPSVectorialReader.ExecutePathConstructionOperator( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2, Param3, Param4, Param5, Param6: TPSToken; + PosX, PosY, PosX2, PosY2, PosX3, PosY3, BaseX, BaseY: Double; + // For Arc + P1, P2, P3, P4: T3DPoint; + startAngle, endAngle: Double; +begin + Result := False; + + // – newpath – Initialize current path to be empty + if AToken.StrValue = 'newpath' then + begin + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] newpath'); + {$endif} +// AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode); +// AData.SetPenWidth(CurrentGraphicState.PenWidth); +// AData.SetClipPath(CurrentGraphicState.ClipPath, CurrentGraphicState.ClipMode); + AData.SetBrushStyle(bsClear); + AData.SetPenStyle(psClear); + AData.EndPath(); + AData.StartPath(); + + AData.SetPenColor(CurrentGraphicState.Color); + AData.SetBrushColor(CurrentGraphicState.Color); + AData.SetPenStyle(psClear); + + Exit(True); + end; + // Param2 Param1 moveto - ===> moveto(X=Param2, Y=Param1); + if AToken.StrValue = 'moveto' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY); + PosX2 := PosX + CurrentGraphicState.TranslateX; + PosY2 := PosY + CurrentGraphicState.TranslateY; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] moveto %f, %f CurrentGraphicState.Translate %f, %f Resulting Value %f, %f', + [PosX, PosY, CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY, PosX2, PosY2])); + {$endif} + AData.AddMoveToPath(PosX2, PosY2); + Exit(True); + end; + // Absolute LineTo + // x y lineto – Append straight line to (x, y) + if AToken.StrValue = 'lineto' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY); + PosX2 := PosX + CurrentGraphicState.TranslateX; + PosY2 := PosY + CurrentGraphicState.TranslateY; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] lineto %f, %f Resulting value %f, %f', [PosX, PosY, PosX2, PosY2])); + {$endif} + AData.AddLineToPath(PosX2, PosY2); + Exit(True); + end; + // Relative LineTo + // dx dy rlineto – Perform relative lineto + if AToken.StrValue = 'rlineto' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX, PosY); + AData.GetCurrentPathPenPos(BaseX, BaseY); + PosX2 := PosX + BaseX; + PosY2 := PosY + BaseY; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rlineto %f, %f Base %f, %f Resulting %f, %f', + [PosX, PosY, BaseX, BaseY, PosX2, PosY2])); + {$endif} + AData.AddLineToPath(PosX2, PosY2); + Exit(True); + end; + // dx1 dy1 dx2 dy2 dx3 dy3 rcurveto – + // (relative curveto) appends a section of a cubic Bézier curve to the current path in + // the same manner as curveto. However, the operands are interpreted as relative + // displacements from the current point rather than as absolute coordinates. That is, + // rcurveto constructs a curve between the current point (x0, y0) and the endpoint + // (x0 + dx3, y0 + dy3), using (x0 + dx1, y0 + dy1) and (x0 + dx2, y0 + dy2) as the Bézier + // control points. In all other respects, the behavior of rcurveto is identical to that of + // curveto. + if AToken.StrValue = 'rcurveto' then + begin + Param1 := TPSToken(Stack.Pop); // dy3 + Param2 := TPSToken(Stack.Pop); // dx3 + Param3 := TPSToken(Stack.Pop); // dy2 + Param4 := TPSToken(Stack.Pop); // dx2 + Param5 := TPSToken(Stack.Pop); // dy1 + Param6 := TPSToken(Stack.Pop); // dx1 + PostScriptCoordsToFPVectorialCoords(Param5, Param6, PosX, PosY); + PostScriptCoordsToFPVectorialCoords(Param3, Param4, PosX2, PosY2); + PostScriptCoordsToFPVectorialCoords(Param1, Param2, PosX3, PosY3); + AData.GetCurrentPathPenPos(BaseX, BaseY); + // First move to the start of the arc +// BaseX := BaseX + CurrentGraphicState.TranslateX; +// BaseY := BaseY + CurrentGraphicState.TranslateY; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rcurveto translate %f, %f', + [CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY])); + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] rcurveto from %f, %f via %f, %f %f, %f to %f, %f', + [BaseX, BaseY, BaseX + PosX, BaseY + PosY, BaseX + PosX2, BaseY + PosY2, BaseX + PosX3, BaseY + PosY3])); + {$endif} + AData.AddBezierToPath(BaseX + PosX, BaseY + PosY, BaseX + PosX2, BaseY + PosY2, BaseX + PosX3, BaseY + PosY3); + Exit(True); + end; + // – closepath – + // + // Don't do anything, because a stroke or fill might come after closepath + // and newpath will be called after stroke and fill anyway + // + if AToken.StrValue = 'closepath' then + begin + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] closepath'); + {$endif} + + Exit(True); + end; + { + x y r angle1 angle2 arc – Append counterclockwise arc + + Arcs in PostScript are described by a center (x, y), a radius r and + two angles, angle1 for the start and angle2 for the end. These two + angles are relative to the X axis growing to the right (positive direction). + + } + if AToken.StrValue = 'arc' then + begin + Param1 := TPSToken(Stack.Pop); // angle2 + Param2 := TPSToken(Stack.Pop); // angle1 + Param3 := TPSToken(Stack.Pop); // r + Param4 := TPSToken(Stack.Pop); // y + Param5 := TPSToken(Stack.Pop); // x + PostScriptCoordsToFPVectorialCoords(Param4, Param5, PosX, PosY); + PosX := PosX + CurrentGraphicState.TranslateX; + PosY := PosY + CurrentGraphicState.TranslateY; + startAngle := Param2.FloatValue * Pi / 180; + endAngle := Param1.FloatValue * Pi / 180; + + // If the angle is too big we need to use two beziers + if endAngle - startAngle > Pi then + begin + CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle, endAngle - Pi, P1, P2, P3, P4); + AData.AddMoveToPath(P1.X, P1.Y); + AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y); + + CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle + Pi, endAngle, P1, P2, P3, P4); + AData.AddMoveToPath(P1.X, P1.Y); + AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y); + end + else + begin + CircularArcToBezier(PosX, PosY, Param3.FloatValue, startAngle, endAngle, P1, P2, P3, P4); + AData.AddMoveToPath(P1.X, P1.Y); + AData.AddBezierToPath(P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y); + end; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecutePathConstructionOperator] arc X,Y=%f, %f Resulting X,Y=%f, %f R=%f Angles Start,End=%f,%f', + [Param5.FloatValue, Param4.FloatValue, PosX, PosY, Param3.FloatValue, Param2.FloatValue, Param1.FloatValue])); + {$endif} + Exit(True); + end; + // – eoclip – Clip using even-odd rule + // + // intersects the inside of the current clipping path with the inside + // of the current path to produce a new, smaller current clipping path. + // The inside of the current path is determined by the even-odd rule, + // while the inside of the current clipping path is determined by whatever + // rule was used at the time that path was created. + // + // Except for the choice of insideness rule, the behavior of eoclip is identical to that of clip. + // + // ERRORS: limitcheck + // + if AToken.StrValue = 'eoclip' then + begin + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecutePathConstructionOperator] eoclip'); + {$endif} + {$ifndef FPVECTORIALDEBUG_CLIP_REGION} + AData.SetPenStyle(psClear); + {$endif} + AData.SetBrushStyle(bsClear); + AData.EndPath(); + CurrentGraphicState.ClipPath := AData.GetEntity(AData.GetEntitiesCount()-1) as TPath; + CurrentGraphicState.ClipMode := vcmEvenOddRule; + Exit(True); + end +end; + +{ Graphics State Operators (Device-Independent) + + – gsave – Push graphics state + – grestore – Pop graphics state + – clipsave – Push clipping path + – cliprestore – Pop clipping path + – grestoreall – Pop to bottommost graphics state + – initgraphics – Reset graphics state parameters + – gstate gstate Create graphics state object + gstate setgstate – Set graphics state from gstate + gstate currentgstate gstate Copy current graphics state into gstate + num setlinewidth – Set line width + – currentlinewidth num Return current line width + int setlinecap – Set shape of line ends for stroke (0 = butt, + 1 = round, 2 = square) + – currentlinecap int Return current line cap + int setlinejoin – Set shape of corners for stroke (0 = miter, + 1 = round, 2 = bevel) + – currentlinejoin int Return current line join + num setmiterlimit – Set miter length limit + – currentmiterlimit num Return current miter limit + bool setstrokeadjust – Set stroke adjustment (false = disable, + true = enable) + – currentstrokeadjust bool Return current stroke adjustment + array offset setdash – Set dash pattern for stroking + – currentdash array offset Return current dash pattern + array|name setcolorspace – Set color space + – currentcolorspace array Return current color space + comp1 … compn setcolor – Set color components + pattern setcolor – Set colored tiling pattern as current color + comp1 … compn pattern setcolor – Set uncolored tiling pattern as current color + – currentcolor comp1 … compn Return current color components + num setgray – Set color space to DeviceGray and color to + specified gray value (0 = black, 1 = white) + – currentgray num Return current color as gray value + hue saturation brightness sethsbcolor – Set color space to DeviceRGB and color to + specified hue, saturation, brightness + – currenthsbcolor hue saturation brightness + Return current color as hue, saturation, + brightness + red green blue setrgbcolor – Set color space to DeviceRGB and color to + specified red, green, blue + – currentrgbcolor red green blue Return current color as red, green, blue + cyan magenta yellow black setcmykcolor – Set color space to DeviceCMYK and color to + specified cyan, magenta, yellow, black + – currentcmykcolor cyan magenta yellow black + Return current color as cyan, magenta, + yellow, black +} +function TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2, Param3: TPSToken; + lRed, lGreen, lBlue: Double; + lGraphicState: TGraphicState; +begin + Result := False; + + // – gsave – Push graphics state + if AToken.StrValue = 'gsave' then + begin + GraphicStateStack.Push(CurrentGraphicState.Duplicate()); + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] gsave'); + {$endif} + Exit(True); + end; + // – grestore - Pop graphics state + if AToken.StrValue = 'grestore' then + begin + lGraphicState := TGraphicState(GraphicStateStack.Pop()); + if lGraphicState = nil then raise Exception.Create('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] grestore: call to grestore without corresponding gsave'); + CurrentGraphicState.Free; + CurrentGraphicState := lGraphicState; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] grestore'); + {$endif} + Exit(True); + end; + // num setlinewidth – Set line width + if AToken.StrValue = 'setlinewidth' then + begin + Param1 := TPSToken(Stack.Pop); + CurrentGraphicState.PenWidth := Round(Param1.FloatValue); + Exit(True); + end; + // int setlinecap – Set shape of line ends for stroke (0 = butt, + // 1 = round, 2 = square) + if AToken.StrValue = 'setlinecap' then + begin + Param1 := TPSToken(Stack.Pop); + Exit(True); + end; + // int setlinejoin – Set shape of corners for stroke (0 = miter, + // 1 = round, 2 = bevel) + if AToken.StrValue = 'setlinejoin' then + begin + Param1 := TPSToken(Stack.Pop); + Exit(True); + end; + // red green blue setrgbcolor – + // sets the current color space in the graphics state to DeviceRGB and the current color + // to the component values specified by red, green, and blue. Each component + // must be a number in the range 0.0 to 1.0. If any of the operands is outside this + // range, the nearest valid value is substituted without error indication. + if AToken.StrValue = 'setrgbcolor' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + Param3 := TPSToken(Stack.Pop); + + lRed := EnsureRange(Param3.FloatValue, 0, 1); + lGreen := EnsureRange(Param2.FloatValue, 0, 1); + lBlue := EnsureRange(Param1.FloatValue, 0, 1); + + CurrentGraphicState.Color.Red := Round(lRed * $FFFF); + CurrentGraphicState.Color.Green := Round(lGreen * $FFFF); + CurrentGraphicState.Color.Blue := Round(lBlue * $FFFF); + CurrentGraphicState.Color.alpha := alphaOpaque; + + AData.SetPenColor(CurrentGraphicState.Color); + + {$ifdef FPVECTORIALDEBUG_COLORS} + WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] setrgbcolor r=%f g=%f b=%f', + [Param3.FloatValue, Param2.FloatValue, Param1.FloatValue])); + {$endif} + + Exit(True); + end; +end; + +{ Graphics State Operators (Device-Dependent) + + halftone sethalftone – Set halftone dictionary + – currenthalftone halftone + Return current halftone dictionary + frequency angle proc setscreen – Set gray halftone screen by frequency, angle, + and spot function + frequency angle halftone setscreen – Set gray halftone screen from halftone + dictionary + – currentscreen frequency angle proc|halftone + Return current gray halftone screen + redfreq redang redproc|redhalftone + greenfreq greenang greenproc|greenhalftone + bluefreq blueang blueproc|bluehalftone + grayfreq grayang grayproc|grayhalftone setcolorscreen – Set all four halftone screens + – currentcolorscreen redfreq redang redproc|redhalftone + greenfreq greenang greenproc|greenhalftone + bluefreq blueang blueproc|bluehalftone + grayfreq grayang grayproc|grayhalftone + Return all four halftone screens + proc settransfer – Set gray transfer function + – currenttransfer proc + Return current gray transfer function + redproc greenproc blueproc grayproc setcolortransfer – Set all four transfer functions + – currentcolortransfer redproc greenproc blueproc grayproc + Return current transfer functions + proc setblackgeneration – Set black-generation function + – currentblackgeneration proc + Return current black-generation function + proc setundercolorremoval – Set undercolor-removal function + – currentundercolorremoval proc + Return current undercolor-removal + function + dict setcolorrendering – Set CIE-based color rendering dictionary + – currentcolorrendering dict + Return current CIE-based color rendering + dictionary + num setflat – Set flatness tolerance + – currentflat num Return current flatness + bool setoverprint – Set overprint parameter + – currentoverprint bool Return current overprint parameter + num setsmoothness – Set smoothness parameter + – currentsmoothness num Return current smoothness parameter + Coordinate System and Matrix Operators + – matrix matrix Create identity matrix + – initmatrix – Set CTM to device default + matrix identmatrix matrix Fill matrix with identity transform + matrix defaultmatrix matrix Fill matrix with device default matrix + matrix currentmatrix matrix Fill matrix with CTM + matrix setmatrix – Replace CTM by matrix + tx ty translate – Translate user space by (tx , ty) + tx ty matrix translate matrix Define translation by (tx , ty) + sx sy scale – Scale user space by sx and sy + sx sy matrix scale matrix Define scaling by sx and sy + angle rotate – Rotate user space by angle degrees + angle matrix rotate matrix Define rotation by angle degrees + matrix concat – Replace CTM by matrix ´ CTM + matrix1 matrix2 matrix3 concatmatrix matrix3 Fill matrix3 with matrix1 ´ matrix2 + x y transform x¢ y¢ Transform (x, y) by CTM + x y matrix transform x¢ y¢ Transform (x, y) by matrix + dx dy dtransform dx¢ dy¢ Transform distance (dx, dy) by CTM + dx dy matrix dtransform dx¢ dy¢ Transform distance (dx, dy) by matrix + x¢ y¢ itransform x y Perform inverse transform of (x¢, y¢) by + CTM + x¢ y¢ matrix itransform x y Perform inverse transform of (x¢, y¢) by + matrix + dx¢ dy¢ idtransform dx dy Perform inverse transform of distance + (dx¢, dy¢) by CTM + dx¢ dy¢ matrix idtransform dx dy Perform inverse transform of distance + (dx¢, dy¢) by matrix + matrix1 matrix2 invertmatrix matrix2 Fill matrix2 with inverse of matrix1 +} +function TvEPSVectorialReader.ExecuteGraphicStateOperatorsDD( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; +begin + Result := False; + + // bool setoverprint – Set overprint parameter + if AToken.StrValue = 'setoverprint' then + begin + Param1 := TPSToken(Stack.Pop); + + CurrentGraphicState.OverPrint := Param1.BoolValue; + + Exit(True); + end; + // sx sy scale – Scale user space by sx and sy + if AToken.StrValue = 'scale' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + + if Param2 = nil then + begin + Exit(True); + end; + + CurrentGraphicState.ScaleX := Param2.FloatValue; + CurrentGraphicState.ScaleY := Param1.FloatValue; + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] scale %f %f', + [CurrentGraphicState.ScaleX, CurrentGraphicState.ScaleY])); + {$endif} + + Exit(True); + end; + { + translate tx ty translate + - tx ty matrix translate matrix + + With no matrix operand, translate builds a temporary matrix and concatenates + this matrix with the current transformation matrix (CTM). Precisely, translate + replaces the CTM by T x CTM. The effect of this is to move the origin of the + user coordinate system by tx units in the x direction and ty units in the y + direction relative to the former user coordinate system. The sizes of the x + and y units and the orientation of the axes are unchanged. + + If the matrix operand is supplied, translate replaces the value of matrix by + T and pushes the modified matrix back on the operand stack. + In this case, translate does not affect the CTM. + } + if AToken.StrValue = 'translate' then + begin + Param1 := TPSToken(Stack.Pop); // ty + Param2 := TPSToken(Stack.Pop); // tx + + if Param2 = nil then + begin + raise Exception.Create('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] Stack underflow in operator "translate"'); + end; + + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] translate %f, %f CurrentGraphicState.Translate %f %f', + [Param2.FloatValue, Param1.FloatValue, CurrentGraphicState.TranslateX, CurrentGraphicState.TranslateY])); + {$endif} + + CurrentGraphicState.TranslateX := CurrentGraphicState.TranslateX + Param2.FloatValue; + CurrentGraphicState.TranslateY := CurrentGraphicState.TranslateY + Param1.FloatValue; + + Exit(True); + end; + // angle rotate – Rotate user space by angle degrees + if AToken.StrValue = 'rotate' then + begin + Param1 := TPSToken(Stack.Pop); + + {$ifdef FPVECTORIALDEBUG_PATHS} + WriteLn(Format('[TvEPSVectorialReader.ExecuteGraphicStateOperatorsDI] rotate angle=%f', [Param1.FloatValue])); + DebugStack(); + {$endif} + + Exit(True); + end; +end; + +{ Dictionary Operators + + int dict dict Create dictionary with capacity for int + elements + – << mark Start dictionary construction + mark key1 value1 … keyn valuen >> dict + End dictionary construction + dict length int Return number of entries in dict + dict maxlength int Return current capacity of dict + dict begin – Push dict on dictionary stack + – end – Pop current dictionary off dictionary stack + key value def – Associate key and value in current dictionary + key load value Search dictionary stack for key and return + associated value + key value store – Replace topmost definition of key + dict key get any Return value associated with key in dict + dict key value put – Associate key with value in dict + dict key undef – Remove key and its value from dict + dict key known bool Test whether key is in dict + key where dict true Find dictionary in which key is defined + or false + dict1 dict2 copy dict2 Copy contents of dict1 to dict2 + dict proc forall – Execute proc for each entry in dict + – currentdict dict Return current dictionary + – errordict dict Return error handler dictionary + – $error dict Return error control and status dictionary + – systemdict dict Return system dictionary + – userdict dict Return writeable dictionary in local VM + – globaldict dict Return writeable dictionary in global VM + – statusdict dict Return product-dependent dictionary + – countdictstack int Count elements on dictionary stack + array dictstack subarray Copy dictionary stack into array + – cleardictstack – Pop all nonpermanent dictionaries off + dictionary stack +} +function TvEPSVectorialReader.ExecuteDictionaryOperators( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +var + Param1, Param2: TPSToken; + NewToken: TExpressionToken; +begin + Result := False; + + // Adds a dictionary definition + // key value def – Associate key and value in current dictionary + if AToken.StrValue = 'def' then + begin + Param1 := TPSToken(Stack.Pop); + Param2 := TPSToken(Stack.Pop); + Dictionary.AddObject(Param2.StrValue, Param1); + Exit(True); + end; + + // Can be ignored, because in the files found it only loads + // standard routines, like /moveto ... + // + // key load value Search dictionary stack for key and return + // associated value + if AToken.StrValue = 'load' then + begin +// {$ifdef FPVECTORIALDEBUG_DICTIONARY} +// WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] load'); +// DebugStack(); +// {$endif} + + Exit(True); + end; + + // Find dictionary in which key is defined + //key where dict true Find dictionary in which key is defined + // or false + if AToken.StrValue = 'where' then + begin + {$ifdef FPVECTORIALDEBUG_DICTIONARY} + WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where'); + DebugStack(); + {$endif} + + Param1 := TPSToken(Stack.Pop); + + if Dictionary.IndexOf(Param1.StrValue) >= 0 then + begin + // We use only 1 dictionary, so this is just a representation of our single dictionary + NewToken := TExpressionToken.Create; + NewToken.ETType := ettDictionary; + Stack.Push(NewToken); + + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := True; + Stack.Push(NewToken); + + {$ifdef FPVECTORIALDEBUG_DICTIONARY} + WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where True'); + {$endif} + end + else + begin + NewToken := TExpressionToken.Create; + NewToken.ETType := ettOperand; + NewToken.BoolValue := False; + Stack.Push(NewToken); + + {$ifdef FPVECTORIALDEBUG_DICTIONARY} + WriteLn('[TvEPSVectorialReader.ExecuteDictionaryOperators] where False'); + {$endif} + end; + + Exit(True); + end; +end; + +{ Miscellaneous Operators + + proc bind proc Replace operator names in proc with + operators; perform idiom recognition + – null null Push null on stack + – version string Return interpreter version + – realtime int Return real time in milliseconds + – usertime int Return execution time in milliseconds + – languagelevel int Return LanguageLevel + – product string Return product name + – revision int Return product revision level + – serialnumber int Return machine serial number + – executive – Invoke interactive executive + bool echo – Turn echoing on or off + – prompt – Executed when ready for interactive input +} +function TvEPSVectorialReader.ExecuteMiscellaneousOperators( + AToken: TExpressionToken; AData: TvVectorialPage; ADoc: TvVectorialDocument): Boolean; +begin + Result := False; + + // Just a hint for more efficient parsing, we can ignore + // + // proc bind proc Replace operator names in proc with + // operators; perform idiom recognition + if AToken.StrValue = 'bind' then + begin + {$ifdef FPVECTORIALDEBUG_CONTROL} + WriteLn('[TvEPSVectorialReader.ExecuteControlOperator] bind'); + DebugStack(); + {$endif} + + Exit(True); + end; +end; + +procedure TvEPSVectorialReader.PostScriptCoordsToFPVectorialCoords(AParam1, + AParam2: TPSToken; var APosX, APosY: Double); +begin + APosX := AParam2.FloatValue; + APosY := AParam1.FloatValue; +end; + +// Returns true if a dictionary substitution was executed +function TvEPSVectorialReader.DictionarySubstituteOperator( + ADictionary: TStringList; var ACurToken: TPSToken): Boolean; +var + lIndex: Integer; + SubstituteToken, NewToken: TPSToken; +begin + Result := False; + lIndex := ADictionary.IndexOf(ACurToken.StrValue); + if lIndex >= 0 then + begin + Result := True; + + SubstituteToken := TPSToken(ADictionary.Objects[lIndex]); + + if SubstituteToken is TExpressionToken then + begin + ACurToken.StrValue := SubstituteToken.StrValue; + ACurToken.FloatValue := SubstituteToken.FloatValue; + end + else if SubstituteToken is TProcedureToken then + begin + ACurToken := SubstituteToken; + end; + if ACurToken.StrValue = '' then raise Exception.Create('[TvEPSVectorialReader.DictionarySubstituteOperator] The Dictionary substitution resulted in an empty value'); + end; +end; + +constructor TvEPSVectorialReader.Create; +begin + inherited Create; + + FPointSeparator := SysUtils.DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := ','; + + Tokenizer := TPSTokenizer.Create(-1); + Stack := TObjectStack.Create; + GraphicStateStack := TObjectStack.Create; + Dictionary := TStringList.Create; + Dictionary.CaseSensitive := True; + CurrentGraphicState := TGraphicState.Create; +end; + +destructor TvEPSVectorialReader.Destroy; +begin + Tokenizer.Free; + Stack.Free; + GraphicStateStack.Free; + Dictionary.Free; + CurrentGraphicState.Free; + + inherited Destroy; +end; + +procedure TvEPSVectorialReader.ReadFromStream(AStream: TStream; + AData: TvVectorialDocument); +var + lPage: TvVectorialPage; +begin + Tokenizer.ReadFromStream(AStream); +// Tokenizer.DebugOut(); + + // Make sure we have at least one path + lPage := AData.AddPage(); + lPage.StartPath(); + + RunPostScript(Tokenizer.Tokens, lPage, AData); + + // Make sure we have at least one path + lPage.EndPath(); + + // PostScript has no document size information, so lets calculate it ourselves + AData.GuessDocumentSize(); + AData.GuessGoodZoomLevel() +end; + +initialization + + RegisterVectorialReader(TvEPSVectorialReader, vfEncapsulatedPostScript); + +end. + diff --git a/components/fpvectorial/examples/fpce_mainform.lfm b/components/fpvectorial/examples/fpce_mainform.lfm new file mode 100644 index 0000000000..0ef12e2faf --- /dev/null +++ b/components/fpvectorial/examples/fpce_mainform.lfm @@ -0,0 +1,62 @@ +object formCorelExplorer: TformCorelExplorer + Left = 216 + Height = 345 + Top = 192 + Width = 466 + Caption = 'FP Corel Explorer' + ClientHeight = 345 + ClientWidth = 466 + LCLVersion = '0.9.29' + object Label1: TLabel + Left = 8 + Height = 14 + Top = 40 + Width = 123 + Caption = 'Location of the Input file:' + ParentColor = False + end + object Label2: TLabel + Left = 8 + Height = 32 + Top = 8 + Width = 224 + AutoSize = False + Caption = 'This application helps us explore the internal structure of Corel Draw files (*.cdr).' + ParentColor = False + WordWrap = True + end + object shellInput: TShellTreeView + Left = 8 + Height = 272 + Top = 64 + Width = 224 + FileSortType = fstFoldersFirst + TabOrder = 0 + OnSelectionChanged = shellInputSelectionChanged + ObjectTypes = [otFolders, otNonFolders] + end + object labelFilename: TLabel + Left = 256 + Height = 14 + Top = 65 + Width = 47 + Caption = 'Filename:' + ParentColor = False + end + object labelVersion: TLabel + Left = 256 + Height = 14 + Top = 88 + Width = 40 + Caption = 'Version:' + ParentColor = False + end + object labelSize: TLabel + Left = 256 + Height = 14 + Top = 112 + Width = 24 + Caption = 'Size:' + ParentColor = False + end +end diff --git a/components/fpvectorial/examples/fpce_mainform.pas b/components/fpvectorial/examples/fpce_mainform.pas new file mode 100644 index 0000000000..3f262ce839 --- /dev/null +++ b/components/fpvectorial/examples/fpce_mainform.pas @@ -0,0 +1,91 @@ +unit fpce_mainform; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + EditBtn, ExtCtrls, ComCtrls, ShellCtrls; + +type + + { TformCorelExplorer } + + TformCorelExplorer = class(TForm) + Label1: TLabel; + Label2: TLabel; + labelSize: TLabel; + labelVersion: TLabel; + labelFilename: TLabel; + shellInput: TShellTreeView; + procedure buttonQuitClick(Sender: TObject); + procedure shellInputSelectionChanged(Sender: TObject); + private + { private declarations } + function CheckInput(): Boolean; + public + { public declarations } + end; + +var + formCorelExplorer: TformCorelExplorer; + +implementation + +uses + fpvectorial, cdrvectorialreader, svgvectorialwriter, pdfvectorialreader, + fpvtocanvas; + +{$R *.lfm} + +{ TformCorelExplorer } + +procedure TformCorelExplorer.buttonQuitClick(Sender: TObject); +begin + Close; +end; + +procedure TformCorelExplorer.shellInputSelectionChanged(Sender: TObject); +var + Vec: TvVectorialDocument; + Reader: TvCDRVectorialReader; + lFormat: TvVectorialFormat; + lChunk, lCurChunk: TCDRChunk; + Str: string; +begin + // First check the in input + if not CheckInput() then Exit; + + // Now read the data from the input file + Reader := TvCDRVectorialReader.Create; + try + Reader.ExploreFromFile(shellInput.GetSelectedNodePath(), lChunk); + + labelFilename.Caption := 'Filename: ' + shellInput.GetSelectedNodePath(); + if (lChunk.ChildChunks <> nil) and (lChunk.ChildChunks.First <> nil) then + begin + // Version Chunk + lCurChunk := TCDRChunk(lChunk.ChildChunks.First); + Str := TCDRChunkVRSN(lCurChunk).VersionStr; + labelVersion.Caption := 'Version: ' + Str; + + // Main data + lCurChunk := TCDRChunk(lChunk.ChildChunks.Items[1]); + labelSize.Caption := 'Size: ' + ; + end; + finally + Reader.Free; + end; +end; + +function TformCorelExplorer.CheckInput(): Boolean; +var + lPath: String; +begin + lPath := shellInput.GetSelectedNodePath(); + Result := (ExtractFileExt(lPath) = STR_CORELDRAW_EXTENSION); +end; + +end. + diff --git a/components/fpvectorial/examples/fpcorelexplorer.ico b/components/fpvectorial/examples/fpcorelexplorer.ico new file mode 100644 index 0000000000..0341321b5d Binary files /dev/null and b/components/fpvectorial/examples/fpcorelexplorer.ico differ diff --git a/components/fpvectorial/examples/fpcorelexplorer.lpi b/components/fpvectorial/examples/fpcorelexplorer.lpi new file mode 100644 index 0000000000..384cea7d41 --- /dev/null +++ b/components/fpvectorial/examples/fpcorelexplorer.lpi @@ -0,0 +1,91 @@ + + + + + + + + + + + + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="fpcorelexplorer.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="fpcorelexplorer"/> + </Unit0> + <Unit1> + <Filename Value="fpce_mainform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="formCorelExplorer"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="fpce_mainform"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="fpcorelexplorer"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)\"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <UseMsgFile Value="True"/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="4"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + <Item4> + <Name Value="EConvertError"/> + </Item4> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/fpvectorial/examples/fpcorelexplorer.lpr b/components/fpvectorial/examples/fpcorelexplorer.lpr new file mode 100644 index 0000000000..0ae0fc957f --- /dev/null +++ b/components/fpvectorial/examples/fpcorelexplorer.lpr @@ -0,0 +1,20 @@ +program fpcorelexplorer; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Interfaces, // this includes the LCL widgetset + Forms, fpce_mainform + { you can add units after this }; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TformCorelExplorer, formCorelExplorer); + Application.Run; +end. + diff --git a/components/fpvectorial/examples/fpvc_mainform.lfm b/components/fpvectorial/examples/fpvc_mainform.lfm new file mode 100644 index 0000000000..c722d8c164 --- /dev/null +++ b/components/fpvectorial/examples/fpvc_mainform.lfm @@ -0,0 +1,98 @@ +object formVectorialConverter: TformVectorialConverter + Left = 216 + Height = 439 + Top = 192 + Width = 240 + BorderStyle = bsSingle + Caption = 'FP Vectorial Converter' + ClientHeight = 439 + ClientWidth = 240 + LCLVersion = '0.9.31' + object Label1: TLabel + Left = 8 + Height = 18 + Top = 112 + Width = 172 + Caption = 'Location of the Input file:' + ParentColor = False + end + object Label2: TLabel + Left = 11 + Height = 104 + Top = 8 + Width = 229 + AutoSize = False + Caption = 'This converter application use the fpvectorial library to convert between various different vectorial graphics formats. The type is detected from the extension and the supported types are: PDF (*.pdf), SVG (*.svg) and Corel Draw file (*.cdr).' + Font.Height = -12 + ParentColor = False + ParentFont = False + WordWrap = True + end + object editInput: TFileNameEdit + Left = 8 + Height = 25 + Top = 128 + Width = 192 + DialogOptions = [] + FilterIndex = 0 + HideDirectories = False + ButtonWidth = 23 + NumGlyphs = 0 + MaxLength = 0 + TabOrder = 0 + end + object Label3: TLabel + Left = 8 + Height = 18 + Top = 152 + Width = 184 + Caption = 'Full path of the Output file:' + ParentColor = False + end + object editOutput: TFileNameEdit + Left = 8 + Height = 25 + Top = 168 + Width = 192 + DialogOptions = [] + FilterIndex = 0 + HideDirectories = False + ButtonWidth = 23 + NumGlyphs = 0 + MaxLength = 0 + TabOrder = 1 + end + object buttonConvert: TButton + Left = 87 + Height = 25 + Top = 192 + Width = 67 + Caption = 'Convert' + OnClick = buttonConvertClick + TabOrder = 2 + end + object buttonQuit: TButton + Left = 176 + Height = 25 + Top = 192 + Width = 59 + Caption = 'Quit' + OnClick = buttonQuitClick + TabOrder = 3 + end + object imagePreview: TImage + Left = 8 + Height = 210 + Top = 224 + Width = 224 + end + object buttonVisualize: TButton + Left = 8 + Height = 25 + Top = 192 + Width = 59 + Caption = 'Visualize' + OnClick = buttonVisualizeClick + TabOrder = 4 + end +end diff --git a/components/fpvectorial/examples/fpvc_mainform.pas b/components/fpvectorial/examples/fpvc_mainform.pas new file mode 100644 index 0000000000..e6b8e5c311 --- /dev/null +++ b/components/fpvectorial/examples/fpvc_mainform.pas @@ -0,0 +1,97 @@ +unit fpvc_mainform; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, + EditBtn, ExtCtrls; + +type + + { TformVectorialConverter } + + TformVectorialConverter = class(TForm) + buttonVisualize: TButton; + buttonConvert: TButton; + buttonQuit: TButton; + editInput: TFileNameEdit; + editOutput: TFileNameEdit; + imagePreview: TImage; + Label1: TLabel; + Label2: TLabel; + Label3: TLabel; + procedure buttonConvertClick(Sender: TObject); + procedure buttonQuitClick(Sender: TObject); + procedure buttonVisualizeClick(Sender: TObject); + private + { private declarations } + function CheckInput(): Boolean; + public + { public declarations } + end; + +var + formVectorialConverter: TformVectorialConverter; + +implementation + +uses + fpvectorial, cdrvectorialreader, svgvectorialwriter, pdfvectorialreader, + fpvtocanvas; + +{$R *.lfm} + +{ TformVectorialConverter } + +procedure TformVectorialConverter.buttonQuitClick(Sender: TObject); +begin + Close; +end; + +procedure TformVectorialConverter.buttonVisualizeClick(Sender: TObject); +var + Vec: TvVectorialDocument; +begin + // First check the in input + if not CheckInput() then Exit; + + Vec := TvVectorialDocument.Create; + try + Vec.ReadFromFile(editInput.FileName, vfPDF); + imagePreview.Canvas.Brush.Color := clWhite; + imagePreview.Canvas.FillRect(0, 0, imagePreview.Width, imagePreview.Height); + DrawFPVectorialToCanvas(Vec, imagePreview.Canvas); + finally + Vec.Free; + end; +end; + +function TformVectorialConverter.CheckInput(): Boolean; +begin + // todo... +end; + +procedure TformVectorialConverter.buttonConvertClick(Sender: TObject); +var + Vec: TvVectorialDocument; + lFormat: TvVectorialFormat; +begin + // First check the in input + if not CheckInput() then Exit; + + // Now convert + Vec := TvVectorialDocument.Create; + try + lFormat := TvVectorialDocument.GetFormatFromExtension(editInput.FileName); + Vec.ReadFromFile(editInput.FileName, lFormat); + lFormat := TvVectorialDocument.GetFormatFromExtension(editOutPut.FileName); + Vec.WriteToFile(editOutPut.FileName, lFormat); + finally + Vec.Free; + end; +end; + +end. + diff --git a/components/fpvectorial/examples/fpvectorialconverter.ico b/components/fpvectorial/examples/fpvectorialconverter.ico new file mode 100644 index 0000000000..0341321b5d Binary files /dev/null and b/components/fpvectorial/examples/fpvectorialconverter.ico differ diff --git a/components/fpvectorial/examples/fpvectorialconverter.lpi b/components/fpvectorial/examples/fpvectorialconverter.lpi new file mode 100644 index 0000000000..21b7cae3c8 --- /dev/null +++ b/components/fpvectorial/examples/fpvectorialconverter.lpi @@ -0,0 +1,95 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <AlwaysBuild Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="fpvectorialconverter"/> + <UseXPManifest Value="True"/> + <Icon Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="fpvectorialconverter.lpr"/> + <IsPartOfProject Value="True"/> + <UnitName Value="fpvectorialconverter"/> + </Unit0> + <Unit1> + <Filename Value="fpvc_mainform.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="formVectorialConverter"/> + <ResourceBaseClass Value="Form"/> + <UnitName Value="fpvc_mainform"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="fpvectorialconverter"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + <Other> + <CompilerMessages> + <UseMsgFile Value="True"/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="4"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + <Item4> + <Name Value="EConvertError"/> + </Item4> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/fpvectorial/examples/fpvectorialconverter.lpr b/components/fpvectorial/examples/fpvectorialconverter.lpr new file mode 100644 index 0000000000..9ad492ceca --- /dev/null +++ b/components/fpvectorial/examples/fpvectorialconverter.lpr @@ -0,0 +1,16 @@ +program fpvectorialconverter; + +{$mode objfpc}{$H+} + +uses + Interfaces, // this includes the LCL widgetset + Forms, fpvc_mainform; + +{$R *.res} + +begin + Application.Initialize; + Application.CreateForm(TformVectorialConverter, formVectorialConverter); + Application.Run; +end. + diff --git a/components/fpvectorial/examples/fpvmodifytest.lpi b/components/fpvectorial/examples/fpvmodifytest.lpi new file mode 100644 index 0000000000..7f6f915bff --- /dev/null +++ b/components/fpvectorial/examples/fpvmodifytest.lpi @@ -0,0 +1,239 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <MainUnit Value="0"/> + <Title Value="fpvmodifytest"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <ActiveWindowIndexAtStart Value="0"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1" Active="Default"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="5"> + <Unit0> + <Filename Value="fpvmodifytest.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="fpvmodifytest"/> + <EditorIndex Value="0"/> + <WindowIndex Value="0"/> + <TopLine Value="19"/> + <CursorPos X="1" Y="44"/> + <UsageCount Value="23"/> + <Loaded Value="True"/> + </Unit0> + <Unit1> + <Filename Value="fpvectorial.pas"/> + <UnitName Value="fpvectorial"/> + <EditorIndex Value="4"/> + <WindowIndex Value="0"/> + <TopLine Value="1267"/> + <CursorPos X="16" Y="1275"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit1> + <Unit2> + <Filename Value="svgvectorialwriter.pas"/> + <UnitName Value="svgvectorialwriter"/> + <IsVisibleTab Value="True"/> + <EditorIndex Value="3"/> + <WindowIndex Value="0"/> + <TopLine Value="228"/> + <CursorPos X="19" Y="245"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit2> + <Unit3> + <Filename Value="svgvectorialreader.pas"/> + <UnitName Value="svgvectorialreader"/> + <EditorIndex Value="2"/> + <WindowIndex Value="0"/> + <TopLine Value="319"/> + <CursorPos X="17" Y="352"/> + <UsageCount Value="12"/> + <Loaded Value="True"/> + </Unit3> + <Unit4> + <Filename Value="fpvutils.pas"/> + <UnitName Value="fpvutils"/> + <EditorIndex Value="1"/> + <WindowIndex Value="0"/> + <TopLine Value="2"/> + <CursorPos X="3" Y="14"/> + <UsageCount Value="11"/> + <Loaded Value="True"/> + </Unit4> + </Units> + <JumpHistory Count="30" HistoryIndex="29"> + <Position1> + <Filename Value="fpvmodifytest.pas"/> + <Caret Line="40" Column="1" TopLine="19"/> + </Position1> + <Position2> + <Filename Value="fpvmodifytest.pas"/> + <Caret Line="42" Column="1" TopLine="19"/> + </Position2> + <Position3> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="217" Column="9" TopLine="188"/> + </Position3> + <Position4> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="260" Column="3" TopLine="226"/> + </Position4> + <Position5> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="258" Column="1" TopLine="226"/> + </Position5> + <Position6> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="261" Column="1" TopLine="226"/> + </Position6> + <Position7> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="263" Column="1" TopLine="226"/> + </Position7> + <Position8> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="93" Column="1" TopLine="69"/> + </Position8> + <Position9> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="94" Column="1" TopLine="69"/> + </Position9> + <Position10> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="95" Column="1" TopLine="69"/> + </Position10> + <Position11> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="96" Column="1" TopLine="69"/> + </Position11> + <Position12> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="98" Column="1" TopLine="69"/> + </Position12> + <Position13> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="100" Column="1" TopLine="69"/> + </Position13> + <Position14> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="102" Column="1" TopLine="69"/> + </Position14> + <Position15> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="104" Column="1" TopLine="69"/> + </Position15> + <Position16> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="105" Column="1" TopLine="69"/> + </Position16> + <Position17> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="111" Column="1" TopLine="71"/> + </Position17> + <Position18> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="112" Column="1" TopLine="72"/> + </Position18> + <Position19> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="113" Column="1" TopLine="73"/> + </Position19> + <Position20> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="115" Column="1" TopLine="75"/> + </Position20> + <Position21> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="119" Column="1" TopLine="79"/> + </Position21> + <Position22> + <Filename Value="fpvectorial.pas"/> + <Caret Line="1224" Column="24" TopLine="1206"/> + </Position22> + <Position23> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="183" Column="31" TopLine="180"/> + </Position23> + <Position24> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="55" Column="3" TopLine="131"/> + </Position24> + <Position25> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="26" Column="74" TopLine="2"/> + </Position25> + <Position26> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="27" Column="15" TopLine="2"/> + </Position26> + <Position27> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="259" Column="3" TopLine="227"/> + </Position27> + <Position28> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="28" Column="98" TopLine="27"/> + </Position28> + <Position29> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="217" Column="38" TopLine="193"/> + </Position29> + <Position30> + <Filename Value="svgvectorialwriter.pas"/> + <Caret Line="220" Column="39" TopLine="188"/> + </Position30> + </JumpHistory> + </ProjectOptions> + <CompilerOptions> + <Version Value="10"/> + <Target> + <Filename Value="fpvmodifytest"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/fpvectorial/examples/fpvmodifytest.pas b/components/fpvectorial/examples/fpvmodifytest.pas new file mode 100644 index 0000000000..b59055153e --- /dev/null +++ b/components/fpvectorial/examples/fpvmodifytest.pas @@ -0,0 +1,67 @@ +{ +Author: Felipe Monteiro de Carvalho + +License: Public Domain +} +program fpvmodifytest; + +{$mode objfpc}{$H+} + +uses + fpvectorial, svgvectorialwriter, svgvectorialreader, fpvutils; + +const + cFormat = vfSVG; + cExtension = '.svg'; +var + VecDoc: TvVectorialDocument; + Vec: TvVectorialPage; + Path: TPath; + i: Integer; + Segment: TPathSegment; + _2DSegment: T2DSegment; + BezSegment: T2DBezierSegment; + lEntity: TvEntity; +begin + VecDoc := TvVectorialDocument.Create; + try + // Read the file + VecDoc.ReadFromFile('bezier_1.svg'); + Vec := VecDoc.GetPage(0); + + // Now add 10 to the Y coordinate of all elements + for i := 0 to Vec.GetEntitiesCount() - 1 do + begin + lEntity := Vec.GetEntity(i); + if not (lEntity is TPath) then Continue; + Path := lEntity as TPath; + Path.PrepareForSequentialReading(); + Path.Next(); + while Path.CurPoint <> nil do + begin + Segment := Path.CurPoint; + + if Segment is T2DBezierSegment then + begin + BezSegment := Segment as T2DBezierSegment; + BezSegment.Y := BezSegment.Y + 10; + BezSegment.Y2 := BezSegment.Y2 + 10; + BezSegment.Y3 := BezSegment.Y3 + 10; + end + else if Segment is T2DSegment then + begin + _2DSegment := Segment as T2DSegment; + _2DSegment.Y := _2DSegment.Y + 10; + end; + + Path.Next(); + end; + end; + + // Write the changed file to disk + VecDoc.WriteToFile('bezier_1_mod' + cExtension, cFormat); + finally + VecDoc.Free; + end; +end. + diff --git a/components/fpvectorial/examples/fpvwritetest.lpi b/components/fpvectorial/examples/fpvwritetest.lpi new file mode 100644 index 0000000000..0333775fac --- /dev/null +++ b/components/fpvectorial/examples/fpvwritetest.lpi @@ -0,0 +1,75 @@ +<?xml version="1.0"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <PathDelim Value="\"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + <MainUnitHasTitleStatement Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="fpvwritetest"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> + <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <LaunchingApplication PathPlusParams="\usr\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="fpvwritetest.pas"/> + <IsPartOfProject Value="True"/> + <UnitName Value="fpvwritetest"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="10"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="fpvwritetest"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerMessages> + <UseMsgFile Value="True"/> + </CompilerMessages> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/components/fpvectorial/examples/fpvwritetest.pas b/components/fpvectorial/examples/fpvwritetest.pas new file mode 100644 index 0000000000..393fde3694 --- /dev/null +++ b/components/fpvectorial/examples/fpvwritetest.pas @@ -0,0 +1,186 @@ +{ +FPVectorial example application for writing vectorial images +generated in code to disk. This program will generate the following +vectorial images: + +single_line_1 One line from (0, 20) to (30, 30) +single_line_2 One line from (20, 30) to (30, 20) +polyline_1 One line from (0, 0) to (10, 10) to (20, 30) to (30, 20) +polyline_2 One line from (10, 10) to (20, 30) to (30, 20) to (40, 40) +bezier_1 One path starting in (0, 0) lining to (10, 10) then bezier to (20, 10) and then line to (30, 0) +bezier_2 One curve from (10, 10) to (20, 20) +text_ascii One text written at (10, 10) +text_europen One text testing european languages at (20, 20) +text_asian One text testing asian languages at (30, 30) + +Author: Felipe Monteiro de Carvalho + +License: Public Domain +} +program fpvwritetest; + +{$mode objfpc}{$H+} + +uses + fpvectorial, svgvectorialwriter, fpvutils; + +const + cFormat = vfSVG; + cExtension = '.svg'; +var + Vec: TvVectorialDocument; + +{$R *.res} + +begin + Vec := TvVectorialDocument.Create; + try + // All documents are 10cm x 10cm + Vec.Width := 100; + Vec.Height := 100; + + // single_line_1 One line from (0, 20) to (30, 30) + Vec.StartPath(0, 20); + Vec.AddLineToPath(30, 30); + Vec.EndPath(); + Vec.WriteToFile('single_line_1' + cExtension, cFormat); + + // single_line_2 One line from (20, 30) to (30, 20) + Vec.Clear; + Vec.StartPath(20, 30); + Vec.AddLineToPath(30, 20); + Vec.EndPath(); + Vec.WriteToFile('single_line_2' + cExtension, cFormat); + + // single_line_3 One line from (0, 20) to (30, 30) + frame + Vec.Clear; + Vec.StartPath(0, 20); + Vec.AddLineToPath(30, 30); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(100, 0); + Vec.AddLineToPath(100, 100); + Vec.AddLineToPath(0, 100); + Vec.AddLineToPath(0, 0); + Vec.EndPath(); + Vec.WriteToFile('single_line_3' + cExtension, cFormat); + + // polyline_1 One line from (0, 0) to (10, 10) to (20, 30) to (30, 20) + Vec.Clear; + Vec.StartPath(0, 0); + Vec.AddLineToPath(10, 10); + Vec.AddLineToPath(20, 30); + Vec.AddLineToPath(30, 20); + Vec.EndPath(); + Vec.WriteToFile('polyline_1' + cExtension, cFormat); + + // polyline_2 One line from (10, 10) to (20, 30) to (30, 20) to (40, 40) + Vec.Clear; + Vec.StartPath(10, 10); + Vec.AddLineToPath(20, 30); + Vec.AddLineToPath(30, 20); + Vec.AddLineToPath(40, 40); + Vec.EndPath(); + Vec.WriteToFile('polyline_2' + cExtension, cFormat); + + // bezier_1 One path starting in (0, 0) lining to (10, 10) then bezier to (20, 10) and then line to (30, 0) + Vec.Clear; + Vec.StartPath(0, 0); + Vec.AddLineToPath(10, 10); + Vec.AddBezierToPath(10, 20, 20, 20, 20, 10); + Vec.AddLineToPath(30, 0); + Vec.EndPath(); + Vec.WriteToFile('bezier_1' + cExtension, cFormat); + + // bezier_2 One curve from (10, 10) to (20, 20) + Vec.Clear; + Vec.StartPath(10, 10); + Vec.AddBezierToPath(10, 15, 15, 20, 20, 10); + Vec.EndPath(); + Vec.WriteToFile('bezier_2' + cExtension, cFormat); + + // text_ascii One text written at (10, 10) + Vec.Clear; + Vec.AddText(10, 10, 0, '10,10 Some text in english.'); + Vec.WriteToFile('text_ascii' + cExtension, cFormat); + + // text_europen One text testing european languages at (20, 20) + Vec.Clear; + Vec.AddText(20, 20, 0, '20, 20 Mówić, cześć, Włosku, Parabéns, Assunção, Correções.'); + Vec.WriteToFile('text_europen' + cExtension, cFormat); + + // text_asian One text testing asian languages at (30, 30) + Vec.Clear; + Vec.AddText(30, 30, 0, '30, 30 森林，是一个高密度树木的区域'); + Vec.WriteToFile('text_asian' + cExtension, cFormat); + + // multi_test_1 Combines various elements + Vec.Clear; + Vec.StartPath(0, 20); + Vec.AddLineToPath(30, 30); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(100, 0); + Vec.AddLineToPath(100, 100); + Vec.AddLineToPath(0, 100); + Vec.AddLineToPath(0, 0); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(10, 10); + Vec.AddBezierToPath(10, 20, 20, 20, 20, 10); + Vec.AddLineToPath(30, 0); + Vec.EndPath(); + Vec.AddText(10, 10, 0, '10,10 Some text in english.'); + Vec.AddText(20, 20, 0, '20, 20 Mówić, cześć, Włosku, Parabéns.'); + Vec.AddText(30, 30, 0, '30, 30 森林，是一个高密'); + Vec.WriteToFile('multi_test_1' + cExtension, cFormat); + + // pen_test_1 Tests the properties of the Pen + Vec.Clear; + Vec.StartPath(0, 20); + Vec.AddLineToPath(30, 30); + Vec.SetPenWidth(10); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(100, 0); + Vec.AddLineToPath(100, 100); + Vec.AddLineToPath(0, 100); + Vec.AddLineToPath(0, 0); + Vec.SetPenWidth(10); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(10, 10); + Vec.AddBezierToPath(10, 20, 20, 20, 20, 10); + Vec.AddLineToPath(30, 0); + Vec.SetPenWidth(10); + Vec.EndPath(); + Vec.WriteToFile('pen_test_1' + cExtension, cFormat); + + // pen_test_2 Tests the properties of the Pen + Vec.Clear; + Vec.StartPath(0, 20); + Vec.AddLineToPath(30, 30); + Vec.SetPenWidth(10); + Vec.SetPenColor(RGBToVColor(255, 0, 0)); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(100, 0); + Vec.AddLineToPath(100, 100); + Vec.AddLineToPath(0, 100); + Vec.AddLineToPath(0, 0); + Vec.SetPenWidth(10); + Vec.SetPenColor(RGBToVColor(0, 255, 0)); + Vec.EndPath(); + Vec.StartPath(0, 0); + Vec.AddLineToPath(10, 10); + Vec.AddBezierToPath(10, 20, 20, 20, 20, 10); + Vec.AddLineToPath(30, 0); + Vec.SetPenWidth(10); + Vec.SetPenColor(RGBToVColor(0, 0, 255)); + Vec.EndPath(); + Vec.WriteToFile('pen_test_2' + cExtension, cFormat); + finally + Vec.Free; + end; +end. + diff --git a/components/fpvectorial/fpvectbuildunit.pas b/components/fpvectorial/fpvectbuildunit.pas new file mode 100644 index 0000000000..e5e68e8a73 --- /dev/null +++ b/components/fpvectorial/fpvectbuildunit.pas @@ -0,0 +1,10 @@ +unit fpvectbuildunit; + +interface +Uses + avisocncgcodereader,avisocncgcodewriter,avisozlib,fpvectorial, + fpvtocanvas, + svgvectorialwriter,cdrvectorialreader,epsvectorialreader; + +implementation +end. diff --git a/components/fpvectorial/fpvectorial.pas b/components/fpvectorial/fpvectorial.pas new file mode 100644 index 0000000000..eab37c9423 --- /dev/null +++ b/components/fpvectorial/fpvectorial.pas @@ -0,0 +1,1480 @@ +{ +fpvectorial.pas + +Vector graphics document + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + Pedro Sol Pegorini L de Lima +} +unit fpvectorial; + +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses + Classes, SysUtils, Math, + fpcanvas, fpimage; + +type + TvVectorialFormat = ( + { Multi-purpose document formats } + vfPDF, vfSVG, vfCorelDrawCDR, vfWindowsMetafileWMF, + { CAD formats } + vfDXF, + { Printing formats } + vfPostScript, vfEncapsulatedPostScript, + { GCode formats } + vfGCodeAvisoCNCPrototipoV5, vfGCodeAvisoCNCPrototipoV6); + +const + { Default extensions } + { Multi-purpose document formats } + STR_PDF_EXTENSION = '.pdf'; + STR_POSTSCRIPT_EXTENSION = '.ps'; + STR_SVG_EXTENSION = '.svg'; + STR_CORELDRAW_EXTENSION = '.cdr'; + STR_WINMETAFILE_EXTENSION = '.wmf'; + STR_AUTOCAD_EXCHANGE_EXTENSION = '.dxf'; + STR_ENCAPSULATEDPOSTSCRIPT_EXTENSION = '.eps'; + +type + { Pen, Brush and Font } + + TvPen = record + Color: TFPColor; + Style: TFPPenStyle; + Width: Integer; + end; + + TvBrush = record + Color: TFPColor; + Style: TFPBrushStyle; + end; + + TvFont = record + Color: TFPColor; + Size: integer; + Name: utf8string; + {@@ + Font orientation is measured in degrees and uses the + same direction as the LCL TFont.orientation, which is counter-clockwise. + Zero is the normal, horizontal, orientation, directed to the right. + } + Orientation: Double; + end; + + { Coordinates and polyline segments } + + T3DPoint = record + X, Y, Z: Double; + end; + + P3DPoint = ^T3DPoint; + + TSegmentType = ( + st2DLine, st2DLineWithPen, st2DBezier, + st3DLine, st3DBezier, stMoveTo); + + {@@ + The coordinates in fpvectorial are given in millimiters and + the starting point is in the bottom-left corner of the document. + The X grows to the right and the Y grows to the top. + } + { TPathSegment } + + TPathSegment = class + public + SegmentType: TSegmentType; + // Fields for linking the list + Previous: TPathSegment; + Next: TPathSegment; + end; + + {@@ + In a 2D segment, the X and Y coordinates represent usually the + final point of the segment, being that it starts where the previous + segment ends. The exception is for the first segment of all, which simply + holds the starting point for the drawing and should always be of the type + stMoveTo. + } + T2DSegment = class(TPathSegment) + public + X, Y: Double; + end; + + T2DSegmentWithPen = class(T2DSegment) + public + Pen: TvPen; + end; + + {@@ + In Bezier segments, we remain using the X and Y coordinates for the ending point. + The starting point is where the previous segment ended, so that the intermediary + bezier control points are [X2, Y2] and [X3, Y3]. + } + T2DBezierSegment = class(T2DSegment) + public + X2, Y2: Double; + X3, Y3: Double; + end; + + T3DSegment = class(TPathSegment) + public + {@@ + Coordinates of the end of the segment. + For the first segment, this is the starting point. + } + X, Y, Z: Double; + end; + + T3DBezierSegment = class(T3DSegment) + public + X2, Y2, Z2: Double; + X3, Y3, Z3: Double; + end; + + TvFindEntityResult = (vfrNotFound, vfrFound, vfrSubpartFound); + + { Now all elements } + + {@@ + All elements should derive from TvEntity, regardless of whatever properties + they might contain. + } + + { TvEntity } + + TvEntity = class + public + X, Y, Z: Double; + {@@ The global Pen for the entire entity. In the case of paths, individual + elements might be able to override this setting. } + Pen: TvPen; + {@@ The global Brush for the entire entity. In the case of paths, individual + elements might be able to override this setting. } + Brush: TvBrush; + constructor Create; virtual; + procedure CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); virtual; + procedure ExpandBoundingBox(var ALeft, ATop, ARight, ABottom: Double); + function TryToSelect(APos: TPoint): TvFindEntityResult; virtual; + procedure Translate(ADeltaX, ADeltaY: Integer); virtual; + end; + + TvClipMode = (vcmNonzeroWindingRule, vcmEvenOddRule); + + TPath = class(TvEntity) + Len: Integer; + Points: TPathSegment; // Beginning of the double-linked list + PointsEnd: TPathSegment;// End of the double-linked list + CurPoint: TPathSegment; // Used in PrepareForSequentialReading and Next + ClipPath: TPath; + ClipMode: TvClipMode; + procedure Assign(ASource: TPath); + procedure PrepareForSequentialReading; + function Next(): TPathSegment; + procedure CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); override; + procedure AppendSegment(ASegment: TPathSegment); + end; + + {@@ + TvText represents a text entity. + } + + { TvText } + + TvText = class(TvEntity) + public + Value: TStringList; + Font: TvFont; + constructor Create; override; + destructor Destroy; override; + function TryToSelect(APos: TPoint): TvFindEntityResult; override; + end; + + {@@ + } + TvCircle = class(TvEntity) + public + Radius: Double; + end; + + {@@ + } + TvCircularArc = class(TvEntity) + public + Radius: Double; + {@@ The Angle is measured in degrees in relation to the positive X axis } + StartAngle, EndAngle: Double; + end; + + {@@ + } + TvEllipse = class(TvEntity) + public + // Mandatory fields + MajorHalfAxis, MinorHalfAxis: Double; + {@@ The Angle is measured in degrees in relation to the positive X axis } + Angle: Double; + // Calculated fields + BoundingRect: TRect; + procedure CalculateBoundingRectangle; + end; + + {@@ + The brush has no effect in this class + + DimensionLeft ---text--- DimensionRight + | | + | | BaseRight + | + | BaseLeft + } + + { TvAlignedDimension } + + TvAlignedDimension = class(TvEntity) + public + // Mandatory fields + BaseLeft, BaseRight, DimensionLeft, DimensionRight: T3DPoint; + end; + + {@@ + Vectorial images can contain raster images inside them and this entity + represents this. + + If the Width and Height differ from the same data in the image, then + the raster image will be stretched. + + Note that TFPCustomImage does not implement a storage, so the property + RasterImage should be filled with either a FPImage.TFPMemoryImage or with + a TLazIntfImage. The property RasterImage might be nil. + } + TvRasterImage = class(TvEntity) + public + RasterImage: TFPCustomImage; + Top, Left, Width, Height: Double; + end; + +type + + TvCustomVectorialWriter = class; + TvCustomVectorialReader = class; + TvVectorialPage = class; + + { TvVectorialDocument } + + TvVectorialDocument = class + private + FPages: TFPList; + FCurrentPageIndex: Integer; + function CreateVectorialWriter(AFormat: TvVectorialFormat): TvCustomVectorialWriter; + function CreateVectorialReader(AFormat: TvVectorialFormat): TvCustomVectorialReader; + public + Width, Height: Double; // in millimeters + Name: string; + // User-Interface information + ZoomLevel: Double; // 1 = 100% + { Selection fields } + SelectedvElement: TvEntity; + { Base methods } + constructor Create; virtual; + destructor Destroy; override; + procedure Assign(ASource: TvVectorialDocument); + procedure AssignTo(ADest: TvVectorialDocument); + procedure WriteToFile(AFileName: string; AFormat: TvVectorialFormat); overload; + procedure WriteToFile(AFileName: string); overload; + procedure WriteToStream(AStream: TStream; AFormat: TvVectorialFormat); + procedure WriteToStrings(AStrings: TStrings; AFormat: TvVectorialFormat); + procedure ReadFromFile(AFileName: string; AFormat: TvVectorialFormat); overload; + procedure ReadFromFile(AFileName: string); overload; + procedure ReadFromStream(AStream: TStream; AFormat: TvVectorialFormat); + procedure ReadFromStrings(AStrings: TStrings; AFormat: TvVectorialFormat); + class function GetFormatFromExtension(AFileName: string): TvVectorialFormat; + function GetDetailedFileFormat(): string; + procedure GuessDocumentSize(); + procedure GuessGoodZoomLevel(AScreenSize: Integer = 500); + { Page methods } + function GetPage(AIndex: Integer): TvVectorialPage; + function GetPageCount: Integer; + function GetCurrentPage: TvVectorialPage; + procedure SetCurrentPage(AIndex: Integer); + function AddPage(): TvVectorialPage; + { Data removing methods } + procedure Clear; virtual; + end; + + { TvVectorialPage } + + TvVectorialPage = class + private + FEntities: TFPList; + FTmpPath: TPath; + FTmpText: TvText; + //procedure RemoveCallback(data, arg: pointer); + procedure ClearTmpPath(); + procedure AppendSegmentToTmpPath(ASegment: TPathSegment); + public + Width, Height: Double; // in millimeters + Owner: TvVectorialDocument; + { Base methods } + constructor Create(AOwner: TvVectorialDocument); virtual; + destructor Destroy; override; + procedure Assign(ASource: TvVectorialPage); + { Data reading methods } + function GetEntity(ANum: Cardinal): TvEntity; + function GetEntitiesCount: Integer; + function FindAndSelectEntity(Pos: TPoint): TvFindEntityResult; + { Data removing methods } + procedure Clear; virtual; + { Data writing methods } + function AddEntity(AEntity: TvEntity): Integer; + procedure AddPathCopyMem(APath: TPath); + procedure StartPath(AX, AY: Double); overload; + procedure StartPath(); overload; + procedure AddMoveToPath(AX, AY: Double); + procedure AddLineToPath(AX, AY: Double); overload; + procedure AddLineToPath(AX, AY: Double; AColor: TFPColor); overload; + procedure AddLineToPath(AX, AY, AZ: Double); overload; + procedure GetCurrentPathPenPos(var AX, AY: Double); + procedure AddBezierToPath(AX1, AY1, AX2, AY2, AX3, AY3: Double); overload; + procedure AddBezierToPath(AX1, AY1, AZ1, AX2, AY2, AZ2, AX3, AY3, AZ3: Double); overload; + procedure SetBrushColor(AColor: TFPColor); + procedure SetBrushStyle(AStyle: TFPBrushStyle); + procedure SetPenColor(AColor: TFPColor); + procedure SetPenStyle(AStyle: TFPPenStyle); + procedure SetPenWidth(AWidth: Integer); + procedure SetClipPath(AClipPath: TPath; AClipMode: TvClipMode); + procedure EndPath(); + procedure AddText(AX, AY, AZ: Double; FontName: string; FontSize: integer; AText: utf8string); overload; + procedure AddText(AX, AY: Double; AStr: utf8string); overload; + procedure AddText(AX, AY, AZ: Double; AStr: utf8string); overload; + procedure AddCircle(ACenterX, ACenterY, ARadius: Double); + procedure AddCircularArc(ACenterX, ACenterY, ARadius, AStartAngle, AEndAngle: Double; AColor: TFPColor); + procedure AddEllipse(CenterX, CenterY, MajorHalfAxis, MinorHalfAxis, Angle: Double); + // Dimensions + procedure AddAlignedDimension(BaseLeft, BaseRight, DimLeft, DimRight: T3DPoint); + end; + + {@@ TvVectorialReader class reference type } + + TvVectorialReaderClass = class of TvCustomVectorialReader; + + { TvCustomVectorialReader } + + TvCustomVectorialReader = class + public + { General reading methods } + constructor Create; virtual; + procedure ReadFromFile(AFileName: string; AData: TvVectorialDocument); virtual; + procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); virtual; + procedure ReadFromStrings(AStrings: TStrings; AData: TvVectorialDocument); virtual; + end; + + {@@ TvVectorialWriter class reference type } + + TvVectorialWriterClass = class of TvCustomVectorialWriter; + + {@@ TvCustomVectorialWriter } + + { TvCustomVectorialWriter } + + TvCustomVectorialWriter = class + public + { General writing methods } + constructor Create; virtual; + procedure WriteToFile(AFileName: string; AData: TvVectorialDocument); virtual; + procedure WriteToStream(AStream: TStream; AData: TvVectorialDocument); virtual; + procedure WriteToStrings(AStrings: TStrings; AData: TvVectorialDocument); virtual; + end; + + {@@ List of registered formats } + + TvVectorialFormatData = record + ReaderClass: TvVectorialReaderClass; + WriterClass: TvVectorialWriterClass; + ReaderRegistered: Boolean; + WriterRegistered: Boolean; + Format: TvVectorialFormat; + end; + +var + GvVectorialFormats: array of TvVectorialFormatData; + +procedure RegisterVectorialReader( + AReaderClass: TvVectorialReaderClass; + AFormat: TvVectorialFormat); +procedure RegisterVectorialWriter( + AWriterClass: TvVectorialWriterClass; + AFormat: TvVectorialFormat); +function Make2DPoint(AX, AY: Double): T3DPoint; + +implementation + +const + Str_Error_Nil_Path = ' The program attempted to add a segment before creating a path'; + +{@@ + Registers a new reader for a format +} +procedure RegisterVectorialReader( + AReaderClass: TvVectorialReaderClass; + AFormat: TvVectorialFormat); +var + i, len: Integer; + FormatInTheList: Boolean; +begin + len := Length(GvVectorialFormats); + FormatInTheList := False; + + { First search for the format in the list } + for i := 0 to len - 1 do + begin + if GvVectorialFormats[i].Format = AFormat then + begin + if GvVectorialFormats[i].ReaderRegistered then + raise Exception.Create('RegisterVectorialReader: Reader class for format ' {+ AFormat} + ' already registered.'); + + GvVectorialFormats[i].ReaderRegistered := True; + GvVectorialFormats[i].ReaderClass := AReaderClass; + + FormatInTheList := True; + Break; + end; + end; + + { If not already in the list, then add it } + if not FormatInTheList then + begin + SetLength(GvVectorialFormats, len + 1); + + GvVectorialFormats[len].ReaderClass := AReaderClass; + GvVectorialFormats[len].WriterClass := nil; + GvVectorialFormats[len].ReaderRegistered := True; + GvVectorialFormats[len].WriterRegistered := False; + GvVectorialFormats[len].Format := AFormat; + end; +end; + +{@@ + Registers a new writer for a format +} +procedure RegisterVectorialWriter( + AWriterClass: TvVectorialWriterClass; + AFormat: TvVectorialFormat); +var + i, len: Integer; + FormatInTheList: Boolean; +begin + len := Length(GvVectorialFormats); + FormatInTheList := False; + + { First search for the format in the list } + for i := 0 to len - 1 do + begin + if GvVectorialFormats[i].Format = AFormat then + begin + if GvVectorialFormats[i].WriterRegistered then + raise Exception.Create('RegisterVectorialWriter: Writer class for format ' + {AFormat +} ' already registered.'); + + GvVectorialFormats[i].WriterRegistered := True; + GvVectorialFormats[i].WriterClass := AWriterClass; + + FormatInTheList := True; + Break; + end; + end; + + { If not already in the list, then add it } + if not FormatInTheList then + begin + SetLength(GvVectorialFormats, len + 1); + + GvVectorialFormats[len].ReaderClass := nil; + GvVectorialFormats[len].WriterClass := AWriterClass; + GvVectorialFormats[len].ReaderRegistered := False; + GvVectorialFormats[len].WriterRegistered := True; + GvVectorialFormats[len].Format := AFormat; + end; +end; + +function Make2DPoint(AX, AY: Double): T3DPoint; +begin + Result.X := AX; + Result.Y := AY; + Result.Z := 0; +end; + +{ TvVectorialPage } + +procedure TvVectorialPage.ClearTmpPath; +var + segment, oldsegment: TPathSegment; +begin + FTmpPath.Points := nil; + FTmpPath.PointsEnd := nil; + FTmpPath.Len := 0; + FTmpPath.Brush.Color := colBlue; + FTmpPath.Brush.Style := bsClear; + FTmpPath.Pen.Color := colBlack; + FTmpPath.Pen.Style := psSolid; + FTmpPath.Pen.Width := 1; +end; + +procedure TvVectorialPage.AppendSegmentToTmpPath(ASegment: TPathSegment); +begin + FTmpPath.AppendSegment(ASegment); +end; + +constructor TvVectorialPage.Create(AOwner: TvVectorialDocument); +begin + inherited Create; + + FEntities := TFPList.Create; + FTmpPath := TPath.Create; + Owner := AOwner; +end; + +destructor TvVectorialPage.Destroy; +begin + Clear; + + FEntities.Free; + + inherited Destroy; +end; + +procedure TvVectorialPage.Assign(ASource: TvVectorialPage); +var + i: Integer; +begin + Clear; + + for i := 0 to ASource.GetEntitiesCount - 1 do + Self.AddEntity(ASource.GetEntity(i)); +end; + +function TvVectorialPage.GetEntity(ANum: Cardinal): TvEntity; +begin + if ANum >= FEntities.Count then raise Exception.Create('TvVectorialDocument.GetEntity: Entity number out of bounds'); + + if FEntities.Items[ANum] = nil then raise Exception.Create('TvVectorialDocument.GetEntity: Invalid Entity number'); + + Result := TvEntity(FEntities.Items[ANum]); +end; + +function TvVectorialPage.GetEntitiesCount: Integer; +begin + Result := FEntities.Count; +end; + +function TvVectorialPage.FindAndSelectEntity(Pos: TPoint): TvFindEntityResult; +var + lEntity: TvEntity; + i: Integer; +begin + Result := vfrNotFound; + + for i := 0 to GetEntitiesCount() - 1 do + begin + lEntity := GetEntity(i); + + Result := lEntity.TryToSelect(Pos); + + if Result <> vfrNotFound then + begin + Owner.SelectedvElement := lEntity; + Exit; + end; + end; +end; + +procedure TvVectorialPage.Clear; +begin + FEntities.Clear(); +end; + +{@@ + Adds an entity to the document and returns it's current index +} +function TvVectorialPage.AddEntity(AEntity: TvEntity): Integer; +begin + Result := FEntities.Count; + FEntities.Add(Pointer(AEntity)); +end; + +procedure TvVectorialPage.AddPathCopyMem(APath: TPath); +var + lPath: TPath; + Len: Integer; +begin + lPath := TPath.Create; + lPath.Assign(APath); + AddEntity(lPath); + //WriteLn(':>TvVectorialDocument.AddPath 1 Len = ', Len); +end; + +{@@ + Starts writing a Path in multiple steps. + Should be followed by zero or more calls to AddPointToPath + and by a call to EndPath to effectively add the data. + + @see EndPath, AddPointToPath +} +procedure TvVectorialPage.StartPath(AX, AY: Double); +var + segment: T2DSegment; +begin + ClearTmpPath(); + + FTmpPath.Len := 1; + segment := T2DSegment.Create; + segment.SegmentType := stMoveTo; + segment.X := AX; + segment.Y := AY; + + FTmpPath.Points := segment; + FTmpPath.PointsEnd := segment; +end; + +procedure TvVectorialPage.StartPath; +begin + ClearTmpPath(); +end; + +procedure TvVectorialPage.AddMoveToPath(AX, AY: Double); +var + segment: T2DSegment; +begin + segment := T2DSegment.Create; + segment.SegmentType := stMoveTo; + segment.X := AX; + segment.Y := AY; + + AppendSegmentToTmpPath(segment); +end; + +{@@ + Adds one more point to the end of a Path being + writing in multiple steps. + + Does nothing if not called between StartPath and EndPath. + + Can be called multiple times to add multiple points. + + @see StartPath, EndPath +} +procedure TvVectorialPage.AddLineToPath(AX, AY: Double); +var + segment: T2DSegment; +begin + segment := T2DSegment.Create; + segment.SegmentType := st2DLine; + segment.X := AX; + segment.Y := AY; + + AppendSegmentToTmpPath(segment); +end; + +procedure TvVectorialPage.AddLineToPath(AX, AY: Double; AColor: TFPColor); +var + segment: T2DSegmentWithPen; +begin + segment := T2DSegmentWithPen.Create; + segment.SegmentType := st2DLineWithPen; + segment.X := AX; + segment.Y := AY; + segment.Pen.Color := AColor; + + AppendSegmentToTmpPath(segment); +end; + +procedure TvVectorialPage.AddLineToPath(AX, AY, AZ: Double); +var + segment: T3DSegment; +begin + segment := T3DSegment.Create; + segment.SegmentType := st3DLine; + segment.X := AX; + segment.Y := AY; + segment.Z := AZ; + + AppendSegmentToTmpPath(segment); +end; + +{@@ + Gets the current Pen Pos in the temporary path +} +procedure TvVectorialPage.GetCurrentPathPenPos(var AX, AY: Double); +begin + // Check if we are the first segment in the tmp path + if FTmpPath.PointsEnd = nil then raise Exception.Create('[TvVectorialDocument.GetCurrentPathPenPos] One cannot obtain the Pen Pos if there are no segments in the temporary path'); + + AX := T2DSegment(FTmpPath.PointsEnd).X; + AY := T2DSegment(FTmpPath.PointsEnd).Y; +end; + +{@@ + Adds a bezier element to the path. It starts where the previous element ended + and it goes throw the control points [AX1, AY1] and [AX2, AY2] and ends + in [AX3, AY3]. +} +procedure TvVectorialPage.AddBezierToPath(AX1, AY1, AX2, AY2, AX3, AY3: Double); +var + segment: T2DBezierSegment; +begin + segment := T2DBezierSegment.Create; + segment.SegmentType := st2DBezier; + segment.X := AX3; + segment.Y := AY3; + segment.X2 := AX1; + segment.Y2 := AY1; + segment.X3 := AX2; + segment.Y3 := AY2; + + AppendSegmentToTmpPath(segment); +end; + +procedure TvVectorialPage.AddBezierToPath(AX1, AY1, AZ1, AX2, AY2, AZ2, AX3, AY3, AZ3: Double); +var + segment: T3DBezierSegment; +begin + segment := T3DBezierSegment.Create; + segment.SegmentType := st3DBezier; + segment.X := AX3; + segment.Y := AY3; + segment.Z := AZ3; + segment.X2 := AX1; + segment.Y2 := AY1; + segment.Z2 := AZ1; + segment.X3 := AX2; + segment.Y3 := AY2; + segment.Z3 := AZ2; + + AppendSegmentToTmpPath(segment); +end; + +procedure TvVectorialPage.SetBrushColor(AColor: TFPColor); +begin + FTmPPath.Brush.Color := AColor; +end; + +procedure TvVectorialPage.SetBrushStyle(AStyle: TFPBrushStyle); +begin + FTmPPath.Brush.Style := AStyle; +end; + +procedure TvVectorialPage.SetPenColor(AColor: TFPColor); +begin + FTmPPath.Pen.Color := AColor; +end; + +procedure TvVectorialPage.SetPenStyle(AStyle: TFPPenStyle); +begin + FTmPPath.Pen.Style := AStyle; +end; + +procedure TvVectorialPage.SetPenWidth(AWidth: Integer); +begin + FTmPPath.Pen.Width := AWidth; +end; + +procedure TvVectorialPage.SetClipPath(AClipPath: TPath; AClipMode: TvClipMode); +begin + FTmPPath.ClipPath := AClipPath; + FTmPPath.ClipMode := AClipMode; +end; + +{@@ + Finishes writing a Path, which was created in multiple + steps using StartPath and AddPointToPath, + to the document. + + Does nothing if there wasn't a previous correspondent call to + StartPath. + + @see StartPath, AddPointToPath +} +procedure TvVectorialPage.EndPath; +begin + if FTmPPath.Len = 0 then Exit; + AddPathCopyMem(FTmPPath); + ClearTmpPath(); +end; + +procedure TvVectorialPage.AddText(AX, AY, AZ: Double; FontName: string; + FontSize: integer; AText: utf8string); +var + lText: TvText; +begin + lText := TvText.Create; + lText.Value.Text := AText; + lText.X := AX; + lText.Y := AY; + lText.Z := AZ; + lText.Font.Name := FontName; + lText.Font.Size := FontSize; + AddEntity(lText); +end; + +procedure TvVectorialPage.AddText(AX, AY: Double; AStr: utf8string); +begin + AddText(AX, AY, 0, '', 10, AStr); +end; + +procedure TvVectorialPage.AddText(AX, AY, AZ: Double; AStr: utf8string); +begin + AddText(AX, AY, AZ, '', 10, AStr); +end; + +procedure TvVectorialPage.AddCircle(ACenterX, ACenterY, ARadius: Double); +var + lCircle: TvCircle; +begin + lCircle := TvCircle.Create; + lCircle.X := ACenterX; + lCircle.Y := ACenterY; + lCircle.Radius := ARadius; + AddEntity(lCircle); +end; + +procedure TvVectorialPage.AddCircularArc(ACenterX, ACenterY, ARadius, + AStartAngle, AEndAngle: Double; AColor: TFPColor); +var + lCircularArc: TvCircularArc; +begin + lCircularArc := TvCircularArc.Create; + lCircularArc.X := ACenterX; + lCircularArc.Y := ACenterY; + lCircularArc.Radius := ARadius; + lCircularArc.StartAngle := AStartAngle; + lCircularArc.EndAngle := AEndAngle; + lCircularArc.Pen.Color := AColor; + AddEntity(lCircularArc); +end; + +procedure TvVectorialPage.AddEllipse(CenterX, CenterY, MajorHalfAxis, + MinorHalfAxis, Angle: Double); +var + lEllipse: TvEllipse; +begin + lEllipse := TvEllipse.Create; + lEllipse.X := CenterX; + lEllipse.Y := CenterY; + lEllipse.MajorHalfAxis := MajorHalfAxis; + lEllipse.MinorHalfAxis := MinorHalfAxis; + lEllipse.Angle := Angle; + AddEntity(lEllipse); +end; + + +procedure TvVectorialPage.AddAlignedDimension(BaseLeft, BaseRight, DimLeft, + DimRight: T3DPoint); +var + lDim: TvAlignedDimension; +begin + lDim := TvAlignedDimension.Create; + lDim.BaseLeft := BaseLeft; + lDim.BaseRight := BaseRight; + lDim.DimensionLeft := DimLeft; + lDim.DimensionRight := DimRight; + AddEntity(lDim); +end; + +{ TvText } + +constructor TvText.Create; +begin + inherited Create; + Value := TStringList.Create; +end; + +destructor TvText.Destroy; +begin + Value.Free; + inherited Destroy; +end; + +function TvText.TryToSelect(APos: TPoint): TvFindEntityResult; +var + lProximityFactor: Integer; +begin + lProximityFactor := 5; + if (APos.X > X - lProximityFactor) and (APos.X < X + lProximityFactor) + and (APos.Y > Y - lProximityFactor) and (APos.Y < Y + lProximityFactor) then + Result := vfrFound + else Result := vfrNotFound; +end; + +{ TvEntity } + +constructor TvEntity.Create; +begin + Pen.Style := psSolid; + Pen.Color := colBlack; + Brush.Style := bsClear; + Brush.Color := colBlue; +end; + +procedure TvEntity.CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); +begin + ALeft := 0; + ATop := 0; + ARight := 0; + ABottom := 0; +end; + +procedure TvEntity.ExpandBoundingBox(var ALeft, ATop, ARight, ABottom: Double); +var + lLeft, lTop, lRight, lBottom: Double; +begin + CalculateBoundingBox(lLeft, lTop, lRight, lBottom); + if lLeft < ALeft then ALeft := lLeft; + if lTop < ATop then ATop := lTop; + if lRight > ARight then ARight := lRight; + if lBottom > ABottom then ABottom := lBottom; +end; + +function TvEntity.TryToSelect(APos: TPoint): TvFindEntityResult; +begin + Result := vfrNotFound; +end; + +procedure TvEntity.Translate(ADeltaX, ADeltaY: Integer); +begin + X := X + ADeltaX; + Y := Y + ADeltaY; +end; + +{ TvEllipse } + +procedure TvEllipse.CalculateBoundingRectangle; +var + t, tmp: Double; +begin + { + To calculate the bounding rectangle we can do this: + + Ellipse equations:You could try using the parametrized equations for an ellipse rotated at an arbitrary angle: + + x = CenterX + MajorHalfAxis*cos(t)*cos(Angle) - MinorHalfAxis*sin(t)*sin(Angle) + y = CenterY + MinorHalfAxis*sin(t)*cos(Angle) + MajorHalfAxis*cos(t)*sin(Angle) + + You can then differentiate and solve for gradient = 0: + 0 = dx/dt = -MajorHalfAxis*sin(t)*cos(Angle) - MinorHalfAxis*cos(t)*sin(Angle) + => + tan(t) = -MinorHalfAxis*tan(Angle)/MajorHalfAxis + => + t = cotang(-MinorHalfAxis*tan(Angle)/MajorHalfAxis) + + On the other axis: + + 0 = dy/dt = b*cos(t)*cos(phi) - a*sin(t)*sin(phi) + => + tan(t) = b*cot(phi)/a + } + t := cotan(-MinorHalfAxis*tan(Angle)/MajorHalfAxis); + tmp := X + MajorHalfAxis*cos(t)*cos(Angle) - MinorHalfAxis*sin(t)*sin(Angle); + BoundingRect.Right := Round(tmp); +end; + +{ TsWorksheet } + +{@@ + Constructor. +} +constructor TvVectorialDocument.Create; +begin + inherited Create; + + FPages := TFPList.Create; +end; + +{@@ + Destructor. +} +destructor TvVectorialDocument.Destroy; +begin + Clear; + + FPages.Free; + + inherited Destroy; +end; + +procedure TvVectorialDocument.Assign(ASource: TvVectorialDocument); +//var +// i: Integer; +begin +// Clear; +// +// for i := 0 to ASource.GetEntitiesCount - 1 do +// Self.AddEntity(ASource.GetEntity(i)); +end; + +procedure TvVectorialDocument.AssignTo(ADest: TvVectorialDocument); +begin + ADest.Assign(Self); +end; + +{@@ + Convenience method which creates the correct + writer object for a given vector graphics document format. +} +function TvVectorialDocument.CreateVectorialWriter(AFormat: TvVectorialFormat): TvCustomVectorialWriter; +var + i: Integer; +begin + Result := nil; + + for i := 0 to Length(GvVectorialFormats) - 1 do + if GvVectorialFormats[i].Format = AFormat then + begin + if GvVectorialFormats[i].WriterClass <> nil then + Result := GvVectorialFormats[i].WriterClass.Create; + + Break; + end; + + if Result = nil then raise Exception.Create('Unsupported vector graphics format.'); +end; + +{@@ + Convenience method which creates the correct + reader object for a given vector graphics document format. +} +function TvVectorialDocument.CreateVectorialReader(AFormat: TvVectorialFormat): TvCustomVectorialReader; +var + i: Integer; +begin + Result := nil; + + for i := 0 to Length(GvVectorialFormats) - 1 do + if GvVectorialFormats[i].Format = AFormat then + begin + if GvVectorialFormats[i].ReaderClass <> nil then + Result := GvVectorialFormats[i].ReaderClass.Create; + + Break; + end; + + if Result = nil then raise Exception.Create('Unsupported vector graphics format.'); +end; + +{@@ + Writes the document to a file. + + If the file doesn't exist, it will be created. +} +procedure TvVectorialDocument.WriteToFile(AFileName: string; AFormat: TvVectorialFormat); +var + AWriter: TvCustomVectorialWriter; +begin + AWriter := CreateVectorialWriter(AFormat); + + try + AWriter.WriteToFile(AFileName, Self); + finally + AWriter.Free; + end; +end; + +procedure TvVectorialDocument.WriteToFile(AFileName: string); +var + lFormat: TvVectorialFormat; +begin + lFormat := GetFormatFromExtension(ExtractFileExt(AFileName)); + WriteToFile(AFileName, lFormat); +end; + +{@@ + Writes the document to a stream +} +procedure TvVectorialDocument.WriteToStream(AStream: TStream; AFormat: TvVectorialFormat); +var + AWriter: TvCustomVectorialWriter; +begin + AWriter := CreateVectorialWriter(AFormat); + + try + AWriter.WriteToStream(AStream, Self); + finally + AWriter.Free; + end; +end; + +procedure TvVectorialDocument.WriteToStrings(AStrings: TStrings; + AFormat: TvVectorialFormat); +var + AWriter: TvCustomVectorialWriter; +begin + AWriter := CreateVectorialWriter(AFormat); + + try + AWriter.WriteToStrings(AStrings, Self); + finally + AWriter.Free; + end; +end; + +{@@ + Reads the document from a file. + + Any current contents in this object will be removed. +} +procedure TvVectorialDocument.ReadFromFile(AFileName: string; + AFormat: TvVectorialFormat); +var + AReader: TvCustomVectorialReader; +begin + Self.Clear; + + AReader := CreateVectorialReader(AFormat); + try + AReader.ReadFromFile(AFileName, Self); + finally + AReader.Free; + end; +end; + +{@@ + Reads the document from a file. A variant that auto-detects the format from the extension and other factors. +} +procedure TvVectorialDocument.ReadFromFile(AFileName: string); +var + lFormat: TvVectorialFormat; +begin + lFormat := GetFormatFromExtension(ExtractFileExt(AFileName)); + ReadFromFile(AFileName, lFormat); +end; + +{@@ + Reads the document from a stream. + + Any current contents in this object will be removed. +} +procedure TvVectorialDocument.ReadFromStream(AStream: TStream; + AFormat: TvVectorialFormat); +var + AReader: TvCustomVectorialReader; +begin + Self.Clear; + + AReader := CreateVectorialReader(AFormat); + try + AReader.ReadFromStream(AStream, Self); + finally + AReader.Free; + end; +end; + +procedure TvVectorialDocument.ReadFromStrings(AStrings: TStrings; + AFormat: TvVectorialFormat); +var + AReader: TvCustomVectorialReader; +begin + Self.Clear; + + AReader := CreateVectorialReader(AFormat); + try + AReader.ReadFromStrings(AStrings, Self); + finally + AReader.Free; + end; +end; + +class function TvVectorialDocument.GetFormatFromExtension(AFileName: string + ): TvVectorialFormat; +var + lExt: string; +begin + lExt := ExtractFileExt(AFileName); + if AnsiCompareText(lExt, STR_PDF_EXTENSION) = 0 then Result := vfPDF + else if AnsiCompareText(lExt, STR_POSTSCRIPT_EXTENSION) = 0 then Result := vfPostScript + else if AnsiCompareText(lExt, STR_SVG_EXTENSION) = 0 then Result := vfSVG + else if AnsiCompareText(lExt, STR_CORELDRAW_EXTENSION) = 0 then Result := vfCorelDrawCDR + else if AnsiCompareText(lExt, STR_WINMETAFILE_EXTENSION) = 0 then Result := vfWindowsMetafileWMF + else if AnsiCompareText(lExt, STR_AUTOCAD_EXCHANGE_EXTENSION) = 0 then Result := vfDXF + else if AnsiCompareText(lExt, STR_ENCAPSULATEDPOSTSCRIPT_EXTENSION) = 0 then Result := vfEncapsulatedPostScript + else + raise Exception.Create('TvVectorialDocument.GetFormatFromExtension: The extension (' + lExt + ') doesn''t match any supported formats.'); +end; + +function TvVectorialDocument.GetDetailedFileFormat(): string; +begin + +end; + +procedure TvVectorialDocument.GuessDocumentSize(); +var + i, j: Integer; + lEntity: TvEntity; + lLeft, lTop, lRight, lBottom: Double; + CurPage: TvVectorialPage; +begin + lLeft := 0; + lTop := 0; + lRight := 0; + lBottom := 0; + + for j := 0 to GetPageCount()-1 do + begin + CurPage := GetPage(j); + for i := 0 to CurPage.GetEntitiesCount() - 1 do + begin + lEntity := CurPage.GetEntity(I); + lEntity.ExpandBoundingBox(lLeft, lTop, lRight, lBottom); + end; + end; + + Width := lRight - lLeft; + Height := lBottom - lTop; +end; + +procedure TvVectorialDocument.GuessGoodZoomLevel(AScreenSize: Integer); +begin + ZoomLevel := AScreenSize / Height; +end; + +function TvVectorialDocument.GetPage(AIndex: Integer): TvVectorialPage; +begin + Result := TvVectorialPage(FPages.Items[AIndex]); +end; + +function TvVectorialDocument.GetPageCount: Integer; +begin + Result := FPages.Count; +end; + +function TvVectorialDocument.GetCurrentPage: TvVectorialPage; +begin + if FCurrentPageIndex >= 0 then + Result := GetPage(FCurrentPageIndex) + else + Result := nil; +end; + +procedure TvVectorialDocument.SetCurrentPage(AIndex: Integer); +begin + FCurrentPageIndex := AIndex; +end; + +function TvVectorialDocument.AddPage: TvVectorialPage; +begin + Result := TvVectorialPage.Create(Self); + FPages.Add(Result); + if FCurrentPageIndex < 0 then FCurrentPageIndex := FPages.Count-1; +end; + +{@@ + Clears all data in the document +} +procedure TvVectorialDocument.Clear; +begin +end; + +{ TvCustomVectorialReader } + +constructor TvCustomVectorialReader.Create; +begin + inherited Create; +end; + +procedure TvCustomVectorialReader.ReadFromFile(AFileName: string; AData: TvVectorialDocument); +var + FileStream: TFileStream; +begin + FileStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyNone); + try + ReadFromStream(FileStream, AData); + finally + FileStream.Free; + end; +end; + +procedure TvCustomVectorialReader.ReadFromStream(AStream: TStream; + AData: TvVectorialDocument); +var + AStringStream: TStringStream; + AStrings: TStringList; +begin + AStringStream := TStringStream.Create(''); + AStrings := TStringList.Create; + try + AStringStream.CopyFrom(AStream, AStream.Size); + AStringStream.Seek(0, soFromBeginning); + AStrings.Text := AStringStream.DataString; + ReadFromStrings(AStrings, AData); + finally + AStringStream.Free; + AStrings.Free; + end; +end; + +procedure TvCustomVectorialReader.ReadFromStrings(AStrings: TStrings; + AData: TvVectorialDocument); +var + AStringStream: TStringStream; +begin + AStringStream := TStringStream.Create(''); + try + AStringStream.WriteString(AStrings.Text); + AStringStream.Seek(0, soFromBeginning); + ReadFromStream(AStringStream, AData); + finally + AStringStream.Free; + end; +end; + +{ TsCustomSpreadWriter } + +constructor TvCustomVectorialWriter.Create; +begin + inherited Create; +end; + +{@@ + Default file writting method. + + Opens the file and calls WriteToStream + + @param AFileName The output file name. + If the file already exists it will be replaced. + @param AData The Workbook to be saved. + + @see TsWorkbook +} +procedure TvCustomVectorialWriter.WriteToFile(AFileName: string; AData: TvVectorialDocument); +var + OutputFile: TFileStream; +begin + OutputFile := TFileStream.Create(AFileName, fmCreate or fmOpenWrite); + try + WriteToStream(OutputFile, AData); + finally + OutputFile.Free; + end; +end; + +{@@ + The default stream writer just uses WriteToStrings +} +procedure TvCustomVectorialWriter.WriteToStream(AStream: TStream; + AData: TvVectorialDocument); +var + lStringList: TStringList; +begin + lStringList := TStringList.Create; + try + WriteToStrings(lStringList, AData); + lStringList.SaveToStream(AStream); + finally + lStringList.Free; + end; +end; + +procedure TvCustomVectorialWriter.WriteToStrings(AStrings: TStrings; + AData: TvVectorialDocument); +begin + +end; + +{ TPath } + +procedure TPath.Assign(ASource: TPath); +begin + Len := ASource.Len; + Points := ASource.Points; + PointsEnd := ASource.PointsEnd; + CurPoint := ASource.CurPoint; + Pen := ASource.Pen; + Brush := ASource.Brush; + ClipPath := ASource.ClipPath; + ClipMode := ASource.ClipMode; +end; + +procedure TPath.PrepareForSequentialReading; +begin + CurPoint := nil; +end; + +function TPath.Next(): TPathSegment; +begin + if CurPoint = nil then Result := Points + else Result := CurPoint.Next; + + CurPoint := Result; +end; + +procedure TPath.CalculateBoundingBox(var ALeft, ATop, ARight, ABottom: Double); +var + lSegment: TPathSegment; + l2DSegment: T2DSegment; + lFirstValue: Boolean = True; +begin + inherited CalculateBoundingBox(ALeft, ATop, ARight, ABottom); + + PrepareForSequentialReading(); + lSegment := Next(); + while lSegment <> nil do + begin + if lSegment is T2DSegment then + begin + l2DSegment := T2DSegment(lSegment); + if lFirstValue then + begin + ALeft := l2DSegment.X; + ATop := l2DSegment.Y; + ARight := l2DSegment.X; + ABottom := l2DSegment.Y; + lFirstValue := False; + end + else + begin + if l2DSegment.X < ALeft then ALeft := l2DSegment.X; + if l2DSegment.Y < ATop then ATop := l2DSegment.Y; + if l2DSegment.X > ARight then ARight := l2DSegment.X; + if l2DSegment.Y > ABottom then ABottom := l2DSegment.Y; + end; + end; + + lSegment := Next(); + end; +end; + +procedure TPath.AppendSegment(ASegment: TPathSegment); +var + L: Integer; +begin + // Check if we are the first segment in the tmp path + if PointsEnd = nil then + begin + if Len <> 0 then + Exception.Create('[TPath.AppendSegment] Assertion failed Len <> 0 with PointsEnd = nil'); + + Points := ASegment; + PointsEnd := ASegment; + Len := 1; + Exit; + end; + + L := Len; + Inc(Len); + + // Adds the element to the end of the list + PointsEnd.Next := ASegment; + ASegment.Previous := PointsEnd; + PointsEnd := ASegment; +end; + +finalization + + SetLength(GvVectorialFormats, 0); + +end. + diff --git a/components/fpvectorial/fpvectorialpkg.lpk b/components/fpvectorial/fpvectorialpkg.lpk new file mode 100644 index 0000000000..9eb8097ce7 --- /dev/null +++ b/components/fpvectorial/fpvectorialpkg.lpk @@ -0,0 +1,82 @@ +<?xml version="1.0"?> +<CONFIG> + <Package Version="4"> + <Name Value="fpvectorialpkg"/> + <AddToProjectUsesSection Value="True"/> + <CompilerOptions> + <Version Value="10"/> + <SearchPaths> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Other> + <CompilerPath Value="$(CompPath)"/> + </Other> + </CompilerOptions> + <Files Count="12"> + <Item1> + <Filename Value="svgvectorialwriter.pas"/> + <UnitName Value="svgvectorialwriter"/> + </Item1> + <Item2> + <Filename Value="fpvtocanvas.pas"/> + <UnitName Value="fpvtocanvas"/> + </Item2> + <Item3> + <Filename Value="fpvectorial.pas"/> + <UnitName Value="fpvectorial"/> + </Item3> + <Item4> + <Filename Value="fpvectbuildunit.pas"/> + <UnitName Value="fpvectbuildunit"/> + </Item4> + <Item5> + <Filename Value="dxfvectorialreader.pas"/> + <UnitName Value="dxfvectorialreader"/> + </Item5> + <Item6> + <Filename Value="cdrvectorialreader.pas"/> + <UnitName Value="cdrvectorialreader"/> + </Item6> + <Item7> + <Filename Value="avisozlib.pas"/> + <UnitName Value="avisozlib"/> + </Item7> + <Item8> + <Filename Value="avisocncgcodewriter.pas"/> + <UnitName Value="avisocncgcodewriter"/> + </Item8> + <Item9> + <Filename Value="avisocncgcodereader.pas"/> + <UnitName Value="avisocncgcodereader"/> + </Item9> + <Item10> + <Filename Value="svgvectorialreader.pas"/> + <UnitName Value="svgvectorialreader"/> + </Item10> + <Item11> + <Filename Value="epsvectorialreader.pas"/> + <UnitName Value="epsvectorialreader"/> + </Item11> + <Item12> + <Filename Value="fpvutils.pas"/> + <UnitName Value="fpvutils"/> + </Item12> + </Files> + <Type Value="RunAndDesignTime"/> + <RequiredPkgs Count="2"> + <Item1> + <PackageName Value="LCL"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + <MinVersion Major="1" Release="1" Valid="True"/> + </Item2> + </RequiredPkgs> + <UsageOptions> + <UnitPath Value="$(PkgOutDir)"/> + </UsageOptions> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + </Package> +</CONFIG> diff --git a/components/fpvectorial/fpvectorialpkg.pas b/components/fpvectorial/fpvectorialpkg.pas new file mode 100644 index 0000000000..bf0888c216 --- /dev/null +++ b/components/fpvectorial/fpvectorialpkg.pas @@ -0,0 +1,23 @@ +{ This file was automatically created by Lazarus. Do not edit! + This source is only used to compile and install the package. + } + +unit fpvectorialpkg; + +interface + +uses + svgvectorialwriter, fpvtocanvas, fpvectorial, fpvectbuildunit, + dxfvectorialreader, cdrvectorialreader, avisozlib, avisocncgcodewriter, + avisocncgcodereader, svgvectorialreader, epsvectorialreader, fpvutils, + LazarusPackageIntf; + +implementation + +procedure Register; +begin +end; + +initialization + RegisterPackage('fpvectorialpkg', @Register); +end. diff --git a/components/fpvectorial/fpvtocanvas.pas b/components/fpvectorial/fpvtocanvas.pas new file mode 100644 index 0000000000..58a0ff886f --- /dev/null +++ b/components/fpvectorial/fpvtocanvas.pas @@ -0,0 +1,591 @@ +unit fpvtocanvas; + +{$mode objfpc}{$H+} + +interface + +{$define USE_LCL_CANVAS} +{$ifdef USE_LCL_CANVAS} + {$define USE_CANVAS_CLIP_REGION} + {.$define DEBUG_CANVAS_CLIP_REGION} +{$endif} +{$ifndef Windows} +{.$define FPVECTORIAL_TOCANVAS_DEBUG} +{$endif} + +uses + Classes, SysUtils, Math, + {$ifdef USE_LCL_CANVAS} + Graphics, LCLIntf, LCLType, + {$endif} + fpcanvas, + fpimage, + fpvectorial, fpvutils; + +procedure DrawFPVectorialToCanvas(ASource: TvVectorialPage; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); +procedure DrawFPVPathToCanvas(ASource: TvVectorialPage; CurPath: TPath; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); +procedure DrawFPVEntityToCanvas(ASource: TvVectorialPage; CurEntity: TvEntity; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); +procedure DrawFPVTextToCanvas(ASource: TvVectorialPage; CurText: TvText; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); + +implementation + +function Rotate2DPoint(P,Fix :TPoint; alpha:double): TPoint; +var + sinus, cosinus : Extended; +begin + SinCos(alpha, sinus, cosinus); + P.x := P.x - Fix.x; + P.y := P.y - Fix.y; + result.x := Round(p.x*cosinus + p.y*sinus) + fix.x ; + result.y := Round(-p.x*sinus + p.y*cosinus) + Fix.y; +end; + +procedure DrawRotatedEllipse( + ADest: TFPCustomCanvas; + CurEllipse: TvEllipse; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); +var + PointList: array[0..6] of TPoint; + f: TPoint; + dk, x1, x2, y1, y2: Integer; + {$ifdef USE_LCL_CANVAS} + ALCLDest: TCanvas absolute ADest; + {$endif} +begin + {$ifdef USE_LCL_CANVAS} + CurEllipse.CalculateBoundingRectangle(); + x1 := CurEllipse.BoundingRect.Left; + x2 := CurEllipse.BoundingRect.Right; + y1 := CurEllipse.BoundingRect.Top; + y2 := CurEllipse.BoundingRect.Bottom; + + dk := Round(0.654 * Abs(y2-y1)); + f.x := Round(CurEllipse.X); + f.y := Round(CurEllipse.Y - 1); + PointList[0] := Rotate2DPoint(Point(x1, f.y), f, CurEllipse.Angle) ; // Startpoint + PointList[1] := Rotate2DPoint(Point(x1, f.y - dk), f, CurEllipse.Angle); + //Controlpoint of Startpoint first part + PointList[2] := Rotate2DPoint(Point(x2- 1, f.y - dk), f, CurEllipse.Angle); + //Controlpoint of secondpoint first part + PointList[3] := Rotate2DPoint(Point(x2 -1 , f.y), f, CurEllipse.Angle); + // Firstpoint of secondpart + PointList[4] := Rotate2DPoint(Point(x2-1 , f.y + dk), f, CurEllipse.Angle); + // Controllpoint of secondpart firstpoint + PointList[5] := Rotate2DPoint(Point(x1, f.y + dk), f, CurEllipse.Angle); + // Conrollpoint of secondpart endpoint + PointList[6] := PointList[0]; // Endpoint of + // Back to the startpoint + ALCLDest.PolyBezier(Pointlist[0]); + {$endif} +end; + +{@@ + This function draws a FPVectorial vectorial image to a TFPCustomCanvas + descendent, such as TCanvas from the LCL. + + Be careful that by default this routine does not execute coordinate transformations, + and that FPVectorial works with a start point in the bottom-left corner, with + the X growing to the right and the Y growing to the top. This will result in + an image in TFPCustomCanvas mirrored in the Y axis in relation with the document + as seen in a PDF viewer, for example. This can be easily changed with the + provided parameters. To have the standard view of an image viewer one could + use this function like this: + + DrawFPVectorialToCanvas(ASource, ADest, 0, ASource.Height, 1.0, -1.0); +} +procedure DrawFPVectorialToCanvas(ASource: TvVectorialPage; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); +var + i: Integer; + CurEntity: TvEntity; +begin + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + WriteLn(':>DrawFPVectorialToCanvas'); + {$endif} + + for i := 0 to ASource.GetEntitiesCount - 1 do + begin + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format('[Path] ID=%d', [i])); + {$endif} + + CurEntity := ASource.GetEntity(i); + + if CurEntity is TPath then DrawFPVPathToCanvas(ASource, TPath(CurEntity), ADest, ADestX, ADestY, AMulX, AMulY) + else if CurEntity is TvText then DrawFPVTextToCanvas(ASource, TvText(CurEntity), ADest, ADestX, ADestY, AMulX, AMulY) + else DrawFPVEntityToCanvas(ASource, CurEntity, ADest, ADestX, ADestY, AMulX, AMulY); + end; + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + WriteLn(':<DrawFPVectorialToCanvas'); + {$endif} +end; + +procedure DrawFPVPathToCanvas(ASource: TvVectorialPage; CurPath: TPath; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); + + function CoordToCanvasX(ACoord: Double): Integer; + begin + Result := Round(ADestX + AmulX * ACoord); + end; + + function CoordToCanvasY(ACoord: Double): Integer; + begin + Result := Round(ADestY + AmulY * ACoord); + end; + +var + j, k: Integer; + PosX, PosY: Double; // Not modified by ADestX, etc + CoordX, CoordY: Integer; + CurSegment: TPathSegment; + Cur2DSegment: T2DSegment absolute CurSegment; + Cur2DBSegment: T2DBezierSegment absolute CurSegment; + // For bezier + CurX, CurY: Integer; // Not modified by ADestX, etc + CoordX2, CoordY2, CoordX3, CoordY3, CoordX4, CoordY4: Integer; + CurveLength: Integer; + t: Double; + // For polygons + Points: array of TPoint; + // Clipping Region + {$ifdef USE_LCL_CANVAS} + ClipRegion, OldClipRegion: HRGN; + ACanvas: TCanvas absolute ADest; + {$endif} +begin + PosX := 0; + PosY := 0; + ADest.Brush.Style := bsClear; + + ADest.MoveTo(ADestX, ADestY); + + // Set the path Pen and Brush options + ADest.Pen.Style := CurPath.Pen.Style; + ADest.Pen.Width := Round(CurPath.Pen.Width * AMulX); + if ADest.Pen.Width < 1 then ADest.Pen.Width := 1; + ADest.Pen.FPColor := CurPath.Pen.Color; + ADest.Brush.FPColor := CurPath.Brush.Color; + + // Prepare the Clipping Region, if any + {$ifdef USE_CANVAS_CLIP_REGION} + if CurPath.ClipPath <> nil then + begin + OldClipRegion := LCLIntf.CreateEmptyRegion(); + GetClipRgn(ACanvas.Handle, OldClipRegion); + ClipRegion := ConvertPathToRegion(CurPath.ClipPath, ADestX, ADestY, AMulX, AMulY); + SelectClipRgn(ACanvas.Handle, ClipRegion); + DeleteObject(ClipRegion); + // debug info + {$ifdef DEBUG_CANVAS_CLIP_REGION} + ConvertPathToPoints(CurPath.ClipPath, ADestX, ADestY, AMulX, AMulY, Points); + ACanvas.Polygon(Points); + {$endif} + end; + {$endif} + + // + // For solid paths, draw a polygon for the main internal area + // + if CurPath.Brush.Style <> bsClear then + begin + CurPath.PrepareForSequentialReading; + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(' Solid Path Internal Area'); + {$endif} + ADest.Brush.Style := CurPath.Brush.Style; + + SetLength(Points, CurPath.Len); + + for j := 0 to CurPath.Len - 1 do + begin + //WriteLn('j = ', j); + CurSegment := TPathSegment(CurPath.Next()); + + CoordX := CoordToCanvasX(Cur2DSegment.X); + CoordY := CoordToCanvasY(Cur2DSegment.Y); + + Points[j].X := CoordX; + Points[j].Y := CoordY; + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format(' P%d,%d', [CoordY, CoordY])); + {$endif} + end; + + ADest.Polygon(Points); + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(' Now the details '); + {$endif} + end; + + // + // For other paths, draw more carefully + // + CurPath.PrepareForSequentialReading; + + for j := 0 to CurPath.Len - 1 do + begin + //WriteLn('j = ', j); + CurSegment := TPathSegment(CurPath.Next()); + + case CurSegment.SegmentType of + stMoveTo: + begin + CoordX := CoordToCanvasX(Cur2DSegment.X); + CoordY := CoordToCanvasY(Cur2DSegment.Y); + ADest.MoveTo(CoordX, CoordY); + PosX := Cur2DSegment.X; + PosY := Cur2DSegment.Y; + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format(' M%d,%d', [CoordY, CoordY])); + {$endif} + end; + // This element can override temporarely the Pen + st2DLineWithPen: + begin + ADest.Pen.FPColor := T2DSegmentWithPen(Cur2DSegment).Pen.Color; + + CoordX := CoordToCanvasX(PosX); + CoordY := CoordToCanvasY(PosY); + CoordX2 := CoordToCanvasX(Cur2DSegment.X); + CoordY2 := CoordToCanvasY(Cur2DSegment.Y); + ADest.Line(CoordX, CoordY, CoordX2, CoordY2); + + PosX := Cur2DSegment.X; + PosY := Cur2DSegment.Y; + + ADest.Pen.FPColor := CurPath.Pen.Color; + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format(' L%d,%d', [CoordToCanvasX(Cur2DSegment.X), CoordToCanvasY(Cur2DSegment.Y)])); + {$endif} + end; + st2DLine, st3DLine: + begin + CoordX := CoordToCanvasX(PosX); + CoordY := CoordToCanvasY(PosY); + CoordX2 := CoordToCanvasX(Cur2DSegment.X); + CoordY2 := CoordToCanvasY(Cur2DSegment.Y); + ADest.Line(CoordX, CoordY, CoordX2, CoordY2); + PosX := Cur2DSegment.X; + PosY := Cur2DSegment.Y; + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format(' L%d,%d', [CoordX, CoordY])); + {$endif} + end; + { To draw a bezier we need to divide the interval in parts and make + lines between this parts } + st2DBezier, st3DBezier: + begin + CoordX := CoordToCanvasX(PosX); + CoordY := CoordToCanvasY(PosY); + CoordX2 := CoordToCanvasX(Cur2DBSegment.X2); + CoordY2 := CoordToCanvasY(Cur2DBSegment.Y2); + CoordX3 := CoordToCanvasX(Cur2DBSegment.X3); + CoordY3 := CoordToCanvasY(Cur2DBSegment.Y3); + CoordX4 := CoordToCanvasX(Cur2DBSegment.X); + CoordY4 := CoordToCanvasY(Cur2DBSegment.Y); + SetLength(Points, 0); + AddBezierToPoints( + Make2DPoint(CoordX, CoordY), + Make2DPoint(CoordX2, CoordY2), + Make2DPoint(CoordX3, CoordY3), + Make2DPoint(CoordX4, CoordY4), + Points + ); + + ADest.Brush.Style := CurPath.Brush.Style; + if Length(Points) >= 3 then + ADest.Polygon(Points); + + PosX := Cur2DSegment.X; + PosY := Cur2DSegment.Y; + + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + Write(Format(' ***C%d,%d %d,%d %d,%d %d,%d', + [CoordToCanvasX(PosX), CoordToCanvasY(PosY), + CoordToCanvasX(Cur2DBSegment.X2), CoordToCanvasY(Cur2DBSegment.Y2), + CoordToCanvasX(Cur2DBSegment.X3), CoordToCanvasY(Cur2DBSegment.Y3), + CoordToCanvasX(Cur2DBSegment.X), CoordToCanvasY(Cur2DBSegment.Y)])); + {$endif} + end; + end; + end; + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} + WriteLn(''); + {$endif} + + // Restores the previous Clip Region + {$ifdef USE_CANVAS_CLIP_REGION} + if CurPath.ClipPath <> nil then + begin + SelectClipRgn(ACanvas.Handle, OldClipRegion); //Using OldClipRegion crashes in Qt + end; + {$endif} +end; + +procedure DrawFPVEntityToCanvas(ASource: TvVectorialPage; CurEntity: TvEntity; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); + + function CoordToCanvasX(ACoord: Double): Integer; + begin + Result := Round(ADestX + AmulX * ACoord); + end; + + function CoordToCanvasY(ACoord: Double): Integer; + begin + Result := Round(ADestY + AmulY * ACoord); + end; + +var + i: Integer; + {$ifdef USE_LCL_CANVAS} + ALCLDest: TCanvas; + {$endif} + // For entities + CurCircle: TvCircle; + CurEllipse: TvEllipse; + // + CurArc: TvCircularArc; + FinalStartAngle, FinalEndAngle: double; + BoundsLeft, BoundsTop, BoundsRight, BoundsBottom, + IntStartAngle, IntAngleLength, IntTmp: Integer; + // + CurDim: TvAlignedDimension; + Points: array of TPoint; + UpperDim, LowerDim: T3DPoint; +begin + {$ifdef USE_LCL_CANVAS} + ALCLDest := TCanvas(ADest); + {$endif} + + ADest.Brush.Style := CurEntity.Brush.Style; + ADest.Pen.Style := CurEntity.Pen.Style; + ADest.Pen.FPColor := CurEntity.Pen.Color; + ADest.Brush.FPColor := CurEntity.Brush.Color; + + if CurEntity is TvCircle then + begin + CurCircle := CurEntity as TvCircle; + ADest.Ellipse( + CoordToCanvasX(CurCircle.X - CurCircle.Radius), + CoordToCanvasY(CurCircle.Y - CurCircle.Radius), + CoordToCanvasX(CurCircle.X + CurCircle.Radius), + CoordToCanvasY(CurCircle.Y + CurCircle.Radius) + ); + end + else if CurEntity is TvEllipse then + begin + CurEllipse := CurEntity as TvEllipse; + DrawRotatedEllipse(ADest, CurEllipse); + end + else if CurEntity is TvCircularArc then + begin + CurArc := CurEntity as TvCircularArc; + {$ifdef USE_LCL_CANVAS} + // ToDo: Consider a X axis inversion + // If the Y axis is inverted, then we need to mirror our angles as well + BoundsLeft := CoordToCanvasX(CurArc.X - CurArc.Radius); + BoundsTop := CoordToCanvasY(CurArc.Y - CurArc.Radius); + BoundsRight := CoordToCanvasX(CurArc.X + CurArc.Radius); + BoundsBottom := CoordToCanvasY(CurArc.Y + CurArc.Radius); + {if AMulY > 0 then + begin} + FinalStartAngle := CurArc.StartAngle; + FinalEndAngle := CurArc.EndAngle; + {end + else // AMulY is negative + begin + // Inverting the angles generates the correct result for Y axis inversion + if CurArc.EndAngle = 0 then FinalStartAngle := 0 + else FinalStartAngle := 360 - 1* CurArc.EndAngle; + if CurArc.StartAngle = 0 then FinalEndAngle := 0 + else FinalEndAngle := 360 - 1* CurArc.StartAngle; + end;} + IntStartAngle := Round(16*FinalStartAngle); + IntAngleLength := Round(16*(FinalEndAngle - FinalStartAngle)); + // On Gtk2 and Carbon, the Left really needs to be to the Left of the Right position + // The same for the Top and Bottom + // On Windows it works fine either way + // On Gtk2 if the positions are inverted then the arcs are screwed up + // In Carbon if the positions are inverted, then the arc is inverted + if BoundsLeft > BoundsRight then + begin + IntTmp := BoundsLeft; + BoundsLeft := BoundsRight; + BoundsRight := IntTmp; + end; + if BoundsTop > BoundsBottom then + begin + IntTmp := BoundsTop; + BoundsTop := BoundsBottom; + BoundsBottom := IntTmp; + end; + // Arc(ALeft, ATop, ARight, ABottom, Angle16Deg, Angle16DegLength: Integer); + {$ifdef FPVECTORIAL_TOCANVAS_DEBUG} +// WriteLn(Format('Drawing Arc Center=%f,%f Radius=%f StartAngle=%f AngleLength=%f', +// [CurArc.CenterX, CurArc.CenterY, CurArc.Radius, IntStartAngle/16, IntAngleLength/16])); + {$endif} + ADest.Pen.FPColor := CurArc.Pen.Color; + ALCLDest.Arc( + BoundsLeft, BoundsTop, BoundsRight, BoundsBottom, + IntStartAngle, IntAngleLength + ); + ADest.Pen.FPColor := colBlack; + // Debug info +// {$define FPVECTORIALDEBUG} +// {$ifdef FPVECTORIALDEBUG} +// WriteLn(Format('Drawing Arc x1y1=%d,%d x2y2=%d,%d start=%d end=%d', +// [BoundsLeft, BoundsTop, BoundsRight, BoundsBottom, IntStartAngle, IntAngleLength])); +// {$endif} +{ ADest.TextOut(CoordToCanvasX(CurArc.CenterX), CoordToCanvasY(CurArc.CenterY), + Format('R=%d S=%d L=%d', [Round(CurArc.Radius*AMulX), Round(FinalStartAngle), + Abs(Round((FinalEndAngle - FinalStartAngle)))])); + ADest.Pen.Color := TColor($DDDDDD); + ADest.Rectangle( + BoundsLeft, BoundsTop, BoundsRight, BoundsBottom); + ADest.Pen.Color := clBlack;} + {$endif} + end + else if CurEntity is TvAlignedDimension then + begin + CurDim := CurEntity as TvAlignedDimension; + // + // Draws this shape: + // vertical horizontal + // ___ + // | | or ---| X cm + // | --| + // Which marks the dimension + ADest.MoveTo(CoordToCanvasX(CurDim.BaseRight.X), CoordToCanvasY(CurDim.BaseRight.Y)); + ADest.LineTo(CoordToCanvasX(CurDim.DimensionRight.X), CoordToCanvasY(CurDim.DimensionRight.Y)); + ADest.LineTo(CoordToCanvasX(CurDim.DimensionLeft.X), CoordToCanvasY(CurDim.DimensionLeft.Y)); + ADest.LineTo(CoordToCanvasX(CurDim.BaseLeft.X), CoordToCanvasY(CurDim.BaseLeft.Y)); + // Now the arrows + // horizontal + SetLength(Points, 3); + if CurDim.DimensionRight.Y = CurDim.DimensionLeft.Y then + begin + ADest.Brush.FPColor := colBlack; + ADest.Brush.Style := bsSolid; + // Left arrow + Points[0] := Point(CoordToCanvasX(CurDim.DimensionLeft.X), CoordToCanvasY(CurDim.DimensionLeft.Y)); + Points[1] := Point(Points[0].X + 7, Points[0].Y - 3); + Points[2] := Point(Points[0].X + 7, Points[0].Y + 3); + ADest.Polygon(Points); + // Right arrow + Points[0] := Point(CoordToCanvasX(CurDim.DimensionRight.X), CoordToCanvasY(CurDim.DimensionRight.Y)); + Points[1] := Point(Points[0].X - 7, Points[0].Y - 3); + Points[2] := Point(Points[0].X - 7, Points[0].Y + 3); + ADest.Polygon(Points); + ADest.Brush.Style := bsClear; + // Dimension text + Points[0].X := CoordToCanvasX((CurDim.DimensionLeft.X+CurDim.DimensionRight.X)/2); + Points[0].Y := CoordToCanvasY(CurDim.DimensionLeft.Y); + LowerDim.X := CurDim.DimensionRight.X-CurDim.DimensionLeft.X; + ADest.Font.Size := 10; + ADest.TextOut(Points[0].X, Points[0].Y, Format('%.1f', [LowerDim.X])); + end + else + begin + ADest.Brush.FPColor := colBlack; + ADest.Brush.Style := bsSolid; + // There is no upper/lower preference for DimensionLeft/Right, so we need to check + if CurDim.DimensionLeft.Y > CurDim.DimensionRight.Y then + begin + UpperDim := CurDim.DimensionLeft; + LowerDim := CurDim.DimensionRight; + end + else + begin + UpperDim := CurDim.DimensionRight; + LowerDim := CurDim.DimensionLeft; + end; + // Upper arrow + Points[0] := Point(CoordToCanvasX(UpperDim.X), CoordToCanvasY(UpperDim.Y)); + Points[1] := Point(Points[0].X + Round(AMulX), Points[0].Y - Round(AMulY*3)); + Points[2] := Point(Points[0].X - Round(AMulX), Points[0].Y - Round(AMulY*3)); + ADest.Polygon(Points); + // Lower arrow + Points[0] := Point(CoordToCanvasX(LowerDim.X), CoordToCanvasY(LowerDim.Y)); + Points[1] := Point(Points[0].X + Round(AMulX), Points[0].Y + Round(AMulY*3)); + Points[2] := Point(Points[0].X - Round(AMulX), Points[0].Y + Round(AMulY*3)); + ADest.Polygon(Points); + ADest.Brush.Style := bsClear; + // Dimension text + Points[0].X := CoordToCanvasX(CurDim.DimensionLeft.X); + Points[0].Y := CoordToCanvasY((CurDim.DimensionLeft.Y+CurDim.DimensionRight.Y)/2); + LowerDim.Y := CurDim.DimensionRight.Y-CurDim.DimensionLeft.Y; + if LowerDim.Y < 0 then LowerDim.Y := -1 * LowerDim.Y; + ADest.Font.Size := 10; + ADest.TextOut(Points[0].X, Points[0].Y, Format('%.1f', [LowerDim.Y])); + end; + SetLength(Points, 0); +{ // Debug info + ADest.TextOut(CoordToCanvasX(CurDim.BaseRight.X), CoordToCanvasY(CurDim.BaseRight.Y), 'BR'); + ADest.TextOut(CoordToCanvasX(CurDim.DimensionRight.X), CoordToCanvasY(CurDim.DimensionRight.Y), 'DR'); + ADest.TextOut(CoordToCanvasX(CurDim.DimensionLeft.X), CoordToCanvasY(CurDim.DimensionLeft.Y), 'DL'); + ADest.TextOut(CoordToCanvasX(CurDim.BaseLeft.X), CoordToCanvasY(CurDim.BaseLeft.Y), 'BL');} + end; +end; + +procedure DrawFPVTextToCanvas(ASource: TvVectorialPage; CurText: TvText; + ADest: TFPCustomCanvas; + ADestX: Integer = 0; ADestY: Integer = 0; AMulX: Double = 1.0; AMulY: Double = 1.0); + + function CoordToCanvasX(ACoord: Double): Integer; + begin + Result := Round(ADestX + AmulX * ACoord); + end; + + function CoordToCanvasY(ACoord: Double): Integer; + begin + Result := Round(ADestY + AmulY * ACoord); + end; + +var + i: Integer; + {$ifdef USE_LCL_CANVAS} + ALCLDest: TCanvas; + {$endif} + // + LowerDim: T3DPoint; +begin + {$ifdef USE_LCL_CANVAS} + ALCLDest := TCanvas(ADest); + {$endif} + + ADest.Font.Size := Round(AmulX * CurText.Font.Size); + ADest.Pen.Style := psSolid; + ADest.Pen.FPColor := colBlack; + ADest.Brush.Style := bsClear; + {$ifdef USE_LCL_CANVAS} + ALCLDest.Font.Orientation := Round(CurText.Font.Orientation * 16); + {$endif} + + // TvText supports multiple lines + for i := 0 to CurText.Value.Count - 1 do + begin + if CurText.Font.Size = 0 then LowerDim.Y := CurText.Y - 12 * (i + 1) + else LowerDim.Y := CurText.Y - CurText.Font.Size * (i + 1); + + ADest.TextOut(CoordToCanvasX(CurText.X), CoordToCanvasY(LowerDim.Y), CurText.Value.Strings[i]); + end; +end; + +end. + diff --git a/components/fpvectorial/fpvutils.pas b/components/fpvectorial/fpvutils.pas new file mode 100644 index 0000000000..a3805f313a --- /dev/null +++ b/components/fpvectorial/fpvutils.pas @@ -0,0 +1,295 @@ +{ +fpvutils.pas + +Vector graphics document + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho + Pedro Sol Pegorini L de Lima +} +unit fpvutils; + +{.$define USE_LCL_CANVAS} +{.$define FPVECTORIAL_BEZIERTOPOINTS_DEBUG} + +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses + Classes, SysUtils, Math, + {$ifdef USE_LCL_CANVAS} + Graphics, LCLIntf, LCLType, + {$endif} + fpvectorial, fpimage; + +type + T10Strings = array[0..9] of shortstring; + TPointsArray = array of TPoint; + +// Color Conversion routines +function FPColorToRGBHexString(AColor: TFPColor): string; +function RGBToFPColor(AR, AG, AB: byte): TFPColor; inline; +// Coordinate Conversion routines +function CanvasCoordsToFPVectorial(AY: Integer; AHeight: Integer): Integer; inline; +function CanvasTextPosToFPVectorial(AY: Integer; ACanvasHeight, ATextHeight: Integer): Integer; +function CoordToCanvasX(ACoord: Double; ADestX: Integer; AMulX: Double): Integer; inline; +function CoordToCanvasY(ACoord: Double; ADestY: Integer; AMulY: Double): Integer; inline; +// Other routines +function SeparateString(AString: string; ASeparator: char): T10Strings; +// Mathematical routines +procedure EllipticalArcToBezier(Xc, Yc, Rx, Ry, startAngle, endAngle: Double; var P1, P2, P3, P4: T3DPoint); +procedure CircularArcToBezier(Xc, Yc, R, startAngle, endAngle: Double; var P1, P2, P3, P4: T3DPoint); +procedure AddBezierToPoints(P1, P2, P3, P4: T3DPoint; var Points: TPointsArray); +procedure ConvertPathToPoints(APath: TPath; ADestX, ADestY: Integer; AMulX, AMulY: Double; var Points: TPointsArray); +// LCL-related routines +{$ifdef USE_LCL_CANVAS} +function ConvertPathToRegion(APath: TPath; ADestX, ADestY: Integer; AMulX, AMulY: Double): HRGN; +{$endif} + +implementation + +{@@ This function is utilized by the SVG writer and some other places, so + it shouldn't be changed. +} +function FPColorToRGBHexString(AColor: TFPColor): string; +begin + Result := Format('%.2x%.2x%.2x', [AColor.Red shr 8, AColor.Green shr 8, AColor.Blue shr 8]); +end; + +function RGBToFPColor(AR, AG, AB: byte): TFPColor; inline; +begin + Result.Red := (AR shl 8) + AR; + Result.Green := (AG shl 8) + AG; + Result.Blue := (AB shl 8) + AB; + Result.Alpha := $FFFF; +end; + +{@@ Converts the coordinate system from a TCanvas to FPVectorial + The basic difference is that the Y axis is positioned differently and + points upwards in FPVectorial and downwards in TCanvas. + The X axis doesn't change. The fix is trivial and requires only the Height of + the Canvas as extra info. + + @param AHeight Should receive TCanvas.Height +} +function CanvasCoordsToFPVectorial(AY: Integer; AHeight: Integer): Integer; inline; +begin + Result := AHeight - AY; +end; + +{@@ + LCL Text is positioned based on the top-left corner of the text. + Besides that, one also needs to take the general coordinate change into account too. + + @param ACanvasHeight Should receive TCanvas.Height + @param ATextHeight Should receive TFont.Size +} +function CanvasTextPosToFPVectorial(AY: Integer; ACanvasHeight, ATextHeight: Integer): Integer; +begin + Result := CanvasCoordsToFPVectorial(AY, ACanvasHeight) - ATextHeight; +end; + +function CoordToCanvasX(ACoord: Double; ADestX: Integer; AMulX: Double): Integer; +begin + Result := Round(ADestX + AmulX * ACoord); +end; + +function CoordToCanvasY(ACoord: Double; ADestY: Integer; AMulY: Double): Integer; +begin + Result := Round(ADestY + AmulY * ACoord); +end; + +{@@ + Reads a string and separates it in substring + using ASeparator to delimite them. + + Limits: + + Number of substrings: 10 (indexed 0 to 9) + Length of each substring: 255 (they are shortstrings) +} +function SeparateString(AString: string; ASeparator: char): T10Strings; +var + i, CurrentPart: integer; +begin + CurrentPart := 0; + + { Clears the result } + for i := 0 to 9 do + Result[i] := ''; + + { Iterates througth the string, filling strings } + for i := 1 to Length(AString) do + begin + if Copy(AString, i, 1) = ASeparator then + begin + Inc(CurrentPart); + + { Verifies if the string capacity wasn't exceeded } + if CurrentPart > 9 then + Exit; + end + else + Result[CurrentPart] := Result[CurrentPart] + Copy(AString, i, 1); + end; +end; + +{ Considering a counter-clockwise arc, elliptical and alligned to the axises + + An elliptical Arc can be converted to + the following Cubic Bezier control points: + + P1 = E(startAngle) <- start point + P2 = P1+alfa * dE(startAngle) <- control point + P3 = P4−alfa * dE(endAngle) <- control point + P4 = E(endAngle) <- end point + + source: http://www.spaceroots.org/documents/ellipse/elliptical-arc.pdf + + The equation of an elliptical arc is: + + X(t) = Xc + Rx * cos(t) + Y(t) = Yc + Ry * sin(t) + + dX(t)/dt = - Rx * sin(t) + dY(t)/dt = + Ry * cos(t) +} +procedure EllipticalArcToBezier(Xc, Yc, Rx, Ry, startAngle, endAngle: Double; + var P1, P2, P3, P4: T3DPoint); +var + halfLength, arcLength, alfa: Double; +begin + arcLength := endAngle - startAngle; + halfLength := (endAngle - startAngle) / 2; + alfa := sin(arcLength) * (Sqrt(4 + 3*sqr(tan(halfLength))) - 1) / 3; + + // Start point + P1.X := Xc + Rx * cos(startAngle); + P1.Y := Yc + Ry * sin(startAngle); + + // End point + P4.X := Xc + Rx * cos(endAngle); + P4.Y := Yc + Ry * sin(endAngle); + + // Control points + P2.X := P1.X + alfa * -1 * Rx * sin(startAngle); + P2.Y := P1.Y + alfa * Ry * cos(startAngle); + + P3.X := P4.X - alfa * -1 * Rx * sin(endAngle); + P3.Y := P4.Y - alfa * Ry * cos(endAngle); +end; + +procedure CircularArcToBezier(Xc, Yc, R, startAngle, endAngle: Double; var P1, + P2, P3, P4: T3DPoint); +begin + EllipticalArcToBezier(Xc, Yc, R, R, startAngle, endAngle, P1, P2, P3, P4); +end; + +{ This routine converts a Bezier to a Polygon and adds the points of this poligon + to the end of the provided Points output variables } +procedure AddBezierToPoints(P1, P2, P3, P4: T3DPoint; var Points: TPointsArray); +var + CurveLength, k, CurX, CurY, LastPoint: Integer; + t: Double; +begin + {$ifdef FPVECTORIAL_BEZIERTOPOINTS_DEBUG} + Write(Format('[AddBezierToPoints] P1=%f,%f P2=%f,%f P3=%f,%f P4=%f,%f =>', [P1.X, P1.Y, P2.X, P2.Y, P3.X, P3.Y, P4.X, P4.Y])); + {$endif} + + CurveLength := + Round(sqrt(sqr(P2.X - P1.X) + sqr(P2.Y - P1.Y))) + + Round(sqrt(sqr(P3.X - P2.X) + sqr(P3.Y - P2.Y))) + + Round(sqrt(sqr(P4.X - P4.X) + sqr(P4.Y - P3.Y))); + + LastPoint := Length(Points)-1; + SetLength(Points, Length(Points)+CurveLength); + for k := 1 to CurveLength do + begin + t := k / CurveLength; + CurX := Round(sqr(1 - t) * (1 - t) * P1.X + 3 * t * sqr(1 - t) * P2.X + 3 * t * t * (1 - t) * P3.X + t * t * t * P4.X); + CurY := Round(sqr(1 - t) * (1 - t) * P1.Y + 3 * t * sqr(1 - t) * P2.Y + 3 * t * t * (1 - t) * P3.Y + t * t * t * P4.Y); + Points[LastPoint+k].X := CurX; + Points[LastPoint+k].Y := CurY; + {$ifdef FPVECTORIAL_BEZIERTOPOINTS_DEBUG} + Write(Format(' P=%d,%d', [CurX, CurY])); + {$endif} + end; + {$ifdef FPVECTORIAL_BEZIERTOPOINTS_DEBUG} + WriteLn(Format(' CurveLength=%d', [CurveLength])); + {$endif} +end; + +procedure ConvertPathToPoints(APath: TPath; ADestX, ADestY: Integer; AMulX, AMulY: Double; var Points: TPointsArray); +var + i, LastPoint: Integer; + CoordX, CoordY: Integer; + CoordX2, CoordY2, CoordX3, CoordY3, CoordX4, CoordY4: Integer; + // Segments + CurSegment: TPathSegment; + Cur2DSegment: T2DSegment absolute CurSegment; + Cur2DBSegment: T2DBezierSegment absolute CurSegment; +begin + APath.PrepareForSequentialReading; + + SetLength(Points, 0); + + for i := 0 to APath.Len - 1 do + begin + CurSegment := TPathSegment(APath.Next()); + + CoordX := CoordToCanvasX(Cur2DSegment.X, ADestX, AMulX); + CoordY := CoordToCanvasY(Cur2DSegment.Y, ADestY, AMulY); + + case CurSegment.SegmentType of + st2DBezier, st3DBezier: + begin + LastPoint := Length(Points)-1; + CoordX4 := CoordX; + CoordY4 := CoordY; + CoordX := Points[LastPoint].X; + CoordY := Points[LastPoint].Y; + CoordX2 := CoordToCanvasX(Cur2DBSegment.X2, ADestX, AMulX); + CoordY2 := CoordToCanvasY(Cur2DBSegment.Y2, ADestY, AMulY); + CoordX3 := CoordToCanvasX(Cur2DBSegment.X3, ADestX, AMulX); + CoordY3 := CoordToCanvasY(Cur2DBSegment.Y3, ADestY, AMulY); + AddBezierToPoints( + Make2DPoint(CoordX, CoordY), + Make2DPoint(CoordX2, CoordY2), + Make2DPoint(CoordX3, CoordY3), + Make2DPoint(CoordX4, CoordY4), + Points); + end; + else + LastPoint := Length(Points); + SetLength(Points, Length(Points)+1); + Points[LastPoint].X := CoordX; + Points[LastPoint].Y := CoordY; + end; + end; +end; + +{$ifdef USE_LCL_CANVAS} +function ConvertPathToRegion(APath: TPath; ADestX, ADestY: Integer; AMulX, AMulY: Double): HRGN; +var + WindingMode: Integer; + Points: array of TPoint; +begin + APath.PrepareForSequentialReading; + + SetLength(Points, 0); + ConvertPathToPoints(APath, ADestX, ADestY, AMulX, AMulY, Points); + + if APath.ClipMode = vcmEvenOddRule then WindingMode := LCLType.ALTERNATE + else WindingMode := LCLType.WINDING; + + Result := LCLIntf.CreatePolygonRgn(@Points[0], Length(Points), WindingMode); +end; +{$endif} + +end. + diff --git a/components/fpvectorial/pdfvectorialreader.pas b/components/fpvectorial/pdfvectorialreader.pas new file mode 100644 index 0000000000..8f184cfcf4 --- /dev/null +++ b/components/fpvectorial/pdfvectorialreader.pas @@ -0,0 +1,265 @@ +{ +pdfvectorialreader.pas + +Reads the vectorial information form a PDF file + +PDF file format specification obtained from: + +ADOBE SYSTEMS INCORPORATED. PDF Reference: Adobe® +Portable Document Format. San Jose, 2006. (Sixth edition). + +AUTHORS: Felipe Monteiro de Carvalho + Pedro Sol Pegorini L de Lima +} +unit pdfvectorialreader; + +{$ifdef fpc} + {$mode delphi} +{$endif} + +interface + +uses + Classes, SysUtils, + pdfvrlexico, pdfvrsintatico, pdfvrsemantico, avisozlib, + fpvectorial; + +type + + { TvPDFVectorialReader } + + TvPDFVectorialReader = class(TvCustomVectorialReader) + private + procedure WriteStringToStream(AStream: TStream; AString: string); + public + { public to allow uncompressing PDFs independently } + function getFirstPage(AInput: TStream; AOutput: TStream):PageHeader; + procedure unzipPage(AInput: TStream; AOutput: TStream); + procedure translatePage(AInput: TStream; AData: TvVectorialDocument; + APageHeader: PageHeader); + { General reading methods } + procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override; + end; + +implementation + +{ TvPDFVectorialReader } + +procedure TvPDFVectorialReader.WriteStringToStream(AStream: TStream; + AString: string); +begin + AStream.WriteBuffer(AString[1], Length(AString)); +end; + +function TvPDFVectorialReader.getFirstPage(AInput: TStream; AOutput: TStream): PageHeader; +var + mytoken: Token; + myAnLexicoPage: AnLexico; + myAnLexicoContents: AnLexico; + myAnSintaticoPage: AnSintaticoPage; + myAnSintaticoContents: AnSintaticoPageContents; + AInput2: TStream; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> TvPDFVectorialReader.getFirstPage'); + {$endif} + AInput2 := TMemoryStream.Create; + AInput2.Size := AInput.Size; + AInput2.CopyFrom(AInput, AInput.Size); + AInput.Seek(0, soFromBeginning); + AInput2.Seek(0, soFromBeginning); + + myAnLexicoPage := AnLexico.Create; + myAnLexicoPage.Doc := AInput; + myAnLexicoPage.bytesRemaining:= myAnLexicoPage.Doc.Size; + myAnSintaticoPage := AnSintaticoPage.Create; + + // find first page + while ((myAnSintaticoPage.pageFound <> true) and + (myAnLexicoPage.bytesRemaining > 0)) do + begin + mytoken := myAnLexicoPage.getToken(); + myAnSintaticoPage.automata(mytoken); + end; + + if (myAnSintaticoPage.pageFound = false) then + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + + AInput.Seek(0, soFromBeginning); + myAnLexicoContents := AnLexico.Create; + myAnLexicoContents.Doc := AInput; + myAnLexicoContents.bytesRemaining:= myAnLexicoContents.Doc.Size; + myAnSintaticoContents := AnSintaticoPageContents.Create; + + // gathering information of the first page + myAnSintaticoContents.obj1:=myAnSintaticoPage.obj1; + myAnSintaticoContents.obj2:=myAnSintaticoPage.obj2; + + //find first page contents + while ((myAnSintaticoContents.contentsFound <> true) and + (myAnLexicoContents.bytesRemaining > 0)) do + begin + mytoken := myAnLexicoContents.getToken(); + myAnSintaticoContents.automata(mytoken, AInput2); + end; + + if (myAnSintaticoContents.contentsFound = false) then + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + + // gathering information of the first page + myAnLexicoContents.bytesRemaining:=myAnSintaticoContents.h.page_length; + + // write file with content just from the first page + while (myAnLexicoContents.bytesRemaining > 0) do + begin + mytoken := myAnLexicoContents.getPageToken(); + WriteStringToStream(AOutput, mytoken.token_string); + end; + + Result:=myAnSintaticoContents.h; + + {$ifdef FPVECTORIALDEBUG} + WriteLn(':< TvPDFVectorialReader.getFirstPage'); + {$endif} + +// AInput2.Free; +end; + +procedure TvPDFVectorialReader.unzipPage(AInput: TStream; AOutput: TStream); +var + compr, uncompr: Pbyte; + comprLen, uncomprLen: LongInt; + myDecode: decode; + BufStr: string; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> TvPDFVectorialReader.unzipPage'); + {$endif} + + myDecode := Decode.Create; + + comprLen := 10000 * SizeOf(Integer); // don't overflow + uncomprLen := comprLen; + GetMem(compr, comprLen); + GetMem(uncompr, uncomprLen); + + if (compr = NIL) or (uncompr = NIL) then + myDecode.EXIT_ERR('Out of memory'); + + (* compr and uncompr are cleared to avoid reading uninitialized + * data and to ensure that uncompr compresses well. + *) + + FillChar(compr^, comprLen, 0); + FillChar(uncompr^, uncomprLen, 0); + + AInput.Read(compr^, comprLen); + + BufStr := string(myDecode.test_inflate(compr, comprLen, uncompr, uncomprLen)); + + WriteStringToStream(AOutput, BufStr); + + FreeMem(compr, comprLen); + FreeMem(uncompr, uncomprLen); + + {$ifdef FPVECTORIALDEBUG} + WriteLn(':< TvPDFVectorialReader.unzipPage'); + {$endif} +end; + +procedure TvPDFVectorialReader.translatePage(AInput: TStream; + AData: TvVectorialDocument; APageHeader: PageHeader); +var + myAnLexico: AnLexico; + myAnSintaticoCommand: AnSintaticoCommand; + myAnSemantico: AnSemantico; + mytoken: Token; + c: Command; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> TvPDFVectorialReader.translatePage'); + {$endif} + + // initialize data main + myAnLexico := AnLexico.Create; + myAnLexico.Doc := AInput; + myAnLexico.bytesRemaining:= myAnLexico.Doc.Size; + myAnSintaticoCommand := AnSintaticoCommand.Create; + myAnSemantico := AnSemantico.Create; + + // initialize machine + myAnSemantico.startMachine(); + + while (myAnLexico.bytesRemaining > 0) do + begin + mytoken := myAnLexico.getToken(); + c:=myAnSintaticoCommand.automata(mytoken); + if (myAnSintaticoCommand.Codigo = true) then + myAnSemantico.generate(c, AData); + end; + + // end machine + myAnSemantico.endMachine(); +end; + +procedure TvPDFVectorialReader.ReadFromStream(AStream: TStream; + AData: TvVectorialDocument); +var + APageHeader: PageHeader; + APageStream, AUnzipStream: TStream; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> TvPDFVectorialReader.ReadFromStream'); + {$endif} + + APageStream := TMemoryStream.Create; + AUnzipStream := TMemoryStream.Create; + + // get first page + APageHeader := getFirstPage(AStream, APageStream); + + // unzip page + if (APageHeader.flate_decode = true) then + begin + APageStream.Seek(0, soFromBeginning); + unzipPage(APageStream, AUnzipStream); + + // translate page to doc data + AUnzipStream.Seek(0, soFromBeginning); + translatePage(AUnzipStream, AData, APageHeader); + end + else + begin + // translate page to doc data + APageStream.Seek(0, soFromBeginning); + translatePage(APageStream, AData, APageHeader); + end; + + APageStream.Free; + AUnzipStream.Free; + + //ShowMessage('Sucesso!'); + {$ifdef FPVECTORIALDEBUG} + WriteLn(':< TvPDFVectorialReader.ReadFromStream'); + WriteLn('Sucesso!'); + {$endif} +end; + +{******************************************************************* +* Initialization section +* +* Registers this reader / writer on fpVectorial +* +*******************************************************************} +initialization + + RegisterVectorialReader(TvPDFVectorialReader, vfPDF); + +end. + diff --git a/components/fpvectorial/pdfvrlexico.pas b/components/fpvectorial/pdfvrlexico.pas new file mode 100644 index 0000000000..e8542e956b --- /dev/null +++ b/components/fpvectorial/pdfvrlexico.pas @@ -0,0 +1,113 @@ +unit pdfvrlexico; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils; + +type + Token = record + tipo: Int64; + token_string: String; + end; + + TPDFCommandCode = (cc_NONE, cc_m_START_PATH, cc_l_ADD_LINE_TO_PATH, + cc_H_CLOSE_PATH, cc_S_END_PATH, cc_hS_CLOSE_AND_END_PATH, + cc_c_BEZIER_TO_X_Y_USING_X2_Y2_AND_X3_Y3, + cc_v_BEZIER_TO_X_Y_USING_CURRENT_POS_AND_X2_Y2, + cc_y_BEZIER_TO_X_Y_USING_X_Y_AND_X2_Y2, + cc_CONCATENATE_MATRIX,cc_RESTORE_MATRIX); + + Command = record + cord_x3: String; + cord_y3: String; + cord_x2: String; + cord_y2: String; + cord_x: String; + cord_y: String; + my_operator: String; + code: TPDFCommandCode; + end; + + PageHeader = record + page_length: Int64; + flate_decode: Boolean; + end; + + AnLexico = class + public + Doc: TStream; + bytesRemaining: Int64; + constructor Create(); + function getToken(): Token; + function getPageToken(): Token; + end; + +implementation + +function AnLexico.getToken(): Token; +var + t: Byte; + mytoken: Token; +begin + mytoken.tipo := 0; + while( bytesRemaining > 0 ) do + begin + t := Doc.ReadByte(); + bytesRemaining := bytesRemaining - 1; + // numbers or points or minus + if((((t >= 48) and (t <= 57)) or (t = 46 ) or (t = 45)) and + ((mytoken.tipo = 1) or (mytoken.tipo = 0))) then + begin + mytoken.token_string := mytoken.token_string + char(t); + mytoken.tipo:=1; + end + else if(((t >= 65) and (t <= 90)) or ((t >= 97) and (t <= 122)) // letters + or (t = 42) // * + and ((mytoken.tipo = 2) or (mytoken.tipo = 0))) then + begin + mytoken.token_string := mytoken.token_string + char(t); + mytoken.tipo:=2; + end + else // everything else + begin + if (mytoken.tipo <> 0) then + begin + // solve CorelDraw problem after "stream" + if ((t=13) and (bytesRemaining>0)) then + begin + t := Doc.ReadByte(); + bytesRemaining:=bytesRemaining-1; + end; + Result := mytoken; + Exit; + end; + end; + end; + Result := mytoken; +end; + +function AnLexico.getPageToken(): Token; +var + t: Byte; + mytoken: Token; +begin + mytoken.tipo := 0; + if (bytesRemaining > 0) then + begin + t := Doc.ReadByte; + mytoken.token_string:=char(t); + bytesRemaining := bytesRemaining - 1; + end; + Result := mytoken; +end; + +constructor AnLexico.Create(); +begin + inherited Create; +end; + +end. + diff --git a/components/fpvectorial/pdfvrsemantico.pas b/components/fpvectorial/pdfvrsemantico.pas new file mode 100644 index 0000000000..bf2c80edfe --- /dev/null +++ b/components/fpvectorial/pdfvrsemantico.pas @@ -0,0 +1,244 @@ +unit pdfvrsemantico; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, pdfvrlexico, fpvectorial; + +type + + { AnSemantico } + + AnSemantico = class + public + FPointSeparator, FCommaSeparator: TFormatSettings; + close_path_x: String; + close_path_y: String; + cm_a, cm_b, cm_c, cm_d, cm_e, cm_f: Real; // coordinate spaces constants + function StringToFloat(AStr: string): Double; + function generate(c: Command; AData: TvVectorialDocument): String; + function convert(x: String; y: String; Axis: Char): String; + function startMachine(): String; + function endMachine(): String; + constructor Create; + end; + +implementation + +{ PDF doesn't seam very consistent when it comes to using commas or + points as decimal separator, so we just try both } +function AnSemantico.StringToFloat(AStr: string): Double; +begin + if Pos('.', AStr) > 0 then Result := StrToFloat(AStr, FPointSeparator) + else Result := StrToFloat(AStr, FCommaSeparator); +end; + +function AnSemantico.generate(c: Command; AData: TvVectorialDocument): String; +var + enter_line : String; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate'); + {$endif} + + enter_line:= LineEnding; //chr(13) + chr(10); // CR and LF + + if ((c.code = cc_H_CLOSE_PATH) or (c.code = cc_hS_CLOSE_AND_END_PATH)) then // command h or s + begin + c.cord_x:=close_path_x; + c.cord_y:=close_path_y; + end; + + if ((c.code <> cc_H_CLOSE_PATH) and (c.code <> cc_hS_CLOSE_AND_END_PATH)) then // close path already converted + begin + if ((c.code = cc_m_START_PATH) or (c.code = cc_l_ADD_LINE_TO_PATH)) then + begin + //WriteLn(':: anSemantico.generate convert code ', Integer(c.code)); + c.cord_x := convert(c.cord_x,c.cord_y,'x'); + c.cord_y := convert(c.cord_x,c.cord_y,'y'); + end; + if ((c.code = cc_c_BEZIER_TO_X_Y_USING_X2_Y2_AND_X3_Y3)) then + begin + //WriteLn(':: anSemantico.generate convert code ', Integer(c.code)); + c.cord_x := convert(c.cord_x,c.cord_y,'x'); + c.cord_y := convert(c.cord_x,c.cord_y,'y'); + c.cord_x2 := convert(c.cord_x2,c.cord_y2,'x'); + c.cord_y2 := convert(c.cord_x2,c.cord_y2,'y'); + c.cord_x3 := convert(c.cord_x3,c.cord_y3,'x'); + c.cord_y3 := convert(c.cord_x3,c.cord_y3,'y'); + end; + end; + + case c.code of + cc_m_START_PATH: // command m + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 1 EndPath StartPath'); + {$endif} + // Result:='G01' + ' ' + 'X' + c.cord_x + ' ' + 'Y' + c.cord_y + enter_line + + // 'G01 Z50 // Abaixa a cabeça de gravação'; + + // Correcao para programas de desenho que geram um novo inicio no + // fim do desenho, terminamos qualquer desenho inacabado + AData.EndPath(); + AData.StartPath(StringToFloat(c.cord_x), StringToFloat(c.cord_y)); + + close_path_x:=c.cord_x; + close_path_y:=c.cord_y; + end; + cc_l_ADD_LINE_TO_PATH: // command l + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 2 AddPointToPath'); + {$endif} + // Result:='G01' + ' ' + 'X' + c.cord_x + ' ' + 'Y' + c.cord_y; + + AData.AddLineToPath(StringToFloat(c.cord_x), StringToFloat(c.cord_y)); + end; + cc_h_CLOSE_PATH: // command h + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 3 AddPointToPath'); + {$endif} + //Result:='G01' + ' ' + 'X' + c.cord_x + ' ' + 'Y' + c.cord_y; + + AData.AddLineToPath(StringToFloat(c.cord_x), StringToFloat(c.cord_y)); + end; + cc_S_END_PATH: // command S + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 4 EndPath'); + {$endif} + // Result:='G01 Z0 // Sobe a cabeça de gravação' + enter_line; + AData.EndPath(); + end; + cc_hS_CLOSE_AND_END_PATH: // command s + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 5 AddPoint EndPath'); + {$endif} + //Result:='G01' + ' ' + 'X' + c.cord_x + ' ' + 'Y' + c.cord_y + enter_line + // +'G01 Z0 // Sobe a cabeça de gravação' + enter_line; + + AData.AddLineToPath(StringToFloat(c.cord_x), StringToFloat(c.cord_y)); + AData.EndPath(); + end; + cc_c_BEZIER_TO_X_Y_USING_X2_Y2_AND_X3_Y3: // command c + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado 6 Bezier'); + {$endif} + //Result:='G01' + ' ' + 'X' + c.cord_x + ' ' + 'Y' + c.cord_y + enter_line + // +'G01 Z0 // Sobe a cabeça de gravação' + enter_line; + + AData.AddBezierToPath( + StringToFloat(c.cord_x3), StringToFloat(c.cord_y3), + StringToFloat(c.cord_x2), StringToFloat(c.cord_y2), + StringToFloat(c.cord_x), StringToFloat(c.cord_y) + ); + end; + cc_CONCATENATE_MATRIX: // command cm + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.cc_CONCATENATE_MATRIX'); + {$endif} + + cm_a := StringToFloat(c.cord_x3); + cm_b := StringToFloat(c.cord_y3); + cm_c := StringToFloat(c.cord_x2); + cm_d := StringToFloat(c.cord_y2); + cm_e := StringToFloat(c.cord_x); + cm_f := StringToFloat(c.cord_y); + end; + cc_RESTORE_MATRIX: // command Q + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.cc_RESTORE_MATRIX'); + {$endif} + + cm_a:=1; + cm_b:=0; + cm_c:=0; + cm_d:=1; + cm_e:=0; + cm_f:=0; + end; + else + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.generate Estado ELSE'); + {$endif} + Result:=c.my_operator; + end; +end; + +function AnSemantico.convert(x: String; y: String; Axis: Char): String; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.convert'); + {$endif} + // convert from 1/72 inch to milimeters and change axis if necessary + + if (Axis = 'y') then + begin + // y' = b * x + d * y + f + Result:=FloatToStr((cm_b*StringToFloat(x)+cm_d*StringToFloat(y)+cm_f)*(25.40/72)); + end + else + // Axis = 'x' + begin + // x' = a * x + c * y + e + Result:=FloatToStr((cm_a*StringToFloat(x)+cm_c*StringToFloat(y)+cm_e)*(25.40/72)); + end; +end; + +function AnSemantico.startMachine(): String; +var + enter_line : String; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.startMachine'); + {$endif} + enter_line:=chr(13) + chr(10); // CR and LF + + Result:='M216 // Ligar monitor de carga' + enter_line + + 'G28 // Ir rapidamente para posição inicial' + enter_line + + 'G00' + enter_line; +end; + +function AnSemantico.endMachine(): String; +var + enter_line : String; +begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSemantico.endMachine'); + {$endif} + enter_line:=chr(13) + chr(10); // CR and LF + + Result:='M30 // Parar o programa e retornar para posição inicial' + enter_line + + 'M215 // Desligar monitor de carga' + enter_line; +end; + +constructor AnSemantico.Create; +begin + inherited Create; + + cm_a:=1; + cm_b:=0; + cm_c:=0; + cm_d:=1; + cm_e:=0; + cm_f:=0; + + // Format seetings to convert a string to a float + FPointSeparator := DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := '#';// disable the thousand separator + FCommaSeparator := DefaultFormatSettings; + FCommaSeparator.DecimalSeparator := ','; + FCommaSeparator.ThousandSeparator := '#';// disable the thousand separator +end; + +end. + diff --git a/components/fpvectorial/pdfvrsintatico.pas b/components/fpvectorial/pdfvrsintatico.pas new file mode 100644 index 0000000000..2bcb7e9057 --- /dev/null +++ b/components/fpvectorial/pdfvrsintatico.pas @@ -0,0 +1,628 @@ +unit pdfvrsintatico; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, pdfvrlexico; + +type + AnSintaticoPage = class + public + Estado: Int64; + obj1,obj2 : String; + pageFound: Boolean; + constructor Create; + procedure automata(t: Token); + end; + + AnSintaticoPageContents = class + public + Estado: Int64; + obj1,obj2 : String; + len_obj1,len_obj2: String; + contentsFound: Boolean; + h: PageHeader; + constructor Create; + procedure automata(t: Token; Input: TStream); + end; + + AnSintaticoCommand = class + public + Estado: Int64; + Codigo: Boolean; + c: Command; + constructor Create; + function automata(t: Token):Command; + end; + + AnSintaticoLength = class + public + Estado: Int64; + len_obj1,len_obj2: String; + page_length : Int64; + lenghtFound: Boolean; + constructor Create; + procedure automata(t: Token); + end; + +implementation + +procedure AnSintaticoPage.automata(t: Token); +begin + case Estado of + 1: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado 1'); + {$endif} + if(t.token_string = 'Type') then + begin + Estado := 2; + end + else + begin + Estado := 1; + end; + end; + 2: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado 2'); + {$endif} + if(t.token_string = 'Page') then + begin + Estado := 3; + end + else + begin + Estado := 1; + end; + end; + 3: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado 3'); + {$endif} + if(t.token_string = 'Contents') then + begin + Estado := 4; + end + else + begin + Estado := 3; + end; + end; + 4: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado 4'); + {$endif} + if(t.tipo = 1) then // numbers 1 + begin + obj1:=t.token_string; + Estado := 5; + end + else + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + end; + 5: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado 5'); + {$endif} + if(t.tipo = 1) then // numbers 2 + begin + obj2:=t.token_string; + Estado := 6; // symbolic state + pageFound := true; + end + else + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + end; + else + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPage.automata Estado ELSE'); + {$endif} + Estado := 1; + end; +end; + +procedure AnSintaticoPageContents.automata(t: Token; Input: TStream); +var + myAnLexicoLength: AnLexico; + myAnSintaticoLength: AnSintaticoLength; + mytokenLength: Token; +begin + case Estado of + 1: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 1'); + {$endif} + if(t.token_string = obj1) then + begin + Estado := 2; + end + else + begin + Estado := 1; + end; + end; + 2: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 2'); + {$endif} + if(t.token_string = obj2) then + begin + Estado := 3; + end + else + begin + Estado := 1; + end; + end; + 3: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 3'); + {$endif} + if(t.token_string = 'obj') then + begin + Estado := 4; + end + else + begin + Estado := 1; + end; + end; + 4: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 4'); + {$endif} + if(t.token_string = 'Length') then + begin + Estado := 5; + end + else if (t.token_string = 'Filter') then + begin + Estado := 7; + end + else + begin + Estado := 4; + end; + end; + 5: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 5'); + {$endif} + if(t.tipo = 1) then + begin + h.page_length := StrToInt(t.token_string); + len_obj1:=t.token_string; + Estado := 6; + end + else + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + end; + 6: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 6'); + {$endif} + if(t.token_string = 'Filter') then + begin + Estado := 7; + end + else if (t.token_string = 'stream') then + begin + contentsFound := true; + Estado := 9; // symbolic state + end + else if (t.tipo = 1) then + begin + len_obj2:=t.token_string; + myAnLexicoLength := AnLexico.Create; + myAnLexicoLength.Doc := Input; + myAnLexicoLength.bytesRemaining:= myAnLexicoLength.Doc.Size; + myAnSintaticoLength := AnSintaticoLength.Create; + + myAnSintaticoLength.len_obj1:=len_obj1; + myAnSintaticoLength.len_obj2:=len_obj2; + + while ((myAnSintaticoLength.lenghtFound <> true) and + (myAnLexicoLength.bytesRemaining > 0)) do + begin + mytokenLength := myAnLexicoLength.getToken(); + myAnSintaticoLength.automata(mytokenLength); + end; + + if (myAnSintaticoLength.lenghtFound = false) then + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + + h.page_length:=myAnSintaticoLength.page_length; + myAnLexicoLength.Doc.Destroy; + Estado := 6; + end + else + begin + Estado := 6; + end; + end; + 7: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 7'); + {$endif} + if(t.token_string = 'FlateDecode') then + begin + h.flate_decode := true; + Estado := 8; + end + else + begin + raise Exception.Create('ERROR: Encodificacao nao suportada.'); + Halt(1); + end; + end; + 8: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado 8'); + {$endif} + if(t.token_string = 'stream') then + begin + contentsFound := true; + Estado := 9; // symbolic state + end + else if (t.token_string = 'Length') then + begin + Estado := 5; + end + else + begin + Estado := 8; + end; + end; + else + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoPageContents.automata Estado ELSE'); + {$endif} + Estado := 1; + end; +end; + +procedure AnSintaticoLength.automata(t: Token); +begin + case Estado of + 1: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoLength.automata Estado 1'); + {$endif} + if(t.token_string = len_obj1) then + begin + Estado := 2; + end + else + begin + Estado := 1; + end; + end; + 2: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoLength.automata Estado 2'); + {$endif} + if(t.token_string = len_obj2) then + begin + Estado := 3; + end + else + begin + Estado := 1; + end; + end; + 3: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoLength.automata Estado 3'); + {$endif} + if(t.token_string = 'obj') then + begin + Estado := 4; + end + else + begin + Estado := 1; + end; + end; + 4: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoLength.automata Estado 4 Length: ', StrToInt(t.token_string)); + {$endif} + if(t.tipo = 1) then + begin + page_length:=StrToInt(t.token_string); + lenghtFound:=true; + Estado := 5; // symbolic state + end + else + begin + raise Exception.Create('ERROR: Arquivo corrompido.'); + Halt(1); + end; + end; + else + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoLength.automata Estado ELSE'); + {$endif} + Estado := 1; + end; +end; + +function AnSintaticoCommand.automata(t: Token):Command; +begin + c.cord_x3 := c.cord_y3; + c.cord_y3 := c.cord_x2; + c.cord_x2 := c.cord_y2; + c.cord_y2 := c.cord_x; + c.cord_x := c.cord_y; + c.cord_y := c.my_operator; + c.my_operator := t.token_string; + c.code := cc_NONE; + + Codigo := false; + + case Estado of + 1: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 1'); + {$endif} + if(t.tipo = 1) then // numbers 1 + begin + Estado := 2; + end + else if( t.token_string = 'h' ) then // command h + begin + Estado := 9; // symbolic state + Estado := 1; + Codigo := true; + c.code:=cc_H_CLOSE_PATH; + Result:=c; + end + else if( t.token_string = 's' ) then // command s + begin + Estado := 10; // symbolic state + Estado := 1; + Codigo := true; + c.code:=cc_hS_CLOSE_AND_END_PATH; + Result:=c; + end + else if( t.token_string = 'S' ) then // command S + begin + Estado := 11; // symbolic state + Estado := 1; + Codigo := true; + c.code:=cc_S_END_PATH; + Result:=c; + end + else if( t.token_string = 'Q' ) then // command Q + begin + Estado := 21; // symbolic state + Estado := 1; + Codigo := true; + c.code:=cc_RESTORE_MATRIX; + Result:=c; + end + else if ((t.token_string = 'f') or (t.token_string = 'F') + or (t.token_string = 'f*') or (t.token_string = 'B') + or (t.token_string = 'B*') or (t.token_string = 'b') + or (t.token_string = 'b*') or (t.token_string = 'n')) then + begin + Estado := 12; // symbolic state + Estado := 1; + Codigo := true; + c.code:=cc_hS_CLOSE_AND_END_PATH; // ignore painting.. + Result:=c; + //raise Exception.Create('ERROR: Prenchimento nao eh suportado.'); + //Halt(1); + end + else if ((t.token_string = 'W') or (t.token_string = 'W*')) then + begin + Estado := 13; // symbolic state + raise Exception.Create('ERROR: Clipping nao eh suportado.'); + Halt(1); + end + else + begin + Estado := 1; + end; + end; + 2: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 2'); + {$endif} + if(t.tipo = 1) then // numbers 2 + begin + Estado := 3; + end + else + begin + Estado := 1; + end; + end; + 3: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 3'); + {$endif} + if(t.tipo = 1) then // numbers 3 + begin + Estado := 5; + end + else if(t.token_string = 'l') then // command l + begin + Estado := 14; // symbolic state + Estado := 1; + c.code:=cc_l_ADD_LINE_TO_PATH; + Codigo := true; + Result:=c; + end + else if(t.token_string = 'm') then // command m + begin + Estado := 15; // symbolic state + Estado := 1; + c.code:=cc_m_START_PATH; + Codigo := true; + Result:=c; + end + else + begin + Estado := 1; + end; + end; + 5: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 5'); + {$endif} + if(t.tipo = 1) then // numbers 4 + begin + Estado := 6; + end + else + begin + Estado := 1; + end; + end; + 6: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 6'); + {$endif} + if(t.tipo = 1) then // numbers 5 + begin + Estado := 7; + end + else if( t.token_string = 'v' ) then // command v + begin + Estado := 16; // symbolic state + raise Exception.Create('ERROR: Curva de bezier nao eh suportada.'); + Halt(1); + end + else if( t.token_string = 'y' ) then // command y + begin + Estado := 17; // symbolic state + raise Exception.Create('ERROR: Curva de bezier nao eh suportada.'); + Halt(1); + end + else if( t.token_string = 're' ) then // command re + begin + Estado := 18; // symbolic state + raise Exception.Create('ERROR: Comando nao suportado.'); + Halt(1); + end + else + begin + Estado := 1; + end; + end; + 7: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 7'); + {$endif} + if(t.tipo = 1) then // numbers 6 + begin + Estado := 8; + end + else + begin + Estado := 1; + end; + end; + 8: + begin + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado 8'); + {$endif} + if(t.token_string = 'c') then // commmand c + begin + Estado := 19; // symbolic state + Estado := 1; + c.code:=cc_c_BEZIER_TO_X_Y_USING_X2_Y2_AND_X3_Y3; + Codigo := true; + Result:=c; + end + else if( t.token_string = 'cm' ) then // command cm + begin + Estado := 20; // symbolic state + Estado := 1; + c.code:=cc_CONCATENATE_MATRIX; + Codigo := true; + Result:=c; + end + else + begin + Estado := 1; + end; + end; + else + {$ifdef FPVECTORIALDEBUG} + WriteLn(':> AnSintaticoCommand.automata Estado ELSE'); + {$endif} + Estado := 1; + end; +end; + +constructor AnSintaticoCommand.Create; +begin + inherited Create; + Estado := 1; +end; + +constructor AnSintaticoPage.Create; +begin + inherited Create; + Estado := 1; + pageFound := false; +end; + +constructor AnSintaticoPageContents.Create; +begin + inherited Create; + Estado := 1; + contentsFound := false; + h.flate_decode := false; +end; + +constructor AnSintaticoLength.Create; +begin + inherited Create; + Estado := 1; + lenghtFound := false; +end; + +end. + diff --git a/components/fpvectorial/svgvectorialreader.pas b/components/fpvectorial/svgvectorialreader.pas new file mode 100644 index 0000000000..a36f956efa --- /dev/null +++ b/components/fpvectorial/svgvectorialreader.pas @@ -0,0 +1,369 @@ +{ +Reads an SVG Document + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho +} +unit svgvectorialreader; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, math, + xmlread, dom, fgl, + fpvectorial, fpvutils; + +type + TSVGTokenType = (sttMoveTo, sttLineTo, sttBezierTo, sttFloatValue); + + TSVGToken = class + TokenType: TSVGTokenType; + Value: Float; + end; + + TSVGTokenList = specialize TFPGList<TSVGToken>; + + { TSVGPathTokenizer } + + TSVGPathTokenizer = class + public + FPointSeparator, FCommaSeparator: TFormatSettings; + Tokens: TSVGTokenList; + constructor Create; + Destructor Destroy; override; + procedure AddToken(AStr: string); + procedure TokenizePathString(AStr: string); + end; + + { TvSVGVectorialReader } + + TvSVGVectorialReader = class(TvCustomVectorialReader) + private + FPointSeparator, FCommaSeparator: TFormatSettings; + FSVGPathTokenizer: TSVGPathTokenizer; + procedure ReadPathFromNode(APath: TDOMNode; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ReadPathFromString(AStr: string; AData: TvVectorialPage; ADoc: TvVectorialDocument); + function StringWithUnitToFloat(AStr: string): Single; + procedure ConvertSVGCoordinatesToFPVCoordinates( + const AData: TvVectorialPage; + const ASrcX, ASrcY: Float; var ADestX, ADestY: Float); + procedure ConvertSVGDeltaToFPVDelta( + const AData: TvVectorialPage; + const ASrcX, ASrcY: Float; var ADestX, ADestY: Float); + public + { General reading methods } + constructor Create; override; + Destructor Destroy; override; + procedure ReadFromStream(AStream: TStream; AData: TvVectorialDocument); override; + end; + +implementation + +const + // SVG requires hardcoding a DPI value + + // The Opera Browser and Inkscape use 90 DPI, so we follow that + + // 1 Inch = 25.4 milimiters + // 90 inches per pixel = (1 / 90) * 25.4 = 0.2822 + // FLOAT_MILIMETERS_PER_PIXEL = 0.3528; // DPI 72 = 1 / 72 inches per pixel + + FLOAT_MILIMETERS_PER_PIXEL = 0.2822; // DPI 90 = 1 / 90 inches per pixel + FLOAT_PIXELS_PER_MILIMETER = 3.5433; // DPI 90 = 1 / 90 inches per pixel + +{ TSVGPathTokenizer } + +constructor TSVGPathTokenizer.Create; +begin + inherited Create; + + FPointSeparator := DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := '#';// disable the thousand separator + + Tokens := TSVGTokenList.Create; +end; + +destructor TSVGPathTokenizer.Destroy; +begin + Tokens.Free; + + inherited Destroy; +end; + +procedure TSVGPathTokenizer.AddToken(AStr: string); +var + lToken: TSVGToken; +begin + lToken := TSVGToken.Create; + + if AStr = 'm' then lToken.TokenType := sttMoveTo + else if AStr = 'l' then lToken.TokenType := sttLineTo + else if AStr = 'c' then lToken.TokenType := sttBezierTo + else + begin + lToken.TokenType := sttFloatValue; + lToken.Value := StrToFloat(AStr, FPointSeparator); + end; + + Tokens.Add(lToken); +end; + +procedure TSVGPathTokenizer.TokenizePathString(AStr: string); +const + Str_Space: Char = ' '; + Str_Comma: Char = ','; +var + i: Integer; + lTmpStr: string; + lState: Integer; + lCurChar: Char; +begin + lState := 0; + + i := 1; + while i <= Length(AStr) do + begin + case lState of + 0: // Adding to the tmp string + begin + lCurChar := AStr[i]; + if lCurChar = Str_Space then + begin + lState := 1; + AddToken(lTmpStr); + lTmpStr := ''; + end + else if lCurChar = Str_Comma then + begin + AddToken(lTmpStr); + lTmpStr := ''; + end + else + lTmpStr := lTmpStr + lCurChar; + + Inc(i); + end; + 1: // Removing spaces + begin + if AStr[i] <> Str_Space then lState := 0 + else Inc(i); + end; + end; + end; +end; + +{ Example of a supported SVG image: + +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<!-- Created with fpVectorial (http://wiki.lazarus.freepascal.org/fpvectorial) --> + +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + width="100mm" + height="100mm" + id="svg2" + version="1.1" + sodipodi:docname="New document 1"> + <g id="layer1"> + <path + style="fill:none;stroke:#000000;stroke-width:10px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="m 0,283.486888731396 l 106.307583274274,-35.4358610914245 " + id="path0" /> + <path + style="fill:none;stroke:#000000;stroke-width:10px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="m 0,354.358610914245 l 354.358610914245,0 l 0,-354.358610914245 l -354.358610914245,0 l 0,354.358610914245 " + id="path1" /> + <path + style="fill:none;stroke:#000000;stroke-width:10px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1" + d="m 0,354.358610914245 l 35.4358610914245,-35.4358610914245 c 0,-35.4358610914246 35.4358610914245,-35.4358610914246 35.4358610914245,0 l 35.4358610914245,35.4358610914245 " + id="path2" /> + </g> +</svg> +} + +{ TvSVGVectorialReader } + +procedure TvSVGVectorialReader.ReadPathFromNode(APath: TDOMNode; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + lNodeName, lStyleStr, lDStr: WideString; + i: Integer; +begin + for i := 0 to APath.Attributes.Length - 1 do + begin + lNodeName := APath.Attributes.Item[i].NodeName; + if lNodeName = 'style' then + lStyleStr := APath.Attributes.Item[i].NodeValue + else if lNodeName = 'd' then + lDStr := APath.Attributes.Item[i].NodeValue + end; + + AData.StartPath(); + ReadPathFromString(UTF8Encode(lDStr), AData, ADoc); + AData.EndPath(); +end; + +procedure TvSVGVectorialReader.ReadPathFromString(AStr: string; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i: Integer; + X, Y, X2, Y2, X3, Y3: Float; + CurX, CurY: Float; +begin + FSVGPathTokenizer.Tokens.Clear; + FSVGPathTokenizer.TokenizePathString(AStr); + CurX := 0; + CurY := 0; + + i := 0; + while i < FSVGPathTokenizer.Tokens.Count do + begin + if FSVGPathTokenizer.Tokens.Items[i].TokenType = sttMoveTo then + begin + CurX := FSVGPathTokenizer.Tokens.Items[i+1].Value; + CurY := FSVGPathTokenizer.Tokens.Items[i+2].Value; + ConvertSVGCoordinatesToFPVCoordinates(AData, CurX, CurY, CurX, CurY); + + AData.AddMoveToPath(CurX, CurY); + + Inc(i, 3); + end + else if FSVGPathTokenizer.Tokens.Items[i].TokenType = sttLineTo then + begin + X := FSVGPathTokenizer.Tokens.Items[i+1].Value; + Y := FSVGPathTokenizer.Tokens.Items[i+2].Value; + ConvertSVGDeltaToFPVDelta(AData, X, Y, X, Y); + + // LineTo uses relative coordenates in SVG + CurX := CurX + X; + CurY := CurY + Y; + + AData.AddLineToPath(CurX, CurY); + + Inc(i, 3); + end + else if FSVGPathTokenizer.Tokens.Items[i].TokenType = sttBezierTo then + begin + X2 := FSVGPathTokenizer.Tokens.Items[i+1].Value; + Y2 := FSVGPathTokenizer.Tokens.Items[i+2].Value; + X3 := FSVGPathTokenizer.Tokens.Items[i+3].Value; + Y3 := FSVGPathTokenizer.Tokens.Items[i+4].Value; + X := FSVGPathTokenizer.Tokens.Items[i+5].Value; + Y := FSVGPathTokenizer.Tokens.Items[i+6].Value; + + ConvertSVGDeltaToFPVDelta(AData, X2, Y2, X2, Y2); + ConvertSVGDeltaToFPVDelta(AData, X3, Y3, X3, Y3); + ConvertSVGDeltaToFPVDelta(AData, X, Y, X, Y); + + AData.AddBezierToPath(X2 + CurX, Y2 + CurY, X3 + CurX, Y3 + CurY, X + CurX, Y + CurY); + + // BezierTo uses relative coordenates in SVG + CurX := CurX + X; + CurY := CurY + Y; + + Inc(i, 7); + end + else + begin + Inc(i); + end; + end; +end; + +function TvSVGVectorialReader.StringWithUnitToFloat(AStr: string): Single; +var + UnitStr, ValueStr: string; + Len: Integer; +begin + // Check the unit + Len := Length(AStr); + UnitStr := Copy(AStr, Len-1, 2); + if UnitStr = 'mm' then + begin + ValueStr := Copy(AStr, 1, Len-2); + Result := StrToInt(ValueStr); + end; +end; + +procedure TvSVGVectorialReader.ConvertSVGCoordinatesToFPVCoordinates( + const AData: TvVectorialPage; const ASrcX, ASrcY: Float; + var ADestX,ADestY: Float); +begin + ADestX := ASrcX * FLOAT_MILIMETERS_PER_PIXEL; + ADestY := AData.Height - ASrcY * FLOAT_MILIMETERS_PER_PIXEL; +end; + +procedure TvSVGVectorialReader.ConvertSVGDeltaToFPVDelta( + const AData: TvVectorialPage; const ASrcX, ASrcY: Float; var ADestX, + ADestY: Float); +begin + ADestX := ASrcX * FLOAT_MILIMETERS_PER_PIXEL; + ADestY := - ASrcY * FLOAT_MILIMETERS_PER_PIXEL; +end; + +constructor TvSVGVectorialReader.Create; +begin + inherited Create; + + FPointSeparator := DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := '#';// disable the thousand separator + + FSVGPathTokenizer := TSVGPathTokenizer.Create; +end; + +destructor TvSVGVectorialReader.Destroy; +begin + FSVGPathTokenizer.Free; + + inherited Destroy; +end; + +procedure TvSVGVectorialReader.ReadFromStream(AStream: TStream; + AData: TvVectorialDocument); +var + Doc: TXMLDocument; + lFirstLayer, lCurNode: TDOMNode; + lPage: TvVectorialPage; +begin + try + // Read in xml file from the stream + ReadXMLFile(Doc, AStream); + + // Read the properties of the <svg> tag + AData.Width := StringWithUnitToFloat(Doc.DocumentElement.GetAttribute('width')); + AData.Height := StringWithUnitToFloat(Doc.DocumentElement.GetAttribute('height')); + + // Now process the elements inside the first layer + lFirstLayer := Doc.DocumentElement.FirstChild; + lCurNode := lFirstLayer.FirstChild; + lPage := AData.AddPage(); + lPage.Width := AData.Width; + lPage.Height := AData.Height; + while Assigned(lCurNode) do + begin + ReadPathFromNode(lCurNode, lPage, AData); + lCurNode := lCurNode.NextSibling; + end; + finally + // finally, free the document + Doc.Free; + end; +end; + +initialization + + RegisterVectorialReader(TvSVGVectorialReader, vfSVG); + +end. + diff --git a/components/fpvectorial/svgvectorialwriter.pas b/components/fpvectorial/svgvectorialwriter.pas new file mode 100644 index 0000000000..811a4914b9 --- /dev/null +++ b/components/fpvectorial/svgvectorialwriter.pas @@ -0,0 +1,275 @@ +{ +Writes an SVG Document + +License: The same modified LGPL as the Free Pascal RTL + See the file COPYING.modifiedLGPL for more details + +AUTHORS: Felipe Monteiro de Carvalho +} +unit svgvectorialwriter; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, math, fpvectorial, fpvutils, fpcanvas; + +type + { TvSVGVectorialWriter } + + TvSVGVectorialWriter = class(TvCustomVectorialWriter) + private + FPointSeparator, FCommaSeparator: TFormatSettings; + procedure WriteDocumentSize(AStrings: TStrings; AData: TvVectorialDocument); + procedure WriteDocumentName(AStrings: TStrings; AData: TvVectorialDocument); + procedure WritePath(AIndex: Integer; APath: TPath; AStrings: TStrings; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure WriteText(AStrings: TStrings; lText: TvText; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure WriteEntities(AStrings: TStrings; AData: TvVectorialPage; ADoc: TvVectorialDocument); + procedure ConvertFPVCoordinatesToSVGCoordinates( + const AData: TvVectorialPage; + const ASrcX, ASrcY: Double; var ADestX, ADestY: double); + public + { General reading methods } + procedure WriteToStrings(AStrings: TStrings; AData: TvVectorialDocument); override; + end; + +implementation + +const + // SVG requires hardcoding a DPI value + + // The Opera Browser and Inkscape use 90 DPI, so we follow that + + // 1 Inch = 25.4 milimiters + // 90 inches per pixel = (1 / 90) * 25.4 = 0.2822 + // FLOAT_MILIMETERS_PER_PIXEL = 0.3528; // DPI 72 = 1 / 72 inches per pixel + + FLOAT_MILIMETERS_PER_PIXEL = 0.2822; // DPI 90 = 1 / 90 inches per pixel + FLOAT_PIXELS_PER_MILIMETER = 3.5433; // DPI 90 = 1 / 90 inches per pixel + +{ TvSVGVectorialWriter } + +procedure TvSVGVectorialWriter.WriteDocumentSize(AStrings: TStrings; AData: TvVectorialDocument); +begin + AStrings.Add(' width="' + FloatToStr(AData.Width, FPointSeparator) + 'mm"'); + AStrings.Add(' height="' + FloatToStr(AData.Height, FPointSeparator) + 'mm"'); +end; + +procedure TvSVGVectorialWriter.WriteDocumentName(AStrings: TStrings; AData: TvVectorialDocument); +begin + AStrings.Add(' sodipodi:docname="New document 1">'); +end; + +{@@ + SVG Coordinate system measures things only in pixels, so that we have to + hardcode a DPI value for the screen, which is usually 72. + FPVectorial uses only milimeters (mm). + + The initial point in FPVectorial is in the bottom-left corner of the document + and it grows to the top and to the right. In SVG, on the other hand, the + initial point is in the top-left corner, growing to the bottom and right. + Besides that, coordinates in SVG are also lengths in comparison to the + previous point and not absolute coordinates. + + SVG uses commas "," to separate the X,Y coordinates, so it always uses points + "." as decimal separators and uses no thousand separators +} +procedure TvSVGVectorialWriter.WritePath(AIndex: Integer; APath: TPath; AStrings: TStrings; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + j: Integer; + PathStr: string; + PtX, PtY, OldPtX, OldPtY: double; + BezierCP1X, BezierCP1Y, BezierCP2X, BezierCP2Y: double; + segment: TPathSegment; + l2DSegment: T2DSegment absolute segment; + l2DBSegment: T2DBezierSegment absolute segment; + // Pen properties + lPenWidth: Integer; + lPenColor: string; + // Brush properties + lFillColor: string; +begin + OldPtX := 0; + OldPtY := 0; + PathStr := ''; + + APath.PrepareForSequentialReading(); + + for j := 0 to APath.Len - 1 do + begin + segment := TPathSegment(APath.Next()); + + if (segment.SegmentType <> st2DLine) + and (segment.SegmentType <> stMoveTo) + and (segment.SegmentType <> st2DBezier) + then Break; // unsupported line type + + // Coordinate conversion from fpvectorial to SVG + ConvertFPVCoordinatesToSVGCoordinates( + AData, l2DSegment.X, l2DSegment.Y, PtX, PtY); + PtX := PtX - OldPtX; + PtY := PtY - OldPtY; + + if (segment.SegmentType = stMoveTo) then + begin + PathStr := PathStr + 'm ' + + FloatToStr(PtX, FPointSeparator) + ',' + + FloatToStr(PtY, FPointSeparator) + ' '; + end + else if (segment.SegmentType = st2DLine) then + begin + PathStr := PathStr + 'l ' + + FloatToStr(PtX, FPointSeparator) + ',' + + FloatToStr(PtY, FPointSeparator) + ' '; + end + else if (segment.SegmentType = st2DBezier) then + begin + // Converts all coordinates to absolute values + ConvertFPVCoordinatesToSVGCoordinates( + AData, l2DBSegment.X2, l2DBSegment.Y2, BezierCP1X, BezierCP1Y); + ConvertFPVCoordinatesToSVGCoordinates( + AData, l2DBSegment.X3, l2DBSegment.Y3, BezierCP2X, BezierCP2Y); + + // Transforms them into values relative to the initial point + BezierCP1X := BezierCP1X - OldPtX; + BezierCP1Y := BezierCP1Y - OldPtY; + BezierCP2X := BezierCP2X - OldPtX; + BezierCP2Y := BezierCP2Y - OldPtY; + + // PtX and PtY already contains the destination point + + // Now render our 2D cubic bezier + PathStr := PathStr + 'c ' + + FloatToStr(BezierCP1X, FPointSeparator) + ',' + + FloatToStr(BezierCP1Y, FPointSeparator) + ' ' + + FloatToStr(BezierCP2X, FPointSeparator) + ',' + + FloatToStr(BezierCP2Y, FPointSeparator) + ' ' + + FloatToStr(PtX, FPointSeparator) + ',' + + FloatToStr(PtY, FPointSeparator) + ' ' + ; + end; + + // Store the current position for future points + OldPtX := OldPtX + PtX; + OldPtY := OldPtY + PtY; + end; + + // Get the Pen Width + if APath.Pen.Width >= 1 then lPenWidth := APath.Pen.Width + else lPenWidth := 1; + + // Get the Pen Color and Style + if APath.Pen.Style = psClear then lPenColor := 'none' + else lPenColor := '#' + FPColorToRGBHexString(APath.Pen.Color); + + // Get the Brush color and style + if APath.Brush.Style = bsClear then lFillColor := 'none' + else lFillColor := '#' + FPColorToRGBHexString(APath.Brush.Color); + + // Now effectively write the path + AStrings.Add(' <path'); + AStrings.Add(Format(' style="fill:%s;stroke:%s;stroke-width:%dpx;' + + 'stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"', + [lFillColor, lPenColor, lPenWidth])); + AStrings.Add(' d="' + PathStr + '"'); + AStrings.Add(' id="path' + IntToStr(AIndex) + '" />'); +end; + +procedure TvSVGVectorialWriter.ConvertFPVCoordinatesToSVGCoordinates( + const AData: TvVectorialPage; const ASrcX, ASrcY: Double; var ADestX, + ADestY: double); +begin + ADestX := ASrcX / FLOAT_MILIMETERS_PER_PIXEL; + ADestY := (AData.Height - ASrcY) / FLOAT_MILIMETERS_PER_PIXEL; +end; + +procedure TvSVGVectorialWriter.WriteToStrings(AStrings: TStrings; + AData: TvVectorialDocument); +var + lPage: TvVectorialPage; +begin + // Format seetings to convert a string to a float + FPointSeparator := DefaultFormatSettings; + FPointSeparator.DecimalSeparator := '.'; + FPointSeparator.ThousandSeparator := '#';// disable the thousand separator + FCommaSeparator := DefaultFormatSettings; + FCommaSeparator.DecimalSeparator := ','; + FCommaSeparator.ThousandSeparator := '#';// disable the thousand separator + + // Headers + AStrings.Add('<?xml version="1.0" encoding="UTF-8" standalone="no"?>'); + AStrings.Add('<!-- Created with fpVectorial (http://wiki.lazarus.freepascal.org/fpvectorial) -->'); + AStrings.Add(''); + AStrings.Add('<svg'); + AStrings.Add(' xmlns:dc="http://purl.org/dc/elements/1.1/"'); + AStrings.Add(' xmlns:cc="http://creativecommons.org/ns#"'); + AStrings.Add(' xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"'); + AStrings.Add(' xmlns:svg="http://www.w3.org/2000/svg"'); + AStrings.Add(' xmlns="http://www.w3.org/2000/svg"'); + AStrings.Add(' xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"'); + WriteDocumentSize(AStrings, AData); + AStrings.Add(' id="svg2"'); + AStrings.Add(' version="1.1"'); + WriteDocumentName(AStrings, AData); + + // Now data + AStrings.Add(' <g id="layer1">'); + lPage := AData.GetPage(0); + WriteEntities(AStrings, lPage, AData); + AStrings.Add(' </g>'); + + // finalization + AStrings.Add('</svg>'); +end; + +procedure TvSVGVectorialWriter.WriteText(AStrings: TStrings; lText: TvText; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + i, j, FontSize: Integer; + TextStr, FontName, SVGFontFamily: string; + PtX, PtY: double; +begin + TextStr := ''; + + ConvertFPVCoordinatesToSVGCoordinates( + AData, lText.X, lText.Y, PtX, PtY); + + TextStr := lText.Value.Text; + FontSize:= ceil(lText.Font.Size / FLOAT_MILIMETERS_PER_PIXEL); + SVGFontFamily := 'Arial, sans-serif';//lText.FontName; + + AStrings.Add(' <text '); + AStrings.Add(' x="' + FloatToStr(PtX, FPointSeparator) + '"'); + AStrings.Add(' y="' + FloatToStr(PtY, FPointSeparator) + '"'); +// AStrings.Add(' font-size="' + IntToStr(FontSize) + '"'); Doesn't seam to work, we need to use the tspan + AStrings.Add(' font-family="' + SVGFontFamily + '">'); + AStrings.Add(' <tspan '); + AStrings.Add(' style="font-size:' + IntToStr(FontSize) + '" '); +// AStrings.Add(' id="tspan2828" '); + AStrings.Add(' >'); + AStrings.Add(TextStr + '</tspan></text>'); +end; + +procedure TvSVGVectorialWriter.WriteEntities(AStrings: TStrings; + AData: TvVectorialPage; ADoc: TvVectorialDocument); +var + lEntity: TvEntity; + i, j: Integer; +begin + for i := 0 to AData.GetEntitiesCount() - 1 do + begin + lEntity := AData.GetEntity(i); + + if lEntity is TPath then WritePath(i, TPath(lEntity), AStrings, AData, ADoc) + else if lEntity is TvText then WriteText(AStrings, TvText(lEntity), AData, ADoc); + end; +end; + +initialization + + RegisterVectorialWriter(TvSVGVectorialWriter, vfSVG); + +end. +