[pstricks] Ghostscript 9.53 transparency operators
Alexander Grahn
A.Grahn at hzdr.de
Tue Mar 30 18:44:53 CEST 2021
On Tue, Mar 30, 2021 at 06:19:01PM +0200, Herbert Voss wrote:
>I had a bug in the current pstricks.pro! Any change to the code must work
>with GhostScript before and after 9.3
>
>Try the attached example with the modified pstricks.pro
Thanks a lot, Herbert, for fixing pstricks.pro! It works like a charm,
also with Dvisvgm.
Kind regards,
Alexander
>% $Id: pstricks.pro 1055 2019-05-16 11:59:06Z herbert $
>%
>%% PostScript prologue for pstricks.tex.
>%% Version 1.33, 2020/09/21
>%%
>%% This program can be redistributed and/or modified under the terms
>%% of the LaTeX Project Public License Distributed from CTAN archives
>%% in directory macros/latex/base/lppl.txt.
>%
>%
>% Define the follwing gs-functions if not known, eg when using distiller
>%
>
>revision 952 gt
>{
> systemdict /.setopacityalpha known not
> {
> (\n\n%%%% WARNING: Transparency operations ignored - need to use -dALLOWPSTRANSPARENCY\n\n) print flush
> /.setopacityalpha { pop } bind def
> /.setshapealpha { pop } bind def
> }
> {
> /.setopacityalpha /.setfillconstantalpha load def
> /.setblendmode { pop } def
> /.setshapealpha {dup .setfillconstantalpha .setstrokeconstantalpha true .setalphaisshape } def
> } ifelse
>}
>{
> systemdict /.setopacityalpha known not
> {
> (\n\n%%%% WARNING: Transparency operations ignored - need to use -dNOSAFER\n\n) print flush
> /.setopacityalpha { pop } bind def
> /.setshapealpha { pop } bind def
> } if
>} ifelse
>
>%%<bool> .setalphaisshape -
>%% If true, the values set by setstrokeconstantalpha and setfillconstantalpha are interpreted as shape values. The initial value of the AIS flag is false.
>
>%
>/tx at Dict 200 dict def % the main PSTricks dictionary
>tx at Dict begin
>/ADict 25 dict def % The arrow dictionary
>/CM { matrix currentmatrix } bind def
>/SLW /setlinewidth load def
>/CLW /currentlinewidth load def
>/CP /currentpoint load def
>/ED { exch def } bind def
>/L /lineto load def
>/T /translate load def
>/TMatrix { } def
>/RAngle { 0 } def
>/Sqrt { dup 0 lt { pop 0 } { sqrt } ifelse } def % return 0 for negative arguments
>/Atan { /atan load stopped { pop pop 0 } if } def % return 0 if atan not known
>/ATAN1 {neg -1 atan 180 sub } def % atan(x) (only one parameter)
>/Div { dup 0 eq { pop } { div } ifelse } def % control the division
>/Log { dup 1e-20 lt { pop -1e30 }{ log } ifelse } def % control the log
>/tan { dup cos abs 1.e-10 lt
> { pop 1.e10 } % return 1.e10 as infinit
> { dup sin exch cos div } ifelse % default sin/cos
>} def
>/Tan { dup sin exch cos Div } def % sin(x)/cos(x) x in degrees
>/Acos {dup dup mul neg 1 add dup 0 lt { % arc cos, returns 0 when negative root
> pop pop 0 }{ sqrt exch atan} ifelse } def
>/Acos2 { 2 dict begin
> /x ED /y ED
> y abs 1.0e-20 lt { 1.0e30 } if
> x y div
> dup dup mul neg 1 add dup 0 lt { % arc cos needs two values x,y
> pop pop 0 }{ sqrt exch atan} ifelse
> y 0 lt { 180 add } if
>} def
>/Power { % a^b latest ghostscript don't allow -4^-3.1
> 2 dict begin % hold all local
> /b ED
> /a ED
> a 0 lt % prevent something like (-4)^(-3.1)=> 1/(-4)^3
> { b 0 lt
> { a b cvi exp }
> { a b exp } ifelse
> }
> { a 0 eq { 0 }{ a b exp } ifelse
> } ifelse
> end
>} def
>%
>/NET { neg exch neg exch T } def % change coordinate system to the negative one
>/Pyth { dup mul exch dup mul add sqrt } def % Pythagoras, expects 2 parameter
>/addCoors {
> 3 -1 roll % xA xB yB yA
> add % xA xB yB+yA
> 3 1 roll % yB+yA xA xB
> add % yB+yA xA+xB
> exch % xA+xB yA+yB
>} def
>/Pyth2 { % Pythagoras, xA yA xB yB
> 3 -1 roll % xA xB yB yA
> sub % xA xB yB-yA
> 3 1 roll % yB-yA xA xB
> sub % yB-yA xA-xB
> Pyth } def
>/PtoC { 2 copy cos mul 3 1 roll sin mul } def % Polar to Cartesian (original)
>/PtoCrel { pst at angleunit PtoC } def % Polar to Cartesian with \degrees[??]
>/PtoCab { dup cos 4 -1 roll mul 3 1 roll sin mul } def % Polar to Cartesian (Ellipse) a b phi-> x y
>/AnytoDeg { pst at angleunit } def
>/DegtoAny { 1 pst at angleunit div} def
>/AnytoRad { AnytoDeg DegtoRad } def
>/RadtoAny { RadtoDeg DegtoAny } def
>%
>%/Rand { rand 4294967295 div } def % a real random number
>/Rand { rand 2147483447 div } def % a real random number between 0 and 1
>%----------------- hv added 20050516 ---------------
>/PiDiv2 1.57079632680 def
>/Pi 3.14159265359 def
>/TwoPi 6.28318530718 def
>/Euler 2.71828182846 def
>%/e Euler bind def
>%
>/RadtoDeg { 180 mul Pi div } bind def % convert from radian to degrees
>/DegtoRad { Pi mul 180 div } bind def % viceversa
>%
>/startGlobal { true setglobal globaldict begin } bind def
>/endGlobal { end false setglobal } bind def
>/pssetRGBcolor /setrgbcolor load def
>/pssetCMYKcolor /setcmykcolor load def
>/pssetGraycolor /setgray load def
>%
>%----------------- hv end---------------------------
>/PathLength@ { /z z y y1 sub x x1 sub Pyth add def /y1 y def /x1 x def } def
>%
>/PathLength {
> flattenpath /z 0 def
> { /y1 ED /x1 ED /y2 y1 def /x2 x1 def }
> { /y ED /x ED PathLength@ }
> {}
> { /y y2 def /x x2 def PathLength@ }
> /pathforall load stopped { pop pop pop pop } if
> z
>} def
>%
>/STP { .996264 dup scale } def % BP/PT scaling
>/STV { SDict begin normalscale end STP } def %
>%
>/DashLine {
> dup 0 gt
> { /a .5 def PathLength exch div }
> { pop /a 1 def PathLength } ifelse
> /b ED % pattern should fit evenly in b
> dup /X ED % pattern array
> 0 get /y ED % length of first black segment
> /z 0 X {add} forall def % length of the full pattern
> %% Computation of the scaling factor as described by van Zandt:
> b a .5 sub 2 mul y mul sub z Div round
> z mul a .5 sub 2 mul y mul add b exch Div
> %%%% scaling factor on stack.
> /z ED %% now, z is the scaling factor
> false % for the length test below
> X { z mul } forall X astore %% modification TN 04-08-07
> %%% Checking whether at least one dash in X has positive length:
> {0 gt or} forall
> { X 1 a sub y mul }
> { [ 1 0 ] 0 }
> ifelse
> setdash stroke
>} def
>%
>/DotLine {
> /b PathLength def
> /a ED /z ED /y CLW def
> /z y z add def
> a 0 gt {
> /b b a div def
> }{
> a 0 eq {
> /b b y sub def
> }{ a -3 eq {
> /b b y add def } if
> } ifelse
> } ifelse
> [ 0 b b z Div round Div dup 0 le { pop 1 } if ]
> a 0 gt { 0 }{ y 2 div a -2 gt { neg }if } ifelse
> setdash 1 setlinecap stroke
>} def
>%
>/SymbolLine { % on stack [ x y x y ...
> counttomark % number of elements
> 2 div cvi /n ED % n pairs
> /YA ED /XA ED % the start point
> n 1 sub {
> /YB ED /XB ED
> /XLength XB XA sub def
> /YLength YB YA sub def
> /PAngle YLength XLength Atan def
> /XYLength XLength YLength Pyth def
> %% for negative SymStep we calculate the distance
> SymStep 0 lt
> { %XYLength SymStep div abs cvi
> /nSym SymStep abs cvi def }
> { /nSym XYLength SymStep div cvi def }
> ifelse
> 0.5 setflat
> /Shift Symbol stringwidth pop 2 div def
> /deltaX XLength nSym div def
> /deltaY YLength nSym div def
> curveticks
> { XA YA moveto }
> { XA Shift sub YA Shift sub moveto }
> ifelse
> nSym {
> gsave
> curveticks
> { PAngle 180 sub CorrAngle sub tickAngle add /rotAngle ED
> currentpoint translate rotAngle rotate
> 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
> SymbolLinewidth setlinewidth stroke
> }
> {
> rotateSymbol { PAngle 180 sub CorrAngle sub rotate } if
> Symbol show
> }
> ifelse
> grestore
> deltaX deltaY rmoveto
> } repeat
> /YA YB def /XA XB def
> } repeat
> curveticks
> { XA YA moveto }
> { XA Shift sub YA Shift sub moveto }
> ifelse
> gsave
> curveticks
> { PAngle 180 sub CorrAngle sub tickAngle add /rotAngle ED
> XA YA translate rotAngle rotate
> 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
> SymbolLinewidth setlinewidth stroke
> }
> {
> rotateSymbol { PAngle 180 sub CorrAngle sub rotate } if
> Symbol show
> }
> ifelse
> grestore
> pop % delete the mark symbol
>} def
>%
>/LineFill { % hv ------------ patch 7 -------------
> gsave
> abs /hatchWidthInc ED
> abs /hatchSepInc ED
> abs CLW add /a ED
> a 0 dtransform round exch round exch
> 2 copy idtransform
> exch Atan rotate
> idtransform pop /a ED
> .25 .25 itransform pathbbox
> /y2 ED
> a Div ceiling cvi /x2 ED /y1 ED
> a Div cvi /x1 ED /y2 y2 y1 sub def
> clipType % must be defined in pstricks.tex: clip -- eoclip
> newpath
> 2 setlinecap
> systemdict
> /setstrokeadjust known { true setstrokeadjust } if
> x2 x1 sub 1 add {
> x1 a mul y1 moveto 0 y2 rlineto stroke
> /x1 x1 1 add
> hatchWidthInc 0 gt { CLW add } if
> def
> hatchSepInc 0 gt hatchWidthInc 0 gt or {
> /a a hatchSepInc add def
> CLW hatchWidthInc add SLW
> } if
> } repeat
> grestore
> pop pop } def
>%
>/DotFill {% on stack: dot radius
> /dotRadius ED
> abs CLW add /a ED
> a 0 dtransform round exch round exch
> 2 copy idtransform
> exch Atan rotate
> idtransform pop /a ED
> .25 .25 itransform
> pathbbox % llx lly urx ury of smallest bounding box
> /y2 ED /x2 ED /y1 ED /x1 ED
> y2 y1 sub a div 2 add cvi /Ny ED
> x2 x1 sub a div 2 add cvi /Nx ED
> clipType % must be defined in pstricks.tex: clip -- eoclip
> newpath
> /yA y1 dotRadius add CLW add def
> /xA0 x1 dotRadius add CLW add def
> Ny {
> /xA xA0 def
> Nx {
> newpath
> xA yA dotRadius 0 360 arc
> SolidDot { gsave fill grestore } if
> stroke
> xA a add /xA ED
> } repeat
> yA a add /yA ED
> } repeat
> grestore
>} def
>%
>/PenroseFill {% on stack: scaling factor
> /Scale ED
>% 1 exch div round /penroseFactor ED
>% a 0 dtransform round exch round exch
>% 2 copy idtransform
>% exch Atan rotate
>% idtransform pop /a ED
>% .25 .25 itransform pathbbox
>% /y2 ED
>% a Div ceiling cvi /x2 ED /y1 ED
>% a Div cvi /x1 ED /y2 y2 y1 sub def
> clip
> newpath
>gsave
> 220 150 translate
> Scale dup scale
> systemdict /setstrokeadjust known { true setstrokeadjust } if
> /I/S/L/W/G/+/Z/F/E/D[/def/exch/for{E D}/add{s E get mul}
> { Z -36.2001 1 33 }{25 E S rlineto}{/q Z dup q G E q 1 + G}{Z 2 2}]{cvx def}forall
> [0 72 1008 {dup sin E cos }F ]1 setlinejoin/s W{/a W{/b I 10{/i I 4{/m I moveto
> i m +/j I 10{/l Z b m l + G a l G sub s m get div .2 + floor .3 + 25
> mul j l + S rmoveto}F i L j L stroke }F}F}F}F
> grestore
>% pop pop
>} def
>%
>/PenroseFillA {% on stack: scaling factor, border color, kite color, dart color
> /Scale ED
> Scale dup scale
> /border_colour ED
> /kite_colour ED
> /dart_colour ED
> clip
> newpath
> gsave
> 100 100 translate
> 6
> Scale 1 lt { 1 Scale dup add div mul cvi } if %%%% Number of iterations
> 10 %%%% Long side length in millimeters
> /border_width { L 0.06 mul }def %%%% Choose the scalefactor for the borders
> /L exch 25.4 div 72 mul def %%%% Conversion: mm -> inches -> points
> /f{-1 5 sqrt add 2 div}bind def %%%% The reciprocal of the golden ratio
> /l{L f mul}bind def %%%% Short side length l = L*f
> /Ll{L l add}bind def %%%% Ll = L + l
> /c{36 cos L mul}bind def %%%% c = L*cos(36)
> /s{36 sin L mul}bind def %%%% s = L*sin(36)
> /draw_tile { 0 0 moveto c s lineto 0 lineto gsave closepath gsave fill grestore
> 0 setlinewidth stroke grestore border_colour stroke } bind def
> /half_kite { dup dup 0 gt{ 1 sub gsave f f neg scale -36 rotate half_dart
> Ll 0 translate 144 rotate kite grestore }
> { kite_colour L draw_tile }ifelse
> pop } bind def
> /half_dart { dup dup 0 gt{ 1 sub gsave f f scale half_kite
> -144 rotate Ll neg 0 translate half_dart grestore }
> { dart_colour l draw_tile }ifelse
> pop } bind def
> /kite{ gsave half_kite 1 -1 scale half_kite grestore }bind def
> border_width setlinewidth 1 setlinejoin 1 setlinecap
>% 450 0 translate
> dup f exch neg exp dup scale
> 5 {kite 72 rotate } repeat stroke
> grestore
>} def
>%
>%
>/TruchetFill { % on stack: scaling factor
> 10 dict begin
> dup dup scale
> 1 exch div round /penroseFactor ED
> a 0 dtransform round exch round exch
> 2 copy idtransform
> exch Atan rotate
> idtransform pop /a ED
> .25 .25 itransform pathbbox
> /y2 ED
> a Div ceiling cvi /x2 ED /y1 ED
> a Div cvi /x1 ED /y2 y2 y1 sub def
> clip
> newpath
> systemdict
> /setstrokeadjust known { true setstrokeadjust } if
> /ma a neg def
> /ha a 2 div def
> /mha ha neg def
> /tile {
> rand dup 2 idiv 2 mul eq { 90 rotate } if
> mha mha moveto ha mha lineto
> ha ha lineto mha ha lineto
>% closepath .1 setlinewidth stroke
> contents
> } def
> /contents{
> 0 ha moveto ha 0 lineto
> 0 mha moveto mha 0 lineto
>% 1 setlinewidth stroke
> } def
> /dotiling {
> f ma mul a f a mul {
> /i exch def
> f ma mul a f a mul {
> /j exch def
> gsave i j translate
> tile stroke grestore
> } for
> } for
> } def
>%
> /f 3 def
> 5 srand dotiling
> end % local user dict
>} def
>%
>/BeginArrow {
> ADict begin % hold it local, for end see EndArrow
> /@mtrx CM def
> gsave
> 2 copy T
> 2 index sub neg exch
> 3 index sub exch Atan
> rotate newpath
>} def
>%
>/EndArrow { @mtrx setmatrix CP grestore end } def % end the ADict
>%
>/Arrow {
> CLW mul add dup
> 2 div /w ED
> mul dup /h ED
> mul /a ED
> { 0 h T 1 -1 scale } if
> w neg h moveto
> 0 0 L w h L w neg a neg rlineto
> gsave fill grestore
>} def
>%
>/ArrowD { % the sides are drawn as curves (hv 20071211)
> CLW mul add dup
> 2 div /w ED
> mul dup /h ED
> mul /Inset ED
> { 0 h T 1 -1 scale } if % changes the direction
>% we use y=w/h^2 * x^2 as equation for the control points
>% for the coordinates the arrow is seen from top to bottom
>% the bottom (tip) is (0;0)
> w neg h moveto % lower left of >
> w 9 div 4 mul neg h 3 div 2 mul
> w 9 div neg h 3 div
> 0 0 curveto % tip of >
> w 9 div h 3 div
> w 9 div 4 mul h 3 div 2 mul
> w h curveto % upper left of >
> w neg Inset neg rlineto % move to x=0 and inset
> gsave fill grestore
>} def
>%
>/Tbar {
> CLW mul add /z ED
> z -2 div CLW 2 div moveto
> z 0 rlineto stroke
> 0 CLW moveto
>} def
>%
>/Bracket {
> CLW mul add dup CLW sub 2 div
> /x ED mul CLW add /y ED /z CLW 2 div def
> x neg y moveto
> x neg CLW 2 div L x CLW 2 div L x y L stroke
> 0 CLW moveto
>} def
>%
>/RoundBracket {
> CLW mul add dup 2 div
> /x ED mul /y ED /mtrx CM def
> 0 CLW 2 div T x y mul 0 ne { x y scale } if
> 1 1 moveto
> .85 .5 .35 0 0 0 curveto
> -.35 0 -.85 .5 -1 1 curveto
> mtrx setmatrix stroke 0 CLW moveto
>} def
>%
>/SD { 0 360 arc fill } def
>%
>/EndDot { % DS is the dot size
> { /z DS def } { /z 0 def } ifelse % outer or inner dimen
> /b ED % the color definition
> 0 z DS SD
> b { 0 z DS CLW sub SD } if
> 0 DS z add CLW 4 div sub
> moveto
>} def
>%
>/Shadow { [ { /moveto load } { /lineto load } { /curveto load } {
> /closepath load } /pathforall load stopped { pop pop pop pop CP /moveto
> load } if ] cvx newpath 3 1 roll T exec } def
>%
>/NArray { % holds the coordinates and on top of stack the showpoints boolean
> /showpoints ED
> counttomark 2 div dup cvi /n ED % n 2 div on stack
> n eq not { exch pop } if % even numbers of points? delete one
> ] aload /Points ED
> showpoints not { Points aload pop } if
>% { ] aload /Points ED }
>% { n 2 mul 1 add -1 roll pop } ifelse % delete the mark symbol
>} def
>%
>/Line {
> NArray n 0 eq not
> { n 1 eq { 0 0 /n 2 def } if ArrowA /n n 2 sub def
> n { Lineto } repeat
> CP 4 2 roll ArrowB L pop pop
> } if
>} def
>%
>/LineToYAxis {
> /Ox ED % Save the x origin value
> NArray % all x-y pairs on stack
> n { 2 copy moveto % go to current point
> Ox exch Lineto % line to y-axis
> pop % delete old x-value
> } repeat
>} def
>%
>/LineToXAxis{
> /Oy ED % Save the y origin value
> NArray % all x-y pairs on stack
> n 0 eq not
> { n 1 eq { 0 0 /n 2 def } if
> ArrowA
> /n n 2 sub def
> CP 2 copy moveto pop Oy Lineto
> n { 2 copy moveto pop Oy Lineto } repeat
> CP
> 4 2 roll
> ArrowB
> 2 copy moveto pop Oy
> L
> pop pop } if
>} def
>%
>/Arcto {
> /a [ 6 -2 roll ] cvx def
> a r
> /arcto load stopped { 5 } { 4 } ifelse { pop } repeat
> a
>} def
>%
>/CheckClosed {
> dup n 2 mul 1 sub index eq 2 index n 2 mul 1 add index eq
> and { pop pop /n n 1 sub def } if
>} def
>%
>/Polygon {
> NArray n 2 eq { 0 0 /n 3 def } if
> n 3 lt
> { n { pop pop } repeat }
> { n 3 gt { CheckClosed } if
> n 2 mul -2 roll
> /y0 ED /x0 ED /y1 ED /x1 ED
> x1 y1
> /x1 x0 x1 add 2 div def
> /y1 y0 y1 add 2 div def
> x1 y1 moveto
> /n n 2 sub def
> n { Lineto } repeat
> x1 y1 x0 y0 6 4 roll Lineto
> Lineto pop pop closepath } ifelse
>} def
>%
>/SymbolPolygon { % on stack [ x y x y ...
> counttomark % number of elements
> 2 add /m ED
> 2 copy m 2 roll % copy last two
> m 2 div cvi /n ED % n pairs
> /YA ED /XA ED % the start point
> n 1 sub {
> /YB ED /XB ED
> /XLength XB XA sub def
> /YLength YB YA sub def
> /PAngle YLength XLength Atan def
> /XYLength XLength YLength Pyth def
> /nSym XYLength SymStep Div cvi def
> /Shift Symbol stringwidth pop 2 Div def
> /deltaX XLength nSym Div def
> /deltaY YLength nSym Div def
> XA Shift sub YA Shift sub moveto
> nSym {
> gsave rotateSymbol { PAngle 180 sub CorrAngle sub rotate } if
> Symbol show
> grestore
> deltaX deltaY rmoveto
> } repeat
>% XB Shift sub YB Shift sub moveto Symbol show
> /YA YB def /XA XB def
> } repeat
> pop % delete the mark symbol
>} def
>%
>/Diamond {
> /mtrx CM def
> T rotate
> /h ED
> /w ED
> dup 0 eq { pop } { CLW mul neg
> /d ED
> /a w h Atan def
> /h d a sin Div h add def
> /w d a cos Div w add def } ifelse
> mark w 2 div h 2 div w 0 0 h neg w neg 0 0 h w 2 div h 2 div
> /ArrowA { moveto } def
> /ArrowB { } def
> false Line
> closepath mtrx setmatrix } def
>%
>/Triangle {
> /mtrx CM def
> translate
> rotate /h ED 2 div /w ED
> dup CLW mul /d ED
> /h h d w h Atan sin Div sub def
> /w w d h w Atan 2 div dup cos exch sin Div mul sub def
> mark
> 0 d w neg d 0 h w d 0 d
> /ArrowA { moveto } def
> /ArrowB { } def
> false
> Line
> closepath
> mtrx
>% DG/SR modification begin - Jun. 1, 1998 - Patch 3 (from Michael Vulis)
>% setmatrix } def
> setmatrix pop
>} def
>% DG/SR modification end
>%
>/CCA {
> /y ED /x ED
> 2 copy y sub /dy1 ED
> x sub /dx1 ED
> /l1 dx1 dy1 Pyth def
>} def
>%
>/CC {
> /l0 l1 def
> /x1 x dx sub def
> /y1 y dy sub def
> /dx0 dx1 def
> /dy0 dy1 def
> CCA
> /dx dx0 l1 c exp mul dx1 l0 c exp mul add def
> /dy dy0 l1 c exp mul dy1 l0 c exp mul add def
> /m dx0 dy0 Atan dx1 dy1 Atan sub 2 div cos abs b exp a mul dx dy Pyth Div 2 div def
> /x2 x l0 dx mul m mul sub def
> /y2 y l0 dy mul m mul sub def
> /dx l1 dx mul m mul neg def
> /dy l1 dy mul m mul neg def
>} def
>%
>/IC {
> /c c 1 add def
> c 0 lt { /c 0 def } { c 3 gt { /c 3 def } if } ifelse
> /a a 2 mul 3 div 45 cos b exp div def
> CCA
> /dx 0 def
> /dy 0 def
>} def
>%
>/BOC { IC CC x2 y2 x1 y1 ArrowA CP 4 2 roll x y curveto } def
>/NC { CC x1 y1 x2 y2 x y curveto } def
>/EOC { x dx sub y dy sub 4 2 roll ArrowB 2 copy curveto } def
>/BAC { IC CC x y moveto CC x1 y1 CP ArrowA } def
>/NAC { x2 y2 x y curveto CC x1 y1 } def
>/EAC { x2 y2 x y ArrowB curveto pop pop } def
>%
>/OpenCurve {
> NArray n 3 lt
> { n { pop pop } repeat }
> { BOC /n n 3 sub def n { NC } repeat EOC } ifelse
>} def
>%
>/CurvePath {
> %% for negative SymStep we calculate the distance
> SymStep 0 lt { gsave PathLength SymStep div abs /SymStep ED grestore } if
> 0.5 setflat
> flattenpath /z 0 def /z0 0 def
> { /y1 ED /x1 ED /y2 y1 def /x2 x1 def
> x1 Shift sub y1 Shift sub moveto
> gsave
> curveticks
> { x1 y1 translate startAngle rotate
> 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
> SymbolLinewidth setlinewidth stroke
> }
> { startAngle rotate Symbol show }
> ifelse
> grestore /z0 z def }
> { /y ED /x ED PathLength@ z z0 sub SymStep ge {
> x Shift sub y Shift sub moveto
> gsave
> curveticks
> { y yOld sub x xOld sub Atan 180 sub CorrAngle sub /rotAngle ED
> x y translate rotAngle rotate
> 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
> SymbolLinewidth setlinewidth stroke
> }
> {
> rotateSymbol { y yOld sub x xOld sub Atan 180 sub CorrAngle sub rotate } if
> Symbol show
> }
> ifelse
> grestore /z0 z def } if
> /yOld y def /xOld x def }
> {} %% the lineto part
> { /y y2 def /x x2 def PathLength@
> x Shift sub y Shift sub moveto
> gsave
> curveticks
> { y yOld sub x xOld sub Atan 180 sub /rotAngle ED
> x y translate rotAngle rotate
> 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
> SymbolLinewidth setlinewidth stroke
> }
> {
> x Shift sub y Shift sub moveto
> rotateSymbol { y yOld sub x xOld sub Atan 180 sub CorrAngle sub rotate } if
> Symbol show
> }
> ifelse
> grestore
> }
> pathforall
>% curveticks
>% { gsave
>% x y translate rotAngle rotate
>% 0 SymbolWidth 2 div moveto 0 SymbolWidth 2 div neg lineto
>% SymbolLinewidth setlinewidth stroke grestore
>% } if
> z
>} def
>%
>/OpenSymbolCurve {
> OpenCurve
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
>} def
>%
>/AltCurve {
> { false NArray n 2 mul 2 roll
> [ n 2 mul 3 sub 1 roll ] aload
> /Points ED
> n 2 mul -2 roll }
> { false NArray } ifelse
> n 4 lt { n { pop pop } repeat } { BAC /n n 4 sub def n { NAC } repeat EAC } ifelse
>} def
>%
>/AltOpenSymbolCurve {
> AltCurve
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
>} def
>%
>/ClosedCurve {
> NArray n 3 lt
> { n { pop pop } repeat }
> { n 3 gt { CheckClosed } if
> 6 copy n 2 mul 6 add 6 roll
> IC CC x y moveto n { NC } repeat
> closepath pop pop
> } ifelse
>} def
>%
>/ClosedSymbolCurve {
> ClosedCurve
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
>} def
>%
>/CalcBezierSpline {% Christoph Bersch
> 10 dict begin
> /getX { Points exch 2 mul get } def
> /getY { Points exch 2 mul 1 add get } def
> /n Points length 1 sub 2 idiv def
> /GetFirstControlPoints {
> /x n array def
> /tmp n array def
> /b 2 def
> x 0 rhs 0 get b div put
> 1 1 n 1 sub {
> /i exch def
> tmp i 1 b div dup 4 1 roll put
> i n 1 sub lt { 4 }{ 3.5 } ifelse exch sub /b exch def
> x i rhs i get x i 1 sub get sub b div put
> } for
> 1 1 n 1 sub {
> n exch sub
> dup dup x exch 1 sub 2 copy 6 2 roll
> get 3 1 roll tmp exch get
> exch x exch get mul sub
> put
> } for
> x
> } def
> %
> n 1 eq {
> 0 getX 2 mul 1 getX add 3 div
> 0 getY 2 mul 1 getY add 3 div
> exch dup 3 1 roll 2 mul 0 getX sub
> exch dup 3 1 roll 2 mul 0 getY sub
> [ 0 getX 0 getY 7 3 roll 1 getX 1 getY ] /outPoints exch def
> } {
> /outPoints 6 n mul 2 add array def
> 0 1 n {
> dup dup 6 mul dup 1 add
> outPoints exch 5 -1 roll getY put
> outPoints exch 3 -1 roll getX put
> } for
> /rhs n array def
> 1 1 n 2 sub {
> rhs exch dup dup getX 4 mul exch 1 add getX 2 mul add put
> } for
> rhs 0 0 getX 1 getX 2 mul add put
> rhs n 1 sub dup getX 8 mul n getX add 2 div put
> GetFirstControlPoints
> 1 1 n 2 sub {
> rhs exch dup dup getY 4 mul exch 1 add getY 2 mul add put
> } for
> rhs 0 0 getY 1 getY 2 mul add put
> rhs n 1 sub dup getY 8 mul n getY add 2 div put
> GetFirstControlPoints
> 0 1 n 1 sub {
> /i exch def
> 2 copy
> i get outPoints 6 i mul 3 add 3 -1 roll put
> i get outPoints 6 i mul 2 add 3 -1 roll put
> 2 copy
> i n 1 sub lt {
> i 1 add get i 1 add getY 2 mul exch sub outPoints 6 i mul 5 add 3 -1 roll put
> i 1 add get i 1 add getX 2 mul exch sub outPoints 6 i mul 4 add 3 -1 roll put
> }{
> n 1 sub get n getY add 2 div outPoints 6 n 1 sub mul 5 add 3 -1 roll put
> n 1 sub get n getX add 2 div outPoints 6 n 1 sub mul 4 add 3 -1 roll put
> } ifelse
> } for
> pop pop
> } ifelse
> outPoints
> end
>} def
>/Spline {
> /showpoints ED
> counttomark 2 div dup cvi /n ED
> n eq not { exch pop } if
> ] /Points ED
> n 1 gt {
> CalcBezierSpline
> mark exch aload pop
> ArrowA
> n 2 sub {
> 6 2 roll 4 2 roll curveto
> } repeat
> 6 2 roll 4 2 roll ArrowB curveto
> } if
>} def
>/OpenSymbolSpline {
> Spline
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
>} def
>%
>/SQ { /r ED r r moveto r r neg L r neg r neg L r neg r L fill } def
>/ST { /y ED /x ED x y moveto x neg y L 0 x L fill } def
>/SP { /r ED gsave 0 r moveto 4 { 72 rotate 0 r L } repeat fill grestore } def
>%
>/FontDot {
> DS 2 mul dup
> matrix scale matrix concatmatrix exch matrix
> rotate matrix concatmatrix exch
> findfont exch makefont setfont
>} def
>%
>/Rect {
> x1 y1 y2 add 2 div moveto
>% x1 y2 lineto
>% x2 y2 lineto
>% x2 y1 lineto
>% x1 y1 lineto
> x1 y1 lineto % counter clockwise path
> x2 y1 lineto
> x2 y2 lineto
> x1 y2 lineto
> closepath
>} def
>%
>/OvalFrame {
> x1 x2 eq y1 y2 eq or
> { pop pop x1 y1 moveto x2 y2 L }
> { y1 y2 sub abs x1 x2 sub abs 2 copy gt
> { exch pop } { pop } ifelse
> 2 div exch { dup 3 1 roll mul exch } if
> 2 copy lt { pop } { exch pop } ifelse
> /b ED
> x1 y1 y2 add 2 div moveto
> x1 y2 x2 y2 b arcto
> x2 y2 x2 y1 b arcto
> x2 y1 x1 y1 b arcto
> x1 y1 x1 y2 b arcto
> 16 { pop } repeat
> closepath
> } ifelse
>} def
>%
>/Frame {
> CLW mul /a ED
> 3 -1 roll
> 2 copy gt { exch } if
> a sub /y2 ED
> a add /y1 ED
> 2 copy gt { exch } if
> a sub /x2 ED
> a add /x1 ED
> 1 index 0 eq { pop pop Rect } { OvalFrame } ifelse
>} def
>%
>/BezierNArray {
> /f ED
> counttomark 2 div dup cvi /n ED
> n eq not { exch pop } if
> n 1 sub neg 3 mod 3 add 3 mod { 0 0 /n n 1 add def } repeat
> f { ] aload /Points ED } { n 2 mul 1 add -1 roll pop } ifelse
>} def
>%
>/OpenBezier {
> BezierNArray
> n 1 eq
> { pop pop }
> { ArrowA n 4 sub 3 idiv
> { 6 2 roll 4 2 roll curveto } repeat
> 6 2 roll 4 2 roll ArrowB curveto } ifelse
>} def
>%
>/OpenSymbolBezier {
> OpenBezier
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
>} def
>%
>/ClosedBezier {
> BezierNArray
> n 1 eq
> { pop pop }
> { moveto n 1 sub 3 idiv
> { 6 2 roll 4 2 roll curveto } repeat
> closepath } ifelse
>} def
>%
>/ClosedSymbolBezier {
> /f ED % save showpoints value
> 2 copy /yEnd ED /xEnd ED
> counttomark -2 roll 2 copy /yStart ED /xStart ED
> counttomark 2 roll
> f
> ClosedBezier
> 0.1 setflat
> /Shift Symbol stringwidth pop 2 div def
> CurvePath
> [ xEnd yEnd xStart yStart SymbolLine
>} def
>%
>/BezierShowPoints {
> gsave
> Points aload length 2 div cvi /n ED
> moveto
> n 1 sub { lineto } repeat
> CLW 2 div SLW [ 4 4 ] 0 setdash stroke
> grestore
>} def
>%
>/Parab {
> /y0 ED /x0 ED /y1 ED /x1 ED
> /dx x0 x1 sub 3 div def
> /dy y0 y1 sub 3 div def
> x0 dx sub y0 dy add x1 y1 ArrowA
> x0 dx add y0 dy add x0 2 mul x1 sub y1 ArrowB
> curveto
> /Points [ x1 y1 x0 y0 x0 2 mul x1 sub y1 ] def
>} def
>%
>/Parab1 { % 1 end | 0 SP
> /ySP ED /xSP ED /y1 ED /x1 ED
> /dx xSP x1 sub 3 div def
> /dy ySP y1 sub 3 div def
> newpath x1 y1 moveto xSP y1 lineto xSP ySP lineto
> x1 ySP lineto closepath clip
> currentpoint
> newpath moveto
> xSP dx sub ySP dy add x1 y1 ArrowA
> xSP dx add ySP dy add xSP 2 mul x1 sub y1 ArrowB
> curveto
> /Points [ x1 y1 xSP ySP xSP 2 mul x1 sub y1 ] def
>} def
>%
>/Grid {
> newpath
> /a 4 string def
> /b ED % psk at gridlabels in pt
> /c ED % { \pst at usecolor\psgridlabelcolor }
> /n ED % psk at griddots
> cvi dup 1 lt { pop 1 } if
> /s ED % \psk at subgriddiv
> s div dup 0 eq { pop 1 } if
> /dy ED s div dup 0 eq { pop 1 } if % \pst at number\psyunit abs
> /dx ED dy div round dy mul % \pst at number\psxunit abs
> /y0 ED dx div round dx mul
> /x0 ED dy div round cvi
> /y2 ED dx div round cvi
> /x2 ED dy div round cvi
> /y1 ED dx div round cvi
> /x1 ED
> /h y2 y1 sub 0 gt { 1 } { -1 } ifelse def
> /w x2 x1 sub 0 gt { 1 } { -1 } ifelse def
> b 0 gt {
> /z1 b 4 div CLW 2 div add def
>%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
>% Helvetica findfont b scalefont setfont
>% is set in pstricks.tex
>%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
>% /NimbusSanL-Regu findfont b scalefont setfont
> /b b .95 mul CLW 2 div add def } if
> systemdict /setstrokeadjust known
> { true setstrokeadjust /t { } def }
> { /t { transform 0.25 sub round 0.25 add exch 0.25 sub round 0.25 add
> exch itransform } bind def } ifelse
> gsave n 0 gt { 1 setlinecap [ 0 dy n div ] dy n div 2 div setdash } { 2 setlinecap } ifelse
> /i x1 def
> /f y1 dy mul n 0 gt { dy n div 2 div h mul sub } if def
> /g y2 dy mul n 0 gt { dy n div 2 div h mul add } if def
> x2 x1 sub w mul 1 add dup 1000 gt { pop 1000 } if
> dup % run loop two times: lines and labels
> { i dx mul dup xGridOffset add y0 moveto % draw the lines
> dup t f moveto
> g t L stroke
> /i i w add def
> } repeat
> /i x1 def
> GridDX div ceiling cvi
> { i dx mul GridDX mul dup xGridOffset add y0 moveto % plot the labels
> b 0 gt
> { gsave c i GridDX mul a cvs dup stringwidth pop /z2 ED
> w 0 gt {z1} {z1 z2 add neg} ifelse
> h 0 gt {b neg}{z1} ifelse exch GridDX div z2 2 div sub exch
> rmoveto show grestore } if
> /i i w add def
> } repeat
> grestore
> gsave
> n 0 gt
> { 1 setlinecap [ 0 dx n div ] dx n div 2 div setdash }
> { 2 setlinecap } ifelse
> /i y1 def
> /f x1 dx mul n 0 gt { dx n div 2 div w mul sub } if def
> /g x2 dx mul n 0 gt { dx n div 2 div w mul add } if def
> y2 y1 sub h mul 1 add dup 1000 gt { pop 1000 } if
> dup % run loop two times: lines and labels
> { newpath i dy mul dup yGridOffset add x0 exch moveto
> dup f exch t moveto
> g exch t L stroke
> /i i h add def
> } repeat
> /i y1 def
> GridDY div ceiling cvi
> { newpath i dy mul GridDY mul dup yGridOffset add x0 exch moveto
> b 0 gt { gsave c i GridDY mul a cvs dup stringwidth pop
> /z2 ED
> w 0 gt {z1 z2 add neg} {z1} ifelse
> h 0 gt {z1} {b neg} ifelse GridDY div b 2 div sub
> rmoveto show grestore } if
> /i i h add def
> } repeat
> grestore
>} def
>%
>/ArcArrow {
> /d ED /b ED /a ED
> gsave
> newpath 0 -1000 moveto clip
> newpath
> 0 1 0 0 b
> grestore
> c mul
> /e ED
> pop pop pop r a e d PtoC y add exch x add
> exch r a PtoC y add exch x add exch b pop pop pop pop a e d CLW 8 div c
> mul neg d
>} def
>%
>%
>/isbool { type (booleantype) cvn eq } def
>%
>/Ellipse {
> dup isbool { /MoveToStart ED }{ /MoveToStart false def }ifelse % false or true
> /rotAngle ED
> /mtrx CM def
> T
> rotAngle rotate
> scale
> MoveToStart { 0 0 moveto 1 0 rmoveto } if % move to the start position
> 0 0 1 5 3 roll arc
> mtrx setmatrix
>} def
>%
>/ArcAdjust { %%%% Vincent Guirardel
>% given a target length (targetLength) and an initial angle (angle0) [in the stack],
>% let M(angle0)=(rx*cos(angle0),ry*sin(angle0))=(x0,y0).
>% This computes an angle t such that (x0,y0) is at distance
>% targetLength from the point M(t)=(rx*cos(t),ry*sin(t)).
>% NOTE: this an absolute angle, it does not have to be added or substracted to angle0
>% contrary to TvZ's code.
>% To achieve, this, one iterates the following process: start with some angle t,
>% compute the point M' at distance targetLength of (x0,y0) on the semi-line [(x0,y0) M(t)].
>% Now take t' (= new angle) so that (0,0) M(t') and M' are aligned.
>%
>% Another difference with TvZ's code is that we need d (=add/sub) to be defined.
>% the value of d = add/sub is used to know on which side we have to move.
>% It is only used in the initialisation of the angle before the iteration.
>%
>%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
>% Input stack: 1: target length 2: initial angle
>% variables used : rx, ry, d (=add/sub)
>%
> /targetLength ED /angle0 ED
> /x0 rx angle0 cos mul def
> /y0 ry angle0 sin mul def
>% we are looking for an angle t such that (x0,y0) is at distance targetLength
>% from the point M(t)=(rx*cos(t),ry*sin(t)))
>%initialisation of angle (using 1st order approx = TvZ's code)
> targetLength 57.2958 mul
> angle0 sin rx mul dup mul
> angle0 cos ry mul dup mul
> add sqrt div
>% if initialisation angle is two large (more than 90 degrees) set it to 90 degrees
>% (if the ellipse is very curved at the point where we draw the arrow, %
>% the value can be much more than 360 degrees !)
>% this should avoid going on the wrong side (more than 180 degrees) or go near
>% a bad attractive point (at 180 degrees)
> dup 90 ge { pop 90 } if
> angle0 exch d % add or sub
>% maximum number of times to iterate the iterative procedure:
>% iterative procedure: takes an angle t on top of stack, computes a
>% better angle (and put it on top of stack)
> 30 { dup
>% compute distance D between (x0,y0) and M(t)
> dup cos rx mul x0 sub dup mul exch sin ry mul y0 sub dup mul add sqrt
>% if D almost equals targetLength, we stop
> dup targetLength sub abs 1e-5 le { pop exit } if
>% stack now contains D t
>% compute the point M(t') at distance targetLength of (x0,y0) on the semi-line [(x0,y0) M(t)]:
>% M(t')= ( (x(t)-x0)*targetLength/d+x0 , (y(t)-y0)*targetLength/d+y0 )
> exch dup cos rx mul x0 sub exch sin ry mul y0 sub
>% stack contains: y(t)-y0, x(t)-x0, d
> 2 index Div targetLength mul y0 add ry Div exch
> 2 index Div targetLength mul x0 add rx Div
>% stack contains x(t')/rx , y(t')/ry , d
>% now compute t', and remove D from stack
> atan exch pop
> } repeat
>% we don't look at what happened... in particular, if targetLength is greater
>% than the diameter of the ellipse...
>% the final angle will be around /angle0 + 180. maybe we should treat this pathological case...
>% after iteration, stack contains an angle t such that M(t) is the tail of the arrow
>% to give back the result as a an angle relative to angle0 we could add the following line:
>% angle0 sub 0 exch d
>%
>% begin bug fix 2006-01-11
>% we want to adjust the new angle t' by a multiple of 360 so that | t'-angle0 | <= 180
>%(we don't want to make the ellipse turn more or less than it should)...
>dup angle0 sub dup abs 180 gt { 180 add 360 div floor 360 mul sub } { pop } ifelse
>% end bug fix
>} def
>%
>/EllipticArcArrow {
> /d ED % is add or sub
> /b ED % arrow procedure
> /a1 ED % angle
> gsave
> newpath
> 0 -1000 moveto
> clip % Set clippath far from arrow.
> newpath
> 0 1 0 0 b % Draw arrow to determine length.
> grestore
>% Length of arrow is on top of stack. Next 3 numbers are junk.
>%
> a1 exch ArcAdjust % Angular position of base of arrow.
> /a2 ED
> pop pop pop
> a2 cos rx mul xOrig add % hv 2007-08-29 x->xOrig
> a2 sin ry mul yOrig add % hv 2007-08-29 y->yOrig
> a1 cos rx mul xOrig add %
> a1 sin ry mul yOrig add %
>% Now arrow tip coor and base coor are on stack.
> b pop pop pop pop % Draw arrow, and discard coordinates.
> a2 CLW 8 div
>% change value of d (test it by looking if `` 1 1 d '' gives 2 or not )
> 1 1 d 2 eq { /d { sub } def } { /d { add } def } ifelse
> ArcAdjust
>% resets original value of d
> 1 1 d 2 eq { /d { sub } def } { /d { add } def } ifelse % Adjust angle to give overlap.
>} def
>%%------------------ tvz/DG/hv (2004-05-10) end -------------------%%
>%
>/Rot { CP CP translate 3 -1 roll neg rotate NET } def
>%
>/RotBegin {
> tx at Dict /TMatrix known not { /TMatrix { } def /RAngle { 0 } def } if
> /TMatrix [ TMatrix CM ] cvx def
> /a ED
> a Rot /RAngle [ RAngle dup a add ] cvx def
>} def
>%
>/RotEnd {
> /TMatrix [ TMatrix setmatrix ] cvx def
> /RAngle [ RAngle pop ] cvx def
>} def
>%
>/PutCoor { gsave CP T CM STV exch exec moveto setmatrix CP grestore } def
>/PutBegin { /TMatrix [ TMatrix CM ] cvx def CP 4 2 roll T moveto } def
>/PutEnd { CP /TMatrix [ TMatrix setmatrix ] cvx def moveto } def
>%
>/Uput {
> /a ED
> add 2 div /h ED 2
> div /w ED
> /s a sin def
> /c a cos def
> /b s abs c abs 2 copy gt dup
> /q ED
> { pop } { exch pop } ifelse def
> /w1 c b div w mul def
> /h1 s b div h mul def
> q { w1 abs w sub dup c mul abs }{ h1 abs h sub dup s mul abs } ifelse
>} def
>%
>/UUput {
> 5 dict begin
> /z ED
> abs /y ED
> /x ED
> q { x s div c mul abs y gt }{ x c div s mul abs y gt } ifelse
> { x x mul y y mul sub z z mul add sqrt z add }
> { q { x s div } { x c div } ifelse abs
> } ifelse
> a PtoC
> h1 add exch
> w1 add exch
> end
>} def
>%
>end
>%-----------------------------------------------------------------------------%
>%
>% END pstricks.pro
More information about the PSTricks
mailing list.