diff --git a/.gitattributes b/.gitattributes index bc38bbca1f..151b52606d 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1498,6 +1498,7 @@ lcl/maskedit.pp svneol=native#text/pascal lcl/menus.pp svneol=native#text/pascal lcl/nonwin32/messages.pp svneol=native#text/pascal lcl/pairsplitter.pas svneol=native#text/pascal +lcl/postscriptcanvas.pas svneol=native#text/pascal lcl/postscriptprinter.pas svneol=native#text/pascal lcl/printers.pas svneol=native#text/pascal lcl/propertystorage.pas svneol=native#text/pascal diff --git a/lcl/postscriptcanvas.pas b/lcl/postscriptcanvas.pas new file mode 100644 index 0000000000..3887c59398 --- /dev/null +++ b/lcl/postscriptcanvas.pas @@ -0,0 +1,1548 @@ +{ + /*************************************************************************** + PostscriptCanvas.pas + ------------ + PostScript Printer Canvas object + + ***************************************************************************/ + + ***************************************************************************** + * * + * This file is part of the Lazarus Component Library (LCL) * + * * + * See the file COPYING.LCL, included in this distribution, * + * for details about the copyright. * + * * + * This program is distributed in the hope that it will be useful, * + * but WITHOUT ANY WARRANTY; without even the implied warranty of * + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * + * * + ***************************************************************************** + + Author: Olivier Guilbaud + + Informations : + - Green Book Listing 9-1, on page 138 for Pattrens + - PostScriptPrinter unit of Tony Maro + - Piddle Project (Python language) + - Internet PostScript forums + + Warnings : + - Draw and StretchDraw it's slow for big image + - Angles it's 1/16 of degre + ToDo : + - Implemente few methods +} + +unit PostscriptCanvas; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, Math, Graphics, Forms, GraphMath, GraphType, + {$IFNDEF DisableFPImage} + FPImage, IntfGraphics, + {$ENDIF} + Printers, LCLType, LCLIntf; + +Type + TPostscriptPrinterCanvas = Class(TPrinterCanvas) + private + fHeader : TStringList; //Header document + fDocument : TstringList; //Current document + fFileName : String; //OutOut fileName + + fBuffer : TStringList; //PostScript temporary buffer + + //Current values + fcBrushStyle : TBrushStyle; + fcPenColor : TColor; //Color of Pen and Brush + fcPenWidth : Integer; + fcPenStyle : TPenStyle; + fcLastFont : TFont; + + fPenPos : TPoint; + + FirstUpdatefont: Boolean; + + procedure WriteHeader(St : String); + procedure Write(St : String; Lst : TstringList=nil); + procedure WriteB(St : string); + procedure ClearBuffer; + procedure Write(Lst : TStringList); overload; + procedure WriteComment(St : string); + + Procedure TranslateCoord(Var X,Y : Integer); + procedure SetPosition(X,Y : Integer); + + procedure UpdateLineWidth; + procedure UpdateLineColor(aColor : TColor=clNone); + procedure UpdateLineStyle; + procedure UpdateFillColor; + procedure UpdateFont; + function MapedFontName : string; + function MapedString(const St : string):string; + + procedure MoveToLastPos; + procedure SetBrushFillPattern(Lst : TStringList; SetBorder,SetFill : Boolean); + procedure SetBrushFillPattern(SetBorder,SetFill : Boolean); overload; + + procedure GetRGBImage(SrcGraph: TGraphic; Lst : TStringList); + protected + procedure CreateHandle; override; + + procedure BeginDoc; override; + procedure EndDoc; override; + procedure NewPage; override; + public + constructor Create(APrinter : TPrinter); override; + destructor Destroy; override; + + procedure SaveToFile(aFileName : string); + + + Procedure MoveTo(X1,Y1: Integer); override; + Procedure LineTo(X1,Y1: Integer); override; + procedure Polyline(Points: PPoint; NumPts: Integer); override; + procedure PolyBezier(Points: PPoint; NumPts: Integer; + Filled: boolean{$IFNDEF VER1_0} = False{$ENDIF}; + Continuous: boolean{$IFNDEF VER1_0} = False{$ENDIF}); override; + + Procedure Rectangle(X1,Y1,X2,Y2: Integer); override; + procedure Frame(const ARect: TRect); override; // border using pen + procedure FrameRect(const ARect: TRect); override; // border using brush + + Procedure FillRect(const ARect: TRect); override; + Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY: Integer); override; + procedure Polygon(Points: PPoint; NumPts: Integer; Winding: boolean=False); override; + + procedure Ellipse(x1, y1, x2, y2: Integer); override; + procedure Arc(x,y,width,height,angle1,angle2: Integer); override; + procedure RadialPie(x,y,width,height,angle1,angle2: Integer); override; + procedure Chord(x, y, width, height, angle1, angle2: Integer); override; + + procedure TextOut(X,Y: Integer; const Text: String); override; + function TextExtent(const Text: string): TSize; override; + + Procedure Draw(X,Y: Integer; SrcGraphic: TGraphic); override; + procedure StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); override; + + + //** Methods not definined on PostScript + procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); override; + Procedure CopyRect(const Dest: TRect; SrcCanvas: TCanvas; const Source: TRect); override; + Procedure BrushCopy(Dest: TRect; InternalImages: TBitmap; Src: TRect; + TransparentColor: TColor); override; + + //** Methods not implemented + procedure Arc(x,y,width,height,SX,SY,EX,EY: Integer); override; + procedure Chord(x, y, width, height, SX, SY, EX, EY: Integer); override; + procedure Frame3d(var ARect: TRect; const FrameWidth: integer; + const Style: TGraphicsBevelCut); override; + procedure RadialPie(x,y,width,height,sx,sy,ex,ey: Integer); override; + procedure Pie(EllipseX1,EllipseY1,EllipseX2,EllipseY2, + StartX,StartY,EndX,EndY: Integer); override; + procedure TextRect(ARect: TRect; X, Y: integer; const Text: string; + const Style: TTextStyle); override; + + + property OutPutFileName : string read fFileName write fFileName; + end; + + TPostscriptCanvas = Class(TPostscriptPrinterCanvas) + public + Constructor Create; overload; + + procedure BeginDoc; override; + procedure EndDoc; override; + procedure NewPage; override; + end; + +implementation +Const + cBrushStyle : Array[bsSolid..bsDiagCross] of String = ('bsSolid','bsClear','bsHorizontal', + 'bsVertical','bsFDiagonal', + 'bsBDiagonal','bsCross','bsDiagCross'); +{ TPostscriptPrinterCanvas } + +//Write an instruction in the header of document +procedure TPostscriptPrinterCanvas.WriteHeader(St: String); +begin + fHeader.Add(St); +end; + +//Write an instruction in the document +procedure TPostscriptPrinterCanvas.Write(St: String; Lst : TStringList=Nil); +begin + If not Assigned(Lst) then + Lst:=fDocument; + + Lst.Add(St); +end; + +//Write data in fBuffer +procedure TPostscriptPrinterCanvas.WriteB(St: string); +begin + Write(St,fBuffer); +end; + +//Clear all data of Buffer +procedure TPostscriptPrinterCanvas.ClearBuffer; +begin + fBuffer.Clear; +end; + +//Write all Lst.Strings in document +procedure TPostscriptPrinterCanvas.Write(Lst: TStringList); +begin + fDocument.AddStrings(Lst); +end; + +//Write an comment in the document +procedure TPostscriptPrinterCanvas.WriteComment(St: string); +begin + fDocument.Add('%'+St); +end; + +//Convert an TCanvas Y point to PostScript Y point +//The TCanvas origine is corner Left,Top and Postscript is Left,Bottom +//Modify X and Y for use Left and Top margin +procedure TPostscriptPrinterCanvas.TranslateCoord(var X,Y : Integer); +begin + Y:=PageHeight-TopMarging-Y; + X:=X+LeftMarging; +end; + +//Save the last position +procedure TPostscriptPrinterCanvas.SetPosition(X, Y: Integer); +begin + fPenPos:= Point(X,Y); + SetInternalPenPos(Point(X,Y)); +end; + +//Init the width of line +procedure TPostscriptPrinterCanvas.UpdateLineWidth; +begin + if Pen.Width<>fcPenWidth then + begin + Write(Format('%d setlinewidth',[Pen.Width])); + fcPenWidth:=Pen.Width; + end; +end; + +//Init the color of line (pen) +procedure TPostscriptPrinterCanvas.UpdateLineColor(aColor : TColor=clNone); +Var R,G,B : Real; + RGBColor : TColor; +begin + if aColor=clNone then + aColor:=Pen.Color; + + if aColor<>fcPenColor then + begin + RGBColor:=ColorToRGB(aColor); + + R:=Red(RGBColor)/255; + G:=Green(RGBColor)/255; + B:=Blue(RGBColor)/255; + Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(aColor)); + fcPenColor:=aColor; + end; +end; + +//Init the style of line +procedure TPostscriptPrinterCanvas.UpdateLineStyle; +Var st : string; +begin + if (Pen.Style<>fcPenStyle) and (Pen.Style<>psClear) then + begin + Case Pen.Style of + psSolid : St:='[] 0'; + psDash : St:='[5 2] 0'; + psDot : St:='[1 3] 0'; + psDashDot : St:='[5 2 2 2] 0'; + psDashDotDot : St:='[5 2 2 2 2 2] 0'; + end; + + Write(Format('%s setdash',[St])); + fcPenStyle:=Pen.Style; + end; +end; + +//Init the color for fill +procedure TPostscriptPrinterCanvas.UpdateFillColor; +Var R,G,B : Real; + RGBColor : TColor; +begin + if (Brush.Style=bsSolid) and (Brush.Color<>fcPenColor) then + begin + RGBColor:=ColorToRGB(Brush.Color); + + R:=Red(RGBColor)/255; + G:=Green(RGBColor)/255; + B:=Blue(RGBColor)/255; + Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(Brush.Color)); + fcPenColor:=Brush.Color; + end; +end; + +//Update current font +procedure TPostscriptPrinterCanvas.UpdateFont; +Var R,G,B : Real; + RGBColor : TColor; +begin + try + if Font.Color=clNone then + Font.Color:=clBlack; + if Font.Size=0 then + Font.Size:=12; + + if Font.Color<>fcPenColor then + begin + RGBColor:=ColorToRGB(Font.Color); + + R:=Red(RGBColor)/255; + G:=Green(RGBColor)/255; + B:=Blue(RGBColor)/255; + + Write(Format('%.3f %.3f %.3f setrgbcolor',[R,G,B])+' % '+ColorToString(Font.Color)); + fcPenColor:=Font.Color; + end; + + if (Font.Name<>fcLastFont.Name) or (Font.Size<>fcLastFont.Size) or + (Font.Style<>fcLastFont.Style) or FirstUpdatefont then + begin + FirstUpdatefont:=False; + Write(Format('/%s findfont %d scalefont setfont',[MapedFontName,Font.Size])); + end; + finally + fcLastFont.Assign(Font); + end; +end; + +//Return an Postscript font Name +function TPostscriptPrinterCanvas.MapedFontName: string; +Var Atr : string; +begin + Atr:=''; + Result:='HelveticaISO'; + if LowerCase(Font.Name)='times' then + Result:='TimesISO'; + if LowerCase(Font.Name)='monospaced' then + Result:='CourierISO'; + if LowerCase(Font.Name)='serif' then + Result:='TimesISO'; + if LowerCase(Font.Name)='sansserif' then + Result:='HelveticaISO'; + if LowerCase(Font.Name)='symbol' then + Result:='Symbol'; + + if (fsItalic in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1)) then + Atr:=Atr+'-Oblique'; + if (fsItalic in Font.Style) and (Pos('Times',Result)=1) then + Atr:=Atr+'-Italic'; + if (fsBold in Font.Style) and ((Pos('Courier',Result)=1) or (Pos('Helvetica',Result)=1) or (Pos('Times',Result)=1)) then + Atr:=Atr+'-Bold'; + if (Result+Atr='Times') or (Result+Atr='TimesISO') then + Result:='RomanISO'; + + WriteComment(Format('MapedFontName "%s" -> "%s"',[Font.Name,Result])); + + Result:=Result+Atr; +end; + +//Replace the controls chars by PostScript string +function TPostscriptPrinterCanvas.MapedString(const St: string): string; +begin + Result:=St; + Result:=StringReplace(Result,'\','\\',[rfReplaceAll]); + Result:=StringReplace(Result,'(','\(',[rfReplaceAll]); + Result:=StringReplace(Result,')','\)',[rfReplaceAll]); + Result:=StringReplace(Result,#10,'\n',[rfReplaceAll]); + Result:=StringReplace(Result,#13,'\r',[rfReplaceAll]); + Result:=StringReplace(Result,#8, '\b',[rfReplaceAll]); + Result:=StringReplace(Result,#9, '\t',[rfReplaceAll]); +end; + +//Move pen at last pos +procedure TPostscriptPrinterCanvas.MoveToLastPos; +begin + write(Format('%d %d moveto',[fPenPos.X,fPenPos.Y])+' %last pos'); +end; + +//Add at the PstScript sequence, the Fill Pattern/Color and Broder +//Use SetBorder and SetFill for initialize 1 or 2 sequence +procedure TPostscriptPrinterCanvas.SetBrushFillPattern(Lst: TStringList; + SetBorder, SetFill: Boolean); +begin + If not Assigned(Lst) then Exit; + + if SetFill then + begin + if (Brush.Color<>clNone) and (Brush.Style<>bsClear) then + begin + UpdateFillColor; + + Case Brush.Style of + bsSolid : begin + Write(Lst); + Write('eofill'); + end; + bsClear : ; + else + begin + UpdateLineColor(Brush.Color); + write(Format('/%s findfont %% a pattern font patternfill',[cBrushStyle[Brush.Style]])); + Write(Lst); + write('patternfill'); + end; + end; + end; + end; + + if SetBorder and ((Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid))) then + begin + UpdateLineColor; + UpdateLineWidth; + UpdateLineStyle; + Write(Lst); + Write('stroke'); + end; +end; + +procedure TPostscriptPrinterCanvas.SetBrushFillPattern(SetBorder, SetFill: Boolean); +begin + SetBrushFillPattern(fBuffer,SetBorder,SetFill); +end; + +//Add in Lst, all RGB pixels of SrcGraph picture +procedure TPostscriptPrinterCanvas.GetRGBImage(SrcGraph: TGraphic; + Lst: TStringList); +{$IFDEF DisableFPImage} +begin +end; +{$ELSE} +var + SrcIntfImg : TLazIntfImage; + px, py : Integer; + CurColor : TFPColor; + St : String; +begin + if (SrcGraph is TBitMap) then + begin + SrcIntfImg:=TLazIntfImage.Create(0,0); + Lst.BeginUpdate; + Try + SrcIntfImg.LoadFromBitmap(TBitMap(SrcGraph).Handle,TBitMap(SrcGraph).MaskHandle); + St:=''; + for py:=0 to SrcIntfImg.Height-1 do + begin + for px:=0 to SrcIntfImg.Width-1 do + begin + CurColor:=SrcIntfImg.Colors[px,py]; + St:=St+IntToHex(Hi(CurColor.Red),2)+ + IntToHex(Hi(CurColor.Green),2)+ + IntToHex(Hi(CurColor.Blue),2); + + if Length(St)>=78 then + begin + Lst.Add(Copy(St,1,78)); + System.Delete(St,1,78); + end; + end; + end; + if St<>'' then + Lst.Add(St); + finally + Lst.EndUpdate; + SrcIntfImg.Free; + end; + end; +end; +{$ENDIF} + +procedure TPostscriptPrinterCanvas.CreateHandle; +begin + SetHandle(1); +end; + + +constructor TPostscriptPrinterCanvas.Create(APrinter: TPrinter); +begin + inherited Create(APrinter); + + fcBrushStyle:=bsClear; + fcPenColor :=clBlack; + fcPenWidth :=0; + fcPenStyle :=psSolid; + fcLastFont :=TFont.Create; + + fHeader:=TStringList.Create; + fBuffer:=TstringList.Create; + fDocument:=TStringList.Create; +end; + +destructor TPostscriptPrinterCanvas.Destroy; +begin + fBuffer.Free; + fHeader.Free; + fDocument.Free; + fcLastFont.Free; + + inherited Destroy; +end; + +procedure TPostscriptPrinterCanvas.SaveToFile(aFileName: string); +Var Lst : TStringList; +begin + Lst:=TStringList.Create; + try + Lst.AddStrings(fHeader); + Lst.AddStrings(fDocument); + + Lst.SaveTofile(ExpandFileName(aFileName)); + finally + Lst.Free; + end; +end; + +procedure TPostscriptPrinterCanvas.BeginDoc; +begin + Inherited BeginDoc; + + FirstUpdatefont:=True; + Font.Size:=12; + Font.Color:=clBlack; + + WriteHeader('%!PS-Adobe-3.0'); + WriteHeader('%%'+Format('BoundingBox: 0 0 %d %d',[PageWidth,PageHeight])); + WriteHeader('%%'+Format('Creator: Lazarus PostScriptCanvas for %s',[Application.ExeName])); + WriteHeader('%%'+Format('Title: %s',[Title])); + WriteHeader('%%CreationDate: '+DateTimeToStr(Now)); + WriteHeader('%%Pages: (atend)'); + WriteHeader('%%PageResources: (atend)'); + WriteHeader('%%PageOrder: Ascend'); + WriteHeader('%%Page: 1'); + WriteHeader(''); + WriteHeader('%------------------------------------------------------------'); + WriteHeader('%================== BEGIN SETUP=============================='); + WriteHeader(''); + WriteHeader('% ISO Fonts'); + WriteHeader('/Helvetica findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/HelveticaISO exch definefont pop'); + WriteHeader(''); + WriteHeader('/Helvetica-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/HelveticaISO-Bold exch definefont pop'); + WriteHeader(''); + WriteHeader('/Helvetica-Oblique findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/HelveticaISO-Oblique exch definefont pop'); + WriteHeader(''); + WriteHeader('/Helvetica-Oblique-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/HelveticaISO-Oblique-Bold exch definefont pop'); + WriteHeader(''); + + WriteHeader('/Courier findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/CourierISO exch definefont pop'); + WriteHeader(''); + WriteHeader('/Courier-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/CourierISO-Bold exch definefont pop'); + WriteHeader(''); + WriteHeader('/Courier-Oblique findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/CourierISO-Oblique exch definefont pop'); + WriteHeader(''); + WriteHeader('/Courier-Oblique-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/CourierISO-Oblique-Bold exch definefont pop'); + WriteHeader(''); + + WriteHeader('/Times findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/TimesISO exch definefont pop'); + WriteHeader(''); + WriteHeader('/Times-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/TimesISO-Bold exch definefont pop'); + WriteHeader(''); + WriteHeader('/Times-Italic findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/TimesISO-Italic exch definefont pop'); + WriteHeader(''); + WriteHeader('/Times-Italic-Bold findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/TimesISO-Italic-Bold exch definefont pop'); + WriteHeader(''); + + WriteHeader('/Roman findfont'); + WriteHeader(' dup length dict begin'); + WriteHeader(' {1 index /FID ne {def} {pop pop} ifelse} forall'); + WriteHeader(' /Encoding ISOLatin1Encoding def'); + WriteHeader(' currentdict'); + WriteHeader('end'); + WriteHeader('/RomanISO exch definefont pop'); + WriteHeader(''); + + + WriteHeader('/underline_on'); + WriteHeader('{%def'); + WriteHeader(' /underline true def'); + WriteHeader(' /underlineposition exch def'); + WriteHeader(' /underlinethickness exch def'); + WriteHeader(' /TEXT { TEXTwith } def'); + WriteHeader('} def'); + + WriteHeader('/underline_off'); + WriteHeader('{ %def'); + WriteHeader(' /undefline false def'); + WriteHeader(' /TEXT { TEXTwithout } def'); + WriteHeader('} def'); + + WriteHeader('/TEXTwithout { moveto show } bind def'); + + WriteHeader('/TEXTwith { %def'); + WriteHeader(' moveto'); + WriteHeader(' gsave'); + WriteHeader(' [] 0 setdash'); + WriteHeader(' 0 underlineposition rmoveto'); + WriteHeader(' underlinethickness setlinewidth'); + WriteHeader(' dup stringwidth rlineto stroke'); + WriteHeader(' grestore'); + WriteHeader(' show'); + WriteHeader('} bind def'); + + WriteHeader('%%BeginProcSet: patternfill 1.0 0'); + WriteHeader('% width height matrix proc key cache'); + WriteHeader('% definepattern -\> font'); + WriteHeader('/definepattern { %def'); + WriteHeader(' 7 dict begin'); + WriteHeader(' /FontDict 9 dict def'); + WriteHeader(' FontDict begin'); + WriteHeader(' /cache exch def'); + WriteHeader(' /key exch def'); + WriteHeader(' /proc exch cvx def'); + WriteHeader(' /mtx exch matrix invertmatrix def'); + WriteHeader(' /height exch def'); + WriteHeader(' /width exch def'); + WriteHeader(' /ctm matrix currentmatrix def'); + WriteHeader(' /ptm matrix identmatrix def'); + WriteHeader(' /str'); + WriteHeader(' (12345678901234567890123456789012)'); + WriteHeader(' def'); + WriteHeader(' end'); + WriteHeader(' /FontBBox [ %def'); + WriteHeader(' 0 0 FontDict /width get'); + WriteHeader(' FontDict /height get'); + WriteHeader(' ] def'); + WriteHeader(' /FontMatrix FontDict /mtx get def'); + WriteHeader(' /Encoding StandardEncoding def'); + WriteHeader(' /FontType 3 def'); + WriteHeader(' /BuildChar { %def'); + WriteHeader(' pop begin'); + WriteHeader(' FontDict begin'); + WriteHeader(' width 0 cache { %ifelse'); + WriteHeader(' 0 0 width height setcachedevice'); + WriteHeader(' }{ %else'); + WriteHeader(' setcharwidth'); + WriteHeader(' } ifelse'); + WriteHeader(' 0 0 moveto width 0 lineto'); + WriteHeader(' width height lineto 0 height lineto'); + WriteHeader(' closepath clip newpath'); + WriteHeader(' gsave proc grestore'); + WriteHeader(' end end'); + WriteHeader(' } def'); + WriteHeader(' FontDict /key get currentdict definefont'); + WriteHeader(' end'); + WriteHeader('} bind def'); + WriteHeader('% dict patternpath -'); + WriteHeader('% dict matrix patternpath -'); + WriteHeader('/patternpath { %def'); + WriteHeader(' dup type /dicttype eq { %ifelse'); + WriteHeader(' begin FontDict /ctm get setmatrix'); + WriteHeader(' }{ %else'); + WriteHeader(' exch begin FontDict /ctm get setmatrix'); + WriteHeader(' concat'); + WriteHeader(' } ifelse'); + WriteHeader(' currentdict setfont'); + WriteHeader(' FontDict begin'); + WriteHeader(' FontMatrix concat'); + WriteHeader(' width 0 dtransform'); + WriteHeader(' round width div exch round width div exch'); + WriteHeader(' 0 height dtransform'); + WriteHeader(' round height div exch'); + WriteHeader(' round height div exch'); + WriteHeader(' 0 0 transform round exch round exch'); + WriteHeader(' ptm astore setmatrix'); + WriteHeader(' '); + WriteHeader(' pathbbox'); + WriteHeader(' height div ceiling height mul 4 1 roll'); + WriteHeader(' width div ceiling width mul 4 1 roll'); + WriteHeader(' height div floor height mul 4 1 roll'); + WriteHeader(' width div floor width mul 4 1 roll'); + WriteHeader(' '); + WriteHeader(' 2 index sub height div ceiling cvi exch'); + WriteHeader(' 3 index sub width div ceiling cvi exch'); + WriteHeader(' 4 2 roll moveto'); + WriteHeader(' '); + WriteHeader(' FontMatrix ptm invertmatrix pop'); + WriteHeader(' { %repeat'); + WriteHeader(' gsave'); + WriteHeader(' ptm concat'); + WriteHeader(' dup str length idiv { %repeat'); + WriteHeader(' str show'); + WriteHeader(' } repeat'); + WriteHeader(' dup str length mod str exch'); + WriteHeader(' 0 exch getinterval show'); + WriteHeader(' grestore'); + WriteHeader(' 0 height rmoveto'); + WriteHeader(' } repeat'); + WriteHeader(' pop'); + WriteHeader(' end end'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('% dict patternfill -'); + WriteHeader('% dict matrix patternfill -'); + WriteHeader('/patternfill { %def'); + WriteHeader(' gsave'); + WriteHeader(' clip patternpath'); + WriteHeader(' grestore'); + WriteHeader(' newpath'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('% dict patterneofill -'); + WriteHeader('% dict matrix patterneofill -'); + WriteHeader('/patterneofill { %def'); + WriteHeader(' gsave'); + WriteHeader(' eoclip patternpath'); + WriteHeader(' grestore'); + WriteHeader(' newpath'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('% dict patternstroke -'); + WriteHeader('% dict matrix patternstroke -'); + WriteHeader('/patternstroke { %def'); + WriteHeader(' gsave'); + WriteHeader(' strokepath clip patternpath'); + WriteHeader(' grestore'); + WriteHeader(' newpath'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('% dict ax ay string patternashow -'); + WriteHeader('% dict matrix ax ay string patternashow -'); + WriteHeader('/patternashow { %def'); + WriteHeader(' (0) exch { %forall'); + WriteHeader(' 2 copy 0 exch put pop dup'); + WriteHeader(' false charpath '); + WriteHeader(' currentpoint'); + WriteHeader(' 5 index type /dicttype eq { %ifelse'); + WriteHeader(' 5 index patternfill'); + WriteHeader(' }{ %else'); + WriteHeader(' 6 index 6 index patternfill'); + WriteHeader(' } ifelse'); + WriteHeader(' moveto'); + WriteHeader(' 3 copy pop rmoveto'); + WriteHeader(' } forall'); + WriteHeader(' pop pop pop'); + WriteHeader(' dup type /dicttype ne { pop } if pop'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('% dict string patternshow -'); + WriteHeader('% dict matrix string patternshow -'); + WriteHeader('/patternshow { %def'); + WriteHeader(' 0 exch 0 exch patternashow'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('/opaquepatternfill { %def'); + WriteHeader(' gsave'); + WriteHeader(' 1 setgray'); + WriteHeader(' fill'); + WriteHeader(' grestore'); + WriteHeader(' patternfill'); + WriteHeader('} bind def'); + WriteHeader(''); + WriteHeader('%%EndProcSet'); + WriteHeader('%%EndProlog'); + WriteHeader(''); + WriteHeader('%%BeginSetup'); + WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 7.5 0 moveto 15 7.5 lineto'); + WriteHeader(' 0 7.5 moveto 7.5 15 lineto'); + WriteHeader(' 2 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsBDiagonal true definepattern pop'); + WriteHeader(''); + WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 7.5 0 moveto 0 7.5 lineto'); + WriteHeader(' 15 7.5 moveto 7.5 15 lineto'); + WriteHeader(' 2 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsFDiagonal true definepattern pop'); + WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 2 scale'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 7.5 0 moveto 15 7.5 lineto'); + WriteHeader(' 0 7.5 moveto 7.5 15 lineto'); + WriteHeader(' 7.5 0 moveto 0 7.5 lineto'); + WriteHeader(' 15 7.5 moveto 7.5 15 lineto'); + WriteHeader(' 0.5 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsDiagCross true definepattern pop'); + WriteHeader(''); + WriteHeader('30 30 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 15 0 moveto 15 30 lineto'); + WriteHeader(' 0 15 moveto 30 15 lineto'); + WriteHeader(' 2 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsCross true definepattern pop'); + WriteHeader(''); + WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 0 7.5 moveto 15 7.5 lineto'); + WriteHeader(' 2 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsHorizontal true definepattern pop'); + WriteHeader(''); + WriteHeader('15 15 [300 72 div 0 0 300 72 div 0 0]'); + WriteHeader('{ %definepattern'); + WriteHeader(' 2 setlinecap'); + WriteHeader(' 7.5 0 moveto 7.5 15 lineto'); + WriteHeader(' 2 setlinewidth stroke'); + WriteHeader('} bind'); + WriteHeader('/bsVertical true definepattern pop'); + WriteHeader('%%EndSetup'); + WriteHeader('%%====================== END SETUP ========================='); + WriteHeader(''); +end; + +procedure TPostscriptPrinterCanvas.EndDoc; +begin + Inherited EndDoc; + + Write('stroke'); + Write('showpage'); + Write('%%EOF'); + + if Trim(fFileName)<>'' then + SaveToFile(ExpandFileName(fFileName)); +end; + +procedure TPostscriptPrinterCanvas.NewPage; +begin + Inherited NewPage; + + Write('stroke'); + Write('showpage'); + Write('%%'+Format('Page: %d',[PageNumber])); + + write('newpath'); +end; + +//Move the current position +procedure TPostscriptPrinterCanvas.MoveTo(X1, Y1: Integer); +begin + RequiredState([csHandleValid]); + WriteComment(Format('MoveTo(%d,%d)',[x1,y1])); + + SetPosition(X1,Y1); + TranslateCoord(X1,Y1); + + write(Format('%d %d moveto',[X1,Y1])); +end; + +//Drawe line +procedure TPostscriptPrinterCanvas.LineTo(X1, Y1: Integer); +begin + Changing; + RequiredState([csHandleValid, csPenValid]); + + WriteComment(Format('LineTo(%d,%d)',[x1,y1])); + SetPosition(X1,Y1); + TranslateCoord(X1,Y1); + UpdateLineColor; + UpdateLineWidth; + UpdateLineStyle; + write(Format('%d %d lineto stroke',[X1,Y1])); + changed; +end; + +procedure TPostscriptPrinterCanvas.Polyline(Points: PPoint; NumPts: Integer); +Var i : LongInt; + Lst: TStringList; + Pt : TPoint; +begin + if (NumPts<=1) or not Assigned(Points) then Exit; + Changing; + RequiredState([csHandleValid, csPenValid]); + + Lst:=TStringList.Create; + try + Pt:=Points[0]; + TranslateCoord(Pt.x,Pt.y); + Write(Format('%d %d moveto',[Pt.x,Pt.y]),Lst); + for i:=1 to NumPts-1 do + begin + Pt:=Points[i]; + TranslateCoord(Pt.x,Pt.y); + SetPosition(Pt.x,Pt.y); + TranslateCoord(Pt.x,Pt.y); + Write(Format('%d %d lineto',[Pt.x,Pt.y]),Lst); + end; + + if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then + begin + UpdateLineColor; + UpdateLineWidth; + UpdateLineStyle; + Write(Lst); + write('stroke'); + end; + finally + Lst.Free; + end; + + MoveToLastPos; + Changed; +end; + +procedure TPostscriptPrinterCanvas.PolyBezier(Points: PPoint; NumPts: Integer; + Filled: boolean; Continuous: boolean); +Var i : Integer; + St : String; + Pt : TPoint; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + if (NumPts>=4) then + begin + ClearBuffer; + + St:=''; + Pt:=Points[0]; + TranslateCoord(Pt.x,Pt.y); + if Continuous then + WriteB('newpath'); + WriteB(Format('%d %d moveto',[Pt.x,Pt.y])); + for i:=1 to NumPts-1 do + begin + Pt:=Points[i]; + TranslateCoord(Pt.x,Pt.y); + St:=St+Format(' %d %d',[Pt.x,Pt.y]); + end; + WriteB(Format('%s curveto',[St])); + + if Continuous then + writeB('closepath'); + SetBrushFillPattern(True,Filled); + + MoveToLastPos; + end; + Changed; +end; + +//Draw an Rectangle +procedure TPostscriptPrinterCanvas.Rectangle(X1, Y1, X2, Y2: Integer); +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + writecomment(Format('Rectangle(%d,%d,%d,%d)',[x1,y1,x2,y2])); + TranslateCoord(X1,Y1); + TranslateCoord(X2,Y2); + + ClearBuffer; + //Tempo draw rect + WriteB('newpath'); + writeB(Format(' %d %d moveto',[X1,Y1])); + writeB(Format(' %d %d lineto',[X2,Y1])); + writeB(Format(' %d %d lineto',[X2,Y2])); + writeB(Format(' %d %d lineto',[X1,Y2])); + writeB('closepath'); + + SetBrushFillPattern(True,True); + + MoveToLastPos; + + Changed; +end; + +procedure TPostscriptPrinterCanvas.Frame(const ARect: TRect); +Var X1,Y1,X2,Y2 : Integer; +begin + Changing; + RequiredState([csHandleValid, csPenValid]); + + X1:=aRect.Left; + Y1:=aRect.Top; + X2:=aRect.Right; + Y2:=aRect.Bottom; + + TranslateCoord(X1,Y1); + TranslateCoord(X2,Y2); + + ClearBuffer; + //Tempo draw rect + WriteB('newpath'); + writeB(Format(' %d %d moveto',[X1,Y1])); + writeB(Format(' %d %d lineto',[X2,Y1])); + writeB(Format(' %d %d lineto',[X2,Y2])); + writeB(Format(' %d %d lineto',[X1,Y2])); + writeB('closepath'); + + SetBrushFillPattern(True,False); + + MoveToLastPos; + + Changed; +end; + +procedure TPostscriptPrinterCanvas.FrameRect(const ARect: TRect); +Var CL : TColor; +begin + Changing; + RequiredState([csHandleValid, csBrushValid]); + + CL:=Pen.Color; + try + Pen.Color:=Brush.Color; + Frame(aRect); + finally + Pen.Color:=CL; + end; + + Changed; +end; + +//Fill an Rectangular region +procedure TPostscriptPrinterCanvas.FillRect(const ARect: TRect); +Var X1,Y1,X2,Y2 : Integer; +begin + Changing; + RequiredState([csHandleValid, csBrushValid]); + + X1:=ARect.Left; + Y1:=ARect.Top; + X2:=ARect.Right; + Y2:=ARect.Bottom; + + Writecomment(Format('FillRect(%d,%d,%d,%d)',[x1,y1,x2,y2])); + TranslateCoord(X1,Y1); + TranslateCoord(X2,Y2); + + ClearBuffer; + + WriteB('newpath'); + WriteB(Format(' %d %d moveto',[X1,Y1])); + WriteB(Format(' %d %d lineto',[X2,Y1])); + WriteB(Format(' %d %d lineto',[X2,Y2])); + WriteB(Format(' %d %d lineto',[X1,Y2])); + WriteB('closepath'); + + SetBrushFillPattern(False,True); + + MoveToLastPos; + + Changed; +end; + +procedure TPostscriptPrinterCanvas.RoundRect(X1, Y1, X2, Y2: Integer; RX, + RY: Integer); +Var ellipsePath : string; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + X1:=Min(X1,X2); + X2:=Max(X1,X2); + Y1:=Min(Y1,Y2); + Y2:=Max(Y1,Y2); + + writecomment(Format('RoundRect(%d,%d,%d,%d,%d,%d)',[x1,y1,x2,y2,Rx,Ry])); + TranslateCoord(X1,Y1); + TranslateCoord(X2,Y2); + + ClearBuffer; + + {Note: arcto command draws a line from current point to beginning of arc + save current matrix, translate to center of ellipse, scale by rx ry, and draw + a circle of unit radius in counterclockwise dir, return to original matrix + arguments are (cx, cy, rx, ry, startAngle, endAngle)} + ellipsePath:='matrix currentmatrix %d %d translate %d %d scale 0 0 1 %d %d arc setmatrix'; + + {choice between newpath and moveto beginning of arc + go with newpath for precision, does this violate any assumptions in code??? + write(format('%d %d moveto',[x1+rx, y1]),Lst # this also works} + WriteB('newpath'); + WriteB(Format(ellipsePath,[x1+rx,y1-ry,rx,ry,90,180])); + WriteB(Format(ellipsePath,[x1+rx,y2+ry,rx,ry,180,270])); + WriteB(Format(ellipsePath,[x2-rx,y2+ry,rx,ry,270,360])); + WriteB(Format(ellipsePath,[x2-rx,y1-ry,rx,ry,0,90])); + WriteB('closepath'); + + SetBrushFillPattern(True,True); + + MoveToLastPos; + Changed; +end; + +procedure TPostscriptPrinterCanvas.Polygon(Points: PPoint; NumPts: Integer; + Winding: boolean); +Var i : LongInt; + Pt : TPoint; +begin + if (NumPts<=1) or not Assigned(Points) then Exit; + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + ClearBuffer; + + Pt:=Points[0]; + TranslateCoord(Pt.x,Pt.y); + WriteB('newpath'); + WriteB(Format('%d %d moveto',[Pt.x,Pt.y])); + for i:=1 to NumPts-1 do + begin + Pt:=Points[i]; + TranslateCoord(Pt.x,Pt.y); + WriteB(Format('%d %d lineto',[Pt.x,Pt.y])); + end; + WriteB('closepath'); + + SetBrushFillPattern(True,True); + + MoveToLastPos; + Changed; +end; + +//Draw an Ellipse +procedure TPostscriptPrinterCanvas.Ellipse(x1, y1, x2, y2: Integer); +var xScale : Real; + yScale : Real; + cX, cY : Real; + rX,Ry : Real; + Code : string; + stAng : Integer; + ang : Integer; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + writecomment(Format('Ellipse(%d,%d,%d,%d)',[x1,y1,x2,y2])); + TranslateCoord(X1,Y1); + TranslateCoord(X2,Y2); + + //Init + StAng:=0; + Ang:=360; + + //calculate centre of ellipse + cx:=(x1+x2)/2; + cy:=(y1+y2)/2; + rx:=(x2-x1)/2; + ry:=(y2-y1)/2; + + //calculate semi-minor and semi-major axes of ellipse + xScale:=Abs((x2-x1)/2.0); + yScale:=Abs((y2-y1)/2.0); + + Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %d %d %s setmatrix', + [cX,cY,xScale,yScale,StAng,Ang,'arc']); + + ClearBuffer; + WriteB(Format('%.3f %.3f moveto',[cX,cY])); //move to center of circle + WriteB(Code); + SetBrushFillPattern(False,True); + + //move current point to start of arc, note negative + //angle because y increases down + ClearBuffer; + WriteB(Format('%.3f %.3f moveto',[cX+(rX*Cos(StAng*-1)),cY+(rY*Sin(StAng*-1))])); + WriteB(Code); + SetBrushFillPattern(True,False); + + MoveToLastPos; + Changed; +end; + +//Draw an Arc +procedure TPostscriptPrinterCanvas.Arc(x, y, width, height, angle1, + angle2: Integer); +var xScale : Real; + yScale : Real; + cX, cY : Real; + rX,Ry : Real; + Code : string; + ang : string; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + writecomment(Format('Arc(%d,%d,%d,%d,%d,%d)',[x,y,Width,Height,Angle1,Angle2])); + TranslateCoord(X,Y); + + //calculate centre of ellipse + cx:=x; + cy:=y; + rx:=Width; + ry:=Height; + + if Angle2>=0 then + Ang:='arc' + else + Ang:='arcn'; + + //calculate semi-minor and semi-major axes of ellipse + xScale:=Abs(rx); + yScale:=Abs(ry); + + Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', + [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); + + + if (Pen.Color<>clNone) and ((Pen.Color<>Brush.Color) or (Brush.Style<>bsSolid)) then + begin + UpdateLineColor; + UpdateLineWidth; + UpdateLineStyle; + + //move current point to start of arc, note negative + //angle because y increases down + write(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + Write(Code); + write('stroke'); + end; + + MoveToLastPos; + Changed; +end; + +procedure TPostscriptPrinterCanvas.RadialPie(x, y, width, height, angle1, + angle2: Integer); +var xScale : Real; + yScale : Real; + cX, cY : Real; + rX,Ry : Real; + Code : string; + ang : string; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + writecomment(Format('RadialPie(%d,%d,%d,%d,%d,%d)',[x,y,Width,Height,Angle1,Angle2])); + TranslateCoord(X,Y); + + //calculate centre of ellipse + cx:=x; + cy:=y; + rx:=Width; + ry:=Height; + + if Angle2>=0 then + Ang:='arc' + else + Ang:='arcn'; + + //calculate semi-minor and semi-major axes of ellipse + xScale:=Abs(rx); + yScale:=Abs(ry); + + Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', + [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); + + //move current point to start of arc, note negative + //angle because y increases down + ClearBuffer; + writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + WriteB(Code); + writeB(Format('%d %d lineto',[X,Y])); + writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + SetBrushFillPattern(False,True); + + //move current point to start of arc, note negative + //angle because y increases down + ClearBuffer; + writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + WriteB(Code); + writeB(Format('%d %d lineto',[X,Y])); + writeB(Format('%.3f %.3f lineto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + SetBrushFillPattern(True,False); + + MoveToLastPos; + Changed; +end; + +//Out the text at the X,Y coord. Set the font +procedure TPostscriptPrinterCanvas.TextOut(X, Y: Integer; const Text: String); +Var PenUnder : Real; + PosUnder : Integer; +begin + TranslateCoord(X,Y); + UpdateFont; + + if fsUnderline in Font.Style then + begin + PenUnder:=0.5; + if fsBold in Font.Style then + PenUnder:=1.0; + PosUnder:=(Abs(Round(Font.Size/3))*-1)+2; + + write(Format('%.3f %d underline_on',[PenUnder,PosUnder])); + write(Format('(%s) %d %d TEXT',[MapedString(Text),X,Y])); + write('underline_off'); + end + else + begin + write(Format('%d %d moveto',[X,Y])); + write(Format('(%s) show',[MapedString(Text)])); + end; + + MoveToLastPos; +end; + +function TPostscriptPrinterCanvas.TextExtent(const Text: string): TSize; +begin + Result.cX := 0; + Result.cY := 0; + if Text='' then Exit; + RequiredState([csHandleValid, csFontValid]); + GetTextExtentPoint(0, PChar(Text), Length(Text), Result); +end; + +//Draw an Picture +procedure TPostscriptPrinterCanvas.Draw(X, Y: Integer; SrcGraphic: TGraphic); +begin + if not Assigned(SrcGraphic) then exit; + StretchDraw(Rect(X,Y,X+SrcGraphic.Width,Y+SrcGraphic.Height),SrcGraphic); +end; + +//Draw an picture with scale size +procedure TPostscriptPrinterCanvas.StretchDraw(const DestRect: TRect; SrcGraphic: TGraphic); +var X,Y,X1,Y1 : Integer; + DrawWidth : Integer; + DrawHeight: Integer; + ImgWidth : Integer; + ImgHeight : Integer; + +begin + if not Assigned(SrcGraphic) then exit; + Changing; + RequiredState([csHandleValid]); + + X:=DestRect.Left; + Y:=DestRect.Top; + X1:=DestRect.Right; + Y1:=DestRect.Bottom; + + TranslateCoord(X,Y); + TransLateCoord(X1,Y1); + + ImgWidth:=SrcGraphic.Width; + ImgHeight:=SrcGraphic.Height; + + DrawWidth:=X1-X; + DrawHeight:=Y-Y1; + ClearBuffer; + + WriteB('gsave'); + writeB(Format('%d %d translate',[X,Y-DrawHeight])); + WriteB(Format('%d %d scale',[DrawWidth,DrawHeight])); + WriteB(Format('/scanline %d 3 mul string def',[ImgWidth])); + WriteB(Format('%d %d %d',[ImgWidth,ImgHeight,8])); + WriteB(Format('[%d %d %d %d %d %d]',[ImgWidth,0,0,-ImgHeight,0,ImgHeight])); + WriteB('{ currentfile scanline readhexstring pop } false 3'); + WriteB('colorimage'); + + GetRGBImage(SrcGraphic,fBuffer); + WriteB('% end of image data'); + WriteB('grestore'); + + Write(fBuffer); + + Changed; +end; + +procedure TPostscriptPrinterCanvas.Arc(x, y, width, height, SX, SY, EX, + EY: Integer); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.Chord(x, y, width, height, angle1,angle2: Integer); +var xScale : Real; + yScale : Real; + cX, cY : Real; + rX,Ry : Real; + Code : string; + ang : string; +begin + Changing; + RequiredState([csHandleValid, csBrushValid, csPenValid]); + + writecomment(Format('Chord(%d,%d,%d,%d,%d,%d)',[x,y,Width,Height,Angle1,Angle2])); + TranslateCoord(X,Y); + + //calculate centre of ellipse + cx:=x; + cy:=y; + rx:=Width; + ry:=Height; + + if Angle2>=0 then + Ang:='arc' + else + Ang:='arcn'; + + //calculate semi-minor and semi-major axes of ellipse + xScale:=Abs(rx); + yScale:=Abs(ry); + + Code:=Format('matrix currentmatrix %.3f %.3f translate %.3f %.3f scale 0 0 1 %.3f %.3f %s setmatrix', + [cX,cY,xScale,yScale,Angle1/16,Angle2/16,ang]); + + //move current point to start of arc, note negative + //angle because y increases down.ClosePath for draw chord + ClearBuffer; + writeB('newpath'); + writeB(Format('%.3f %.3f moveto',[cX+(rX*Cos((Angle1/16)*-1)),cY+(rY*Sin((Angle1/16)*-1))])); + WriteB(Code); + writeB('closepath'); + SetBrushFillPattern(True,True); + + MoveToLastPos; + Changed; +end; + +procedure TPostscriptPrinterCanvas.Chord(x, y, width, height, SX, SY, EX, EY: Integer); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.Frame3d(var ARect: TRect; + const FrameWidth: integer; const Style: TGraphicsBevelCut); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.RadialPie(x, y, width, height, sx, sy, ex, + ey: Integer); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.Pie(EllipseX1, EllipseY1, EllipseX2, + EllipseY2, StartX, StartY, EndX, EndY: Integer); +begin +//Not implemented +end; + +procedure TPostscriptPrinterCanvas.TextRect(ARect: TRect; X, Y: integer; + const Text: string; const Style: TTextStyle); +begin + //Not implemented +end; + + +procedure TPostscriptPrinterCanvas.FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.CopyRect(const Dest: TRect; + SrcCanvas: TCanvas; const Source: TRect); +begin + //Not implemented +end; + +procedure TPostscriptPrinterCanvas.BrushCopy(Dest: TRect; + InternalImages: TBitmap; Src: TRect; TransparentColor: TColor); +begin + //Not implemented +end; + +{ TPostscriptCanvas } + +constructor TPostscriptCanvas.Create; +begin + Inherited Create(nil); +end; + +procedure TPostscriptCanvas.BeginDoc; +begin + inherited BeginDoc; +end; + +procedure TPostscriptCanvas.EndDoc; +begin + inherited EndDoc; +end; + +procedure TPostscriptCanvas.NewPage; +begin + inherited NewPage; +end; + +end. +