From 098bf061faf05059dd90a3b9ee89bb5d85abebda Mon Sep 17 00:00:00 2001 From: Karl Berry Date: Wed, 11 Jul 2012 00:23:38 +0000 Subject: pst-optexp (10jul12) git-svn-id: svn://tug.org/texlive/trunk@26992 c570f23f-e606-0410-a88d-b1316a301751 --- Master/texmf-dist/dvips/pst-optexp/pst-optexp.pro | 1618 ++++++++++++++++++--- 1 file changed, 1437 insertions(+), 181 deletions(-) (limited to 'Master/texmf-dist/dvips/pst-optexp') diff --git a/Master/texmf-dist/dvips/pst-optexp/pst-optexp.pro b/Master/texmf-dist/dvips/pst-optexp/pst-optexp.pro index 2aff67a4521..991a54f9652 100644 --- a/Master/texmf-dist/dvips/pst-optexp/pst-optexp.pro +++ b/Master/texmf-dist/dvips/pst-optexp/pst-optexp.pro @@ -1,12 +1,79 @@ -% -% PostScript prologue for pst-optexp.tex. -% version 0.3 2009-11-05 (cb) -% For distribution, see pstricks.tex. -% -/tx@OptexpDict 20 dict def +%% +%% This is file `pst-optexp.pro', +%% generated with the docstrip utility. +%% +%% The original source files were: +%% +%% pst-optexp.dtx (with options: `prolog') +%% +%% This is a generated file. +%% +%% Project: pst-optexp +%% Version: 3.0 (2012/07/09) +%% +%% Copyright (C) 2007-2012 by Christoph Bersch +%% +%% This work may be distributed and/or modified under the +%% conditions of the LaTeX Project Public License, either version 1.3c +%% of this license or (at your option) any later version. +%% The latest version of this license is in +%% http://www.latex-project.org/lppl.txt +%% and version 1.3c or later is part of all distributions of LaTeX +%% version 2008/05/04 or later. +%% +%% This work has the LPPL maintenance status "maintained". +%% +%% The current maintainer of this work is Christoph Bersch. +%% +%% This work consists of the files pst-optexp.dtx and pst-optexp.ins +%% and the derived files +%% pst-optexp.sty, pst-optexp.pro. +%% +/tx@OptexpDict 200 dict def tx@OptexpDict begin -% -% str1 str2 append str1str2 +/DebugOE false def +/DebugDepth 0 def +/DebugBegin { + DebugOE { + /DebugProcName ED + DebugDepth 2 mul string + 0 1 DebugDepth 2 mul 1 sub { + dup 2 mod 0 eq { (|) }{( )} ifelse + 3 -1 roll dup 4 2 roll + putinterval + } for + DebugProcName strcat == + /DebugDepth DebugDepth 1 add def + }{ + pop + } ifelse +} bind def +/DebugEnd { + DebugOE { + /DebugDepth DebugDepth 1 sub def + DebugDepth 2 mul 2 add string + 0 1 DebugDepth 2 mul 1 sub { + dup 2 mod 0 eq { (|) }{ ( ) } ifelse + 3 -1 roll dup 4 2 roll + putinterval + } for + dup DebugDepth 2 mul (+-) putinterval + ( done) strcat == + } if +} bind def +/DebugMsg { + DebugOE { + DebugDepth 1 add 2 mul string + 0 1 DebugDepth 2 mul 1 add { + dup 2 mod 0 eq { (|) }{( )} ifelse + 3 -1 roll dup 4 2 roll + putinterval + } for + exch strcat == + }{ + pop + } ifelse +} bind def /strcat { exch 2 copy length exch length add @@ -14,184 +81,1373 @@ tx@OptexpDict begin copy length exch putinterval } bind def -% -% expects: XB YB XA YA XG YG -/calcNodes {% def - /YG exch def /XG exch def - /ay YG 3 -1 roll sub def - /ax XG 3 -1 roll sub def - /by exch YG sub def - /bx exch XG sub def - /a ax ay Pyth def - /modA a def % for external use - /b bx by Pyth def - /cx ax a div bx b div add def - /cy ay a div by b div add def - /c@tmp cx cy Pyth def - /c ax bx add ay by add Pyth def - /OEangle c dup mul a dup mul sub b dup mul sub -2 a b mul mul div Acos def - % - % if c=0, then set the coordinates of the vector manually - % depending on the dotproduct (and thus, if 'a' and 'b' - % are parallel or antiparallel - c 0 eq - {ax bx mul ay by mul add 0 gt - % if dotprod > 0 then a and b are parallel - {/cx ax def - /cy ay def} - % else a and b are antiparallel - {/cx ay def - /cy ax neg def} ifelse - /c@tmp a def - } if - /X@A XG cx c@tmp div add def - /Y@A YG cy c@tmp div add def - /X@B XG cx c@tmp div sub def - /Y@B YG cy c@tmp div sub def - % - % chirality: - % test the order of the input points as a input angle > 90° - % doesn't really make sens. - % So if 'chir' <= 0 exchange the calculated coordinates of - % A and B and otherwise leave it as is - /chirality ax by mul ay bx mul sub def - chirality 0 le - {Y@A X@A - /X@A X@B def - /Y@A Y@B def - /X@B exch def - /Y@B exch def}if -} bind def -% -% called with: R1 height -% leaves on stack: a1 -/segLen {% def +/nametostr { + dup length string cvs +} bind def +/PrintWarning { + (Warning: ) exch strcat == +} bind def +/inttostr { + dup type /integertype eq { + dup log 1 add floor cvi string cvs + } if +} bind def +/IfcCopy { + 2 copy IfcName exch IfcName load dup + length dict copy def + name exch NodeName name 3 -1 roll NodeName + tx@NodeDict begin + load dup length dict copy def + end +} bind def +/calcNodes { + (calcNode) DebugBegin + /YG exch def /XG exch def + /ay YG 3 -1 roll sub def + /ax XG 3 -1 roll sub def + /by exch YG sub def + /bx exch XG sub def + /a ax ay Pyth def + /modA a def + /b bx by Pyth def + /modB b def + /cx ax a div bx b div add def + /cy ay a div by b div add def + /c@tmp cx cy Pyth def + /c ax bx add ay by add Pyth def + /OEangle c dup mul a dup mul sub b dup mul sub + -2 a b mul mul div Acos def + c 0 eq { + ax ay bx by DotProd 0 gt { + /cx ax def + /cy ay def + }{ + /cx ay def + /cy ax neg def + } ifelse + /c@tmp a def + } if + /X@A XG cx c@tmp div add def + /Y@A YG cy c@tmp div add def + /X@B XG cx c@tmp div sub def + /Y@B YG cy c@tmp div sub def + ax by mul ay bx mul sub 0 le { + Y@A X@A + /X@A X@B def + /Y@A Y@B def + /X@B exch def + /Y@B exch def + modA modB /modA exch def /modB exch def + } if + DebugEnd +} bind def +/capHeight { dup mul neg exch abs dup 3 1 roll dup mul add sqrt sub } bind def -% -% called with: height R1 -% leaves on stack: y |R1| alpha_bottom alpha_top R1 -/leftConvex {% def - /R1 exch def /h exch def - /a1 R1 h segLen def - 0 R1 abs - R1 a1 sub neg dup - h exch atan exch - h neg exch atan - /ArcL /arc load def - R1 -} bind def -% -% called with: height R1 -% leaves on stack: y |R1| alpha_bottom alpha_top R1 -/leftConcave {% def - /R1 exch def /h exch def - /a1 R1 h segLen def - 0 R1 abs - R1 neg a1 sub dup - h exch atan exch - h neg exch atan - /ArcL /arcn load def - /a1 0.5 a1 mul def - R1 -} bind def -% -% called with: height R2 -% leaves on stack: y |R2| alpha_bottom alpha_top R2 -/rightConvex {%def - /R2 exch def /h exch def - /a2 R2 h segLen def - 0 R2 abs - R2 a2 sub dup - h neg exch atan exch - h exch atan - R2 - /ArcR /arc load def -} bind def -% -% called with: height R2 -% leaves on stack: y |R2| alpha_bottom alpha_top R2 -/rightConcave {%def - /R2 exch def /h exch def - /a2 R2 h segLen def - 0 R2 abs - R2 a2 add dup - h neg exch atan exch - h exch atan - /ArcR /arcn load def - /a2 0.5 a2 mul def - R2 -} bind def -% -/mwNode {%def - exch 3 1 roll add 2 div 3 1 roll add 2 div exch -} bind def -% -/FiberAngleB {% - N@tempNode@A GetCenter N@tempNode@B GetCenter exch 3 1 roll sub 3 1 roll sub atan -} bind def -% -/FiberAngleA {% - FiberAngleB 180 add -} bind def -% -/ExtNode {% - @@x0 @xref @@x mul add - @@y0 @yref @@y mul add -} bind def -% basicnodename reverse GetInternalNodeNames -/GetInternalNodeNames {% def - /reverse exch def - (N@) exch strcat - 1 % counter - {% counter and name on stack - 2 copy dup 3 string cvs 3 -1 roll exch strcat dup - tx@NodeDict exch known {% - reverse { 4 1 roll pop } { exch 2 add 1 roll } ifelse - } { - reverse { pop pop pop (N) strcat } { pop pop exch (N) strcat exch 1 roll } ifelse - exit - } ifelse - 1 add - } loop -} bind def -% -% basicnodename reverse GetInternalBeamNodes x_n y_n ... x_1 y_1 (if reverse = false) -/GetInternalBeamNodes {% def - [ 3 1 roll GetInternalNodeNames ] - { cvn tx@NodeDict begin load GetCenter end } forall -} bind def -% -% +/leftCurvedIfc { + /R1 exch def /h exch def + 0 R1 abs dup R1 h capHeight exch sub R1 sign mul dup + h exch atan exch + h neg exch atan + R1 0 lt { + /ArcL /arcn load def + } { + /ArcL /arc load def + } ifelse + R1 +} bind def +/rightCurvedIfc { + /R2 exch def /h exch def + 0 R2 abs dup R2 h capHeight sub R2 sign mul dup + h neg exch atan exch + h exch atan + R2 0 lt { + /ArcR /arcn load def + } { + /ArcR /arc load def + } ifelse + R2 +} bind def +/SlopeAngle { + (SlopeAngle) DebugBegin + @GetCenter 3 -1 roll @GetCenter @ABVect exch atan + DebugEnd +} bind def +/DefineExtNode {% + (DefineExtNode) DebugBegin + @@y mul RefFac mul @@y0 add + exch @@x mul RefFac mul @@x0 add exch + DebugEnd +} bind def +/GetInternalNodeNames { + (GetInternalNodeNames) DebugBegin + /reverse ED + dup cvn load /N get dup + reverse { -1 1 } { 1 1 3 -1 roll } ifelse + { 2 copy eq { pop (N) } { inttostr } ifelse + 3 -1 roll dup 4 1 roll exch NodeName 3 1 roll + } for + pop pop + DebugEnd +} bind def +/GetInternalBeamNodes { + (GetInternalBeamNodes) DebugBegin + [ 3 1 roll GetInternalNodeNames ] + { @GetCenter } forall + DebugEnd +} bind def +/GetInternalBeamNodesCompat { + exch dup 3 1 roll (C) NodeName dup tx@NodeDict exch known { + @GetCenter ToVec + 3 1 roll pop pop + } { + pop GetInternalBeamNodes + } ifelse +} bind def +/GetInternalBeamNodeCompat { + exch dup 3 1 roll (C) NodeName dup tx@NodeDict exch known { + @GetCenter ToVec + 3 1 roll pop pop + } { + pop NodeName @GetCenter ToVec + } ifelse +} bind def /InitOptexpComp {% - tx@Dict begin - /@@x 0 def - /@@y 0 def - /@@x0 0 def - /@@y0 0 def - /@xref 0 def - /@yref 0 def + /@@x 0 def + /@@y 0 def + /@@x0 0 def + /@@y0 0 def + /@xref 0 def + /@yref 0 def + /RefFac 1 def +} bind def +/NewTempNodeComp { + (NewTempNodeComp) DebugBegin + /sc ED + dup cvn + 6 dict dup 3 1 roll def begin + /ambiguous false def + /allowbeaminside false def + /name ED + /correct false def + {0 0} exch 3 -1 roll exec + gsave + translate + /CompMtrx CM def + grestore + /N 1 def + /n bgRefIndex def + 5 dict dup dup /P@1 ED /P@N ED + begin + /mode trans def + {} 0 0 PlainIfc + end + /adjustRel true def + end + DebugEnd +} bind def +/CurvedIfc { + 5 2 roll + 2 copy 5 3 roll exec 3 -1 roll exec VecAdd + 5 -1 roll exec /Y ED /X ED + exch exec 3 -1 roll 3 copy exec /RY ED /RX ED + 3 1 roll NormalizeVec 3 -1 roll exec + tx@Dict begin Pyth end dup + 3 1 roll mul 1.00001 mul /NAup ED + mul 1.00001 mul /NAlow ED +} bind def +/PlainIfc { + 5 2 roll + dup 3 -1 roll exec NormalizeVec 3 -1 roll exec 2 copy /DY ED /DX ED + tx@Dict begin Pyth end dup 4 2 roll + exch exec 3 -1 roll exec /Y ED /X ED + 3 1 roll mul 1.00001 mul /NAup ED + mul 1.00001 mul /NAlow ED +} bind def +/NewCompIfc { + /scl ED + /next ED + dup (P@) exch strcat cvn + 6 dict dup + 3 1 roll def + begin + 3 -1 roll + /mode ED + 6 -1 roll dup 7 -1 roll + {scl} 8 -2 roll next + end + exec scl ToVec 3 1 roll NodeName @NewNode +} bind def +/relative 0 def /absolute 1 def /center 2 def +/refl 0 def /trans 1 def /absorb 2 def +/desc 0 def /asc 1 def /amb 2 def +/ok 0 def /tir 1 def /missed 2 def +/bgRefIndex 0 def +/NewOptexpComp { + (NewOptexpComp) DebugBegin + /sc ED dup cvn + gsave + 12 dict dup 3 1 roll def begin + /name ED + /allowbeaminside ED + /ambiguous ED + dup type /booleantype eq not { false } if /correct ED + tx@Dict begin + STV {CP T} stopped pop + end + /CompMtrx CM def + grestore + counttomark dup 6 idiv dup /N ED 6 mul eq { 1 } if + cvx 1 EvalRefIndex /n ED + ambiguous { + /ambIfc ED + }{ + /ambIfc 0 def + } ifelse + 1 N eq { + name (1) 3 -1 roll {sc} NewCompIfc + (1) (N) IfcCopy + }{ + N -1 1 { % + dup N eq { pop (N) }{inttostr} ifelse + exch name 3 1 roll {sc} NewCompIfc + } for + } ifelse + ambiguous ambIfc 0 gt and { + ambIfc N eq { (N) }{ ambIfc inttostr } ifelse (C) IfcCopy + } if + end + pop + DebugEnd +} bind def +/NewOptexpFiberComp { + (NewOptexpFiberComp) DebugBegin + /sc ED dup cvn + gsave + 12 dict dup 3 1 roll def begin + /name ED + tx@Dict begin + STV {CP T} stopped pop + end + /CompMtrx CM def + grestore + counttomark /N ED + 1 N eq { + {0 1} 0 0 trans name (1) {PlainIfc} {sc} NewCompIfc + (1) (N) IfcCopy + }{ + N -1 1 { + dup N eq { pop (N) }{inttostr} ifelse + {0 1} 0 0 absorb name 6 -1 roll {PlainIfc} {sc} NewCompIfc + } for + } ifelse + end + pop + DebugEnd +} bind def +/IfcAlias { + 2 copy IfcName exch IfcName load def + tx@NodeDict begin + name exch NodeName name 3 -1 roll NodeName load def + end +} bind def +/GetPlaneVec { + (GetPlaneVec) DebugBegin + cvn load begin + IfcName load begin + currentdict /RX known { + RX RY CompMtrx dtransform CM idtransform + neg exch + } { + DX DY CompMtrx dtransform CM idtransform + } ifelse + end + end + DebugEnd +} bind def +/GetIfcCenter { + (GetIfcCenter) DebugBegin + dup type /stringtype eq not { + dup xcheck not { + 0 get (C) exch + } { + exec pop pop pop + } ifelse + } if + cvn load begin + IfcName load begin + currentdict /RX known { + X RX sub Y RY sub + } { + X Y + } ifelse + CompMtrx transform CM itransform + end + end + DebugEnd +} bind def +/GetIfcCenter { + (GetIfcCenter) DebugBegin + dup type /stringtype eq not { + dup xcheck not { + 0 get (C) exch + } { + exec pop pop pop + } ifelse + } if + cvn load begin + IfcName load begin + currentdict /RX known { + X RX sub Y RY sub + } { + X Y + } ifelse + CompMtrx transform CM itransform + end + end + DebugEnd +} bind def +/GetIfcCenterCorr { + (GetIfcCenterCorr) DebugBegin + cvn load begin + IfcName load begin + currentdict /XCorr known { + XCorr YCorr + }{ + X Y + } ifelse + currentdict /RX known { + RX neg RY neg VecAdd + } if + CompMtrx transform CM itransform + end + end + DebugEnd +} bind def +/TransformInVec { + (TransformInVec) DebugBegin + 3 1 roll + GetIfcCenter 4 2 roll + GetIfcCenter 5 -2 roll + @ABVect + 3 -1 roll exec 2 copy 6 2 roll + 0 eq exch 0 eq and not { + exch atan matrix rotate dtransform + } { + 4 2 roll pop pop + } ifelse + ToVec + DebugEnd +} bind def +/TransformStartPos { + (TransformStartPos) DebugBegin + exec 2 copy 6 2 roll 0 eq exch 0 eq and not + 3 1 roll GetIfcCenter 4 2 roll + GetIfcCenter 5 2 roll { + 2 copy 8 2 roll + @ABVect exch atan matrix rotate dtransform + VecAdd + } { + 6 2 roll pop pop pop pop + } ifelse + ToVec + DebugEnd +} bind def +/GetNearestPlane { + (GetNearestPlane) DebugBegin + 3 copy 1 exch GetIfcCenter @ABDist /dist ED /nearestPlane 1 def + dup cvn load /N get 2 1 3 -1 roll { + 4 copy exch GetIfcCenter @ABDist dup dist lt { + /dist ED /nearestPlane ED + } { + pop pop + } ifelse + } for + pop pop pop nearestPlane + DebugEnd +} bind def +/PushAmbCompPlanesOnStack { + (PushAmbCompPlanesOnStack) DebugBegin + currentdict /outToPlane undef + PN IfcCnt eq not { + exch dup 3 1 roll % nextifc ambcomp nextifc + dup xcheck not { + 0 get (C) exch + } { + exec pop pop pop + } ifelse + [ 3 1 roll ] cvx /outToPlane ED + } if + /IfcCntTmp IfcCnt def + aload pop /draw ED /name ED + name cvn load /N get /N ED + currentdict /Curr known { + /CurrTmp /Curr load def + /CurrVecTmp /CurrVec load def + } { + /CurrTmp /CurrLow load def + /CurrVecTmp /CurrVecLow load def + } ifelse + PN 1 eq { + [ (C) name name GetRefIndex trans draw] cvx + name /outToPlane load GetNextPlane + dup 0 eq not { + [ exch name bgRefIndex trans draw ] cvx exch + /IfcCntTmp IfcCntTmp 1 add def + } { + pop + } ifelse + }{ + CurrTmp name GetNearestPlane dup /firstPlane ED + name isAmbiguousIfc not { + CurrVecTmp firstPlane name GetPlaneVec NormalVec + (C) name GetIfcCenter firstPlane name GetIfcCenter + @ABVect 2 copy 6 2 roll DotProd + 0 lt { trans }{ refl } ifelse + 3 1 roll ToVec /CurrVecTmp ED + [ firstPlane name + connectifc { + bgRefIndex + }{ + name GetRefIndex + } ifelse + 5 -1 roll true ] cvx + /IfcCntTmp IfcCntTmp 1 add def + } if + PN IfcCnt eq { + [ (C) name + name GetRefIndex + trans draw ] cvx + IfcCntTmp IfcCnt gt { exch } if + } { + [ (C) name + name GetRefIndex + CurrVecTmp (C) name GetPlaneVec NormalVec outToPlane + GetIfcCenter (C) name GetIfcCenter @ABVect DotProd + 0 lt { trans } { refl } ifelse % mode + draw ] cvx + name /outToPlane load GetNextPlane + dup dup name isAmbiguousIfc exch 0 eq or not { + [ exch name bgRefIndex trans draw ] cvx exch + firstPlane name isAmbiguousIfc not { 3 -1 roll } if + /IfcCntTmp IfcCntTmp 1 add def + } { + pop + exec 3 -1 roll pop bgRefIndex 3 1 roll [ 6 1 roll ] cvx + firstPlane name isAmbiguousIfc not { exch } if + } ifelse + } ifelse + } ifelse + /IfcCnt IfcCntTmp def + DebugEnd +} bind def +/GetNextPlane { + (GetNextPlane) DebugBegin + 2 copy (C) 3 -1 roll + GetIfcCenter 3 -1 roll exec GetIfcCenter + 4 2 roll 4 copy @ABVect /VecY ED /VecX ED + @ABDist /centerDist ED + /sprod 1 def + /nextPlane 0 def + exch dup 3 1 roll + cvn load dup /ambIfc get /ambIfc ED /N get 1 1 3 -1 roll { + dup ambIfc eq not { + 3 copy 3 -1 roll 2 copy + GetPlaneVec VecX VecY 4 2 roll NormalVec + VecX VecY DotProd dup sprod lt 5 2 roll + GetIfcCenter 3 -1 roll exec GetIfcCenter @ABDist + centerDist lt and + { /sprod ED /nextPlane ED } { pop pop } ifelse + } { + pop + } ifelse + } for + pop pop nextPlane + DebugEnd +} bind def +/TraceBeam { + (Tracebeam) DebugBegin + AngToVec /InVec ED /StartPoint ED + /oldbeaminsidelast currentdict /beaminsidelast known { + beaminsidelast + } { + false + } ifelse def + exec + connectifc { + /nbeam bgRefIndex def + } if + /startinside startinside beaminsidefirst or def + /stopinside stopinside beaminsidelast or def + /PrevCorrect false def + PrearrangePlanes + PushAllPlanesOnStack + currentdict /lastVecTmp known { + lastVecTmp beamangle matrix rotate dtransform ToVec + } { + beamalign relative eq counttomark 2 ge and { + 2 copy /InVec load TransformInVec + } { + /InVec load + } ifelse + } ifelse + /CurrVec ED + currentdict /lastBeamPointTmp known { + /lastBeamPointTmp load /Curr ED + }{ + counttomark 2 ge { + 2 copy /StartPoint load TransformStartPos + } { + /StartPoint load + } ifelse + /Curr ED + } ifelse + counttomark /IfcCnt ED + /n1 bgRefIndex def + /PN 1 def + (start looping) DebugMsg + { + PN IfcCnt gt { + exit + } if + (checked) DebugMsg + dup xcheck not { + PushAmbCompPlanesOnStack + } if + exec + /draw ED /Mode ED /n2 ED 2 copy /CompName ED /IfcNum ED + GetIfcCenter ToVec /CurrCenter ED + Curr CurrVec + connectifc PrevCorrect PN 2 gt and PN 2 eq or and { + CurrVec CurrCenter PrevCenter PrevMode + currentdict /relAngle known + { relAngle } { 0 } ifelse connectInterfaces + /relAngle ED + } if + IfcNum CompName Mode n2 8 4 roll HandleInterface + missed eq { + counttomark PN 1 sub 3 mul sub {pop} repeat + (The beam missed an interface) Warning exit + exit + } if + PN 1 eq { + pop pop + /draw beaminsidefirst oldbeaminsidelast xor def + } { + ToVec /CurrVec ED + } ifelse + 2 copy + ToVec /Curr ED + draw PN skipconn 1 add gt and + counttomark 3 roll + /PrevCenter /CurrCenter load def + /lastBeamPointTmp /Curr load def + /lastVecTmp /CurrVec load def + /PrevMode Mode def + CompName cvn load /correct get /PrevCorrect ED + PN IfcCnt eq { + exit + } { + CurrVec 0 eq exch 0 eq and { + IfcCnt PN sub {pop} repeat + (Total internal reflection occured, this is not supported) + Warning + exit + } if + /PN PN 1 add def + } ifelse + } loop + DebugEnd +} bind def +/sign { + 0 ge { 1 } { -1 } ifelse +} bind def +/TraceAndFillWideBeam { + (TraceAndFillWideBeam) DebugBegin + AngToVec /InvecLow ED /StartLow ED + AngToVec /InvecUp ED /StartUp ED + exec + connectifc { + /nbeam bgRefIndex def + } if + /startinside startinside beaminsidefirst or def + /stopinside stopinside beaminsidelast or def + /DrawnSegm 0 def + /PrevCorrect false def + PrearrangePlanes + PushAllPlanesOnStack + currentdict /lastVecTmpUp known + currentdict /lastVecTmpLow known and { + /CurrVecLow lastVecTmpLow beamangle matrix rotate dtransform ToVec def + /CurrVecUp lastVecTmpUp beamangle matrix rotate dtransform ToVec def + }{ + beamalign relative eq counttomark 2 ge and { + 2 copy /InvecLow load TransformInVec /CurrVecLow ED + 2 copy /InvecUp load TransformInVec /CurrVecUp ED + } { + /CurrVecLow /InvecLow load def + /CurrVecUp /InvecUp load def + } ifelse + } ifelse + currentdict /lastBeamPointTmpLow known + currentdict /lastBeamPointTmpUp known and { + /lastBeamPointTmpLow load /CurrLow ED + /lastBeamPointTmpUp load /CurrUp ED + } { + counttomark 2 ge { + 2 copy /StartLow load TransformStartPos /CurrLow ED + 2 copy /StartUp load TransformStartPos /CurrUp ED + } { + /StartLow load /CurrLow ED + /StartUp load /CurrUp ED + } ifelse + } ifelse + counttomark /IfcCnt ED + /n1 bgRefIndex def + /CurrR false def + /ret missed def + /PN 1 def + { + PN IfcCnt gt { + exit + } if + dup xcheck not { + PushAmbCompPlanesOnStack + } if + exec + PN skipconn 1 add gt and /draw ED + /Mode ED /n2 ED 2 copy /CompName ED /IfcNum ED + GetIfcCenter ToVec /CurrPCenter ED + /oldn1 n1 def + CurrUp CurrVecUp + connectifc PrevCorrect PN 2 gt and PN 2 eq or and { + CurrVecUp CurrPCenter PrevPCenter PrevMode + currentdict /relAngleUp known { relAngleUp } { 0 } ifelse + connectInterfaces /relAngleUp ED + } if + /CurrVecUp load /PrevVecUp ED + /CurrUp load /PrevUp ED + IfcNum CompName Mode n2 8 4 roll HandleInterface + dup /ret ED + missed eq { + counttomark {pop} repeat + (The upper beam missed an interface) Warning exit + } if + ToVec /CurrVecUp ED + ToVec /CurrUp ED + /n1 oldn1 def + /CurrVecLow load /PrevVecLow ED + /CurrLow load /PrevLow ED + CurrLow CurrVecLow + connectifc PrevCorrect PN 2 gt and PN 2 eq or and { + CurrVecLow CurrPCenter PrevPCenter PrevMode + currentdict /relAngleLow known { relAngleLow } { 0 } ifelse + connectInterfaces /relAngleLow ED + } if + IfcNum CompName Mode n2 8 4 roll HandleInterface + dup missed eq { + /ret ED + (The lower beam missed an interface) Warning + counttomark {pop} repeat exit + } if + tir eq ret tir eq or { + /ret tir def + } { + /ret ok def + } ifelse + ToVec /CurrVecLow ED + ToVec /CurrLow ED + /PrevR CurrR def + PrevR type /realtype eq { + /CurrCenter load /PrevCenter ED + } if + IfcNum CompName isCurved { + IfcNum CompName LoadIfc + tx@Dict begin Pyth end /CurrR ED + ToVec /CurrCenter ED + } { + /CurrR false def + /CurrCenter false def + } ifelse + PN 1 gt currentdict /fillBeam known and { + draw { + /DrawnSegm DrawnSegm 1 add def + PrevUp moveto CurrUp lineto + IfcNum CompName isCurved { + CurrCenter CurrUp CurrLow + 4 copy 3 -1 roll eq 3 1 roll eq and { + 6 {pop} repeat + } { + TangentCrosspoint + CurrLow CurrR arct + } ifelse + } { + CurrLow lineto + } ifelse + PrevLow lineto + PrevR type /booleantype eq not { + PrevCenter PrevLow PrevUp + 4 copy 3 -1 roll eq 3 1 roll eq and { + 6 {pop} repeat + } { + TangentCrosspoint + PrevUp PrevR arct + } ifelse + } { + PrevUp lineto + } ifelse + } if + Mode refl eq draw and + draw not DrawnSegm 0 gt and or { + fillBeam newpath + /DrawnSegm 0 def + } if + } if + PN 1 eq { + /CurrVecUp /PrevVecUp load def + /CurrVecLow /PrevVecLow load def + } if + strokeBeam { + CurrUp draw CurrLow draw counttomark 1 add 6 roll + } if + PN IfcCnt eq ret tir eq or { + DrawnSegm 0 gt currentdict /fillBeam known and { + fillBeam newpath + /DrawnSegm 0 def + } if + ret tir eq { + IfcCnt PN sub {pop} repeat + (Total internal reflection occured, this is not supported) + Warning + } if + exit + } if + /PN PN 1 add def + /PrevPCenter /CurrPCenter load def + /PrevMode Mode def + CompName cvn load /correct get /PrevCorrect ED + } loop + DrawnSegm 0 gt currentdict /fillBeam known and { + fillBeam newpath + /DrawnSegm 0 def + } if + ret missed eq not { + CurrUp CurrLow @ABVect + CurrVecUp CurrVecLow 3 -1 roll add 3 1 roll add exch + 4 -1 roll mul 3 1 roll mul sub 0 gt { + /lastBeamPointTmpUp /CurrLow load def + /lastBeamPointTmpLow /CurrUp load def + /lastVecTmpUp /CurrVecLow load def + /lastVecTmpLow /CurrVecUp load def + } { + /lastBeamPointTmpLow /CurrLow load def + /lastBeamPointTmpUp /CurrUp load def + /lastVecTmpUp /CurrVecUp load def + /lastVecTmpLow /CurrVecLow load def + } ifelse + } if + DebugEnd +} bind def +/isAmbiguous { + cvn load dup /ambiguous known { + /ambiguous get + } { + pop false + } ifelse +} bind def +/isAmbiguousIfc { + cvn load dup /ambiguous known { + /ambIfc get eq + } { + pop pop false + } ifelse +} bind def +/isCurved { + cvn load begin + IfcName load /RX known + end +} bind def +/HandleInterface { + (HandleInterface) DebugBegin + /Yin ED /Xin ED /Y0 ED /X0 ED /n2 ED /mode ED + 2 copy 2 copy LoadIfc + 6 -2 roll isCurved { CurvedInterface }{ PlainInterface } ifelse + dup missed eq not useNA connectifc not and and { + 7 3 roll 2 copy 9 2 roll + 4 2 roll 2 copy + %% X0' Y0' Xout Yout status X0' Y0' IfcNum CompName IfcNum CompName + cvn load begin IfcName load dup /NAlow get exch /NAup get end + 2 copy lt { + 4 2 roll 2 copy LoadIfc NormalizeVec + 6 -2 roll isCurved { + neg exch + } if + %% ... X0' Y0' NAlow NAup X Y dXp dYp + 8 -2 roll 6 -2 roll + %% ... NAlow NAup dXp dYp X0' Y0' X Y + @ABVect DotProd + dup 4 -1 roll ge 3 1 roll ge and not + { + pop missed + } if + }{ + 6 {pop} repeat + } ifelse + } { + 7 -2 roll pop pop + } ifelse + DebugEnd +} bind def +/LoadIfc { + (LoadIfc) DebugBegin + cvn load begin + IfcName load begin + X Y + CompMtrx transform CM itransform + currentdict /RX known { RX RY }{ DX DY } ifelse + CompMtrx dtransform CM idtransform + end + end + DebugEnd +} bind def +/isFreeray { + cvn load /n known + dup not { + (Encountered fiber component in beam path) Warning + } if +} bind def +/PrearrangePlanes { + (PrearrangePlanes) DebugBegin + counttomark /N ED + /CompA ED dup /CompB ED + CompA isFreeray { + CompA isAmbiguous { + amb dup CompA + } { + CompB isAmbiguous { + 1 CompA GetIfcCenter (C) CompB GetIfcCenter @ABDist + (N) CompA GetIfcCenter (C) CompB GetIfcCenter @ABDist + } { + 1 CompA GetIfcCenter + 1 CompB GetIfcCenter + (N) CompB GetIfcCenter + true OrderNodes exch pop + (N) CompA GetIfcCenter + 1 CompB GetIfcCenter + (N) CompB GetIfcCenter + true OrderNodes exch pop + } ifelse + le { desc } { asc } ifelse dup CompA + } ifelse + counttomark 2 roll + } { + counttomark 1 sub { pop } repeat + /N 0 def + } ifelse + 2 1 N { + /i ED exch /CompB ED + CompB isFreeray not { + counttomark i 1 sub 2 mul 1 add sub { pop } repeat + exit + } if + CompB isAmbiguous not { + dup desc eq { 1 } { dup amb eq { (C) }{ (N) } ifelse } ifelse + CompA GetIfcCenter + 1 CompB GetIfcCenter + (N) CompB GetIfcCenter false OrderNodes dup dup + 4 -1 roll CompA exch 5 -1 roll CompB exch + i 2 eq { + 4 copy 4 2 roll AdjustRelRot + } if + AdjustRelRot + } { + pop amb dup + } ifelse + CompB /CompA CompB def + counttomark 2 roll + } for pop + DebugEnd +} bind def +/AdjustRelRot { + (AdjustRelRot) DebugBegin + exch dup cvn load /adjustRel known { + dup dup 4 2 roll isAmbiguous { + exch pop (C) + }{ + desc eq { (N) }{ 1 } ifelse + } ifelse + exch GetIfcCenter 5 3 roll + exch dup 3 1 roll isAmbiguous { + pop (C) + }{ + desc eq { 1 }{ (N) } ifelse + } ifelse + exch GetIfcCenter + @ABVect exch atan exch + cvn load begin + adjustRel { + matrix rotate CompMtrx matrix concatmatrix /CompMtrx ED + /adjustRel false def + } { + pop + } ifelse + end + } { + pop pop pop pop + } ifelse + DebugEnd +} bind def +/PushAllPlanesOnStack { + (PushAllPlanesOnStack) DebugBegin + counttomark 2 div cvi /@N ED + 1 1 @N { + /last false def + /first false def + dup 1 eq { + /first true def pop beaminsidefirst + } { + @N eq { + beaminsidelast + /last true def + } { + beaminside + } ifelse + } ifelse + exch load dup dup /allowbeaminside get 4 -1 roll and + /drawinside ED + /ambiguous get { + /name get drawinside [ 3 1 roll ] + counttomark 1 roll pop + } { + begin + desc eq { + N N -1 1 1 + } { + 1 1 1 N N + } ifelse + first startinside not and { + 5 -2 roll + pop pop + 2 copy 5 2 roll + } if + 5 1 roll + { + 3 1 roll 2 copy 5 -1 roll + dup 3 1 roll + eq first not and { + true + } { + drawinside + } ifelse + exch dup 4 -1 roll eq { + bgRefIndex + }{ + name GetRefIndex + } ifelse + exch dup N eq { + pop (N) + } { + inttostr + } ifelse exch + 3 1 roll name + 4 1 roll + dup IfcName load /mode get + 3 1 roll 5 1 roll + [ 6 1 roll ] cvx counttomark 1 roll + last { + savebeampoints 1 ge stopinside not and + savebeampoints 1 lt beaminsidelast not and or { + exit + } if + } if + } for pop pop + end + } ifelse + } for + DebugEnd +} bind def +/IfcName { + dup dup 1 eq not exch N eq and { + pop (N) + } { + inttostr + } ifelse + (P@) exch strcat cvn +} bind def +/NodeName { + dup /stringtype eq not { inttostr } if + strcat (N@) exch strcat cvn +} bind def +/OrderNodes { + 7 1 roll 6 -2 roll 2 copy 8 2 roll + @ABDist 5 1 roll @ABDist 2 copy gt { + pop asc exch + } { + exch pop desc exch + } ifelse + 3 -1 roll not { + pop + } if +} bind def +/NormalVec { + neg exch 2 copy 6 2 roll DotProd 0 gt { + -1 mul exch -1 mul exch + } if + NormalizeVec +} bind def +/DotProd { + 3 -1 roll mul 3 1 roll mul add +} bind def +/VecAngle { + 4 copy 4 copy DotProd 5 1 roll + tx@Dict begin + Pyth 3 1 roll Pyth + end mul + div Acos + 5 2 roll mul 4 1 roll 3 -1 roll mul 3 -1 roll sub + 0 le { -1 }{ 1 } ifelse mul +} bind def +/VecAdd { + 3 -1 roll add 3 1 roll add exch +} bind def +/VecScale { + dup 4 -1 roll mul 3 1 roll mul +} bind def +/ToVec { + [ 3 1 roll ] cvx +} bind def +/AngToVec { + dup cos exch sin ToVec +} bind def +/NormalizeVec { + 2 copy + tx@Dict begin + Pyth + end + dup 3 1 roll div 3 1 roll div exch +} bind def +/@ABVect { + tx@EcldDict begin ABVect end +} bind def +/@ABDist { + tx@EcldDict begin ABDist end +} bind def +/@InterLines { + tx@EcldDict begin + EqDr /D1c exch def /D1b exch def /D1a exch def + EqDr /D2c exch def /D2b exch def /D2a exch def + D1a D2b mul D1b D2a mul sub dup + ZeroEq { % parallel lines + pop 0 0 missed + }{ + /Det exch def + D1b D2c mul D1c D2b mul sub Det div + D1a D2c mul D2a D1c mul sub Det div + ok + } ifelse + end +} bind def +/@GetCenter { + tx@NodeDict begin load GetCenter end +} bind def +/@NewNode { + tx@NodeDict begin + false exch 10 {InitPnode } NewNode + end +} bind def +/RefractVec { + (RefractVec) DebugBegin + TransformRefIndex exch TransformRefIndex exch div /n ED + /Ynorm ED /Xnorm ED + NormalizeVec /Yin ED /Xin ED + n abs 1 eq { + Xin Yin + }{ + /costheta1 Xnorm Ynorm Xin neg Yin neg DotProd def + 1 n dup mul 1 costheta1 dup mul sub mul sub + dup 0 lt { + pop 0 0 + } { + sqrt /costheta2 ED + n Xin mul n Yin mul + n costheta1 mul costheta2 sub dup + Xnorm mul exch Ynorm mul VecAdd + } ifelse + } ifelse + DebugEnd +} bind def +/ReflectVec { + (ReflectVec) DebugBegin + /Ynorm ED /Xnorm ED NormalizeVec /Yin ED /Xin ED + /costheta1 Xnorm Ynorm Xin neg Yin neg DotProd def + Xin Yin 2 costheta1 mul dup Xnorm mul exch Ynorm mul VecAdd + DebugEnd +} bind def +/CurvedInterface { + (CurvedInterface) DebugBegin + 2 copy /Yr ED /Xr ED + tx@Dict begin Pyth end /radius ED /Yp ED /Xp ED + /X0n X0 Xp sub def /Y0n Y0 Yp sub def + tx@EcldDict begin + X0n Y0n 2 copy 2 copy Xin 3 -1 roll add Yin 3 -1 roll add + 2 copy 6 2 roll EqDr radius InterLineCircle + end + 4 copy + 0 eq 3 {exch 0 eq and} repeat { + missed + } { + 4 copy + Xr neg Yr neg 2 copy + 8 -2 roll @ABDist + 5 1 roll @ABDist + gt { + 4 2 roll + } if pop pop + Xp Yp VecAdd + 2 copy Xp Yp 4 2 roll @ABVect exch neg Xin Yin 4 2 roll NormalVec + Xin Yin 4 2 roll + mode trans eq { + n1 n2 RefractVec + 2 copy 0 eq exch 0 eq and { tir } { ok } ifelse + } { + ReflectVec ok + } ifelse /n1 n2 def + 5 -2 roll 2 copy 7 2 roll X0 Y0 @ABVect Xin Yin DotProd 0 lt + PN 1 gt and { + pop missed + } if + } ifelse + DebugEnd +} bind def +/PlainInterface {% + (PlainInterface) DebugBegin + /dYp ED /dXp ED /Yp ED /Xp ED + Xp Yp Xp dXp add Yp dYp add X0 Y0 X0 Xin add Y0 Yin add + @InterLines missed eq { + 0 0 missed + } { + Xin Yin Xin Yin dXp dYp NormalVec + mode trans eq { + n1 n2 RefractVec + 2 copy 0 eq exch 0 eq and { tir } { ok } ifelse + } { + ReflectVec ok + } ifelse /n1 n2 def + 5 -2 roll 2 copy 7 2 roll X0 Y0 @ABVect Xin Yin DotProd 0 lt + PN 1 gt and { + pop missed + } if + } ifelse + DebugEnd +} bind def +/TransformRefIndex { + dup bgRefIndex eq { pop 1 } if +} bind def +/GetRefIndex { + cvn load /n get /nbeam load exch + EvalRefIndex +} bind def +/EvalRefIndex { + dup bgRefIndex eq not { + 1 dict begin + /n ED + exec end + } if +} bind def +/Sellmaier { + dup mul + dup dup 1.03961212 mul exch 6000.69867 sub div + exch dup dup 0.231792344 mul exch 20017.9144 sub div + exch dup 1.01046945 mul exch 103.560653e6 sub div + add add 1 add sqrt +} bind def +/TangentCrosspoint { + 4 copy 4 copy 14 -2 roll 2 copy + 6 2 roll @ABVect neg exch + 6 2 roll @ABVect neg exch + 8 -2 roll VecAdd 10 2 roll VecAdd + @InterLines pop +} bind def +/NearestNodeTmp { + exch /NodeB ED + /dist -1 def + dup cvn load /N get dup 1 eq { + [ exch (N) ] + } { + [ exch 1 1 3 -1 roll { } for ] + } ifelse + { + 2 copy pop + GetIfcCenterCorr 2 copy + NodeB @ABDist + dist 0 lt { + /dist ED + ToVec /node ED + } { + dup dist lt { + /dist ED + ToVec /node ED + } { + pop pop pop + } ifelse + } ifelse + } forall + pop dist /node load +} bind def +/NearestNode { + (NearestNode) DebugBegin + dup xcheck not { nametostr } if /CompB ED + dup xcheck not { + nametostr /CompA ED + /CompB load dup xcheck not { + /mindist -1 def + [ exch false GetInternalNodeNames ] + { @GetCenter ToVec + CompA NearestNodeTmp + exch dup mindist ge mindist 0 ge and { + pop pop + }{ + /mindist ED /minnodeA ED + } ifelse + } forall + minnodeA + } { + CompA NearestNodeTmp exch pop exec + } ifelse + } { + exec + } ifelse + DebugEnd } bind def -% -% defaultbasicnodename basicnodename CloseOptexpComp -/CloseOptexpComp {% def - 2 copy eq { - exch pop [ exch false GetInternalNodeNames ] { tx@NodeDict exch undef } forall - } { pop pop } ifelse -} bind def -% -% xa ya xb yb ExchCoor true|false -/ExchCoor {% def - exch 4 -1 roll% ya yb xb xa - 2 copy % ya yb xb xa - gt - { pop pop pop pop false } % xB > xA - { eq % xA == xB - 3 1 roll gt % yA < yB - and - { false } - { true } ifelse +/RelFiberAngle { + (RelFiberAngle) DebugBegin + /fiberalign ED + dup xcheck not { nametostr } if /CompB ED + dup xcheck not { nametostr } if /CompA ED + /CompA load xcheck { + /CompB load xcheck { + @ABVect exch atan + } { + 4 copy @ABVect 6 2 roll pop pop 2 copy + CompB (Center) NodeName @GetCenter + 4 2 roll @ABVect 4 2 roll + CompB + fiberalign center eq { + RelFiberAngle@center + }{ + RelFiberAngle@ref + } ifelse + 2 copy exch atan + 7 3 roll 2 copy 9 -2 roll + DotProd 0 gt 5 1 roll DotProd 0 gt xor { 180 add } if } ifelse + } { + 4 2 roll pop pop 2 copy + CompA (Center) NodeName @GetCenter + 4 2 roll @ABVect 4 2 roll + CompA fiberalign center eq { + RelFiberAngle@center + }{ + RelFiberAngle@tref + } ifelse + 2 copy exch atan + 5 1 roll DotProd 0 gt { 180 add } if + } ifelse + DebugEnd +} bind def +/RelFiberAngle@ref { + 3 1 roll pop pop + dup (A) NodeName exch (B) NodeName + @GetCenter 3 -1 roll @GetCenter @ABVect +} bind def +/RelFiberAngle@tref { + 3 1 roll pop pop + dup (TrefA) NodeName exch (TrefB) NodeName + @GetCenter 3 -1 roll @GetCenter @ABVect +} bind def +/RelFiberAngle@center { + (Center) NodeName @GetCenter 4 2 roll @ABVect +} bind def +/getsubnode { + dup xcheck { + exch pop exec + } { + nametostr exch nametostr exch GetIfcCenter + } ifelse +} bind def +/connectInterfaces { + /relAngleTmp ED + PN 2 eq { + pop @ABVect NormalizeVec 4 2 roll VecAngle /relAngleTmp ED + } if + PN 3 ge { + trans eq { + @ABVect NormalizeVec 4 2 roll pop pop % remove Vec from stack + relAngleTmp matrix rotate dtransform + 4 2 roll pop pop + } { + @ABVect NormalizeVec 4 2 roll VecAngle /relAngleTmp ED + } ifelse + } if + relAngleTmp +} bind def +/GetCompRange { + 2 copy gt { 1 }{ -1 } ifelse 3 -1 roll + { exch dup 3 -1 roll inttostr strcat exch} for + pop +} bind def +/CorrectDipoleIfc { + (CorrectDipoleIfc) DebugBegin + dup dup 3 copy + 8 -1 roll dup 9 1 roll NodeName exch 7 -1 roll dup 7 1 roll NodeName + gsave + tx@Dict begin + STV CP T + exch @GetCenter 3 -1 roll @GetCenter + end + grestore + 4 copy @ABDist 1e-7 lt { + 6 -1 roll + gsave + tx@Dict begin + STV CP T + (TrefA) NodeName @GetCenter 7 -1 roll + (TrefB) NodeName @GetCenter + end + grestore + @ABVect NormalizeVec 2 copy + 8 -2 roll abs exch abs max -1e-6 mul VecScale + 8 -2 roll cvn load begin + IfcName load begin + X Y VecAdd /YCorr exch def /XCorr exch def + end + end + 4 2 roll abs exch abs max 1e-6 mul VecScale + 4 2 roll cvn load begin + IfcName load begin + X Y VecAdd /YCorr exch def /XCorr exch def + end + end + } { + 10 { pop } repeat + } ifelse + DebugEnd +} bind def +/debug { + /@N ED count dup @N gt @N 0 ge and { pop @N } if + copy @N { == } repeat +} bind def +/debugComp { + dup (debug comp ") exch strcat ("===============) strcat == + cvn load { + dup type /dicttype eq { + (plane----------------) == + { == == } forall + (-----------done) == + } { == } ifelse + == + } forall + (================== done) == } bind def end % tx@OptexpDict -- cgit v1.2.3