mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-12-11 14:55:01 +01:00
458 lines
9.3 KiB
PostScript
458 lines
9.3 KiB
PostScript
%!
|
|
%
|
|
% $Id$
|
|
%
|
|
% we need to define metric units
|
|
/mm {2.834 mul} def
|
|
/cm {28.34 mul } def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Configurable section
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% sets the line width of the class graph to 0.5 points
|
|
/SetLineWidth { 0.5 setlinewidth} def
|
|
|
|
% sets the line color of the class graph to black
|
|
/SetLineColor { 0 0 0 setrgbcolor } def
|
|
|
|
% sets the default font for class names
|
|
/SetClassFont
|
|
{
|
|
/Arial-BoldMT findfont
|
|
10 scalefont
|
|
setfont
|
|
} def
|
|
|
|
% sets the default font for large written class names
|
|
/SetLargeClassFont
|
|
{
|
|
/Arial-BoldMT findfont
|
|
18 scalefont
|
|
setfont
|
|
} def
|
|
|
|
% RGB colors of the texts
|
|
/StandardTextColor { 0 0 0 } def
|
|
/MissedTextColor { 0.50 0.50 0.50 } def
|
|
|
|
% RGB colors of the boxes
|
|
/MissedColor { 0.92 0.92 0.92 } def
|
|
/IncompleteColor { 1 0.5 0.5 } def
|
|
/UntestedColor { 1 1 0.6} def
|
|
/ReadyColor { 0.7 1 0.7 } def
|
|
|
|
% Starting point of the class graph
|
|
% (0,0) is the lower left corner of the paper
|
|
/startx { 0 mm } def
|
|
/starty { 290 mm } def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% End of Configurable section
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% some setups
|
|
/Missed {0} def
|
|
/Incomplete {1} def
|
|
/Untested {2} def
|
|
/Ready {3} def
|
|
/nextx startx def
|
|
/nexty starty def
|
|
/maxx 0 mm def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% drawbox
|
|
% takes two parameters:
|
|
% classname........name of the class
|
|
% status......status of development
|
|
/drawbox
|
|
{
|
|
% save parameters
|
|
/status exch def
|
|
/classname exch def
|
|
% save enviroment
|
|
gsave
|
|
newpath
|
|
|
|
% determine the size of the class name
|
|
SetClassFont
|
|
classname
|
|
stringwidth
|
|
|
|
% and save it ...
|
|
/widthy exch def
|
|
/widthx exch def
|
|
|
|
% moveto start point of the box
|
|
nextx 8 mm add
|
|
nexty
|
|
moveto
|
|
|
|
% calculate the place for the icons
|
|
nextx 8 mm add
|
|
widthx 4.5 mm add add
|
|
/nexticonx exch def
|
|
|
|
% max. ?
|
|
nexticonx 1.5 mm sub maxx gt { /maxx nexticonx def } if
|
|
|
|
% set box color
|
|
status Missed eq { MissedColor setrgbcolor } if
|
|
status Incomplete eq { IncompleteColor setrgbcolor } if
|
|
status Untested eq { UntestedColor setrgbcolor } if
|
|
status Ready eq { ReadyColor setrgbcolor } if
|
|
|
|
% draw box
|
|
0 mm 2.1 mm rlineto
|
|
widthx 3 mm add 0 mm rlineto
|
|
0 mm -4.2 mm rlineto
|
|
0 widthx 3 mm add sub 0 mm rlineto
|
|
0 mm 2.1 mm rlineto
|
|
closepath
|
|
fill
|
|
|
|
% set text color
|
|
status Missed eq { MissedTextColor setrgbcolor }
|
|
{ StandardTextColor setrgbcolor } ifelse
|
|
|
|
% set text pos and write text
|
|
nextx 9.5 mm add
|
|
nexty 1.25 mm sub
|
|
moveto
|
|
classname
|
|
show
|
|
|
|
grestore
|
|
} def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% drawlargebox
|
|
% takes two parameters:
|
|
% classname........name of the class
|
|
% status......status of development
|
|
/drawlargebox
|
|
{
|
|
% save parameters
|
|
/status exch def
|
|
/classname exch def
|
|
% save enviroment
|
|
gsave
|
|
newpath
|
|
|
|
% determine the size of the class name
|
|
SetLargeClassFont
|
|
classname
|
|
stringwidth
|
|
|
|
% and save it ...
|
|
/widthy exch def
|
|
/widthx exch def
|
|
|
|
% moveto start point of the box
|
|
nextx 8 mm add
|
|
nexty
|
|
moveto
|
|
|
|
% calculate the place for the icons
|
|
nextx 8 mm add
|
|
% add text with and additional space
|
|
widthx 7.5 mm add add
|
|
/nexticonx exch def
|
|
|
|
% max. ? (remove icon offset using 1.5 mm sub)
|
|
nexticonx 1.5 mm sub maxx gt { /maxx nexticonx def } if
|
|
|
|
%save x-pos for the horizontal line (remove icon offset using 4.5 mm sub)
|
|
/lastlargeobjectx nexticonx 1.5 mm sub def
|
|
|
|
% set box color
|
|
status Missed eq { MissedColor setrgbcolor } if
|
|
status Incomplete eq { IncompleteColor setrgbcolor } if
|
|
status Untested eq { UntestedColor setrgbcolor } if
|
|
status Ready eq { ReadyColor setrgbcolor } if
|
|
|
|
% draw box
|
|
0 mm 4.2 mm rlineto
|
|
widthx 6 mm add 0 mm rlineto
|
|
0 mm -8.4 mm rlineto
|
|
0 widthx 6 mm add sub 0 mm rlineto
|
|
0 mm 4.2 mm rlineto
|
|
closepath
|
|
fill
|
|
|
|
% set text color
|
|
status Missed eq { MissedTextColor setrgbcolor }
|
|
{ StandardTextColor setrgbcolor } ifelse
|
|
|
|
% set text pos and write text
|
|
nextx 11 mm add
|
|
nexty 2.5 mm sub
|
|
moveto
|
|
classname
|
|
show
|
|
nexty 2.1 mm sub
|
|
/nexty exch def
|
|
grestore
|
|
} def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% newchildclass
|
|
% draws a new class
|
|
% takes two parameters:
|
|
% name of the class
|
|
% status of development
|
|
/newchildclass
|
|
{
|
|
% save parameters
|
|
/status exch def
|
|
/classname exch def
|
|
% save enviroment
|
|
% push this on the stack for onelevelback
|
|
nexty
|
|
newpath
|
|
SetLineWidth
|
|
SetLineColor
|
|
nexty -2.1 mm add
|
|
/nexty exch def
|
|
nextx 11 mm add
|
|
/nextx exch def
|
|
nextx nexty moveto
|
|
0 mm -2.9 mm rlineto
|
|
8 mm 0 mm rlineto stroke
|
|
nexty -2.9 mm add
|
|
/nexty exch def
|
|
classname
|
|
status
|
|
drawbox
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% newclass
|
|
% draws a new class
|
|
% takes two parameters:
|
|
% name of the class
|
|
% status of development
|
|
/newclass
|
|
{
|
|
gsave
|
|
newpath
|
|
SetLineWidth
|
|
SetLineColor
|
|
nextx nexty moveto
|
|
0 mm -5 mm rlineto
|
|
8 mm 0 mm rlineto stroke
|
|
nexty -5 mm add
|
|
/nexty exch def
|
|
drawbox
|
|
grestore
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% newclassxmoved
|
|
% draws a new class
|
|
% takes three parameters:
|
|
% name of the class
|
|
% status of development
|
|
% x offset in points
|
|
%
|
|
% Remark:
|
|
% between newclassxmoved and restoreoldxy have to be a newchildclass,
|
|
% else the output gets scrambled, but don't do a
|
|
% onelevelback should be used, restoreoldxy removes one child level!
|
|
/newclassxmoved
|
|
{
|
|
% save parameters
|
|
/offsetx exch def
|
|
/status exch def
|
|
/classname exch def
|
|
% save enviroment
|
|
% push this on the stack for onemovelevelback
|
|
nextx
|
|
nexty
|
|
newpath
|
|
SetLineWidth
|
|
SetLineColor
|
|
nextx nexty moveto
|
|
0 mm -5 mm rlineto
|
|
8 mm offsetx add 0 mm rlineto stroke
|
|
nexty -5 mm add
|
|
/nexty exch def
|
|
/nextx nextx offsetx add def
|
|
classname status drawbox
|
|
} def
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% restoreoldxy
|
|
% restores old state of nextx and nexty
|
|
/restoreoldxy
|
|
{
|
|
% remove old child y coordinate
|
|
/dummy def
|
|
5 mm sub
|
|
/nexty exch def
|
|
/nextx exch def
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% newlargeheadclass
|
|
% draws a new large class item to the head line (liek tobject)
|
|
% takes two parameters:
|
|
% name of the class
|
|
% status of development
|
|
/newlargeheadclass
|
|
{
|
|
gsave
|
|
newpath
|
|
SetLineWidth
|
|
SetLineColor
|
|
nextx nexty moveto
|
|
8 mm 0 mm rlineto stroke
|
|
drawlargebox
|
|
grestore
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% onelevelback
|
|
% goes one level back in the class hierarchy
|
|
/onelevelback
|
|
{
|
|
/oldy exch def
|
|
newpath
|
|
SetLineWidth
|
|
SetLineColor
|
|
nextx -11 mm add
|
|
/nextx exch def
|
|
nextx oldy moveto
|
|
nextx nexty lineto stroke
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Linuxonly
|
|
% draws the linux icon
|
|
/Linuxonly
|
|
{
|
|
gsave
|
|
newpath
|
|
nexticonx
|
|
nexty 1.25 mm sub
|
|
moveto
|
|
SetClassFont
|
|
StandardTextColor setrgbcolor
|
|
% (Linux)
|
|
% show
|
|
%!!!!!! here we have to update maxx (max. len of the current column)
|
|
grestore
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Win32only
|
|
% draws the win32 icon
|
|
/Win32only
|
|
{
|
|
gsave
|
|
newpath
|
|
nexticonx
|
|
nexty 1.25 mm sub
|
|
moveto
|
|
SetClassFont
|
|
StandardTextColor setrgbcolor
|
|
% (Win32)
|
|
% show
|
|
%!!!!!! here we have to update maxx (max. len of the current column)
|
|
grestore
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Both
|
|
% dummy
|
|
/Both
|
|
{
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% goes to a new column
|
|
% newcolumn
|
|
/newcolumn
|
|
{
|
|
% add 3 mm space
|
|
/nextx maxx 3 mm add def
|
|
/nexty starty def
|
|
SetLineWidth
|
|
SetLineColor
|
|
newpath
|
|
lastlargeobjectx nexty moveto
|
|
nextx nexty lineto stroke
|
|
} def
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% here the class tree follows
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
% TObject
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
(TObject) Ready drawlargebox
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Exception classes
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
(Exception) Missed newchildclass
|
|
(EAbort) Incomplete newchildclass
|
|
(EAbstractError) Missed newclass Linuxonly
|
|
(EDatabaseError) Missed newclass Linuxonly
|
|
(EDBCLient) Missed newchildclass
|
|
(EReconcileError) Missed newchildclass Linuxonly
|
|
onelevelback
|
|
(EDBEngineError) Missed newclass Win32only
|
|
(ENoResultSet) Missed newclass
|
|
(EUpdateError) Missed newclass
|
|
onelevelback
|
|
(EDBEditError) Missed newclass
|
|
(EDSWriter) Missed newclass
|
|
onelevelback
|
|
(OutlineError) Missed newclass
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Some more base classes
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
newcolumn
|
|
(TInterface) Missed 40 mm newclassxmoved
|
|
(TIAddInNotifier) Missed newchildclass
|
|
|
|
restoreoldxy
|
|
(TInterfacedObject) Missed newclass
|
|
|
|
(TList) Ready newclass
|
|
(TLookupList) Missed newclass
|
|
|
|
(TPropertyEditor) Missed 40 mm newclassxmoved
|
|
(TClassProperty) Missed newchildclass
|
|
(TFontProperty) Missed newchildclass
|
|
onelevelback
|
|
(TComponentProperty) Missed newclass
|
|
% remove a childy coordinate
|
|
restoreoldxy
|
|
(TRegistry) Missed newclass
|
|
(TRegIniFile) Missed newchildclass
|
|
onelevelback
|
|
(TSessionList) Missed newclass
|
|
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
% TPersistent classes
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
newcolumn
|
|
(TPersistent) Untested newlargeheadclass
|
|
(TCanvas) Missed newchildclass
|
|
(TControlCanvas) Missed newchildclass
|
|
(TMetafileCanvas) Missed newclass
|
|
onelevelback
|
|
(TClipboard) Missed newclass
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
% TComponent classes
|
|
%%%%%%%%%%%%%%%%%%%%%%%
|
|
newcolumn
|
|
(TComponent) Untested newlargeheadclass
|
|
showpage
|
|
|
|
%
|
|
% $Log$
|
|
% Revision 1.6 1998-10-01 20:40:20 florian
|
|
% * log was written wrong
|
|
%
|
|
% Revision 1.5 1998/10/01 20:39:08 florian
|
|
% + history and log added
|
|
%
|
|
%
|