%!PS % Revised tuna can utilities tuna1.psl % ============================================================== % 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 % This is a revision of a long history of "tunacan" mapping where text gets % wrapped around a cylindrical surface. The new code id Google Earth compatible % and full color and otherwise updated. %%////// Extracted Gonzo Utilities ////// /mt {moveto} store /rm {rmoveto} def /rl {rlineto} 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 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 {false} store /fatter10 { false} store /showdots { false } store /dot { showdots { currentpoint newpath 0.150 0 360 arc fill }if} def /mdot { m dot} def /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 /black {0 setwebtint} store % ///////// (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 % //////////////////////////////////////////////// % //////////////////////////////////////////////// % Rewritten code does the tuna can transform % tuna transform is % tilt constant k = (D/2) sin (theta) % x' = (D/2) sin (114.591 x/D) % y' = y - k cos (114.591 x/D) /tiltangle 18 def % forward tilt angle /diam 20 def % major can diameter /magick diam 2 div tiltangle sin mul def % special numble /xtransform { /xx exch store % MUST save for y!!!! diam 2 div 114.591 xx mul diam div sin mul } def /ytransform { /yy exch store yy magick 114.591 xx mul diam div cos mul sub } def % these procs can be rewritten to do most nonlinear transforms... /movetoproc {moveto} def /linetoproc {lineto} def /curvetoproc {curveto} def /closepathproc {closepath} def % initial movetoproc converts to a cruvetrace to try and minimize % corner cutting. Long horizontal lines should be done in segments. /movetoproc { 2 copy /lastymt exch store /lasty lastymt store % save close and cp /lastxmt exch store /lastx lastxmt store exch xtransform exch ytransform % x must go first! /moveto cvx} def /linetoproc { /y3 exch store /x3 exch store x3 lastx sub 3 div lastx add xtransform y3 lasty sub 3 div lasty add ytransform x3 lastx sub 3 div 2 mul lastx add xtransform y3 lasty sub 3 div 2 mul lasty add ytransform x3 dup /lastx exch store xtransform % save for currentpoint y3 dup /lasty exch store ytransform /curveto cvx } def /curvetoproc {/y3 exch store /x3 exch store % can use stack roll - nonobvious /y2 exch store /x2 exch store /y1 exch store /x1 exch store /lasty y3 store /lastx x3 store x1 xtransform y1 ytransform x2 xtransform y2 ytransform x3 xtransform y3 ytransform /curveto cvx } def /closepathproc { lastxmt lastx sub 3 div lastx add xtransform lastymt lasty sub 3 div lasty add ytransform lastxmt lastx sub 3 div 2 mul lastx add xtransform lastymt lasty sub 3 div 2 mul lasty add ytransform lastxmt xtransform lastymt ytransform /curveto cvx /closepath cvx } def % final close should be zero /remapit { mark {movetoproc} {linetoproc} {curvetoproc} {closepathproc} pathforall ] newpath cvx exec } def /remapit { mark {movetoproc} {linetoproc} {curvetoproc} {closepathproc} pathforall ] newpath cvx exec } def /fudge 3.1415926 2 div store % distance around can to diameter /can { -10 fudge mul 0 mt 6 pu 10{2 fudge mul pr } repeat 6 pd 10{2 fudge mul pl } repeat closepath remapit gsave 212 setwebtint fill grestore line2 stroke } def /lid { 0 6 mt 30 {2 fudge mul pr} repeat remapit gsave 214 setwebtint fill grestore line2 stroke } def /label {-10 1.2 mt 3.5 pu 10 {2 pr} repeat 3.5 pd 10 {2 pl} repeat closepath remapit gsave 0.9 1 0.8 setrgbcolor 29 setwebtint fill grestore line2 stroke } def /lettering { ( /font1 /StoneSans-Bold 5 gonzofont /font1 /StoneSerif-Bold 2.7 gonzofont font1 % -9.6 10 moveto (FREE FONT) false charpath remapit ) pop /kernadj {0.18 0 rmoveto} store -8.4 2 moveto (F) false charpath kernadj (R) false charpath kernadj (E) false charpath kernadj (E) false charpath kernadj ( ) false charpath kernadj (F) false charpath kernadj (O) false charpath kernadj (N) false charpath kernadj (T) false charpath 44 setwebtint remapit 8 setwebtint fill } def /lid { % 20 30 mt 0 50 rlineto 6 setlinewidth stroke 0 6 mt 30 {2 fudge mul pr} repeat remapit gsave 214 setwebtint fill grestore line2 stroke } store /drawatunacan {gsave translate can lid label lettering grestore} def % ////// demo - remove or alter before reuse ///// 33 setwebtint % green grid 100 100 10 setgrid 26 16 showgrid 0 setwebtint % default line black /font1 /Arial-BoldMT [2.7 0 0 2.7 0 0 ] gonzofont font1 13 5 drawatunacan showpage % eof