diff --git a/designer/designer.pp b/designer/designer.pp index 592c533c46..ffc0d02146 100644 --- a/designer/designer.pp +++ b/designer/designer.pp @@ -235,8 +235,10 @@ type function NonVisualComponentLeftTop(AComponent: TComponent): TPoint; function NonVisualComponentAtPos(x,y: integer): TComponent; - function WinControlAtPos(x,y: integer; UseFormAsDefault: boolean): TWinControl; - function ControlAtPos(x,y: integer; UseFormAsDefault: boolean): TControl; + function WinControlAtPos(x,y: integer; UseFormAsDefault, + IgnoreHidden: boolean): TWinControl; + function ControlAtPos(x,y: integer; UseFormAsDefault, + IgnoreHidden: boolean): TControl; function GetDesignedComponent(AComponent: TComponent): TComponent; function GetComponentEditorForSelection: TBaseComponentEditor; function GetShiftState: TShiftState; override; @@ -1047,7 +1049,7 @@ Begin if NonVisualComp<>nil then MouseDownComponent:=NonVisualComp; if MouseDownComponent=nil then begin - MouseDownComponent:=ControlAtPos(MouseDownPos.X,MouseDownPos.Y,true); + MouseDownComponent:=ControlAtPos(MouseDownPos.X,MouseDownPos.Y,true,true); if MouseDownComponent=nil then exit; end; MouseDownSender:=Sender; @@ -1211,7 +1213,7 @@ var if MouseDownComponent is TWinControl then NewParentControl:=TWinControl(MouseDownComponent) else - NewParentControl:=WinControlAtPos(MouseDownPos.X,MouseUpPos.X,true); + NewParentControl:=WinControlAtPos(MouseDownPos.X,MouseUpPos.X,true,true); while (NewParentControl<>nil) and ((not (csAcceptsControls in NewParentControl.ControlStyle)) or ((NewParentControl.Owner<>FLookupRoot) @@ -2215,8 +2217,8 @@ begin Result:=nil; end; -function TDesigner.WinControlAtPos(x, y: integer; UseFormAsDefault: boolean - ): TWinControl; +function TDesigner.WinControlAtPos(x, y: integer; UseFormAsDefault, + IgnoreHidden: boolean): TWinControl; var i: integer; WinControlBounds: TRect; begin @@ -2224,19 +2226,21 @@ begin Result:=TWinControl(FLookupRoot.Components[i]); if (Result is TWinControl) then begin with Result do begin - WinControlBounds:=GetParentFormRelativeBounds(Result); - if (WinControlBounds.Left<=x) and (WinControlBounds.Top<=y) - and (WinControlBounds.Right>x) - and (WinControlBounds.Bottom>y) then - exit; + if (not IgnoreHidden) or ControlIsInDesignerVisible(Result) then begin + WinControlBounds:=GetParentFormRelativeBounds(Result); + if (WinControlBounds.Left<=x) and (WinControlBounds.Top<=y) + and (WinControlBounds.Right>x) + and (WinControlBounds.Bottom>y) then + exit; + end; end; end; end; Result:=Form; end; -function TDesigner.ControlAtPos(x, y: integer; UseFormAsDefault: boolean - ): TControl; +function TDesigner.ControlAtPos(x, y: integer; UseFormAsDefault, + IgnoreHidden: boolean): TControl; var i: integer; ControlBounds: TRect; begin @@ -2244,11 +2248,13 @@ begin Result:=TControl(FLookupRoot.Components[i]); if (Result is TControl) then begin with Result do begin - ControlBounds:=GetParentFormRelativeBounds(Result); - if (ControlBounds.Left<=x) and (ControlBounds.Top<=y) - and (ControlBounds.Right>x) - and (ControlBounds.Bottom>y) then - exit; + if (not IgnoreHidden) or ControlIsInDesignerVisible(Result) then begin + ControlBounds:=GetParentFormRelativeBounds(Result); + if (ControlBounds.Left<=x) and (ControlBounds.Top<=y) + and (ControlBounds.Right>x) + and (ControlBounds.Bottom>y) then + exit; + end; end; end; end; diff --git a/lcl/postscriptprinter.pas b/lcl/postscriptprinter.pas index 26fd06b75d..7910ef7d07 100644 --- a/lcl/postscriptprinter.pas +++ b/lcl/postscriptprinter.pas @@ -1,10 +1,8 @@ { /*************************************************************************** - postscriptprinter.pas - --------------------- - - Printer object - Initial Revision : Mon Nov 05 2002 + PostscriptCanvas.pas + ------------ + PostScript Printer Canvas object ***************************************************************************/ @@ -20,1041 +18,1533 @@ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * ***************************************************************************** - - Author: Tony Maro + + 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 PostScriptPrinter; +unit PostscriptPrinter; {$mode objfpc}{$H+} interface uses - Classes, SysUtils, LCLProc, GraphType, Graphics, GraphMath, LCLIntf, Forms; + Classes, SysUtils, Math, Graphics, Forms, GraphMath, GraphType, + {$IFDEF DisableFPImage} + FPImage, IntfGraphics, + {$ENDIF} + Printers, LCLType, LCLIntf; - // uses lcllinux or winapi for RGB conversions and FORMS for application object +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(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; - { - Defines a special canvas type object and override drawing methods to make - the postscript code... - - Defines a TPSPattern object that handles creation of patterns to be used - in fills and paints - - TPostScript manages a list of patterns and inserts the definitions into the - postscript code and manages when they are changed - - A pattern definition can access pattern definitions within the same - postscript object, as long as the TPSPattern object pointer is placed into - the canvas pen/brush at the time the new pattern is made - } - -type - TPostScript = class; - - TPSPaintType = (ptColored, ptUncolored); - TPSTileType = (ttConstant, ttNoDistortion, ttFast); - TPostScriptCanvas = class; // forward reference - - { Remember, modifying a pattern affects that pattern for the ENTIRE document! } - TPSPattern = class(TObject) - private - FOldName: String; - FOnChange: TNotifyEvent; - FBBox: TRect; - FCanvas: TPostScriptCanvas; - FName: String; - FPaintType: TPSPaintType; - FPostScript: TStringList; - FTilingType: TPSTileType; - FXStep: Real; - FYStep: Real; - function GetpostScript: TStringList; - procedure SetBBox(const AValue: TRect); - procedure SetName(const AValue: String); - procedure SetPaintType(const AValue: TPSPaintType); - procedure SetTilingType(const AValue: TPSTileType); - procedure SetXStep(const AValue: Real); - procedure SetYStep(const AValue: Real); - protected - public - constructor Create; - destructor Destroy; override; - procedure Changed; - property BBox: TRect read FBBox write SetBBox; - property PaintType: TPSPaintType read FPaintType write SetPaintType; - property TilingType: TPSTileType read FTilingType write SetTilingType; - property XStep: Real read FXStep write SetXStep; - property YStep: Real read FYStep write SetYStep; - property Name: String read FName write SetName; - property Canvas: TPostScriptCanvas read FCanvas; - property GetPS: TStringList read GetPostscript; - property OldName: string read FOldName write FOldName; // used when notifying that name Changed - property OnChange: TNotifyEvent read FOnChange write FOnChange; - end; - PPSPattern = ^TPSPattern; // used for array - - { basic pen object - modify later for better splitting of brush object } - TPSObject = class(TObject) - private - FOnChange: TNotifyEvent; - protected - procedure Changed; dynamic; - Procedure Lock; - Procedure UnLock; - public - property OnChange: TNotifyEvent read FOnChange write FOnChange; - end; - - { Pen and brush object both right now...} - TPSPen = class(TPSObject) - private - FColor: TColor; - FPattern: TPSPattern; - FWidth: Real; - procedure SetPattern(const AValue: TPSPattern); - protected - procedure SetColor(Value : TColor); - procedure Setwidth(value : Real); - public - constructor Create; - destructor Destroy; override; - procedure Assign(Source: TPSPen); - property Color: TColor read FColor write SetColor; - property Pattern: TPSPattern read FPattern write SetPattern; - property Width: Real read FWidth write SetWidth; - function AsString: String; - end; - - - { Custom canvas-like object that handles postscript code } - TPostScriptCanvas = class(TObject) - private - FBrush: TPSPen; - FFontFace: String; - FFontSize: Integer; - FHeight: Integer; - FLineSpacing: Integer; - FColor: TColor; // canvas color - implement later - FPen: TPSPen; - LastX: Integer; - LastY: Integer; - FPostScript: TStringList; - function GetColor: TColor; - procedure SetBrush(const AValue: TPSPen); - procedure SetColor(const AValue: TColor); - procedure SetFontFace(const AValue: String); - procedure SetFontSize(const AValue: Integer); - procedure SetPen(const AValue: TPSPen); - function TranslateY(Ycoord: Integer): Integer; // Y axis is backwards in postscript - procedure AddFill; - procedure ResetPos; // reset back to last moveto location - procedure PenChanged(Sender: TObject); - public - MPostScript: TPostScript; - constructor Create(APostScript: TPostScript); - destructor Destroy; override; - procedure Clear; - property PostScript: TStringList read FPostScript write FPostScript; - property FontFace: String read FFontFace write SetFontFace; - property FontSize: Integer read FFontSize write SetFontSize; - property LineSpacing: Integer read FLineSpacing write FLineSpacing; - Procedure MoveTo(X1,Y1 : Integer); - Procedure LineTo(X1,Y1 : Integer); - Procedure Line(X1,Y1,X2,Y2 : Integer); - Procedure Rectangle(X1,Y1,X2,Y2 : Integer); - Procedure Rectangle(const Rect: TRect); - procedure Polyline(Points: PPoint; NumPts: Integer); - procedure Ellipse(x1, y1, x2, y2: Integer); - procedure Ellipse(const Rect: TRect); - procedure Pie(x,y,width,mheight,angle1,angle2 : Integer); - //procedure Pie(x,y,width,height,SX,SY,EX,EY : Integer); - procedure Writeln(const AString: String); - procedure TextOut(X,Y: Integer; const Text: String); - //procedure Chord(x,y,width,height,angle1,angle2 : Integer); - //procedure Chord(x,y,width,height,SX,SY,EX,EY : Integer); - //procedure PolyBezier(Points: PPoint; NumPts: Integer; - // Filled: boolean{$IFNDEF VER1_0} = False{$ENDIF}; - // Continuous: boolean{$IFNDEF VER1_0} = False{$ENDIF}); - //procedure PolyBezier(const Points: array of TPoint; - // Filled: boolean{$IFNDEF VER1_0} = False{$ENDIF}; - // Continuous: boolean{$IFNDEF VER1_0} = False{$ENDIF}); - //procedure PolyBezier(const Points: array of TPoint); - //procedure Polygon(const Points: array of TPoint; - // Winding: Boolean{$IFNDEF VER1_0} = False{$ENDIF}; - // StartIndex: Integer{$IFNDEF VER1_0} = 0{$ENDIF}; - // NumPts: Integer {$IFNDEF VER1_0} = -1{$ENDIF}); - //procedure Polygon(Points: PPoint; NumPts: Integer; - // Winding: boolean{$IFNDEF VER1_0} = False{$ENDIF}); - //Procedure Polygon(const Points: array of TPoint); - //Procedure FillRect(const Rect : TRect); - //procedure FloodFill(X, Y: Integer; FillColor: TColor; FillStyle: TFillStyle); - //Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer); - //Procedure RoundRect(const Rect : TRect; RX,RY : Integer); - property Height: Integer read FHeight write FHeight; // set so we can translate Y coords - property Color: TColor read GetColor write SetColor; - property Pen: TPSPen read FPen write SetPen; - property Brush: TPSPen read FBrush write SetBrush; - end; - - { Encapsulates ALL the postscript and uses the TPostScriptCanvas object for a single page } - TPostScript = class(TObject) - private - FCanvas: TPostScriptCanvas; - FHeight: Integer; - FLineSpacing: Integer; - FPageNumber: Integer; - FTitle: String; - FWidth: Integer; - FDocument: TStringList; - Patterns: PPSPattern; // array of pointers to pattern objects - NumPatterns: Integer; // number of patterns in array - procedure SetHeight(const AValue: Integer); - procedure SetLineSpacing(const AValue: Integer); - procedure SetTitle(const AValue: String); - procedure SetWidth(const AValue: Integer); - procedure GrabCanvas; - procedure UpdateBoundingBox; - procedure PatternChanged(Sender: TObject); - procedure InsertPattern(APattern: TPSPattern); // adds the pattern to the postscript - procedure RemovePattern(APattern: TPSPattern); // remove the pattern from the postscript - public - constructor Create; - destructor Destroy; override; - procedure AddPattern(APSPattern: TPSPattern); - function FindPattern(AName: String): TPSPattern; - function DelPattern(AName: String): Boolean; - function NewPattern(AName: String): TPSPattern; - property Canvas: TPostScriptCanvas read FCanvas; - property Height: Integer read FHeight write SetHeight; - property Width: Integer read FWidth write SetWidth; - property Document: TStringList read FDocument; - property PageNumber: Integer read FPageNumber; - property Title: String read FTitle write SetTitle; - property LineSpacing: Integer read FLineSpacing write SetLineSpacing; - procedure BeginDoc; - procedure NewPage; - procedure EndDoc; - end; - - implementation +Const + cBrushStyle : Array[bsSolid..bsDiagCross] of String = ('bsSolid','bsClear','bsHorizontal', + 'bsVertical','bsFDiagonal', + 'bsBDiagonal','bsCross','bsDiagCross'); +{ TPostscriptPrinterCanvas } - -{ TPostScriptCanvas ----------------------------------------------------------} - -{ Y coords in postscript are backwards... } -function TPostScriptCanvas.TranslateY(Ycoord: Integer): Integer; +//Write an instruction in the header of document +procedure TPostscriptPrinterCanvas.WriteHeader(St: String); begin - Result := FHeight - Ycoord; + fHeader.Add(St); end; -{ Adds a fill finishing line to any path we desire to fill } -procedure TPostScriptCanvas.AddFill; +//Write an instruction in the document +procedure TPostscriptPrinterCanvas.Write(St: String; Lst : TStringList=Nil); begin - FPostScript.Add('gsave '+FBrush.AsString+' fill grestore'); + If not Assigned(Lst) then + Lst:=fDocument; + + Lst.Add(St); end; -{ Sets the current font face} -procedure TPostScriptCanvas.SetFontFace(const AValue: String); -var - MyString: String; +//Write data in fBuffer +procedure TPostscriptPrinterCanvas.WriteB(St: string); begin - if FFontFace=AValue then exit; - if pos(' ',AValue) > 0 then - FFontFace := '('+AValue+')' - else FFontFace:=AValue; - - MyString := '/'+FFontFace+' '+IntToStr(FFontSize)+' selectfont'; - // set the pen info - - FPostScript.Add(MyString); + Write(St,fBuffer); end; - -function TPostScriptCanvas.GetColor: TColor; +//Clear all data of Buffer +procedure TPostscriptPrinterCanvas.ClearBuffer; begin - Result := FColor; + fBuffer.Clear; end; -procedure TPostScriptCanvas.SetBrush(const AValue: TPSPen); +//Write all Lst.Strings in document +procedure TPostscriptPrinterCanvas.Write(Lst: TStringList); begin - if FBrush=AValue then exit; - FBrush:=AValue; + fDocument.AddStrings(Lst); end; -procedure TPostScriptCanvas.SetColor(const AValue: TColor); +//Write an comment in the document +procedure TPostscriptPrinterCanvas.WriteComment(St: string); begin - FColor := AValue; + fDocument.Add('%'+St); end; -procedure TPostScriptCanvas.SetFontSize(const AValue: Integer); +//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 - if FFontSize=AValue then exit; - FFontSize:=AValue; - FPostScript.Add('/'+FFontFace+' '+IntToStr(AValue)+' selectfont'); + Y:=PageHeight-TopMarging-Y; + X:=X+LeftMarging; end; -procedure TPostScriptCanvas.SetPen(const AValue: TPSPen); +//Save the last position +procedure TPostscriptPrinterCanvas.SetPosition(X, Y: Integer); begin - // change to ASSIGN method? - if FPen=AValue then exit; - FPen:=AValue; + fPenPos:= Point(X,Y); + SetInternalPenPos(Point(X,Y)); end; - -{ Return to last moveto location } -procedure TPostScriptCanvas.ResetPos; +//Init the width of line +procedure TPostscriptPrinterCanvas.UpdateLineWidth; begin - // any routines that you specify a start location when calling such as - // textout, ellipse, etc. should not affect the default cursor location. - - FPostScript.Add(IntToStr(LastX)+' '+IntToStr(TranslateY(LastY))+' moveto'); -end; - -{ This is called when drawing pen is Changed but NOT when brush changes } -procedure TPostScriptCanvas.PenChanged(Sender: TObject); -begin - if FPostScript[FPostScript.Count-2] = '%%PEN' then begin - // last operation was a pen, so delete it - FPostScript.Delete(FPostScript.Count-1); - FPostScript.Delete(FPostScript.Count-1); - end; - FPostScript.Add('%%PEN'); - FPostScript.Add(FPen.AsString); -end; - -constructor TPostScriptCanvas.Create(APostScript: TPostScript); -begin - MPostScript := APostScript; - - FPostScript := TStringList.Create; - FHeight := 792; // length of page in points at 72 ppi - - // Choose a standard font in case the user doesn't - FFontFace := 'AvantGarde-Book'; - SetFontSize(10); - - if Assigned(MPostScript) then begin - FLineSpacing := MPostScript.LineSpacing; - end; - - FPen := TPSPen.Create; - FPen.Width := 1; - FPen.Color := 0; - FPen.OnChange := @PenChanged; - - FBrush := TPSPen.Create; - FBrush.Width := 1; - FBrush.Color := -1; - // don't notify us that the brush Changed... -end; - -destructor TPostScriptCanvas.Destroy; -begin - FPostScript.Free; - FPen.Free; - FBrush.Free; - inherited Destroy; -end; - -{ Clear the postscript canvas AND the graphic canvas (Add later) } -procedure TPostScriptCanvas.clear; -begin - // clear the canvas for the next page - FPostScript.Clear; - // Choose a standard font in case the user doesn't - FPostScript.Add('/AvantGarde-Book findfont'); - FPostScript.Add('10 scalefont'); - FPostScript.Add('setfont'); - - // also clear the canvas itself if we plan to embed the bitmap into - // the postscript - - // also grab the latest canvas height just in case it's Changed - FHeight := 792; - if Assigned(MPostScript) then FHeight := MPostScript.Height; -end; - -{ Move draw location } -procedure TPostScriptCanvas.MoveTo(X1, Y1: Integer); -var - Y: Integer; -begin - Y := TranslateY(Y1); - FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' moveto'); - LastX := X1; - LastY := Y1; -end; - -{ Draw a line from current location to these coords } -procedure TPostScriptCanvas.LineTo(X1, Y1: Integer); -var - Y: Integer; -begin - Y := TranslateY(Y1); - FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y)+' lineto'); - LastX := X1; - LastY := Y1; -end; - -procedure TPostScriptCanvas.Line(X1, Y1, X2, Y2: Integer); -var - Y12, Y22: Integer; -begin - Y12 := TranslateY(Y1); - Y22 := TranslateY(Y2); - - FPostScript.Add('newpath '+IntToStr(X1)+' '+IntToStr(Y12)+' moveto '+ - IntToStr(X2)+' '+IntToStr(Y22)+' lineto closepath stroke'); - - // go back to last moveto position - ResetPos; -end; - -procedure TPostScriptCanvas.Rectangle(X1, Y1, X2, Y2: Integer); -var - Y12, Y22: Integer; -begin - Y12 := TranslateY(Y1); - Y22 := TranslateY(Y2); - - FPostScript.Add('stroke newpath'); - FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y12)+' moveto'); - FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y12)+' lineto'); - FPostScript.Add(IntToStr(X2)+' '+IntToStr(Y22)+' lineto'); - FPostScript.Add(IntToStr(X1)+' '+IntToStr(Y22)+' lineto'); - FPostScript.Add('closepath'); - if FBrush.Color > -1 then AddFill; - FPostScript.Add('stroke'); - ResetPos; -end; - -{ Draw a rectangle } -procedure TPostScriptCanvas.Rectangle(const Rect: TRect); -var - Y12, Y22: Integer; -begin - Y12 := TranslateY(Rect.Top); - Y22 := TranslateY(Rect.Bottom); - - FPostScript.Add('stroke newpath'); - FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y12)+' moveto'); - FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y12)+' lineto'); - FPostScript.Add(IntToStr(Rect.Right)+' '+IntToStr(Y22)+' lineto'); - FPostScript.Add(IntToStr(Rect.Left)+' '+IntToStr(Y22)+' lineto'); - FPostScript.Add('closepath'); - if FBrush.Color > -1 then AddFill; - FPostScript.Add('stroke'); - ResetPos; -end; - -{ Draw a series of lines } -procedure TPostScriptCanvas.Polyline(Points: PPoint; NumPts: Integer); -var - i : Longint; -begin - If (NumPts <= 1) or (Points = nil) then exit; - - MoveTo(Points[0].X, Points[0].Y); - For i := 1 to NumPts - 1 do - LineTo(Points[i].X, Points[i].Y); - - ResetPos; -end; - -{ This was a pain to figure out... } -procedure TPostScriptCanvas.Ellipse(x1, y1, x2, y2: Integer); -var - radius: Integer; - YRatio: Real; - centerX, centerY: Integer; -begin - // set radius to half the width - radius := (x2 - x1) div 2; - - //calculate ratios - if radius <1 then exit; // do nothing - YRatio := real(Y2 - Y1) / (X2-X1); - - // find center - CenterX := ((X2 - X1) div 2) + X1; - CenterY := ((Y2 - Y1) div 2) + Y1; - - FPostScript.Add('newpath '+IntToStr(CenterX)+' '+IntToStr(TranslateY(CenterY))+' translate'); - - // move to edge - FPostScript.Add(IntToStr(radius)+' 0 moveto'); - - // now draw it - FPostScript.Add('gsave 1 '+format('%.3f',[YRatio])+' scale'); - FPostScript.Add('0 0 '+IntToStr(radius)+' 0 360 arc'); - if FBrush.Color > -1 then AddFill; - - // reset scale for drawing line thickness so it doesn't warp - YRatio := 1 / YRatio; - FPostScript.Add('1 '+format('%.2f',[YRatio])+' scale stroke grestore'); - - // move origin back - FPostScript.Add(IntToStr(-CenterX)+' '+IntToStr(-TranslateY(CenterY))+' translate closepath stroke'); - ResetPos; -end; - -procedure TPostScriptCanvas.Ellipse(const Rect: TRect); -begin - self.Ellipse(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom); -end; - -procedure TPostScriptCanvas.Pie(x, y, width, mheight, angle1, angle2: Integer); -begin - // set zero at center - FPostScript.Add('newpath '+IntToStr(X)+' '+IntToStr(TranslateY(Y))+' translate'); - - // scale it - FPostScript.Add('gsave '+IntToStr(width)+' '+IntToStr(mheight)+' scale'); - //FPostScript.Add('gsave 1 1 scale'); - - // draw line to edge - FPostScript.Add('0 0 moveto'); - FPostScript.Add('0 0 1 '+IntToStr(angle1)+' '+IntToStr(angle2)+' arc closepath'); - - if FBrush.Color > -1 then AddFill; - - // reset scale so we don't change the line thickness - // adding 0.01 to compensate for scaling error - there may be a deeper problem here... - FPostScript.Add(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore'); - - // close out and return origin - FPostScript.Add(IntToStr(-X)+' '+IntToStr(-TranslateY(Y))+' translate closepath stroke'); - - ResetPos; -end; - -{ Writes text with a carriage return } -procedure TPostScriptCanvas.Writeln(const AString: String); -begin - TextOut(LastX, LastY, AString); - LastY := LastY+FFontSize+FLineSpacing; - MoveTo(LastX, LastY); -end; - - -{ Output text, restoring draw location } -procedure TPostScriptCanvas.TextOut(X, Y: Integer; const Text: String); -var - Y1: Integer; -begin - Y1 := TranslateY(Y); - FPostScript.Add(IntToStr(X)+' '+IntToStr(Y1)+' moveto'); - FPostScript.Add('('+Text+') show'); - ResetPos; // move back to last moveto location -end; - -{ TPostScript -------------------------------------------------------------- } - -procedure TPostScript.SetHeight(const AValue: Integer); -begin - if FHeight=AValue then exit; - FHeight:=AValue; - UpdateBoundingBox; - // filter down to the canvas height property - if assigned(FCanvas) then FCanvas.Height := FHeight; -end; - -procedure TPostScript.SetLineSpacing(const AValue: Integer); -begin - if FLineSpacing=AValue then exit; - FLineSpacing:=AValue; - // filter down to the canvas - if assigned(FCanvas) then FCanvas.LineSpacing := AValue; -end; - -procedure TPostScript.SetTitle(const AValue: String); -begin - if FTitle=AValue then exit; - FTitle:=AValue; - - // need to not hard-link these... - FDocument[3] := '%%Title: '+AValue; -end; - -procedure TPostScript.SetWidth(const AValue: Integer); -begin - if FWidth=AValue then exit; - FWidth:=AValue; - UpdateBoundingBox; -end; - -{ Places the current canvas object into the document } -procedure TPostScript.GrabCanvas; -var - I: Integer; -begin - // internally calls this at the end of a page... - - I := 0; - while I < FCanvas.PostScript.Count do begin - Document.Add(FCanvas.PostScript[I]); - I := I+1; - end; -end; - -{ Take our sizes and change the boundingbox line } -procedure TPostScript.UpdateBoundingBox; -begin - // need to not hard-link this to line 1 - FDocument[1] := '%%BoundingBox: 0 0 '+IntToStr(FWidth)+' '+IntToStr(FHeight); -end; - -{ Pattern Changed so update the postscript code } -procedure TPostScript.PatternChanged(Sender: TObject); -begin - // called anytime a pattern changes. Update the postscript code. - // look for and delete the current postscript code for this pattern - // then paste the pattern back into the code before the first page - RemovePattern(Sender As TPSPattern); - InsertPattern(Sender As TPSPattern); -end; - -{ Places a pattern definition into the bottom of the header in postscript } -procedure TPostScript.InsertPattern(APattern: TPSPattern); -var - I, J: Integer; - MyStrings: TStringList; -begin - I := 0; - if FDocument.Count < 1 then begin - // added pattern when no postscript exists - this shouldn't happen - raise exception.create('Pattern inserted with no postscript existing'); - exit; - end; - - for I := 0 to FDocument.count - 1 do begin - if (FDocument[I] = '%%Page: 1 1') then begin - // found it! - // insert into just before that - MyStrings := APattern.GetPS; - for J := 0 to MyStrings.Count - 1 do begin - FDocument.Insert(I-1+J, MyStrings[j]); - end; - exit; - end; - end; -end; - -{Remove a pattern from the postscript code } -procedure TPostScript.RemovePattern(APattern: TPSPattern); -var - I: Integer; - MyName: String; -begin - // this does NOT destroy the object, just removes from postscript - - if APattern.OldName <> '' then MyName := APattern.OldName - else MyName := APattern.name; - - I := 0; - if FDocument.Count < 1 then begin - // added pattern when no postscript exists - this shouldn't happen - raise exception.create('Pattern removed with no postscript existing'); - exit; - end; - - for I := 0 to FDocument.Count - 1 do begin - if (FDocument[I] = '%% PATTERN '+MyName) then begin - // found it... - // delete until gone - while I < FDocument.Count - 1 do begin - // stay within our limites - if (FDocument[I] = '%% END PATTERN '+MyName) then begin - FDocument.Delete(I); - APattern.oldName := ''; - exit; - end else FDocument.Delete(I); - end; - end; - end; -end; - -constructor TPostScript.Create; -begin - inherited create; - - FDocument := TStringList.Create; - - // Set some defaults - FHeight := 792; // 11 inches at 72 dpi - FWidth := 612; // 8 1/2 inches at 72 dpi - FCanvas := TPostScriptCanvas.Create(Self); - - FDocument.Clear; - FDocument.Add('%!PS-Adobe-3.0'); - FDocument.Add('%%BoundingBox: 0 0 612 792'); - FDocument.Add('%%Creator: '+Application.ExeName); - FDocument.Add('%%Title: '+FTitle); - FDocument.Add('%%Pages: (atend)'); - FDocument.Add('%%PageOrder: Ascend'); - - // Choose a standard font in case the user doesn't - FDocument.Add('/AvantGarde-Book findfont'); - FDocument.Add('10 scalefont'); - FDocument.Add('setfont'); - - // start our first page - FPageNumber := 1; - FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice - FDocument.Add('newpath'); - -end; - -destructor TPostScript.Destroy; -var - I: Integer; -begin - - FCanvas.Free; - FDocument.Free; - - // destroy the patterns - if NumPatterns > 0 then begin - for I := 0 to NuMPatterns-1 do begin - Patterns[i].Free; - end; - end; - - // free the pattern pointer memory - Reallocmem(Patterns, 0); - - inherited Destroy; - -end; - -{ Add a pattern to the array } -procedure TPostScript.AddPattern(APSPattern: TPSPattern); -begin - // does NOT create the pattern, just insert in the array of patterns - - NumPatterns := NumPatterns+1; - - reallocmem(Patterns, sizeof(TPSPattern) * NumPatterns); - - Patterns[NumPatterns-1] := APSPattern; -end; - -{ Find a pattern object by it's name } -function TPostScript.FindPattern(AName: String): TPSPattern; -var - I: Integer; -begin - Result := nil; - if NumPatterns < 1 then exit; - for I := 0 to NumPatterns-1 do begin - if Patterns[I].Name = AName then begin - result := Patterns[i]; - exit; - end; - end; -end; - -function TPostScript.DelPattern(AName: String): Boolean; -begin - if AName<>'' then - DebugLn('[TPostScript.DelPattern] ToDo '); - - // can't do that yet... - Result:=false; -end; - -{ Create a new pattern and inserts it into the array for safe keeping } -function TPostScript.NewPattern(AName: String): TPSPattern; -var - MyPattern: TPSPattern; -begin - MyPattern := TPSPattern.Create; - AddPattern(MyPattern); - MyPattern.Name := AName; - MyPattern.OnChange := @PatternChanged; - MyPattern.OldName := ''; - - // Add this to the postscript now... - - InsertPattern(MyPattern); - result := MyPattern; -end; - -{ Start a new document } -procedure TPostScript.BeginDoc; -var - I: Integer; -begin - FCanvas.Clear; - FDocument.Clear; - - // destroy the patterns - if NumPatterns > 0 then + if Pen.Width<>fcPenWidth then begin - for I := 0 to NuMPatterns-1 do - begin - Patterns[i].Free; - Patterns[i]:=nil; + 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; - NumPatterns:=0; + + Write(Format('%s setdash',[St])); + fcPenStyle:=Pen.Style; end; - - // free the pattern pointer memory - Reallocmem(Patterns, 0); - - FDocument.Add('%!PS-Adobe-3.0'); - FDocument.Add('%%BoundingBox: 0 0 612 792'); - FDocument.Add('%%Creator: '+Application.ExeName); - FDocument.Add('%%Title: '+FTitle); - FDocument.Add('%%Pages: (atend)'); - FDocument.Add('%%PageOrder: Ascend'); - - // Choose a standard font in case the user doesn't - FDocument.Add('/AvantGarde-Book findfont'); - FDocument.Add('10 scalefont'); - FDocument.Add('setfont'); - - // start our first page - FPageNumber := 1; - FDocument.Add('%%Page: 1 1'); // I'm still not sure why u put the page # twice - FDocument.Add('newpath'); - - UpdateBoundingBox; end; -{ Copy current page into the postscript and start a new one } -procedure TPostScript.NewPage; +//Init the color for fill +procedure TPostscriptPrinterCanvas.UpdateFillColor; +Var R,G,B : Real; + RGBColor : TColor; begin - // dump the current page into our postscript first - GrabCanvas; + if (Brush.Style=bsSolid) and (Brush.Color<>fcPenColor) then + begin + RGBColor:=ColorToRGB(Brush.Color); - // put end page definition... - FDocument.Add('stroke'); - FDocument.Add('showpage'); - FPageNumber := FPageNumber+1; - // start new page definition... - FDocument.Add('%%Page: '+IntToStr(FPageNumber)+' '+IntToStr(FPageNumber)); - FDocument.Add('newpath'); - FCanvas.Clear; + 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; -{ Finish off the document } -procedure TPostScript.EndDoc; +//Update current font +procedure TPostscriptPrinterCanvas.UpdateFont; +Var R,G,B : Real; + RGBColor : TColor; begin - // dump the canvas into the postscript code - GrabCanvas; + 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); - // Start printing the document after closing out the pages - FDocument.Add('stroke'); - FDocument.Add('showpage'); - FDocument.Add('%%Pages: '+IntToStr(FPageNumber)); + R:=Red(RGBColor)/255; + G:=Green(RGBColor)/255; + B:=Blue(RGBColor)/255; - // okay, the postscript is all ready, so dump it to the text file - // or to the printer - FPageNumber := 0; + 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; -{ TPSObject } - -procedure TPSObject.Changed; +//Return an Postscript font Name +function TPostscriptPrinterCanvas.MapedFontName: string; +Var Atr : string; begin - //Assert(False, Format('Trace:[TgraphicsObject.Changed] %s', [ClassName])); - if Assigned(FOnChange) then FOnChange(Self); + 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; -procedure TPSObject.Lock; +//Replace the controls chars by PostScript string +function TPostscriptPrinterCanvas.MapedString(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; -procedure TPSObject.UnLock; +//Move pen at last pos +procedure TPostscriptPrinterCanvas.MoveToLastPos; begin - + write(Format('%d %d moveto',[fPenPos.X,fPenPos.Y])+' %last pos'); end; -{ TPSPen } - -procedure TPSPen.SetPattern(const AValue: TPSPattern); +//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 FPattern=AValue then exit; - FPattern:=AValue; - Changed; + 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 TPSPen.SetColor(Value: TColor); +procedure TPostscriptPrinterCanvas.SetBrushFillPattern(SetBorder, SetFill: Boolean); begin - FColor := Value; - Changed; + SetBrushFillPattern(fBuffer,SetBorder,SetFill); end; -procedure TPSPen.Setwidth(value: Real); +//Add in Lst, all RGB pixels of SrcGraph picture +procedure TPostscriptPrinterCanvas.GetRGBImage(SrcGraph: TGraphic; + Lst: TStringList); +{$IFNDEF DisableFPImage} begin - FWidth := Value; - Changed; end; - -constructor TPSPen.Create; -begin - FPattern := nil; -end; - -destructor TPSPen.Destroy; -begin - // Do NOT free the pattern object from here... - inherited Destroy; -end; - -procedure TPSPen.Assign(Source: TPSPen); -begin - if source = nil then exit; - - FWidth := Source.Width; - FColor := Source.Color; - FPattern := Source.Pattern; -end; - -{ Return the pen definition as a postscript string } -function TPSPen.AsString: String; +{$ELSE} var - MyOut: String; + SrcIntfImg : TLazIntfImage; + px, py : Integer; + CurColor : TFPColor; + i : integer; + St : String; begin - MyOut := ''; + 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); - // set all the features of this pen... - if FPattern <> nil then begin - // we have a pattern - // uh... let's make it work for both colored and uncolored patterns - // first for colored: - - if FPattern.PaintType = ptColored then - MyOut := '/Pattern setcolorspace '+FPattern.Name+' setcolor ' - else begin - // now for uncolored, use color from pen - MyOut := '[/Pattern /DeviceRGB] setcolorspace '+IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+ - IntToStr(GetBValue(FColor))+' '+FPattern.Name+' setcolor '; + if Length(St)>=78 then + begin + Lst.Add(Copy(St,1,78)); + System.Delete(St,1,78); + end; end; - - end else // no pattern do this: - MyOut := IntToStr(GetRValue(FColor))+' '+IntToStr(GetGValue(FColor))+' '+ - IntToStr(GetBValue(FColor))+' setrgbcolor '; + end; - MyOut := MyOut + format('%f',[FWidth])+' setlinewidth '; - Result := MyOut; -end; - -{ TPSPattern } - -{ Returns the pattern definition as postscript } -function TPSPattern.GetpostScript: TStringList; -var - I: Integer; -begin - // If nothing in the canvas, error - if FCanvas.Postscript.Count < 1 then begin - raise exception.create('Empty pattern'); - exit; + if St<>'' then + Lst.Add(St); + finally + Lst.EndUpdate; + SrcIntfImg.Free; + end; end; - - FPostScript.Clear; - With FPostScript do begin - Add('%% PATTERN '+FName); - Add('/'+FName+'proto 12 dict def '+FName+'proto begin'); - Add('/PatternType 1 def'); - case FPaintType of - ptColored: Add('/PaintType 1 def'); - ptUncolored: Add('/PaintType 2 def'); - end; - case FTilingType of - ttConstant: Add('/TilingType 1 def'); - ttNoDistortion: Add('/TilingType 2 def'); - ttFast: Add('/TilingType 3 def'); - end; - Add('/BBox ['+IntToStr(FBBox.Left)+' '+IntToStr(FBBox.Top)+' '+IntToStr(FBBox.Right)+' '+IntToStr(FBBox.Bottom)+'] def'); - Add('/XStep '+format('%f',[FXStep])+' def'); - Add('/YStep '+format('%f',[FYstep])+' def'); - Add('/PaintProc { begin'); +end; +{$ENDIF} - // insert the canvas - for I := 0 to FCanvas.PostScript.Count - 1 do begin - Add(FCanvas.PostScript[I]); - end; - - // Add support for custom matrix later - Add('end } def end '+FName+'proto [1 0 0 1 0 0] makepattern /'+FName+' exch def'); - Add('%% END PATTERN '+FName); - end; - Result := FPostScript; +procedure TPostscriptPrinterCanvas.CreateHandle; +begin + SetHandle(1); end; -procedure TPSPattern.SetBBox(const AValue: TRect); + +constructor TPostscriptPrinterCanvas.Create(APrinter: TPrinter); begin - if FBBox=AValue then exit; - FBBox:=AValue; - //FCanvas.Width := FBBox.Right - FBBox.Left; - FCanvas.Height := FBBox.Bottom - FBBox.Top; - Changed; + inherited Create(APrinter); + + fcBrushStyle:=bsClear; + fcPenColor :=clBlack; + fcPenWidth :=0; + fcPenStyle :=psSolid; + fcLastFont :=TFont.Create; + + fHeader:=TStringList.Create; + fBuffer:=TstringList.Create; + fDocument:=TStringList.Create; end; -procedure TPSPattern.SetName(const AValue: String); +destructor TPostscriptPrinterCanvas.Destroy; begin - FOldName := FName; - if FName=AValue then exit; - FName:=AValue; - Changed; -end; - -procedure TPSPattern.Changed; -begin - if Assigned(FOnChange) then FOnChange(Self); -end; - -procedure TPSPattern.SetPaintType(const AValue: TPSPaintType); -begin - if FPaintType=AValue then exit; - FPaintType:=AValue; - Changed; -end; - -procedure TPSPattern.SetTilingType(const AValue: TPSTileType); -begin - if FTilingType=AValue then exit; - FTilingType:=AValue; - Changed; -end; - -procedure TPSPattern.SetXStep(const AValue: Real); -begin - if FXStep=AValue then exit; - FXStep:=AValue; - Changed; -end; - -procedure TPSPattern.SetYStep(const AValue: Real); -begin - if FYStep=AValue then exit; - FYStep:=AValue; - Changed; -end; - -constructor TPSPattern.Create; -begin - FPostScript := TStringList.Create; - FPaintType := ptColored; - FTilingType := ttConstant; - FCanvas := TPostScriptCanvas.Create(nil); - FName := 'Pattern1'; -end; - -destructor TPSPattern.Destroy; -begin - FPostScript.Free; - FCanvas.Free; + 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. diff --git a/lcl/printers.pas b/lcl/printers.pas index c0b5a4e27f..4356c57936 100644 --- a/lcl/printers.pas +++ b/lcl/printers.pas @@ -128,7 +128,7 @@ type fTitle : string; //Title of current document fPrinting : Boolean; //Printing fAborted : Boolean; //Abort process - fCapabilities: TPrinterCapabilities; + //fCapabilities: TPrinterCapabilities; fPaperSize : TPaperSize; function GetCanvas: TCanvas;