andy@ecrcvax.UUCP (Andrew Dwelly) (07/21/88)
Just before last Christmas, John Pratt posted a postscript program to draw an
accurate copy of Escher's square limit program (a la Henderson), for various
reasons the program did not work under NeWS 1.0 (bugs, missing primitives etc.).
What follows is a version that works under NeWS 1.1
John doesn't have access to the net currently, so I am posting, and collecting
replies and comments which I will forward to him.
Andy
------------------------------------------------------------------------------
#!/usr/NeWS/bin/psh
% TRIANGULAR-DIVISION
% Copyright John M. Pratt. ECRC Arabellastr 17, D8000 Munich 81
% -- With acknowledgements to M.C.Escher.
% Produces a facsimile of "Square Limit.
% Executes under psh, adapts to window size, and provides menu for rotation
% Prepared as a exercise of graphic transformation, and curve drawing under NeWS
/Fishdict 200 dict def Fishdict begin
/Helvetica-Bold findfont 0.5 scalefont setfont
% COLOUR CONTROLS
/Colourdisplay false def
/Parity 0 def /Swap {/Parity 0.5 Parity sub def} def %Parity is 0 or 0.5
/Colour 0 def %colour variable
/Dark {/Colour Parity def Colour Set-Colour} def
/Light {/Colour 0.5 Parity sub def Colour Set-Colour} def
/White {/Colour 1 def Set-White} def
/Comp {Colour 1 ne {Set-White} {Parity Set-Colour} ifelse} def
/De-Comp{Colour 1 eq {Set-White} {Colour Set-Colour} ifelse} def
/Set-Colour { Colourdisplay {1 0.5 sethsbcolor} {setgray} ifelse} def
/Set-White { Colourdisplay {0 0 1 sethsbcolor} {1 setgray} ifelse } def
% CONSTANTS AND PRECALCULATED TRANSFORMS
/cm {28.35 mul} def
/HeadMatrix [-0.5 0.5 0.5 0.5 0 10] def
% 0 10 translate -Invroot2 Invroot2 scale 45 rotate
/UpheadMatrix [-1 1 1 1 -10 -10] def
% -45 rotate Root2 neg Root2 scale 0 -10 translate
/TailMatrix [-0.5 -0.5 -0.5 0.5 0 10] def
% 0 10 translate -Invroot2 Invroot2 scale -45 rotate
/UptailMatrix [-1 -1 -1 1 10 -10] def
% 45 rotate Root2 -Root2 scale 0 -10 translate
/Op1 [-1 0 0 -1 0 20] def %matrix for duple opposite
%0 10 translate 180 rotate 0 -10 translate
/Head-to-headMatrix [0.5 -0.5 -0.5 -0.5 10 20] def
%Op1 HeadMatrix matrix concatmatrix
/Transform { 3 dict begin %simulates -- X Y matrix transform
/Mat exch def /Y exch def /X exch def
Mat 0 get X mul Mat 2 get Y mul Mat 4 get add add %X` on stack
Mat 1 get X mul Mat 3 get Y mul Mat 5 get add add %Y` on stack
end } def
/Downtail {TailMatrix concat} def %apply to CTM
/Op {Op1 concat} def %apply to CTM
/DwnR {HeadMatrix Transform} def %applies Head matrix to point
/UpR {UpheadMatrix Transform} def %applies UpHead matrix to point
/DwnL {TailMatrix Transform} def %applies Tail matrix to point
/UpL {UptailMatrix Transform} def %applies UpTail matrix to point
/Opp {Op1 Transform} def %applies opposite matrix to point
/Qflip {exch neg exch} def %Flip by X, X/Y point 180
/Qrot90 {exch neg} def %rotate X/Y point -90
/Qrotm90 {neg exch } def %rotate X/Y point 90
/Qxtran {3 -1 roll add exch} def %adds top to 3rd, X
/* {aload pop} bind def
% POINTS defined as [X Y]
/A [10 10] def /A1 [9 8] def /A2 [7.5 6.2] def
/Ah [A * -1 Qxtran -0.5 add ] def
/B [6 5.6] def /B1 [4.8 5] def /B2 [2.2 4.5] def
/C [0 5] def /C1 [-1.1 5.3] def /C2 [-4.2 6] def
/D [B * Qrotm90] def /D1 [A1 * Qrotm90] def /D2 [A2 * Qrotm90] def
/E [A * Qrotm90] def /E1 [A1 * DwnL] def /E2 [A2 * DwnL] def
/Eh [Ah * Qflip] def
/F [B * DwnL] def /F1 [F * 2 Qxtran 2 sub] def /F2 [-2 7] def
/G [0 7.6] def /G1 [2 8.2] def /G2 [3.2 9.5 ] def
/Gop [G * Opp] def /GuP [G * UpL] def
/H [5.1 10] def /H1 [6.5 10.5] def /H2 [8 10.5] def
/I1 [0 4] def /I2 [0 2] def
/J [0 0] def /J1 [3 0] def /J2 [3 0] def
/K [C * Qrot90] def
/L [C * DwnR] def /L1 [C1 * DwnR] def /L2 [4.7 11] def
/N [0 10.7] def /N1 [I1 * DwnR] def /N2 [I2 * DwnR] def
/Nl [N * UpL] def /Nr [N * UpR] def
/P [L * Qflip] def /Q1 [4.1 12.4] def /Q2 [2 13.1] def
/Sq2 {nm Pupil} def
% CURVES defined as [Point Point Point]
/a [A1 * A2 * B * ] def /b [B2 * B1 * B * ] def
/c [C1 * C2 * D * ] def
/d [D2 * D1 * E * ] def /e [E1 * E2 * F * ] def
/f [F1 * F2 * G * ] def /ft [F1 * UpL F2 * UpL G * UpL] def
/g [G2 * G1 * G * ] def
/h [H1 * H2 * A * ] def /ho [H2 * Opp H1 * Opp H * Opp] def
/hu [H1 * UpR H2 * UpR A * UpR ] def
/i [I2 * I1 * C * ] def /j [J2 * J1 * J * ] def
/k [C2 * Qrot90 C1 * Qrot90 K * ] def
/l [L1 * L2 * H * ] def /lu [L1 * UpR L2 * UpR H * UpR ] def
/n [N2 * N1 * L * ] def /nt [I2 * I1 * C * ] def
/nm (J M P) def
/p [I2 * I1 * C * ] def /pr [I1 * Qrot90 I2 * Qrot90 Nr * ] def
/q [Q2 * Q1 * H * ] def /qo [Q1 * Opp Q2 * Opp G * ] def
% OUTLINE GROUPS defined as [curve curve .. arraylength]
/OutA [f * e * d * c * i * j * k * a * 8] def
/OutB [f * e * hu * lu * nt * pr * k * a * 8] def
/OutC [qo * ho * hu * lu * nt * pr * k * a * 8] def
/OutD [qo * ho * d * c * p * 5] def
/OutE [qo * ho * d * c * i * j * k * a * 8] def
/OutF [h * q * 2] def
/OutG [ft * a * 2] def
/OutH [f * e * d * c * p * 5] def
/OutI [h * l * n * 3] def
/Out1s [A * E * D * C * J * K * B * 7] def %used for lines
/Out2s [A * E * H * UpR C * Nr * K * B * 7] def
/Out3s [A * E * D * C * Nl * G * UpL B * 7] def
% PROCEDURES
/Fish1 {newpath %Convex 90, quadwing, concave 45, Triwing 1
A * moveto OutA * {curveto} repeat
N * lineto OutI * {curveto} repeat
fill } def
/Fish2 {Colour 1 eq {} { %dont draw if white
newpath %Convex 45, TriWing2, concave 45, Triwing 1
A * moveto OutB * {curveto} repeat
N * lineto OutI * {curveto} repeat
fill }ifelse } def
/Fish3 {newpath %Convex 90, TriWing3, concave 45, Triwing 1
A * moveto OutG * {curveto} repeat
Nl * lineto OutH * {curveto} repeat
N * lineto OutI * {curveto} repeat
fill } def
/Fish4 {Colour 1 eq {} {
newpath %Convex 45, Triwing2, concave 180, Duplewing
A * moveto OutC * {curveto} repeat
Gop * lineto OutF * {curveto} repeat
fill }ifelse } def
/Fish5 {newpath %Convex 90, Triwing3, concave 180, Duplewing
A * moveto OutG * {curveto} repeat
Nl * lineto OutD * {curveto} repeat
Gop * lineto OutF * {curveto} repeat
fill } def
/Fish6 {Colour 1 eq {} {
newpath %Convex 90, quad, concave 180, Duplewing
A * moveto OutE * {curveto} repeat
Gop * lineto OutF * {curveto} repeat
fill }ifelse } def
/Fish1s {newpath %Straight fish with Quadwing for border
A * moveto Out1s * {lineto} repeat
fill} def
/Fish2s {newpath %Straight fish with Triwing1 for border
A * moveto Out2s * {lineto} repeat
fill} def
/Fish3s {newpath %Straight fish with Triwing2 for border
A * moveto Out3s * {lineto} repeat
fill} def
/Spine {newpath %Fishcentre line
Ah * moveto C * 0.3 add C * -0.6 Qxtran 0.3 add Eh * curveto
Eh * -0.05 add lineto
C * -0.3 add -0.6 Qxtran C * -0.3 add Ah * -0.05 add curveto
Ah * lineto
gsave fill grestore } def
/Tailribs {0.15 setlinewidth
newpath -6 9 moveto -5 8 -4 7.3 -2.4 6.9 curveto stroke
newpath -5.5 6.7 moveto -4.5 6.3 -3.5 6.2 -2.3 6 curveto stroke
newpath -2.2 7.1 moveto -2.4 6.7 -2.4 6.2 -2.2 5.8 curveto stroke} def
/EyeshapeL { -0.4 0.8 moveto 0.7 1.3 1.5 1.2 2.5 0.8 curveto
1.9 0 1.1 -0.4 0.1 -0.9 curveto
0 -0.2 -0.1 0.3 -0.4 0.8 curveto } def
/EyeshapeR { 0 0.8 moveto 1.4 1.6 1.9 1.6 2.6 1.5 curveto
2.4 0.8 1.6 0 0.1 -0.8 curveto
0.1 -0.3 0.1 0.3 0 0.8 curveto } def
/Pupil {-3 0.2 moveto White show 0 0 moveto} def
/WhiteEye { 0.01 setlinewidth gsave
5.9 6.7 translate EyeshapeR stroke
0.2 0 translate 0.4 0.4 scale EyeshapeR fill
grestore gsave
5.6 8.9 translate EyeshapeL stroke
0.2 0.1 translate 0.4 0.4 scale EyeshapeL fill grestore }def
/DarkEye {gsave
5.9 6.7 translate EyeshapeR
0.2 0 translate 0.4 0.4 scale EyeshapeR
eofill grestore gsave
5.6 8.9 translate EyeshapeL
0.2 0.1 translate 0.4 0.4 scale EyeshapeL
eofill grestore} def
/Bodylines {Spine Tailribs Colour 1 eq {WhiteEye} {DarkEye} ifelse} def
/Ribl {newpath L * moveto l * curveto stroke } def
/Ribk {newpath B * moveto k * curveto stroke }def
/Ribf {newpath B * moveto ft * curveto stroke } def
/Ribb {newpath C * moveto b * curveto stroke } def
/Ribg {newpath H * moveto g * curveto stroke} def
% WING Outlines for Clip Paths
/QuadW {C * moveto b * curveto K * lineto J * lineto
closepath}def
/TriW1 { %wing on Hypoteneuse for triple
H * moveto g * curveto N * lineto L * lineto
closepath } def
/TriW2 { %wing on head side for triple
C * moveto b * curveto K * lineto Nr * lineto
closepath } def
/TriW3 { %wing on tail side for triple
C * moveto b * curveto GuP * lineto Nl * lineto
closepath } def
/DupleW { %wing for duple
H * moveto g * curveto Gop * lineto q * curveto
closepath } def
/Wingribs %stack WingRib, Translate-offset, Translate-inc, Y-Rotatione-inc
{4 copy 4 copy %copy parameters given for 3 ribs
0.15 setlinewidth
0 1 2 {gsave %stack Wr To Ti Sy Loopv
dup dup 0.25 mul 0.75 exch sub %stack ----Sy Lv Lv Sx
exch 4 -1 roll mul 0.95 exch sub %stack ---To Ti Lv Sx Sy
scale %stack --To Ti Lv
mul add 0 exch translate %stack --Wr
cvx exec %execute WingRibxx
grestore } for %stack Sr
} def
/Quadribs {gsave QuadW clip newpath
/Ribk 0.5 0 0 Wingribs grestore 0.2 setlinewidth Ribb } def
/Triribs1 {gsave TriW1 clip newpath
/Ribl -0.5 0 0.04 Wingribs grestore 0.2 setlinewidth Ribg} def
/Triribs2 {gsave TriW2 clip newpath
/Ribk 0.5 0.1 0 Wingribs grestore 0.2 setlinewidth Ribb } def
/Triribs3 {gsave TriW3 clip newpath
/Ribf 0.8 0.6 0.03 Wingribs grestore 0.2 setlinewidth Ribb }def
/Dupribs {gsave DupleW clip newpath
/Ribl -0.5 0 0.04 Wingribs grestore 0.2 setlinewidth Ribg }def
/Decor1 {Comp Bodylines Quadribs Triribs1 De-Comp} def
/Decor2 {Comp Bodylines Triribs2 Triribs1 De-Comp} def
/Decor3 {Comp Bodylines Triribs3 Triribs1 De-Comp} def
/Decor4 {Comp Bodylines Triribs2 Dupribs De-Comp} def
/Decor5 {Comp Bodylines Triribs3 Dupribs De-Comp} def
/Decor6 {Comp Bodylines Quadribs Dupribs De-Comp} def
/Decors {Comp Spine De-Comp} def
%STRUCTURAL PROCEDURES
/Sq1 {4 { Dark Fish1 Decor1 Swap pause -90 rotate } repeat
gsave Downtail
4 { Light Fish3 Decor3 20 0 translate
White Fish2 Decor2 -90 rotate
Swap pause } repeat
grestore } def
/Sq8 {
gsave -15 15 translate 0.5 0.5 scale
4 { Dark Fish1 Decor1 -90 rotate
Light Fish6 Decor6 Op
White Fish4 Decor4 -90 rotate
Dark Fish3 Decor3 20 0 translate
Fish2 Decor2 -90 rotate
Light Fish5 Decor5 Op
White Fish6 Decor6 -90 rotate
Dark Fish1 Decor1
Swap pause -90 rotate }repeat
Downtail
4 { Light Swap Fish3 Decor3 20 0 translate
White Fish2 Decor2 -90 rotate
3 {Light Fish3 Decor3 20 20 translate
White 90 rotate Fish2 Decor2 -90 rotate
pause }repeat
}repeat
grestore
} def
/Sq20 { gsave -22.5 22.5 translate 0.25 0.25 scale
4 { Dark Fish1 Decor1 -90 rotate
Light Fish6 Decor6 Op
4{ White Fish4 Decor4 -90 rotate
Dark Fish3 Decor3 20 0 translate
Fish2 Decor2 -90 rotate
Light Fish5 Decor5 Op
} repeat
White Fish6 Decor6 -90 rotate
Dark Fish1 Decor1
Swap pause -90 rotate }repeat
Downtail
4 { Light Swap Fish3 Decor3 20 0 translate
White Fish2 Decor2 -90 rotate
9 {Light Fish3 Decor3 20 20 translate
White 90 rotate Fish2 Decor2 -90 rotate
pause }repeat
}repeat
grestore
} def
/Sq44 {gsave -26.25 26.25 translate 0.125 0.125 scale
4 { Dark Fish1 Decors -90 rotate
Light Fish6 Decors Op
10{White Fish4 Decors -90 rotate
Dark Fish3 Decors 20 0 translate
Fish2 Decors -90 rotate
Light Fish5 Decors Op
} repeat
White Fish6 Decors -90 rotate
Dark Fish1 Decors
Swap pause -90 rotate }repeat
Downtail
4 { Light Swap Fish3 Decors 20 0 translate
White Fish2 Decors -90 rotate
21 {Light Fish3 Decors 20 20 translate
White 90 rotate Fish2 Decors -90 rotate
pause }repeat
}repeat
grestore } def
/Sq92 {gsave -28.125 28.125 translate 0.0625 0.0625 scale
4 { Dark Fish1 -90 rotate
Light Fish6 Op
22{ White Fish4 -90 rotate
Dark Fish3 20 0 translate
Fish2 -90 rotate
Light Fish5 Op
} repeat
White Fish6 -90 rotate
Dark Fish1
Swap pause -90 rotate }repeat
Downtail
4 { Light Swap Fish3 20 0 translate
White Fish2 -90 rotate
45 {Light Fish3 20 20 translate
White 90 rotate Fish2 -90 rotate
pause }repeat
}repeat
grestore } def
/Sq188 {gsave -29.1125 29.1125 translate 0.03125 0.03125 scale
4 { Dark Fish1s -90 rotate
Light Fish1s Op
46{ White Fish2s -90 rotate
Dark Fish3s 20 0 translate
Fish2s -90 rotate
Light Fish3s Op
} repeat
White Fish1s -90 rotate
Dark Fish1s
Swap pause -90 rotate }repeat
grestore } def
/Fishes {
RotateFactor rotate
0.05 setlinewidth 1 setflat 1 setlinecap
Colourdisplay {0 0 1 hsbcolor} {1} ifelse fillcanvas
gsave Sq1 Sq2 Sq8 Sq20 Sq44 Sq92 Sq188 grestore
} def %end of Fishes
/Calcscale {initclip clippath pathbbox
2 copy 2 div exch 2 div exch translate
60 div exch 60 div exch scale
pop pop} def
/main{
/RotateFactor 0 def
/Rotation {/RotateFactor currentkey cvi store
/paintclient win send} def
/win framebuffer /new DefaultWindow send def
{/FrameLabel(Square-Limit) def
/PaintClient{gsave Calcscale Fishes grestore} def
/PaintIcon
{gsave 3 3 scale 10 0 translate Fish1 Decor1 grestore} def
/ClientMenu[(0) (10) (30) (45) (60) (90)][ {Rotation} ]
/new DefaultMenu send def
} win send
ColorDisplay? /Colourdisplay exch def %defined in init.ps
/reshapefromuser win send
/map win send
}def
main
end %of dict
------------------------------------------------------------------------------
Andrew Dwelly
E.C.R.C. UUCP: mcvax!unido!ecrcvax!andy
pyramid!ecrcvax!andy
ArabellaStrasse 17 CSNET:ecrcvax!andy@Germany.CSNET
D-8000 Muenchen 81, West Germany UUCP Domain: andy@ecrcvax.UUCP
[Bump, Crash ......
Listen; who swears ?.
Christopher Robin has fallen down stairs.]