%!PS-Adobe-3.1 % PS spherical demo of nonlinear transforms % ====================================================== % Copyright c 2019 by Don Lancaster & Synergetics, Box 809, Thatcher, AZ, 85552 % (928) 428-4073 Email: don@tinaja.com Website: http://www.tinaja.com % Consulting services available http://www.tinaja.com/info01.html % All commercial rights and all electronic media rights ~fully~ reserved. % Linking usually welcome. Reposting expressly forbidden. Version 1.1 % A revision of our older spherical transform. This includes a "near perfect" % scheme of eliminating nonlinear corner cutting and provides an exceptionally % accurate way to draw precision circles. The scheme is based on replacing % curvetos with 4 point splines. % A gonzo tutorial is found at https://www.tinaja.com/glib/gonzotut.pdf % A PostScript Reference Manual at % % https://www.adobe.com/content/dam/acom/en/devnet/actionscript/articles/PLRM.pdf % A PostScript Video at https://www.youtube.com/watch?v=C_tWW560tAE % Intended for acrobat distiller use via command line //acrodist /F % Can be used with GhostScript or Google Drive if want_to_trace is false % IMPORTANT: Change these two lines to switch betweeen tracing code and any result! /want_to_trace { false } store % not used in this example /want_to_see_grid {true} store %%////// Extracted Gonzo Utilities ////// /mt {moveto} def /li {lineto} def /rm {rmoveto} def /rl {rlineto} def /ct {curveto} def /cp {closepath} def /f {fill} def /pd {0 exch neg rl} def /pr { 0 rl} def /pu {0 exch rl} def /pl {neg 0 rl} def /line1 {.06 dup setlinewidth 5 mul /erase exch def} def /line2 {.12 dup setlinewidth 5 mul /erase exch def} def /line3 {.18 dup setlinewidth 5 mul /erase exch def} def /thingridlines {0} def /setgrid { /blocksize exch def translate % simplified blocksize dup scale} def /showgrid {gsave /vblocks exch def /hblocks exch def thingridlines setlinewidth [{0 0 moveto 0 vblocks rlineto stroke} 1 hblocks 1 add] xrpt [{0 0 moveto hblocks 0 rlineto stroke} 1 vblocks 1 add] yrpt fatterborder { gsave newpath 0 0.96 blocksize div dtransform round idtransform setlinewidth pop 2 setlinecap 0 0 moveto hblocks 0 rlineto 0 vblocks rlineto hblocks neg 0 rlineto closepath stroke grestore} if fat5 { gsave newpath 0 0.48 blocksize div dtransform round idtransform setlinewidth pop mark {5 0 moveto 0 vblocks rlineto stroke} 5 hblocks 5 div cvi] xrpt mark {0 5 moveto hblocks 0 rlineto stroke} 5 vblocks 5 div cvi] yrpt grestore} if fatter10 { gsave 18 setwebtint % emphasize here newpath 0 0.96 blocksize div dtransform round idtransform setlinewidth pop mark {10 0 moveto 0 vblocks rlineto stroke} 10 hblocks 10 div cvi] xrpt mark {0 10 moveto hblocks 0 rlineto stroke} 10 vblocks 10 div cvi] yrpt grestore} if grestore} def /fatterborder {true } store /fat5 {true} store /fatter10 { true} store /showdots { false } store /dot { showdots { currentpoint newpath 0.150 0 360 arc fill }if} def /mdot { mt dot} def /random {rand 65536 div 32768 div mul cvi} def % as in -- 6 random -- /gonzofont {dup type cvlit /arraytype eq {exch findfont exch makefont} {exch findfont exch scalefont} ifelse setfont mark /spacewidth ( ) stringwidth pop /cstretch cvx /add cvx /sstretch cvx /add cvx /def cvx currentfont dup backcdict exch (F?) dup 1 14 index (xxxxx) cvs 4 get put put /setfont cvx ] cvx def} def 50 dict /backcdict exch def % used "backwards" during compiling to get % fontname given the "made" font dictionary /cstretch 0 store /sstretch 0 store % repeats [ proc distance trips] xrpt /xrpt{gsave aload pop /trips exch def /dist exch def /rproc exch def trips { gsave rproc grestore dist 0 translate } repeat grestore} def /yrpt{gsave aload pop /trips exch def /dist exch def /rproc exch def trips { gsave rproc grestore 0 dist translate } repeat grestore} def % timing utilities. use stopwatchon and stopwatchoff for simple % one shot timing. For multiple time totals, use resettimer % starttimer stoptimer ... starttimer stoptimer reporttimer /mergestr {2 copy length exch length add string dup dup 4 3 roll 4 index length exch putinterval 3 1 roll exch 0 exch putinterval} def /stopwatchoff {stoptimer reporttimer} def % for single shots /stopwatchon {resettimer starttimer} def % for single shots /reporttimer {mytime 1000 div (\rElapsed time: ) print 20 string cvs print ( seconds.\r) print flush} def % to host /resettimer {/mytime 0 def} def % reset timer /starttimer {usertime /mytimenow exch def} def % add to time so far /stoptimer {usertime mytimenow sub /mytime exch mytime add def} def % for multiple timing intervals % curvetrace - creates a smooth curved path from a data point list. % enter with currentpoint set and absolute array. % 0 0 as initial data appends path; any other values % creates new path /curvetrace {/curvelist exch def tension 0 eq {/tension .000001 def} if curvelist length 3 div 1 sub cvi /#triads exch def /ptr 0 def firstpoint morepoint} def /tension 2.83301 def % default value for best fit SLIGHTLY REVISED! /showtick false def % don't show points /ticklen 15 def % length of ticks /tickhead ticklen 4 div def /prvx { curvelist ptr 3 sub get } def /curx { curvelist ptr get } def /prvy { curvelist ptr 2 sub get } def /cury { curvelist ptr 1 add get } def /prva { curvelist ptr 1 sub get } def /cura { curvelist ptr 2 add get 180 sub} def /showtic1 { showtick true eq {gsave currentpoint newpath translate cura 180 add rotate ticklen neg 2 div 0 moveto ticklen 0 rlineto tickhead neg dup rlineto tickhead dup rlineto tickhead dup neg exch rlineto 0 setlinewidth stroke 0 ticklen neg 2 div moveto 0 ticklen rlineto stroke grestore} if }def /firstpoint { curx cury 2 copy abs exch abs add 0 eq {pop pop currentpoint curvelist exch 1 exch put curvelist exch 0 exch put}{moveto} ifelse showtic1 /ptr ptr 3 add def}def /morepoint {#triads { curx prvx sub dup mul cury prvy sub dup mul add sqrt tension div /zdist exch def prva cos zdist mul prvx add prva sin zdist mul prvy add cura cos zdist mul curx add cura sin zdist mul cury add curx cury curveto showtic1 /ptr ptr 3 add def} repeat} def /showtick false def % timing utilities. use stopwatchon and stopwatchoff for simple % one shot timing. For multiple time totals, use resettimer % starttimer stoptimer ... starttimer stoptimer reporttimer /stopwatchoff {stoptimer reporttimer} def % for single shots /stopwatchon {resettimer starttimer} def % for single shots /reporttimer {mytime 1000 div (\rElapsed time: ) print 20 string cvs print ( seconds.\r) print flush} def % to host /resettimer {/mytime 0 def} def % reset timer /starttimer {usertime /mytimenow exch def} def % add to time so far /stoptimer {usertime mytimenow sub /mytime exch mytime add def} def % for multiple timing interval % insert image proc ( not needed in this example ) /jpegimageprocwithlink { % hoffset voffset hres vres urlfrom urlto save /snap2 exch def /inurllink exch store % grab link filename /infilename exch store % grab passed pix file /photoscale exch store /vpixels exch store /hpixels exch store % (\nvpixels = )print vpixels == % (\nhpixels = )print hpixels == % (\photoscale = ) print photoscale == % (\ninurllink = ) print inurllink == % (\ninfilemane = ) print infilename == translate % adjust position for final figure ??? inurllink setareaurl % autolink sizing /DeviceRGB setcolorspace % pick color model 0 0 translate % set page position hpixels vpixels scale % magnify unit square photoscale dup scale /infile infilename (r) file def % establish input read file /Data {infile /DCTDecode filter} def % define a data source << % start image dicationary /ImageType 1 % always one /Width hpixels % JPEG width in pixels /Height vpixels % JPEG height in pixels /ImageMatrix [hpixels 0 0 vpixels neg 0 vpixels ] /DataSource Data % proc to get filtered JPEG /BitsPerComponent 8 % color resolution /Decode [0 1 0 1 0 1] % per red book 4.10 >> image % call the image operator ypos snap2 restore /ypos exch def } def /setareaurl { % for auto include routine /cururlname exch store mark % start pdfmark /Rect [ 0 0 hpixels photoscale mul vpixels photoscale mul ] /Border [ 0 0 0] % [0 0 0 ] = none; [0 0 2] = debug /Color [ .7 0 0 ] /Action <> /Subtype /Link /ANN % annotation type pdfmark % call pdf operators } def % ///////// (A) WEB FRIENDLY COLOR UTILITIES ///////////// % tintmat is a self-generating list of 216 triple color values /webtintmat [ 0 1 5 { /a exch store 0 1 5 { /b exch store 0 1 5 { 5 div b 5 div a 5 div }for } for } for ] def % setwebtint accepts a color number 0 to 215 and then % sets the PostScript color generator for later use... /setwebtint { abs cvi 216 cvi mod % restrict range webtintmat exch 3 mul 3 getinterval % get values from table aload pop setrgbcolor} def % and set them % The blocks are arranged as red to the right, green % up in order of increasing blue. % Some "pure color" sequences are % red: 0 1 2 3 4 5 % orange: 0 7 8 15 16 23 (sort of) % yellow: 0 7 14 21 28 35 % green: 0 6 12 18 24 30 % aqua: 0 42 84 126 168 210 % blue: 0 36 72 108 144 180 % magenta: 0 37 74 111 148 185 % purple 0 73 73 110 147 183 (sort of) % gray 0 43 86 129 172 215 /want_to_trace false store want_to_trace { % code used by tracing program but not yet Google Drive compatible /imagelocaldirectory (C:/Users/don/Desktop/canal/images/) store % sin fwd slashes for win /imageremotedirectory (http://www.tinaja.com/canal/images/) store % sin fwd slashes for chrome /imageurl imageremotedirectory (prep1.jpg) mergestr store % goto remote image % /imagelocalsource imagelocaldirectory (prep1.jpg) mergestr store % /imagelocalsource (C:/Users/don/Desktop/google_drive/Meowrrr/meowwr1a.jpg) store /imagelocalsource (C:/Users/don/Desktop/google_drive/Ivy/ivyvid1.jpg) store gsave 66 100 % page translate ( data for jpegimageprocwithlink ) 946 1223 % hpixels and vpixels 0.445 % photoscale imagelocalsource % local jpg source imageurl % image url on clickthru jpegimageprocwithlink grestore } if %%%%%%%%%%% SPHERICAL TRANSFORM CODE %%%%%%%%%%%%%%%%%% % //// Bezier through four points remaps lineto into spherical transform % spherical transformes are x' = sin(x)cos(y) y' = sin(y) % y always must be transformed first! /xtransform { want_latlon_degrees not {90 mul} if % grab lon /xx exch store xx sin yy cos mul} store /ytransform { want_latlon_degrees not {90 mul} if % grab lat /yy exch store yy sin} store /chord1 {chord make5ctswith4pts} store /make5ctswith4pts { carray 0 get carray 1 get xf carray 2 get carray 3 get xf carray 4 get carray 5 get xf carray 6 get carray 7 get xf bez4pts1 currentpoint carray 8 get carray 9 get xf carray 10 get carray 11 get xf carray 12 get carray 13 get xf bez4pts1 currentpoint carray 14 get carray 15 get xf carray 16 get carray 17 get xf carray 18 get carray 19 get xf bez4pts1 currentpoint carray 20 get carray 21 get xf carray 22 get carray 23 get xf carray 24 get carray 25 get xf bez4pts1 currentpoint carray 26 get carray 27 get xf carray 28 get carray 29 get xf carray 30 get carray 31 get xf bez4pts1 } store /xf {ytransform exch xtransform exch} store % utility proc used for 4 point Bezier... /solvexy {/ff exch store % grab data values /ee exch store /dd exch store /cc exch store /bb exch store /aa exch store cc aa dd div ff mul sub % find j bb aa ee mul dd div sub div /jj exch store /ii cc bb jj mul sub aa div store % find i ii jj } store % return to stack /bez4pts1 {/y3 exch store % grab data /x3 exch store /y5 exch store % strange numbering /x5 exch store /y4 exch store /x4 exch store /y0 exch store /x0 exch store /c1 x4 x0 sub dup mul y4 y0 % find chord lengths sub dup mul add sqrt store /c2 x5 x4 sub dup mul y5 y4 sub dup mul add sqrt store /c3 x3 x5 sub dup mul y3 y5 sub dup mul add sqrt store /t1 c1 dup c2 add c3 add div store % guess "best" t /t2 c1 c2 add dup c3 add div store /b0 {1 exch sub dup dup mul mul} store % basis functions /b1 {dup 1 exch sub dup mul mul 3 mul} store /b2 {dup 1 exch sub exch dup mul mul 3 mul} store /b3 {dup dup mul mul} store t1 b1 t1 b2 x4 x0 t1 b0 mul sub % transform x1 and x2 x3 t1 b3 mul sub t2 b1 t2 b2 x5 x0 t2 b0 mul sub x3 t2 b3 mul sub solvexy /x2 exch store /x1 exch store t1 b1 t1 b2 y4 y0 t1 b0 mul sub % transform y1 and y2 y3 t1 b3 mul sub t2 b1 t2 b2 y5 y0 t2 b0 mul sub y3 t2 b3 mul sub solvexy /y2 exch store /y1 exch store x0 y0 moveto % and draw the curve x1 y1 x2 y2 x3 y3 curveto } def % /chord accepts x0 y0 x15 y15 and produces an array of sixteen data points % These have been split into five 4-point Bezier fits for extreme accuracy. /chord { /y15 exch store /x15 exch store /y0 exch store /x0 exch store /yinc y15 y0 sub 15 div store /xinc x15 x0 sub 15 div store % xinc == % yinc == /carray mark x0 y0 15 { 1 index xinc add 1 index yinc add } repeat ] store } store /movetoproc { /lasty exch store % save for cloee and curveto's /lastx exch store /lastymt lasty store /lastxmt lastx store lasty ytransform lastx xtransform exch /moveto cvx} store /linetoproc { /lty exch store % presently substitutes curveto /ltx exch store % lty ytransform % y must go first! ORIG CODE HERE % ltx xtransform % exch /lineto cvx } store /yinc lty lasty sub 3 div store /xinc ltx lastx sub 3 div store lasty yinc add ytransform % first influence lastx xinc add xtransform exch lasty yinc 2 mul add ytransform % second influence lastx xinc 2 mul add xtransform exch lty dup /lasty exch store ytransform ltx dup /lastx exch store xtransform exch /curveto cvx } store /curvetoproc { /crvy3 exch store % grab curveto data /crvx3 exch store /crvy2 exch store /crvx2 exch store /crvy1 exch store /crvx1 exch store crvy1 ytransform % y first for the sphere! crvx1 xtransform exch crvy2 ytransform crvx2 xtransform exch crvy3 dup /lasty exch store ytransform crvx3 dup /lastx exch store xtransform exch /curveto cvx} store /closepathproc { /yinc lastymt lasty sub 3 div store % in UN transformed space /xinc lastxmt lastx sub 3 div store lasty yinc add ytransform % first influence point lastx xinc add xtransform exch lasty yinc 2 mul add ytransform % second influence point lastx xinc 2 mul add xtransform exch lastymt ytransform % closepath dest lastxmt xtransform exch /curveto cvx /closepath cvx } store /remapit { % pastes text onto the spherical surface {movetoproc} {linetoproc} {curvetoproc} {closepathproc} pathforall } def %%%%%%%%%%% SPHERICAL TRANSFORM DEMO %%%%%%%%%%%%%%%%%% % stopwatchon % google drive can't accept this timing utility % tracing feature is currently inactive, so still triply compatible /want_to_see_grid true store % view background grid? /want_latlon_degrees false store % true for -90-0-90 false for -1 0 1 /rad 20 store % scaled radius double for diameter 30 setwebtint % this sets a 10x grid 50 50 10 setgrid want_to_see_grid {50 60 showgrid} if % show grid ? 0 setwebtint gsave 25 30 translate % center on grid rad dup scale % set size gsave 0 0 1 0 360 arc 180 setwebtint % outer edge via arc gsave 213 setwebtint fill grestore % fill in the sphere 0.009 setlinewidth stroke grestore %% latitude chords stopwatchon 180 setwebtint 0.005 setlinewidth -1 0 1 0 chord1 -1 0.18 1 0.18 chord1 -1 -0.18 1 -0.18 chord1 -1 0.36 1 0.36 chord1 -1 -0.36 1 -0.36 chord1 -1 0.54 1 0.54 chord1 -1 -0.54 1 -0.54 chord1 -1 0.72 1 0.72 chord1 -1 -0.72 1 -0.72 chord1 stroke %% longitude chords 180 setwebtint 0.005 setlinewidth -.72 -1 -.72 1 chord1 .72 -1 .72 1 chord1 -.54 -1 -.54 1 chord1 .54 -1 .54 1 chord1 -.36 -1 -.36 1 chord1 .36 -1 .36 1 chord1 -.18 -1 -.18 1 chord1 .18 -1 .18 1 chord1 0 -1 0 1 chord1 stroke %% edge chords will show precision when uncommented and GREATLY MAGNIFIED! /want_to_see_precision false store want_to_see_precision { 0 setlinewidth 215 setwebtint -1 -1 -1 1 chord1 1 -1 1 1 chord1 0 setlinewidth stroke } if % lettering starts here... % Lettering only includes curveto conversion. It is easily upgraded % to the bez4pts1 lat lon accuracy. % Note that any longitude >90 or <-90 degrees appears "around the back" % and possibly reversed. /font1 /StoneSans-Bold .4 gonzofont 0.005 setlinewidth -.46 .07 moveto mark (FREE) false charpath remapit ] cvx newpath exec gsave 30 setwebtint fill grestore 0 setwebtint stroke -.55 -.33 moveto mark (FONT) false charpath remapit ] cvx newpath exec gsave 30 setwebtint fill grestore 0 setwebtint stroke % stopwatchoff showpage %EOF