mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-14 05:41:17 +02:00
1561 lines
45 KiB
ObjectPascal
1561 lines
45 KiB
ObjectPascal
{
|
|
/***************************************************************************
|
|
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;
|
|
|
|
//if not FPImage then draw ab Rectangle because other wise PostScript
|
|
//interpreter wait infinite some RGB datas
|
|
{$ifndef DisableFPImage}
|
|
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');
|
|
|
|
{$else}
|
|
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');
|
|
{$endif}
|
|
|
|
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.
|
|
|