mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-11-04 07:43:04 +01:00
+ Added header to all files
+ Added const to calls that accept structure as arguments. + Re-Implemented TPostscriptcanvas as descendent of TFPCustomCanvas (initial tests work)
This commit is contained in:
michael
parent
4f8c390198
commit
430621bc9b
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/07/11]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/06/26]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx
|
||||
@ -204,7 +204,7 @@ UNITSDIR:=$(wildcard $(FPCDIR)/units/$(OS_TARGET))
|
||||
endif
|
||||
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
|
||||
override PACKAGE_NAME=fcl
|
||||
override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv
|
||||
override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas
|
||||
override TARGET_EXAMPLES+=imgconv
|
||||
override INSTALL_FPCPACKAGE=y
|
||||
override COMPILER_TARGETDIR+=../$(OS_TARGET)
|
||||
|
||||
@ -10,7 +10,7 @@ packages=paszlib
|
||||
|
||||
[target]
|
||||
units=fpimgcmn fpimage pngcomn fpreadpng fpreadxpm fpwritexpm clipping \
|
||||
fpcanvas pixtools fppixlcanv fpimgcanv
|
||||
fpcanvas pixtools fppixlcanv fpimgcanv pscanvas
|
||||
examples=imgconv
|
||||
|
||||
[compiler]
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Clipping support.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit Clipping;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TFPCustomBrush implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCustomBrush }
|
||||
|
||||
procedure TFPCustomBrush.SetStyle (AValue : TFPBrushStyle);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TFPCustomCanvas implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCustomCanvas }
|
||||
|
||||
constructor TFPCustomCanvas.Create;
|
||||
@ -326,13 +341,13 @@ begin
|
||||
Line (p1.x,p1.y,p2.x,p2.y);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Line (points:TRect);
|
||||
procedure TFPCustomCanvas.Line (const points:TRect);
|
||||
begin
|
||||
with points do
|
||||
Line (left,top, right,bottom);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Polyline (points:array of TPoint);
|
||||
procedure TFPCustomCanvas.Polyline (Const points:array of TPoint);
|
||||
begin
|
||||
if Pen.Style <> psClear then
|
||||
if Pen is TFPCustomDrawPen then
|
||||
@ -357,25 +372,25 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.DoRectangleAndFill (Bounds:TRect);
|
||||
procedure TFPCustomCanvas.DoRectangleAndFill (const Bounds:TRect);
|
||||
begin
|
||||
DoRectangleFill (Bounds);
|
||||
DoRectangle (Bounds);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.DoEllipseAndFill (Bounds:TRect);
|
||||
procedure TFPCustomCanvas.DoEllipseAndFill (const Bounds:TRect);
|
||||
begin
|
||||
DoEllipseFill (Bounds);
|
||||
DoEllipse (Bounds);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.DoPolygonAndFill (points:array of TPoint);
|
||||
procedure TFPCustomCanvas.DoPolygonAndFill (const points:array of TPoint);
|
||||
begin
|
||||
DoPolygonFill (points);
|
||||
DoPolygon (points);
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Ellipse (Bounds:TRect);
|
||||
procedure TFPCustomCanvas.Ellipse (const Bounds:TRect);
|
||||
var p,b,dp,db,pb : boolean;
|
||||
begin
|
||||
p := Pen.style <> psClear;
|
||||
@ -424,7 +439,7 @@ begin
|
||||
Rectangle (Rect(left,top,right,bottom));
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Rectangle (Bounds:TRect);
|
||||
procedure TFPCustomCanvas.Rectangle (const Bounds:TRect);
|
||||
var p,b,dp,db,pb : boolean;
|
||||
begin
|
||||
p := Pen.style <> psClear;
|
||||
@ -473,7 +488,7 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFPCustomCanvas.Polygon (points:array of TPoint);
|
||||
procedure TFPCustomCanvas.Polygon (const points:array of TPoint);
|
||||
var p,b,dp,db,pb : boolean;
|
||||
begin
|
||||
p := Pen.style <> psClear;
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Basic canvas definitions.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPCanvas;
|
||||
|
||||
@ -151,7 +166,8 @@ type
|
||||
function DoAllowPen (APen : TFPCustomPen) : boolean; virtual;
|
||||
function DoAllowBrush (ABrush : TFPCustomBrush) : boolean; virtual;
|
||||
procedure SetColor (x,y:integer; Value:TFPColor); Virtual; abstract;
|
||||
function GetColor (x,y:integer) : TFPColor; Virtual; abstract; procedure SetHeight (AValue : integer); virtual; abstract;
|
||||
function GetColor (x,y:integer) : TFPColor; Virtual; abstract;
|
||||
procedure SetHeight (AValue : integer); virtual; abstract;
|
||||
function GetHeight : integer; virtual; abstract;
|
||||
procedure SetWidth (AValue : integer); virtual; abstract;
|
||||
function GetWidth : integer; virtual; abstract;
|
||||
@ -161,16 +177,16 @@ type
|
||||
procedure DoGetTextSize (text:string; var w,h:integer); virtual; abstract;
|
||||
function DoGetTextHeight (text:string) : integer; virtual; abstract;
|
||||
function DoGetTextWidth (text:string) : integer; virtual; abstract;
|
||||
procedure DoRectangle (Bounds:TRect); virtual; abstract;
|
||||
procedure DoRectangleFill (Bounds:TRect); virtual; abstract;
|
||||
procedure DoRectangleAndFill (Bounds:TRect); virtual;
|
||||
procedure DoEllipseFill (Bounds:TRect); virtual; abstract;
|
||||
procedure DoEllipse (Bounds:TRect); virtual; abstract;
|
||||
procedure DoEllipseAndFill (Bounds:TRect); virtual;
|
||||
procedure DoPolygonFill (points:array of TPoint); virtual; abstract;
|
||||
procedure DoPolygon (points:array of TPoint); virtual; abstract;
|
||||
procedure DoPolygonAndFill (points:array of TPoint); virtual;
|
||||
procedure DoPolyline (points:array of TPoint); virtual; abstract;
|
||||
procedure DoRectangle (Const Bounds:TRect); virtual; abstract;
|
||||
procedure DoRectangleFill (Const Bounds:TRect); virtual; abstract;
|
||||
procedure DoRectangleAndFill (Const Bounds:TRect); virtual;
|
||||
procedure DoEllipseFill (Const Bounds:TRect); virtual; abstract;
|
||||
procedure DoEllipse (Const Bounds:TRect); virtual; abstract;
|
||||
procedure DoEllipseAndFill (Const Bounds:TRect); virtual;
|
||||
procedure DoPolygonFill (const points:array of TPoint); virtual; abstract;
|
||||
procedure DoPolygon (const points:array of TPoint); virtual; abstract;
|
||||
procedure DoPolygonAndFill (const points:array of TPoint); virtual;
|
||||
procedure DoPolyline (const points:array of TPoint); virtual; abstract;
|
||||
procedure DoFloodFill (x,y:integer); virtual; abstract;
|
||||
procedure DoMoveTo (x,y:integer); virtual;
|
||||
procedure DoLineTo (x,y:integer); virtual;
|
||||
@ -193,11 +209,11 @@ type
|
||||
function GetTextHeight (text:string) : integer;
|
||||
function GetTextWidth (text:string) : integer;
|
||||
// using pen and brush
|
||||
procedure Ellipse (Bounds:TRect);
|
||||
procedure Ellipse (Const Bounds:TRect);
|
||||
procedure Ellipse (left,top,right,bottom:integer);
|
||||
procedure Polygon (points:array of TPoint);
|
||||
procedure Polyline (points:array of TPoint);
|
||||
procedure Rectangle (Bounds:TRect);
|
||||
procedure Polygon (Const points:array of TPoint);
|
||||
procedure Polyline (Const points:array of TPoint);
|
||||
procedure Rectangle (Const Bounds:TRect);
|
||||
procedure Rectangle (left,top,right,bottom:integer);
|
||||
// using brush
|
||||
procedure FloodFill (x,y:integer);
|
||||
@ -209,7 +225,7 @@ type
|
||||
procedure LineTo (p:TPoint);
|
||||
procedure Line (x1,y1,x2,y2:integer);
|
||||
procedure Line (p1,p2:TPoint);
|
||||
procedure Line (points:TRect);
|
||||
procedure Line (const points:TRect);
|
||||
// other procedures
|
||||
procedure CopyRect (x,y:integer; canvas:TFPCustomCanvas; SourceRect:TRect);
|
||||
procedure Draw (x,y:integer; image:TFPCustomImage);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TDrawObjects implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCustomDrawPen }
|
||||
|
||||
procedure TFPCustomDrawPen.DrawLine (x1,y1,x2,y2:integer);
|
||||
|
||||
@ -1,3 +1,19 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Some color conversion routines.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
|
||||
function FillOtherBits (initial:word;CorrectBits:byte):word;
|
||||
var r,c : byte;
|
||||
begin
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Color definitions and functions.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
const
|
||||
BytesNeeded : array[TColorFormat] of byte =
|
||||
(1,1,1,1,2,3,1,2,4,2,2,3,4,6,1,2,4,8,2,2,3,4,6,1,2,4,8);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Implementation of TFPCustomFont
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ FPCustomFont }
|
||||
|
||||
procedure TFPCustomFont.SetName (AValue:string);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TImageHandlers implementations
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TImageHandlersManager }
|
||||
|
||||
constructor TImageHandlersManager.Create;
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Implementation of TFPCanvasHelper
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCanvasHelper }
|
||||
|
||||
constructor TFPCanvasHelper.Create;
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TFPCustomImage implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCustomImage }
|
||||
|
||||
constructor TFPCustomImage.create (AWidth,AHeight:integer);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
fpImage base definitions.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPimage;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Image Canvas - canvas which draws on an image.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPImgCanv;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Auxiliary routines for image support.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPImgCmn;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TFPPalette implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPPalette }
|
||||
|
||||
constructor TFPPalette.create (ACount : integer);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TFPCustomPen implementation
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ TFPCustomPen }
|
||||
|
||||
procedure TFPCustomPen.SetMode (AValue : TFPPenMode);
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TPixelCanvas class.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPPixlCanv;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
PNG reader implementation
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPReadPNG;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
XPM reader class.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPReadXPM;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
XPM writer implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit FPWriteXPM;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Image conversion example.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
program ImgConv;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
Pixel drawing routines.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit PixTools;
|
||||
|
||||
|
||||
@ -1,3 +1,18 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
PNG reader/writer common code.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{$mode objfpc}{$h+}
|
||||
unit PNGcomn;
|
||||
|
||||
|
||||
939
fcl/image/pscanvas.pp
Normal file
939
fcl/image/pscanvas.pp
Normal file
@ -0,0 +1,939 @@
|
||||
{
|
||||
$Id$
|
||||
This file is part of the Free Pascal run time library.
|
||||
Copyright (c) 2003 by the Free Pascal development team
|
||||
|
||||
TPostScriptCanvas implementation.
|
||||
|
||||
See the file COPYING.FPC, 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.
|
||||
|
||||
**********************************************************************}
|
||||
{ ---------------------------------------------------------------------
|
||||
This code is heavily based on Tony Maro's initial TPostScriptCanvas
|
||||
implementation in the LCL, but was adapted to work with the custom
|
||||
canvas code and to work with streams instead of strings.
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
|
||||
{$mode objfpc}
|
||||
{$H+}
|
||||
|
||||
unit pscanvas;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils,fpimage,fpcanvas;
|
||||
|
||||
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(TFPCanvasHelper)
|
||||
private
|
||||
FStream : TMemoryStream;
|
||||
FPatternCanvas : TPostScriptCanvas;
|
||||
FOldName: String;
|
||||
FOnChange: TNotifyEvent;
|
||||
FBBox: TRect;
|
||||
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 GetPS: TStringList read GetPostscript;
|
||||
property OldName: string read FOldName write FOldName; // used when notifying that name changed
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
Property PatternCanvas : TPostScriptCanvas Read FPatternCanvas;
|
||||
end;
|
||||
PPSPattern = ^TPSPattern; // used for array
|
||||
|
||||
{ Pen and brush object both right now...}
|
||||
TPSPen = class(TFPCustomPen)
|
||||
private
|
||||
FPattern: TPSPattern;
|
||||
procedure SetPattern(const AValue: TPSPattern);
|
||||
public
|
||||
destructor Destroy; override;
|
||||
property Pattern: TPSPattern read FPattern write SetPattern;
|
||||
function AsString: String;
|
||||
end;
|
||||
|
||||
TPSBrush = Class(TFPCustomBrush)
|
||||
Private
|
||||
Function GetAsString : String;
|
||||
Public
|
||||
Property AsString : String Read GetAsString;
|
||||
end;
|
||||
|
||||
TPSFont = Class(TFPCustomFont)
|
||||
end;
|
||||
|
||||
{ Custom canvas-like object that handles postscript code }
|
||||
TPostScriptCanvas = class(TFPCustomCanvas)
|
||||
private
|
||||
FHeight,FWidth : Integer;
|
||||
FStream : TStream;
|
||||
FLineSpacing: Integer;
|
||||
LastX: Integer;
|
||||
LastY: Integer;
|
||||
function TranslateY(Ycoord: Integer): Integer; // Y axis is backwards in postscript
|
||||
procedure AddFill;
|
||||
procedure ResetPos; // reset back to last moveto location
|
||||
procedure SetWidth (AValue : integer); override;
|
||||
function GetWidth : integer; override;
|
||||
procedure SetHeight (AValue : integer); override;
|
||||
function GetHeight : integer; override;
|
||||
Protected
|
||||
Procedure WritePS(Const Cmd : String);
|
||||
Procedure WritePS(Const Fmt : String; Args : Array of Const);
|
||||
procedure DrawRectangle(const Bounds: TRect; DoFill : Boolean);
|
||||
procedure DrawEllipse(const Bounds: TRect; DoFill : Boolean);
|
||||
public
|
||||
constructor Create(AStream : TStream);
|
||||
destructor Destroy; override;
|
||||
function DoCreateDefaultFont : TFPCustomFont; override;
|
||||
function DoCreateDefaultPen : TFPCustomPen; override;
|
||||
function DoCreateDefaultBrush : TFPCustomBrush; override;
|
||||
property LineSpacing: Integer read FLineSpacing write FLineSpacing;
|
||||
Procedure DoMoveTo(X1,Y1 : Integer); override;
|
||||
Procedure DoLineTo(X1,Y1 : Integer); override;
|
||||
Procedure DoLine(X1,Y1,X2,Y2 : Integer); override;
|
||||
Procedure DoRectangle(Const Bounds : TRect); override;
|
||||
Procedure DoRectangleFill(Const Bounds : TRect); override;
|
||||
procedure DoPolyline(Const Points: Array of TPoint); override;
|
||||
procedure DoEllipse(const Bounds: TRect); override;
|
||||
procedure DoEllipseFill(const Bounds: TRect); override;
|
||||
procedure DoPie(x,y,awidth,aheight,angle1,angle2 : Integer);
|
||||
//procedure Pie(x,y,width,height,SX,SY,EX,EY : Integer);
|
||||
procedure Writeln(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{$IFDEF VER1_1} = False{$ENDIF};
|
||||
// Continuous: boolean{$IFDEF VER1_1} = False{$ENDIF});
|
||||
//procedure PolyBezier(const Points: array of TPoint;
|
||||
// Filled: boolean{$IFDEF VER1_1} = False{$ENDIF};
|
||||
// Continuous: boolean{$IFDEF VER1_1} = False{$ENDIF});
|
||||
//procedure PolyBezier(const Points: array of TPoint);
|
||||
//procedure Polygon(const Points: array of TPoint;
|
||||
// Winding: Boolean{$IFDEF VER1_1} = False{$ENDIF};
|
||||
// StartIndex: Integer{$IFDEF VER1_1} = 0{$ENDIF};
|
||||
// NumPts: Integer {$IFDEF VER1_1} = -1{$ENDIF});
|
||||
//procedure Polygon(Points: PPoint; NumPts: Integer;
|
||||
// Winding: boolean{$IFDEF VER1_1} = False{$ENDIF});
|
||||
//Procedure Polygon(const Points: array of TPoint);
|
||||
//Procedure FillRect(const Rect : TRect);
|
||||
//procedure FloodFill(X, Y: Integer; FillColor: TFPColor; FillStyle: TFillStyle);
|
||||
//Procedure RoundRect(X1, Y1, X2, Y2: Integer; RX,RY : Integer);
|
||||
//Procedure RoundRect(const Rect : TRect; RX,RY : Integer);
|
||||
Property Stream : TStream read FStream;
|
||||
end;
|
||||
|
||||
{ Encapsulates ALL the postscript and uses the TPostScriptCanvas object for a single page }
|
||||
TPostScript = class(TComponent)
|
||||
private
|
||||
FDocStarted : Boolean;
|
||||
FCreator : String;
|
||||
FStream : TStream;
|
||||
FCanvas: TPostScriptCanvas;
|
||||
FHeight: Integer;
|
||||
FLineSpacing: Integer;
|
||||
FPageNumber: Integer;
|
||||
FTitle: String;
|
||||
FWidth: Integer;
|
||||
FPatterns: TList; // array of pointers to pattern objects
|
||||
procedure SetHeight(const AValue: Integer);
|
||||
procedure SetLineSpacing(const AValue: Integer);
|
||||
procedure SetWidth(const AValue: Integer);
|
||||
procedure UpdateBoundingBox;
|
||||
procedure PatternChanged(Sender: TObject);
|
||||
procedure InsertPattern(APattern: TPSPattern); // adds the pattern to the postscript
|
||||
Procedure SetStream (Value : TStream);
|
||||
Function GetCreator : String;
|
||||
Protected
|
||||
Procedure WritePS(Const Cmd : String);
|
||||
Procedure WritePS(Const Fmt : String; Args : Array of Const);
|
||||
Procedure WriteDocumentHeader; virtual;
|
||||
Procedure WriteStandardFont; virtual;
|
||||
Procedure WritePage; virtual;
|
||||
Procedure FreePatterns;
|
||||
Procedure CheckStream;
|
||||
public
|
||||
Constructor Create(AOwner : TComponent);
|
||||
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 PageNumber: Integer read FPageNumber;
|
||||
property Title: String read FTitle write FTitle;
|
||||
property LineSpacing: Integer read FLineSpacing write SetLineSpacing;
|
||||
procedure BeginDoc;
|
||||
procedure NewPage;
|
||||
procedure EndDoc;
|
||||
Property Stream : TStream Read FStream Write SetStream;
|
||||
Property Creator : String Read GetCreator Write FCreator;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
Resourcestring
|
||||
SErrNoStreamAssigned = 'Invalid operation: No stream assigned';
|
||||
SErrDocumentAlreadyStarted = 'Cannot start document twice.';
|
||||
|
||||
{ TPostScriptCanvas ----------------------------------------------------------}
|
||||
|
||||
Procedure TPostScriptCanvas.WritePS(const Cmd : String);
|
||||
|
||||
begin
|
||||
If length(Cmd)>0 then
|
||||
FStream.Write(Cmd[1],Length(Cmd));
|
||||
FStream.Write(LineEnding,SizeOf(LineEnding));
|
||||
end;
|
||||
|
||||
Procedure TPostScriptCanvas.WritePS(Const Fmt : String; Args : Array of Const);
|
||||
|
||||
begin
|
||||
WritePS(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
{ Y coords in postscript are backwards... }
|
||||
function TPostScriptCanvas.TranslateY(Ycoord: Integer): Integer;
|
||||
begin
|
||||
Result:=Height-Ycoord;
|
||||
end;
|
||||
|
||||
{ Adds a fill finishing line to any path we desire to fill }
|
||||
procedure TPostScriptCanvas.AddFill;
|
||||
begin
|
||||
WritePs('gsave '+(Brush as TPSBrush).AsString+' fill grestore');
|
||||
end;
|
||||
|
||||
{ Return to last moveto location }
|
||||
procedure TPostScriptCanvas.ResetPos;
|
||||
begin
|
||||
WritePS(inttostr(LastX)+' '+inttostr(TranslateY(LastY))+' moveto');
|
||||
end;
|
||||
|
||||
constructor TPostScriptCanvas.Create(AStream : TStream);
|
||||
|
||||
begin
|
||||
inherited create;
|
||||
FStream:=AStream;
|
||||
Height := 792; // length of page in points at 72 ppi
|
||||
{ // Choose a standard font in case the user doesn't
|
||||
FFontFace := 'AvantGarde-Book';
|
||||
SetFontSize(10);
|
||||
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;
|
||||
|
||||
procedure TPostScriptCanvas.SetWidth (AValue : integer);
|
||||
|
||||
begin
|
||||
FWidth:=AValue;
|
||||
end;
|
||||
|
||||
function TPostScriptCanvas.GetWidth : integer;
|
||||
|
||||
begin
|
||||
Result:=FWidth;
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.SetHeight (AValue : integer);
|
||||
|
||||
begin
|
||||
FHeight:=AValue;
|
||||
end;
|
||||
|
||||
function TPostScriptCanvas.GetHeight : integer;
|
||||
|
||||
begin
|
||||
Result:=FHeight;
|
||||
end;
|
||||
|
||||
|
||||
{ Move draw location }
|
||||
procedure TPostScriptCanvas.DoMoveTo(X1, Y1: Integer);
|
||||
|
||||
var
|
||||
Y: Integer;
|
||||
|
||||
begin
|
||||
Y := TranslateY(Y1);
|
||||
WritePS(inttostr(X1)+' '+inttostr(Y)+' moveto');
|
||||
LastX := X1;
|
||||
LastY := Y1;
|
||||
end;
|
||||
|
||||
{ Draw a line from current location to these coords }
|
||||
procedure TPostScriptCanvas.DoLineTo(X1, Y1: Integer);
|
||||
|
||||
var
|
||||
Y: Integer;
|
||||
|
||||
begin
|
||||
Y := TranslateY(Y1);
|
||||
WritePS(inttostr(X1)+' '+inttostr(Y)+' lineto');
|
||||
LastX := X1;
|
||||
LastY := Y1;
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DoLine(X1, Y1, X2, Y2: Integer);
|
||||
var
|
||||
Y12, Y22: Integer;
|
||||
|
||||
begin
|
||||
Y12 := TranslateY(Y1);
|
||||
Y22 := TranslateY(Y2);
|
||||
WritePS('newpath '+inttostr(X1)+' '+inttostr(Y12)+' moveto '+
|
||||
inttostr(X2)+' '+inttostr(Y22)+' lineto closepath stroke');
|
||||
// go back to last moveto position
|
||||
ResetPos;
|
||||
end;
|
||||
|
||||
{ Draw a rectangle }
|
||||
|
||||
procedure TPostScriptCanvas.DoRectangleFill(const Bounds: TRect);
|
||||
|
||||
begin
|
||||
DrawRectangle(Bounds,true)
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DoRectangle(const Bounds: TRect);
|
||||
|
||||
begin
|
||||
DrawRectangle(Bounds,False);
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DrawRectangle(const Bounds: TRect; DoFill : Boolean);
|
||||
|
||||
var
|
||||
Y12, Y22: Integer;
|
||||
|
||||
begin
|
||||
Y12 := TranslateY(Bounds.Top);
|
||||
Y22 := TranslateY(Bounds.Bottom);
|
||||
WritePS('stroke newpath');
|
||||
With Bounds do
|
||||
begin
|
||||
WritePS(inttostr(Left)+' '+inttostr(Y12)+' moveto');
|
||||
WritePS(inttostr(Right)+' '+inttostr(Y12)+' lineto');
|
||||
WritePS(inttostr(Right)+' '+inttostr(Y22)+' lineto');
|
||||
WritePS(inttostr(Left)+' '+inttostr(Y22)+' lineto');
|
||||
end;
|
||||
WritePS('closepath');
|
||||
If DoFill and (Brush.Style<>bsClear) then
|
||||
AddFill;
|
||||
WritePS('stroke');
|
||||
ResetPos;
|
||||
end;
|
||||
|
||||
{ Draw a series of lines }
|
||||
procedure TPostScriptCanvas.DoPolyline(Const Points: Array of TPoint);
|
||||
var
|
||||
i : Longint;
|
||||
begin
|
||||
MoveTo(Points[0].X, Points[0].Y);
|
||||
For i := 1 to High(Points) do
|
||||
LineTo(Points[i].X, Points[i].Y);
|
||||
ResetPos;
|
||||
end;
|
||||
|
||||
{ This was a pain to figure out... }
|
||||
|
||||
procedure TPostScriptCanvas.DoEllipse(Const Bounds : TRect);
|
||||
|
||||
begin
|
||||
DrawEllipse(Bounds,False);
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DoEllipseFill(Const Bounds : TRect);
|
||||
|
||||
begin
|
||||
DrawEllipse(Bounds,true);
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DrawEllipse(Const Bounds : TRect; DoFill : Boolean);
|
||||
|
||||
var
|
||||
radius: Integer;
|
||||
YRatio: Real;
|
||||
centerX, centerY: Integer;
|
||||
|
||||
begin
|
||||
// set radius to half the width
|
||||
With Bounds do
|
||||
begin
|
||||
radius := (Right-Left) div 2;
|
||||
if radius <1 then
|
||||
exit;
|
||||
YRatio := (Bottom - Top) / (Right-Left);
|
||||
// find center
|
||||
CenterX := (Right+Left) div 2;
|
||||
CenterY := (Top+Bottom) div 2;
|
||||
end;
|
||||
WritePS('newpath '+inttostr(CenterX)+' '+inttostr(TranslateY(CenterY))+' translate');
|
||||
// move to edge
|
||||
WritePS(inttostr(radius)+' 0 moveto');
|
||||
// now draw it
|
||||
WritePS('gsave 1 '+format('%.3f',[YRatio])+' scale');
|
||||
WritePS('0 0 '+inttostr(radius)+' 0 360 arc');
|
||||
if DoFill and (Brush.Style<>bsClear) then
|
||||
AddFill;
|
||||
// reset scale for drawing line thickness so it doesn't warp
|
||||
YRatio := 1 / YRatio;
|
||||
WritePS('1 '+format('%.2f',[YRatio])+' scale stroke grestore');
|
||||
// move origin back
|
||||
WritePS(inttostr(-CenterX)+' '+inttostr(-TranslateY(CenterY))+' translate closepath stroke');
|
||||
ResetPos;
|
||||
end;
|
||||
|
||||
procedure TPostScriptCanvas.DoPie(x, y, AWidth, AHeight, angle1, angle2: Integer);
|
||||
begin
|
||||
// set zero at center
|
||||
WritePS('newpath '+inttostr(X)+' '+inttostr(TranslateY(Y))+' translate');
|
||||
// scale it
|
||||
WritePS('gsave '+inttostr(AWidth)+' '+inttostr(Aheight)+' scale');
|
||||
//WritePS('gsave 1 1 scale');
|
||||
// draw line to edge
|
||||
WritePS('0 0 moveto');
|
||||
WritePS('0 0 1 '+inttostr(angle1)+' '+inttostr(angle2)+' arc closepath');
|
||||
if Brush.Style<>bsClear 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...
|
||||
WritePS(format('%.6f',[(real(1) / X)+0.01])+' '+format('%.6f',[(real(1) / Y)+0.01])+' scale stroke grestore');
|
||||
// close out and return origin
|
||||
WritePS(inttostr(-X)+' '+inttostr(-TranslateY(Y))+' translate closepath stroke');
|
||||
resetpos;
|
||||
end;
|
||||
|
||||
{ Writes text with a carriage return }
|
||||
procedure TPostScriptCanvas.Writeln(AString: String);
|
||||
begin
|
||||
TextOut(LastX, LastY, AString);
|
||||
LastY := LastY+Font.Size+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);
|
||||
WritePS(inttostr(X)+' '+inttostr(Y1)+' moveto');
|
||||
WritePS('('+Text+') show');
|
||||
ResetPos; // move back to last moveto location
|
||||
end;
|
||||
|
||||
function TPostScriptCanvas.DoCreateDefaultFont : TFPCustomFont;
|
||||
|
||||
begin
|
||||
Result:=TPSFont.Create;
|
||||
end;
|
||||
|
||||
|
||||
function TPostScriptCanvas.DoCreateDefaultPen : TFPCustomPen;
|
||||
|
||||
begin
|
||||
Result:=TPSPen.Create;
|
||||
end;
|
||||
|
||||
function TPostScriptCanvas.DoCreateDefaultBrush : TFPCustomBrush;
|
||||
|
||||
begin
|
||||
Result:=TPSBrush.Create;
|
||||
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.SetWidth(const AValue: Integer);
|
||||
begin
|
||||
if FWidth=AValue then exit;
|
||||
FWidth:=AValue;
|
||||
UpdateBoundingBox;
|
||||
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
|
||||
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;
|
||||
|
||||
constructor TPostScript.Create(AOwner : TComponent);
|
||||
begin
|
||||
inherited create(AOwner);
|
||||
// Set some defaults
|
||||
FHeight := 792; // 11 inches at 72 dpi
|
||||
FWidth := 612; // 8 1/2 inches at 72 dpi
|
||||
end;
|
||||
|
||||
Procedure TPostScript.WritePS(const Cmd : String);
|
||||
|
||||
begin
|
||||
If length(Cmd)>0 then
|
||||
FStream.Write(Cmd[1],Length(Cmd));
|
||||
FStream.Write(LineEnding,SizeOf(LineEnding));
|
||||
end;
|
||||
|
||||
Procedure TPostScript.WritePS(Const Fmt : String; Args : Array of Const);
|
||||
|
||||
begin
|
||||
WritePS(Format(Fmt,Args));
|
||||
end;
|
||||
|
||||
Procedure TPostScript.WriteDocumentHeader;
|
||||
|
||||
begin
|
||||
WritePS('%!PS-Adobe-3.0');
|
||||
WritePS('%%BoundingBox: 0 0 612 792');
|
||||
WritePS('%%Creator: '+Creator);
|
||||
WritePS('%%Title: '+FTitle);
|
||||
WritePS('%%Pages: (atend)');
|
||||
WritePS('%%PageOrder: Ascend');
|
||||
WriteStandardFont;
|
||||
end;
|
||||
|
||||
Procedure TPostScript.WriteStandardFont;
|
||||
|
||||
begin
|
||||
// Choose a standard font in case the user doesn't
|
||||
WritePS('/AvantGarde-Book findfont');
|
||||
WritePS('10 scalefont');
|
||||
WritePS('setfont');
|
||||
end;
|
||||
|
||||
Procedure TPostScript.FreePatterns;
|
||||
|
||||
Var
|
||||
i : Integer;
|
||||
|
||||
begin
|
||||
If Assigned(FPatterns) then
|
||||
begin
|
||||
For I:=0 to FPatterns.Count-1 do
|
||||
TObject(FPatterns[i]).Free;
|
||||
FreeAndNil(FPatterns);
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TPostScript.Destroy;
|
||||
|
||||
begin
|
||||
Stream:=Nil;
|
||||
FreePatterns;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ add a pattern to the array }
|
||||
procedure TPostScript.AddPattern(APSPattern: TPSPattern);
|
||||
begin
|
||||
If Not Assigned(FPatterns) then
|
||||
FPatterns:=Tlist.Create;
|
||||
FPatterns.Add(APSPattern);
|
||||
end;
|
||||
|
||||
{ Find a pattern object by it's name }
|
||||
|
||||
function TPostScript.FindPattern(AName: String): TPSPattern;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
|
||||
begin
|
||||
Result := nil;
|
||||
If Assigned(FPatterns) then
|
||||
begin
|
||||
I:=Fpatterns.Count-1;
|
||||
While (Result=Nil) and (I>=0) do
|
||||
if TPSPattern(FPatterns[I]).Name = AName then
|
||||
result := TPSPattern(FPatterns[i])
|
||||
else
|
||||
Dec(i)
|
||||
end;
|
||||
end;
|
||||
|
||||
function TPostScript.DelPattern(AName: String): Boolean;
|
||||
begin
|
||||
// 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
|
||||
CheckStream;
|
||||
If FDocStarted then
|
||||
Raise Exception.Create(SErrDocumentAlreadyStarted);
|
||||
FCanvas:=TPostScriptCanvas.Create(FStream);
|
||||
FCanvas.Height:=Self.Height;
|
||||
FCanvas.Width:=Self.width;
|
||||
FreePatterns;
|
||||
WriteDocumentHeader;
|
||||
// start our first page
|
||||
FPageNumber := 1;
|
||||
WritePage;
|
||||
UpdateBoundingBox;
|
||||
end;
|
||||
|
||||
Procedure TPostScript.WritePage;
|
||||
|
||||
begin
|
||||
WritePS('%%Page: '+inttostr(FPageNumber)+' '+inttostr(FPageNumber));
|
||||
WritePS('newpath');
|
||||
end;
|
||||
|
||||
{ Copy current page into the postscript and start a new one }
|
||||
procedure TPostScript.NewPage;
|
||||
begin
|
||||
// dump the current page into our postscript first
|
||||
// put end page definition...
|
||||
WritePS('stroke');
|
||||
WritePS('showpage');
|
||||
FPageNumber := FPageNumber+1;
|
||||
WritePage;
|
||||
end;
|
||||
|
||||
{ Finish off the document }
|
||||
procedure TPostScript.EndDoc;
|
||||
begin
|
||||
// Start printing the document after closing out the pages
|
||||
WritePS('stroke');
|
||||
WritePS('showpage');
|
||||
WritePS('%%Pages: '+inttostr(FPageNumber));
|
||||
// okay, the postscript is all ready, so dump it to the text file
|
||||
// or to the printer
|
||||
FDocStarted:=False;
|
||||
FreeAndNil(FCanvas);
|
||||
end;
|
||||
|
||||
Function TPostScript.GetCreator : String;
|
||||
|
||||
begin
|
||||
If (FCreator='') then
|
||||
Result:=ClassName
|
||||
else
|
||||
Result:=FCreator;
|
||||
end;
|
||||
|
||||
|
||||
Procedure TPostScript.SetStream (Value : TStream);
|
||||
|
||||
begin
|
||||
if (FStream<>Value) then
|
||||
begin
|
||||
If (FStream<>Nil) and FDocStarted then
|
||||
EndDoc;
|
||||
FStream:=Value;
|
||||
FDocStarted:=False;
|
||||
end;
|
||||
end;
|
||||
|
||||
Procedure TPostScript.CheckStream;
|
||||
|
||||
begin
|
||||
If Not Assigned(FStream) then
|
||||
Raise Exception.Create(SErrNoStreamAssigned);
|
||||
end;
|
||||
|
||||
{ TPSPen }
|
||||
|
||||
procedure TPSPen.SetPattern(const AValue: TPSPattern);
|
||||
begin
|
||||
if FPattern<>AValue then
|
||||
begin
|
||||
FPattern:=AValue;
|
||||
// NotifyCanvas;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
destructor TPSPen.Destroy;
|
||||
begin
|
||||
// Do NOT free the pattern object from here...
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
|
||||
{ Return the pen definition as a postscript string }
|
||||
function TPSPen.AsString: String;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
if FPattern <> nil then
|
||||
begin
|
||||
if FPattern.PaintType = ptColored then
|
||||
Result:='/Pattern setcolorspace '+FPattern.Name+' setcolor '
|
||||
else
|
||||
begin
|
||||
Result:='[/Pattern /DeviceRGB] setcolorspace '+inttostr(Color.Red)+' '+inttostr(Color.Green)+' '+
|
||||
inttostr(Color.Blue)+' '+FPattern.Name+' setcolor ';
|
||||
end;
|
||||
end
|
||||
else // no pattern do this:
|
||||
Result:=inttostr(Color.Red)+' '+inttostr(Color.Green)+' '+
|
||||
inttostr(Color.Blue)+' setrgbcolor ';
|
||||
Result := Result + format('%f',[Width])+' setlinewidth ';
|
||||
end;
|
||||
|
||||
{ TPSPattern }
|
||||
|
||||
{ Returns the pattern definition as postscript }
|
||||
function TPSPattern.GetpostScript: TStringList;
|
||||
|
||||
var
|
||||
I: Integer;
|
||||
S : String;
|
||||
|
||||
begin
|
||||
// If nothing in the canvas, error
|
||||
if FStream.Size=0 then
|
||||
raise exception.create('Empty pattern');
|
||||
FPostScript.Clear;
|
||||
With FPostScript do
|
||||
begin
|
||||
add('%% PATTERN '+FName);
|
||||
add('/'+FName+'proto 12 dict def '+FName+'proto begin');
|
||||
add('/PatternType 1 def');
|
||||
add(Format('/PaintType %d def',[ord(FPaintType)+1]));
|
||||
add(Format('/TilingType %d def',[ord(FTilingType)+1]));
|
||||
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');
|
||||
// insert the canvas
|
||||
SetLength(S,FStream.Size);
|
||||
FStream.Seek(0,soFromBeginning);
|
||||
FStream.Read(S[1],FStream.Size);
|
||||
Add(S);
|
||||
// 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;
|
||||
end;
|
||||
|
||||
procedure TPSPattern.SetBBox(const AValue: TRect);
|
||||
begin
|
||||
{ if FBBox<>AValue then
|
||||
begin
|
||||
FBBox:=AValue;
|
||||
FPatternCanvas.Height := FBBox.Bottom - FBBox.Top;
|
||||
// NotifyCanvas;
|
||||
end;
|
||||
}
|
||||
end;
|
||||
|
||||
procedure TPSPattern.SetName(const AValue: String);
|
||||
begin
|
||||
FOldName := FName;
|
||||
if (FName<>AValue) then
|
||||
begin
|
||||
FName:=AValue;
|
||||
// NotifyCanvas;
|
||||
end;
|
||||
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;
|
||||
FStream:=TmemoryStream.Create;
|
||||
FPatternCanvas := TPostScriptCanvas.Create(FStream);
|
||||
FName := 'Pattern1';
|
||||
end;
|
||||
|
||||
destructor TPSPattern.Destroy;
|
||||
begin
|
||||
FPostScript.Free;
|
||||
FPatternCanvas.Free;
|
||||
FStream.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ ---------------------------------------------------------------------
|
||||
TPSBrush
|
||||
---------------------------------------------------------------------}
|
||||
|
||||
|
||||
Function TPSBrush.GetAsString : String;
|
||||
|
||||
begin
|
||||
Result:='';
|
||||
end;
|
||||
|
||||
|
||||
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user