% From owen@Sun.COM Mon Dec 12 21:12:13 1988 % Date: Mon, 5 Dec 88 11:25:55 PST % From: owen@Sun.COM (Owen Densmore) % To: don@amanda.cs.umd.edu % Subject: Re: scrap.ps & codebook.ps % % The scrap.ps file is possibly not that interesting because it % is fairly out of date. I'll send anyway. % =============================================================== % scrap.ps % Anybody can pick over these for whatever purpose they'd like. % They are random pieces used in a class given at Sun for % tech support engineers. % Note: The /demo procedures included below are small code % fragments illustrating various parts of the system. % Because they all have the same name, each one should % be cut & paste to NeWS individually, as needed. % =============================================================== % Misc: % =============================================================== /cds {countdictstack =} def /ps {pstack} def /fb {framebuffer} def /temp { executive systemdict begin (~/ps/server/NeWS/scrap.ps)run end } def /scrap {(~/ps/server/NeWS/scrap.ps)run} def % --------------------------------------------------------- /setshade { % GrayOrColor => - (set gray or color) dup type /colortype eq {setcolor} {setgray} ifelse } def % --------------------------------------------------------- /fillcanvas { % GrayOrColor => - (Fills current canvas w/ GrayOrColor) setshade clippath fill } def % --------------------------------------------------------- /insetrect { % delta x y w h => x' y' w' h' (return new rect inset by delta) 10 dict begin [/h /w /y /x /delta] {exch def} forall x delta add y delta add w delta dup add sub h delta dup add sub end } def % --------------------------------------------------------- /rectpath { % x y w h => - (make a rect path) 4 2 roll moveto dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath } def % --------------------------------------------------------- /ovalpath { % x y w h => - (make a oval path) matrix currentmatrix 5 1 roll % xfm x y w h 4 2 roll translate scale % xfm .5 .5 translate 0 0 .5 0 360 arc closepath % xfm setmatrix % - } def % --------------------------------------------------------- /starpath { % x y w h => - (make a star path) matrix currentmatrix 5 1 roll % xfm x y w h 4 2 roll translate scale % xfm .2 0 moveto .5 1 lineto .8 0 lineto % xfm 0 .65 lineto 1 .65 lineto closepath % xfm setmatrix % - } def % =============================================================== % Canvases: % =============================================================== /demo { gsave framebuffer setcanvas 100 100 translate 0 0 300 300 rectpath /can framebuffer newcanvas def can reshapecanvas can /Mapped true put can setcanvas .5 fillcanvas grestore } def % --------------------------------------------------------- /pathcanvas { % x y w h parent path => canvas (make a "path" shaped canvas) 10 dict begin gsave cvx [/path /parent /h /w /y /x] {exch def} forall /can parent newcanvas def parent setcanvas x y translate 0 0 w h path can reshapecanvas can /Mapped true put can grestore end } def % --------------------------------------------------------- /rectcanvas { {rectpath} pathcanvas } def % x y w h parent => canvas /rectcanvas { /rectpath pathcanvas } def % x y w h parent => canvas /demo { /can 100 100 200 200 framebuffer rectcanvas def can setcanvas .5 fillcanvas } def % --------------------------------------------------------- /ovalcanvas { {ovalpath} pathcanvas } def % x y w h parent => canvas /demo { /can 100 100 200 200 framebuffer ovalcanvas def can setcanvas .5 fillcanvas } def % --------------------------------------------------------- /starcanvas { {starpath} pathcanvas } def % x y w h parent => canvas /demo { /can 100 100 200 200 framebuffer starcanvas def can setcanvas .5 fillcanvas } def % =============================================================== % Sub Canvases: % =============================================================== /demo { /can 100 100 200 200 framebuffer rectcanvas def /can1 10 10 180 180 can rectcanvas def can setcanvas .5 fillcanvas can1 setcanvas 1 fillcanvas } def % --------------------------------------------------------- /demo { /can 100 100 200 200 framebuffer ovalcanvas def /can1 10 10 180 180 can ovalcanvas def can setcanvas .5 fillcanvas can1 setcanvas 1 fillcanvas } def % --------------------------------------------------------- /demo { /can 100 100 200 200 framebuffer starcanvas def /can1 25 25 150 150 can starcanvas def can setcanvas .5 fillcanvas can1 setcanvas 1 fillcanvas } def % --------------------------------------------------------- /demo { /look { % canvas => - (print a canvas & its sub-tree) countdictstack 2 sub {( ) print} repeat dup == begin TopChild null ne {TopChild look} if CanvasBelow end dup null ne {look} {pop} ifelse } def framebuffer look } def % =============================================================== % Transparency: % =============================================================== /demo { % transparent? => - (make /can & /can1) gsave framebuffer setcanvas 100 100 translate 0 0 300 300 rectpath /can framebuffer newcanvas def can reshapecanvas can /Mapped true put can setcanvas 75 75 translate 0 0 150 150 ovalpath /can1 can newcanvas def can1 reshapecanvas can1 /Transparent 3 -1 roll put can1 /Mapped true put grestore } def /demo1 { true demo can1 setcanvas .5 fillcanvas can setcanvas 0 fillcanvas can1 setcanvas .5 fillcanvas false demo can1 setcanvas .5 fillcanvas can setcanvas 0 fillcanvas } def % =============================================================== % Overlay Canvases: % =============================================================== /demo { % needs /can to be defined /Times-Roman findfont 36 scalefont setfont /olay can createoverlay def can setcanvas 1 fillcanvas 0 setshade 20 20 moveto (Here Is Some Text) show olay setcanvas 0 fillcanvas erasepage 20 20 50 50 ovalpath stroke 20 100 moveto (Here Is Some Text) show erasepage } def % =============================================================== % Lightweight Processes % =============================================================== /demo { /p {2 2 add} def p = % 4 /pp {p} fork def pp = % process(7663140, runnable) pp waitprocess = % 4 } def % --------------------------------------------------------- /demo { /p {2 2 add} fork def p = % process(7762460, runnable) pause p = % process(7762460, zombie) p waitprocess = % 4 } def % --------------------------------------------------------- /demo { /p {1 2 3} fork def p waitprocess = % 3 /p {[1 2 3]} fork def p waitprocess dup == % [1 2 3] aload pop ps clear % 1 2 3 } def % --------------------------------------------------------- /demo { clear /a 1 def /p null def /peek { % - => array (Return an array showing the current status.) [ count 1 roll ] [ exch (Dictstack=% a=% Stack=) [countdictstack a] sprintf exch ] } def 10 dict begin /a 10 def (Hi!) /p { peek } fork store pop end peek == % [(Dictstack=2 a=1 Stack=) []] p waitprocess == % [(Dictstack=3 a=10 Stack=) [(Hi!) /p]] } def /demo { /a 1 def /PrintStatus { % - => - (Print current processes status.) (State of process:%\n a=% Dictstack=% stack=) [currentprocess a countdictstack] printf pstack } def PrintStatus %State of process:process(2222550, runnable) % a=1 Dictstack=2 stack=Empty stack 10 dict begin /a 10 def (Hi!) /p { PrintStatus } fork store pop end %State of process:process(4041374, runnable) % a=10 Dictstack=3 stack=(Hi!) /p } def % =============================================================== % Events & Interests % =============================================================== /snoop { /snoopprocess { createevent expressinterest {awaitevent dup == redistributeevent} loop } fork def } def /killsnoop {snoopprocess killprocess} def /demo { snoop % event(0x1f7f3c, [382,223], name(/MouseDragged), action(null)) % event(0x1f42f0, [382,223], name(/LeftMouseButton), action(/DownTransition)) % event(0x1f7f3c, [382,223], name(/LeftMouseButton), action(/UpTransition)) % event(0x1f7f3c, [382,223], name(28493), action(/DownTransition)) % event(0x1f7f3c, [382,223], name(28493), action(/UpTransition)) % event(0x1f42f0, [356,229], name(/MouseDragged), action(null)) killsnoop } def % --------------------------------------------------------- /settarget { % - => - (set tty target = current selection holder) /TtyTarget createevent dup begin /Name /InsertValue def /Process /PrimarySelection getselection /SelectionHolder get def /Canvas /PrimarySelection getselection /Canvas get def end def } def /sendtarget { % string => - (send string to current tty target) TtyTarget /Action 3 -1 roll put TtyTarget sendevent } def /demo { settarget (ls\n) sendtarget (ps\n) sendtarget } def /demo { settarget ( 1 2 add = ) sendtarget } def /demo { settarget (/settarget { % - => - (set tty target = current selection holder) /TtyTarget createevent dup begin /Name /InsertValue def /Process /PrimarySelection getselection /SelectionHolder get def /Canvas /PrimarySelection getselection /Canvas get def end def } def /sendtarget { % string => - (send string to current tty target) TtyTarget /Action 3 -1 roll put TtyTarget sendevent } def ) sendtarget } def % --------------------------------------------------------- /demo { /sendtimeevent { % timedelta => - createevent begin /Name /Timer def /TimeStamp exch currenttime add def currentdict end sendevent } def /p { /timercount 0 def createevent dup /Name /Timer put expressinterest { awaitevent pop (Tick\n) print /timercount timercount 1 add def timercount 10 eq {exit} if 1 60 div sendtimeevent } loop } fork def p = (Starting processes:\n) print 1 60 div sendtimeevent p waitprocess pop p = % process(2716670, runnable) % Starting processes: % Tick % Tick % Tick % Tick % Tick % Tick % Tick % Tick % Tick % Tick % process(2716670, zombie) } def % --------------------------------------------------------- /demo { /sendnameevent { % name => - createevent dup /Name 4 -1 roll put sendevent } def /p1 { /p1count 0 def createevent dup /Name /Tick put expressinterest { awaitevent pop (Tick ) print /Tock sendnameevent /p1count p1count 1 add def p1count 10 eq {exit} if } loop } fork def /p2 { /p2count 0 def createevent dup /Name /Tock put expressinterest { awaitevent pop (Tock!\n) print /Tick sendnameevent /p2count p2count 1 add def p2count 10 eq {exit} if } loop } fork def p1 = p2 = (Starting processes:\n) print /Tick sendnameevent 21 {pause} repeat p1 = p2 = % process(4244540, input_wait) % process(2716670, runnable) % Starting processes: % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % Tick Tock! % process(4244540, zombie) % process(2716670, zombie) } def % =============================================================== % ADD MONITORS % =============================================================== % =============================================================== % Keyboard % =============================================================== /snoop { /snoopprocess { createevent dup /Priority 10 put expressinterest {awaitevent dup == redistributeevent} loop } fork def } def /killsnoop {snoopprocess killprocess} def % snoop % event(0x27836C, [184,325], name(/MouseDragged), action(null)) % event(0x27836C, [186,325], name(28493), action(/DownTransition)) % event(0x24C17C, [186,325], name(28493), action(/UpTransition)) % event(0x27836C, [186,325], name(/RightMouseButton), action(/DownTransition)) % event(0x26CFA4, [170,324], name(/RightMouseButton), action(/UpTransition)) % event(0x279564, [0,0], name(/DoItEvent), action(/Window)) % event(0x24C1D8, [169,324], name(/MouseDragged), action(null)) % killsnoop % --------------------------------------------------------- /demo {( % Text Sample (Jerry Farrell) /MaxLen 1024 def /buffer MaxLen string def /buflen 0 def /addchar { buflen MaxLen lt { buffer buflen Name put /buflen buflen 1 add store } if } def /backchar { buflen 0 gt { /buflen buflen 1 sub store } if } def /clearline { /buflen 0 def } def /replaceline { Action length MaxLen gt { /Action Action 0 MaxLen getinterval def } if buffer 0 Action putinterval /buflen Action length store } def /namedict dictbegin 8 /backchar load def % BS 10 /clearline load def % LF 13 /clearline load def % CR 21 /clearline load def % ^U 32 1 126 { /addchar load def } for % printable characters 127 /backchar load def % DEL /InsertValue /replaceline load def % strings dictend def /win framebuffer /new DefaultWindow send def { /PaintClient { 1 fillcanvas 0 setgray 10 10 moveto buffer 0 buflen getinterval show } def /FrameLabel (Text Example) def /DestroyClient { kbdinterests ClientCanvas revokekbdinterests KbdHandler killprocessgroup } def } win send /reshapefromuser win send /map win send /KbdHandler { /kbdinterests win /ClientCanvas get addkbdinterests def { awaitevent begin namedict Name known { namedict Name get exec /paintclient win send } if end } loop } fork def ) runprogram }def % --------------------------------------------------------- /seteventmgrcallback { % interest proc => - /ClientData 10 dict dup /CallBack 5 -1 roll put put } def /eventmgrkbdinterest { % callback can Editkeys? Fnames? Fstrings? => proc [6 1 roll] { 3 index addkbdinterests % p can E? FN? FS? a exch {[4 index addfunctionstringsinterest] append} if % p can E? FN? a exch {[3 index addfunctionnamesinterest] append} if % p can E? a exch {[2 index addeditkeysinterest] append} if % p can a {2 index seteventmgrcallback} forall % p can pop pop } append cvx } def /demo { framebuffer setcanvas 100 100 translate 0 0 300 300 rectpath /can framebuffer newcanvas def can reshapecanvas can /Mapped true put can setcanvas .5 fillcanvas /MyEventProc {==} def /p [ PointButton {interactivemove .5 fillcanvas} /DownTransition can eventmgrinterest {MyEventProc} can true true false eventmgrkbdinterest ] forkeventmgr def } def % =============================================================== % User Interaction % =============================================================== /interact { % proc startup? => result % Repeatedly call proc, with x0 y0 x y defined in a local % dictionary, whenever MouseDragged & MouseUp. If startup? % also call on initial MouseDown. Returns TOS of tracker. % Uses "callback" procedures stored in interests. 20 dict begin /startup? exch def /proc exch cvx def currentcursorlocation /y0 exch def /x0 exch def /x x0 def /y y0 def /callproc {/x XLocation store /y YLocation store proc} def MakeInteractInterests { startup? {[StartInterest]} {proc [TrackInterest StopInterest]} ifelse {expressinterest} forall { awaitevent begin Interest /ClientData get exec end } loop } fork waitprocess end } def /MakeInteractInterests { % proc startup? /StartInterest createevent dup begin /Name [/LeftMouseButton /RightMouseButton /MiddleMouseButton] def /Action /DownTransition def /ClientData { /x0 XLocation store /y0 YLocation store StopInterest /Name Name put TrackInterest expressinterest StopInterest expressinterest callproc } def end def /TrackInterest createevent dup begin /Name /MouseDragged def /ClientData {callproc} def end def /StopInterest createevent dup begin /Action /UpTransition def /ClientData {callproc exit} def end def } def % --------------------------------------------------------- /demo { /p { (x0=% y0=% x=% y=%\n) [x0 y0 x y] printf } def /p true interact == /p false interact == % x0=463 y0=283 x=463 y=283 % x0=463 y0=283 x=422 y=267 % x0=463 y0=283 x=298 y=193 % x0=463 y0=283 x=238 y=153 % x0=463 y0=283 x=10 y=59 % x0=463 y0=283 x=-64 y=37 % x0=463 y0=283 x=-66 y=35 % x0=463 y0=283 x=-66 y=35 % null } def % --------------------------------------------------------- /calcbbox {x0 x min y0 y min x x0 sub abs y y0 sub abs} def /getbbox { % canvas pathproc startup? => [x y w h] (relative to canvas) gsave 3 -1 roll createoverlay setcanvas % pathproc bool { erasepage calcbbox 4 index cvx exec stroke % use the path proc Action /UpTransition eq { erasepage [calcbbox] } if } exch interact % pathproc array exch pop % array grestore } def /demo { framebuffer /starpath true getbbox /can exch aload pop framebuffer starcanvas def can setcanvas .5 fillcanvas } def % --------------------------------------------------------- /canvasfromuser { % parent pathproc => canvas 2 copy true getbbox aload pop % parent proc x y w h 6 -2 roll pathcanvas % canvas } def /demo { /can framebuffer /starpath canvasfromuser def can setcanvas .5 fillcanvas } def % --------------------------------------------------------- /slidecanvas { % canvas startup? => - (interactively move canvas) gsave 1 index /Parent get setcanvas {gsave dup setcanvas x y movecanvas grestore} exch interact pop pop grestore } def /slidecanvas { % canvas startup? => - (interactively move canvas) gsave exch dup /Parent get setcanvas % bool canvas (parent=current) dup getcanvaslocation % bool canvas x1 y1 { gsave 2 index setcanvas % canvas x1 y1 x x0 sub 2 index add % canvas x1 y1 x y y0 sub 2 index add movecanvas % canvas x1 y1 grestore } 5 -1 roll interact % canvas x1 y1 result pop pop pop pop grestore } def /demo { can true slidecanvas } def % =============================================================== % Utilities % =============================================================== /isutility { % keyword => bool load type /arraytype eq = } def /demo { /add isutility % false /rectpath isutility % true % forkeventmgr: interests => process (fork a process with these interests) % eventmgrinterest: eventname eventproc action canvas => interest } def % =============================================================== % Classes % =============================================================== /temp { % FCS documentation /Foo Object % Foo is a subclass of Object dictbegin % (initialized) instance variables /Value 0 def /Time null def dictend classbegin /ClassTime currenttime def % The class variable "ClassTime". % class methods /new { % - => - (Make a new Foo) /new super send begin /resettime self send currentdict end } def /printvars { % - => - (Print current state) (..we got: Value=%, Time=%.\n) [Value Time] printf } def /changevalue { % value => - (Change the value of "Value") /Value exch def } def /resettime { % - => - (Change Time to the current time) /Time currenttime def } def classend def /foo /new Foo send def /printvars foo send % ..we got: Value=0, Time=1.31435. (A String) /changevalue foo send /printvars foo send % ..we got: Value=A String, Time=1.31435. /resettime foo send /printvars foo send % ..we got: Value=A String, Time=1.31667. {/Time ClassTime def} foo send /printvars foo send % ..we got: Value=A String, Time=1.31168. {currenttime Time sub round /changevalue self send} /doit foo send /printvars foo send % ..we got: Value=0, Time=1.31168. {currenttime 60 mul round} /changevalue foo send /printvars foo send 1000 {pause} repeat /printvars foo send % ..we got: Value=79, Time=1.31168. % ..we got: Value=81, Time=1.31168. } def % =============================================================== /demo { % page 62-65 of smalltalk blue book /One Object [] classbegin /test {1} def /result1 {/test self send} def classend def /Two One [] classbegin /test {2} def classend def /ex1 /new One send def /ex2 /new Two send def /test ex1 send = /result1 ex1 send = /test ex2 send = /result1 ex2 send = /Three Two [] classbegin /result2 {/result1 self send} def /result3 {/test super send} def classend def /Four Three [] classbegin /test {4} def classend def /ex3 /new Three send def /ex4 /new Four send def /test ex3 send = /result1 ex4 send = /result2 ex3 send = /result2 ex4 send = /result3 ex3 send = /result3 ex4 send = } def % =============================================================== /Canvas Object [/TheCanvas /EventMgr /Height /Width] classbegin /FillColor 1 1 1 rgbcolor def /EdgeColor .5 .5 .5 rgbcolor def /EdgeSize 8 def /new { % ParentCanvas => instance /new super send begin /TheCanvas exch newcanvas store currentdict end } def /path {rectpath} def % x y w h => - (currentpath now is my kind of path) /reshape { % x y w h => - gsave TheCanvas /Parent get setcanvas /Height exch def /Width exch def translate 0 0 Width Height /path self send TheCanvas reshapecanvas grestore } def /reshapefromuser { % - => - TheCanvas /Parent get /path true getbbox aload pop /reshape self send } def /paint { % - => - gsave TheCanvas setcanvas EdgeColor fillcanvas FillColor setcolor EdgeSize 0 0 Width Height % delta x y w h insetrect /path self send % - fill grestore } def /fix { % - => - gsave TheCanvas setcanvas damagepath clipcanvas /paint self send newpath clipcanvas grestore } def /map { % - => - EventMgr null eq {/fork self send} if TheCanvas /Mapped true put } def /fork { % - => - /EventMgr [ PointButton {TheCanvas canvastotop} /DownTransition TheCanvas eventmgrinterest AdjustButton {TheCanvas false slidecanvas} /DownTransition TheCanvas eventmgrinterest /Damaged {/fix self send} null TheCanvas eventmgrinterest ] forkeventmgr def } def classend def % --------------------------------------------------------- /demo { /can framebuffer /new Canvas send def /reshapefromuser can send /map can send 10 20 100 200 /reshape can send } def % --------------------------------------------------------- /OvalCanvas Canvas [] classbegin /path {ovalpath} def classend def /demo { /can1 framebuffer /new OvalCanvas send def /reshapefromuser can1 send /map can1 send } def % --------------------------------------------------------- /StarCanvas Canvas [] classbegin /EdgeSize 20 def /path {starpath} def classend def /demo { /can2 framebuffer /new StarCanvas send def /reshapefromuser can2 send /map can2 send } def % =============================================================== % Windows & Menus % =============================================================== /demo { /win framebuffer /new DefaultWindow send def { /FrameLabel (USENIX is a Star!) def /IconImage /hello_world def /PaintClient { .5 fillcanvas 1 setshade clippath pathbbox starpath fill } def } win send /reshapefromuser win send /map win send } def % --------------------------------------------------------- /demo { /StarGray 1 def /FillGray .5 def /FillCanvasWithStar { % stargray fillgray => - fillcanvas setshade clippath pathbbox starpath fill } def /SetStarGrays { % stargray fillgray => - /FillGray exch store /StarGray exch store /paintclient win send } def /win framebuffer /new DefaultWindow send def { /FrameLabel (USENIX is a Star!) def /PaintIcon {.25 .75 FillCanvasWithStar 0 strokecanvas} def /PaintClient {StarGray FillGray FillCanvasWithStar} def /ClientMenu [ (White Star) { 1 FillGray SetStarGrays} (Lite Star) {.75 FillGray SetStarGrays} (Gray Star) {.50 FillGray SetStarGrays} (Dark Star) {.25 FillGray SetStarGrays} (Black Star) { 0 FillGray SetStarGrays} (White Fill) {StarGray 1 SetStarGrays} (Gray Fill) {StarGray .50 SetStarGrays} (Black Fill) {StarGray 0 SetStarGrays} ] /new DefaultMenu send def } win send /reshapefromuser win send /map win send } def % --------------------------------------------------------- /demo { /StarGray 1 def /FillGray .5 def /FillCanvasWithStar { % stargray fillgray => - fillcanvas setshade clippath pathbbox starpath fill } def /SetStarGrays { % stargray fillgray => - /FillGray exch store /StarGray exch store /paintclient win send } def /GetMenuNumber {/currentkey self send cvr} def % - => num /StarGraysMenu [(.1) (.2) (.25) (.3) (.4) (.5) (.6) (.7) (.75) (.8) (.9) (1.0)] [{GetMenuNumber FillGray SetStarGrays}] /new DefaultMenu send def /FillGraysMenu [(.1) (.2) (.25) (.3) (.4) (.5) (.6) (.7) (.75) (.8) (.9) (1.0)] [{StarGray GetMenuNumber SetStarGrays}] /new DefaultMenu send def /win framebuffer /new DefaultWindow send def { /FrameLabel (USENIX is a Star!) def /PaintIcon {.25 .75 FillCanvasWithStar 0 strokecanvas} def /PaintClient {StarGray FillGray FillCanvasWithStar} def /ClientMenu [ (White on Black) { 1 0 SetStarGrays} (Black on White) { 0 1 SetStarGrays} (Lite on Dark) {.75 .25 SetStarGrays} (Star Grays =>) StarGraysMenu (Fill Grays =>) FillGraysMenu ] /new DefaultMenu send def } win send /reshapefromuser win send /map win send } def % =============================================================== % Custom Windows % =============================================================== /OvalWindow LiteWindow [] classbegin /Border 16 def /FrameFillColor .75 .75 .75 rgbcolor def /ShapeFrameCanvas { % - => - ([Re]set frame canvas' shape) gsave ParentCanvas setcanvas FrameX FrameY translate 0 0 FrameWidth FrameHeight ovalpath FrameCanvas reshapecanvas grestore } def /PaintFrame { % - => - (Paint frame canvas) FrameFillColor fillcanvas PaintFocus } def /PaintFocus { % - => - (Paint frame focus) gsave FrameCanvas setcanvas KeyFocus? {0} {FrameFillColor} ifelse setshade Border 2 div 0 0 FrameWidth FrameHeight insetrect ovalpath stroke grestore } def /ShapeClientCanvas { % - => - ([Re]set client canvas' shape) ClientCanvas null ne { gsave FrameCanvas setcanvas Border 0 0 FrameWidth FrameHeight insetrect 4 2 roll translate 0 0 4 2 roll ovalpath ClientCanvas reshapecanvas grestore } if } def classend def /demo { /win framebuffer /new OvalWindow send def { /IconImage /hello_world def /PaintClient {1 fillcanvas} def } win send /reshapefromuser win send /map win send } def % =============================================================== % Development % =============================================================== /demo { /win framebuffer /new DefaultWindow send def /reshapefromuser win send /map win send /paintme {.5 fillcanvas} def win /PaintClient {paintme} put } def % --------------------------------------------------------- /runprogram { % string => - (exececute the string as a psh program) (/tmp/pshscript) (w) file % str file dup 3 -1 roll % file file str writestring closefile % - (psh /tmp/pshscript) forkunix } def % % timeit % /Temp 10 dict dup begin /timeitms { % - => int % (T2-T1)*60000/Count -or- (T2-T1)/(minim*Count) T2 T1 sub 60000 mul Count div % truncate at third decimal. 1000 mul round 1000 div } def end def /timeit { % count test => - //Temp begin /Proc 1 index def /Count 2 index def /T1 currenttime def end repeat currenttime //Temp begin /T2 exch def (Time: % ms, Loops: %, Test: ) [timeitms Count] printf /Proc load == end } def %------------------------------------------ % from Sam Leffler @ Pixar % Time: 6998.291 ms /bubblesort { % array => array (sort array with bubble sort) 10 dict begin /a exch def a length 2 sub -1 -1 { % for j=n-2 step -1 until 0 do 0 1 3 -1 roll { % for i=0 step 1 until j do /i exch def a i 1 add get a i get lt { % if a[i+1] < a[i] then a i get % a[i] a i 1 add get a i 3 -1 roll put % a[i] = a[i+1] a i 1 add 3 -1 roll put % a[i+1] = a[i] } if } for } for a end } def %------------------------------------------ % Time: 1952.82 ms (358% faster!) /SiftDown { % L U => - /U exch def /L exch def /Xl X L get def { /C L 2 mul 1 add def C U gt {exit} if /Xc X C get def /C+1 C 1 add def C+1 U le { X C+1 get dup Xc Bigger? {/Xc exch def /C C+1 def} {pop} ifelse } if Xl Xc Bigger? {exit} if X L Xc put /L C def } loop X L Xl put } def /heapsort { % array proc => array (sorted) 10 dict begin /Bigger? exch cvx def % a b bigger? => t if a>b /X exch def /N X length 1 sub def % Make the heap N % X N dup 1 sub 2 div floor -1 0 { % N n; for: |N/2| -1 0 1 index SiftDown } for % N % Sort the heap -1 1 { % i:N -1 1 /I exch def X 0 get X I get X 0 3 -1 roll put X I 3 -1 roll put 0 I 1 sub SiftDown } for X end } def % Time: 1679.69 ms (16% faster than above) /SiftDown { % L U => - /U exch def /L exch def /Xl X L get def { L 2 mul 1 add % C (i.e child index) dup U gt {pop exit} if X 1 index get % C Xc 1 index 1 add % C Xc C+1 dup U le { X 1 index get % C Xc C+1 Xc+1 dup 3 index Bigger? {4 2 roll} if pop pop % C' Xc' (largest child) } {pop} ifelse Xl 1 index Bigger? {pop pop exit} if X L 3 -1 roll put /L exch def } loop X L Xl put } def /heapsort { % array proc => array (sorted) 10 dict begin /Bigger? exch cvx def % a b bigger? => t if a>b /X exch def % Make the heap X dup length 1 sub % X N dup 1 sub 2 div floor -1 0 { % X N for: |N/2| -1 0 1 index SiftDown } for % X N % Sort the heap -1 1 { % X i:N -1 1 2 copy 1 index 0 % X i X i X 0 4 copy get 3 1 roll get exch % X i X i X 0 Xi X0 4 1 roll put put % X i 0 exch 1 sub SiftDown } for end } def % Time: 1599.43 ms (6% faster than above) % Converting /Bigger? to use /gt rather than {gt}: 1499.634! % Using gt rather than Bigger? 100ms faster. /SiftDown { % X L U => - 3 1 roll 2 copy get exch % U X Xl L { dup 2 mul 1 add % U X Xl L C (i.e child index) dup 5 index gt {pop exit} if % C>U: exit 3 index 1 index get % U X Xl L C Xc 1 index 1 add % U X Xl L C Xc C+1 dup 7 index le { % C+1<=U: check right child 5 index 1 index get % U X Xl L C Xc C+1 Xc+1 dup 3 index Bigger? % Xc+1 > Xc: roll {4 2 roll} if pop pop % U X Xl L C' Xc' (largest child) } {pop} ifelse % U X Xl L C Xc 3 index 1 index Bigger? % Xl > Xc: exit {pop pop exit} if 4 index 3 index 3 -1 roll put % U X Xl L C; X[L]=Xc exch pop % U X Xl L'; L=C } loop exch put pop % -; X[L]=Xl } def /heapsort { % array proc => array (sorted) 10 dict begin /Bigger? exch cvx def % a b bigger? => t if a>b % Make the heap dup length 1 sub % X N dup 1 sub 2 div floor -1 0 { % X N n ; for: |N/2| -1 0 3 copy exch SiftDown pop } for % X N % Sort the heap -1 1 { % X i:N -1 1 57 type = 11.56 type = true type = (Foo) type = /Foo type = [1 2 3] type = {3 4 add} type = {3 4 add} xcheck = 10 dict type = clear pstack 64 (Hi) /Name pstack exch pstack dup pstack 2 index pstack pop pop pstack 3 1 roll pstack 3 copy pstack clear /min {dup 2 index lt pstack {xch pop (1st) ==} {op (2nd) ==} ielse } def 76 -6 min == -676 m = 2 copy 1 index 0 % X i X i X 0 4 copy get 3 1 roll get exch % X i X i X 0 Xi X0 4 1 roll put put % X i 2 copy 1 sub 0 exch SiftDown pop % X } for end } def %------------------------------------------