%!
% 
% Date: Sat, 23 Jul 88 22:40:33 EDT
% To: NeWS-makers@brillig.umd.edu
% Subject: Yet Another Square Limit
% From: mcvax!unido!ecrcvax!andy@uunet.uu.net  (Andrew Dwelly)
% 
% 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
% -----------------------------------------------------------------------------

% 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.]