%!PS
/CompareVal { % [R X Y Theta] [R2 X2 Y2 Theta2 ] CompareXY integer
2 copy 0 get exch 0 get sub
dup 0 eq
{
pop
3 get exch 3 get sub
} {
exch pop exch pop
} ifelse
neg
} bind def
/QSort { % [Array] /CompareFunction QSort [Array']
cvx
1 index 0 get
0 3 index length 1 sub
% [Array] Comp pivot l r
{
2 copy ge { exit } if
{
2 copy ge { exit } if
4 index 1 index get 3 index 5 index
exec 0 lt { exit } if
1 sub
} loop
2 copy ne {
4 index 1 index get
5 index exch 3 index exch put
exch 1 add exch
} if
{
2 copy ge { exit } if
4 index 2 index get 3 index 5 index exec 0 gt { exit } if
exch 1 add exch
} loop
2 copy ne {
4 index 2 index get
5 index exch 2 index exch put
1 sub
} if
} loop
4 index 2 index 4 index put
1 index 1 gt {
4 index 0 3 index getinterval
4 index QSort pop
} if
% [Array] Comp pivot l r
4 index length 1 index 2 add gt {
4 index dup length 3 index sub 1 sub 3 index 1 add exch getinterval
4 index
QSort pop
} if
pop pop pop pop
} bind def
/GenLattice { % N GenLattice [ [r^2 x1 y1 angle] ... ]
[ exch
2 div sqrt 1 add cvi
dup neg exch 1 exch
% [ -X0 1 X0
3 copy {
% [ -X0 1 X0 Y
4 copy pop {
% [ -X0 1 X0 Y X
2 copy [ 3 1 roll
% [ -X0 1 X0 Y X [ Y X
2 copy dup mul exch dup mul add sqrt
3 1 roll
2 index 0 eq { 0 } { 2 copy atan } ifelse
]
% [ -X0 1 X0 Y X [ r^2 Y X theta ]
6 1 roll pop
% [ [] -X0 1 X0 Y
} for
pop
} for
pop pop pop ]
} bind def
/DisplayLatticePoints { % N DisplayLatticePoints -
dup GenLattice /CompareVal QSort
0 1 4 -1 roll
{
1 index exch get aload pop pop
10 string cvs print (, ) print =
pop
} for
pop
} bind def
1000 DisplayLatticePoints
Nemo
#6530()
[
PostScript
]
Rating0/0=0.00
力技で.. Bubble Sort したら遅かったので無理矢理 Quick Sort を実装。まだ荒削りですが。
%!PS /CompareVal { % [R X Y Theta] [R2 X2 Y2 Theta2 ] CompareXY integer 2 copy 0 get exch 0 get sub dup 0 eq { pop 3 get exch 3 get sub } { exch pop exch pop } ifelse neg } bind def /QSort { % [Array] /CompareFunction QSort [Array'] cvx 1 index 0 get 0 3 index length 1 sub % [Array] Comp pivot l r { 2 copy ge { exit } if { 2 copy ge { exit } if 4 index 1 index get 3 index 5 index exec 0 lt { exit } if 1 sub } loop 2 copy ne { 4 index 1 index get 5 index exch 3 index exch put exch 1 add exch } if { 2 copy ge { exit } if 4 index 2 index get 3 index 5 index exec 0 gt { exit } if exch 1 add exch } loop 2 copy ne { 4 index 2 index get 5 index exch 2 index exch put 1 sub } if } loop 4 index 2 index 4 index put 1 index 1 gt { 4 index 0 3 index getinterval 4 index QSort pop } if % [Array] Comp pivot l r 4 index length 1 index 2 add gt { 4 index dup length 3 index sub 1 sub 3 index 1 add exch getinterval 4 index QSort pop } if pop pop pop pop } bind def /GenLattice { % N GenLattice [ [r^2 x1 y1 angle] ... ] [ exch 2 div sqrt 1 add cvi dup neg exch 1 exch % [ -X0 1 X0 3 copy { % [ -X0 1 X0 Y 4 copy pop { % [ -X0 1 X0 Y X 2 copy [ 3 1 roll % [ -X0 1 X0 Y X [ Y X 2 copy dup mul exch dup mul add sqrt 3 1 roll 2 index 0 eq { 0 } { 2 copy atan } ifelse ] % [ -X0 1 X0 Y X [ r^2 Y X theta ] 6 1 roll pop % [ [] -X0 1 X0 Y } for pop } for pop pop pop ] } bind def /DisplayLatticePoints { % N DisplayLatticePoints - dup GenLattice /CompareVal QSort 0 1 4 -1 roll { 1 index exch get aload pop pop 10 string cvs print (, ) print = pop } for pop } bind def 1000 DisplayLatticePointsRating0/0=0.00-0+
[ reply ]