%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Cyber Space Deck % Copyright (C) 1989. % By Don Hopkins. (don@toad.com) % All rights reserved. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % This program is provided for UNRESTRICTED use provided that this % copyright message is preserved on all copies and derivative works. % This is provided without any warranty. No author or distributor % accepts any responsibility whatsoever to any person or any entity % with respect to any loss or damage caused or alleged to be caused % directly or indirectly by this program. This includes, but is not % limited to, any interruption of service, loss of business, loss of % information, loss of anticipated profits, core dumps, abuses of the % virtual memory system, or any consequential or incidental damages % resulting from the use of this program. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WARNING WARNING! DANGER! DANGER WILL ROBINSON! DANGER! % This is *gross* code. I mean UUUUUGLY! (And it used to be % even more contorted, if you can believe that.) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % This version works with OpenWindows Version 2 currentprocess /ErrorDetailLevel 1 put systemdict /XNeWS? known not { systemdict /XNeWS? false put } if systemdict /ClassWindow known { systemdict /NewWorld? true put } { systemdict /NewWorld? false put } ifelse NewWorld? { systemdict /UIprivate known not { systemdict /UIprivate 200 dict put } if } if %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Load necessary stuff % I want to know the name of the directory in which to look for all the % files I'm going to want to suck in. Here are three ways for you to tell % me, any of which you can select and paste into a terminal emulator. % You can put the directory name in the systemdict variable /CyberDir: % echo "/CyberDir (`pwd`) def" | psh ; psh cyber.ps % Or set the environmment variable CYBERDIR: % echo "(CYBERDIR) (`pwd`) putenv" | psh ; psh cyber.ps % Or pass it in as an argument to psh (NeWS 1.1): % psh cyber.ps `pwd` systemdict begin /CyberDir where { pop /CyberDir CyberDir (/) append def } { { (CYBERDIR) getenv } stopped { pop % Warning: % X11/NeWS psh does not support the undocumented $1 $2 $3 feature. ($1/) dup 0 get 36 eq { pop /CyberDir () def } { /CyberDir exch (/) append def } ifelse } { /CyberDir exch (/) append def } ifelse } ifelse end % systemdict systemdict /DontSetDefaultMenu true put [ /setselection (NeWS/compat.ps) % New World /Item (liteitem.ps) /dbgstart (debug.ps) /TextCanvas (textcan.ps) /PieMenu (piemenu.ps) /PulloutPieMenu (pullout.ps) /QuickWindow (quickwin.ps) /OverlayWindow (overlay.ps) /pointing-hand (pointer.ps) /StillDict (distill.ps) /start_visualizer (mics.ps) /vexec (ps.ps) /ArpaMap (arpa.map) /ColossalCave (advent.map) ] { dup type /nametype eq { systemdict exch known not } { exch { (Loading ) print dup print (\n) print flush pause pause pause CyberDir 1 index append LoadFile { pop } { dup LoadFile { pop } { dup (NeWS/) exch append LoadFile { pop } { (Can't find the file ") print print ("!\n) print } ifelse } ifelse } ifelse } { pop } ifelse } ifelse } forall %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Brute force debugging hacks % Ignore this stuff. It was written when I was very frustrated. (% ifdef PISSEDOFF systemdict begin /s 512 string def false setautobind systemdict /logfile known not { /logfile (log.out) (w) file def %/logfile ($1) (w) file def %/logfile (/j/don/foo) (w) file def /def { 2 copy exch logfile (def: ) writestring logfile exch //s cvs writestring logfile ( = ) writestring logfile exch //s cvs writestring logfile (\n) writestring logfile flushfile //def } def /store { 2 copy exch logfile (store: ) writestring logfile exch //s cvs writestring logfile ( = ) writestring logfile exch //s cvs writestring logfile (\n) writestring logfile flushfile //store } def /put { 3 copy exch 3 -1 roll logfile (put: ) writestring logfile exch //s cvs writestring logfile ( ) writestring logfile exch //s cvs writestring logfile ( = ) writestring logfile exch //s cvs writestring logfile (\n) writestring logfile flushfile //put } def /get { 2 copy exch logfile (get: ) writestring logfile exch //s cvs writestring logfile ( ) writestring logfile exch //s cvs writestring logfile ( = ) writestring //get logfile 1 index //s cvs writestring logfile (\n) writestring logfile flushfile } def /send { logfile (send: ) writestring logfile 2 index //s cvs writestring logfile ( ) writestring logfile 1 index /ClassName exch //send //s cvs writestring logfile (\n) writestring logfile flushfile //send } def } if systemdict /s undef end % systemdict ) % endif PISSEDOFF %cvx exec pop % For use when mildly irritated: % XXX: Uncomment to find mismatched parens: %/def {1 index = currentdict length = //def} def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % And now for something completely different statusdict begin 0 setjobtimeout end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % X11/NeWS Compatibility % This is nasty evil vile implementation dependant hackery. XNeWS? { systemdict begin % not defined in X11/NeWS beta 2 /PutInEventMgrInterest { % interest key value => - 3 -1 roll dup /ClientData get % key val int CD dup null ne { exch pop } { % key val int null pop dup /ClientData 20 dict put /ClientData get } ifelse 3 1 roll put } def % not defined in X11/NeWS beta 2 /GetFromCurrentEvent { % key => value CurrentEvent /Interest get /ClientData get exch get } def % not defined in X11/NeWS beta 2 /removefocusinterest { pop } def % not defined in X11/NeWS beta 2 class.ps Object /InstanceVarDict { InstanceVars } put % Make it so the debugger /printf's in MessageItem context don't hose us! MessageItem /printf undef version cvr 2.1 ge { % OpenWindows 2.0 patches % userdict /ThisWindow {win} put % XXX KLUDGE !!! systemdict /popmsg known not { systemdict /popmsg { { console exch writestring console (\n) writestring } forall pop pop } put } if systemdict /errored known not { systemdict /errored /stopped load put } if systemdict /unmapcanvas known not { systemdict /unmapcanvas { /Mapped false put } put systemdict /mapcanvas { /Mapped true put } put } if % Stash fboverlay in userdict when first referenced /fboverlay { framebuffer createoverlay userdict /fboverlay 2 index put } def /getanimated { % proc => [ x y ] 10 dict begin /overcan currentcanvas def /overmat matrix currentmatrix def /proc exch def /y0 exch def /x0 exch def currentcursorlocation /y exch def /x exch def GA_constraint null ne GA_value null eq and { /GA_value currentcursorlocation GA_constraint 1 eq {exch} if pop store } if .033333 blockinputqueue { createevent begin /Action [/UpTransition /DownTransition] def /Exclusivity true def currentdict end expressinterest createevent begin /Name /MouseDragged def /Exclusivity true def currentdict end expressinterest createevent begin /Name [/EnterEvent /ExitEvent] def /Canvas framebuffer def /Exclusivity true def currentdict end expressinterest unblockinputqueue { GA_constraint 0 eq {/x GA_value def} if GA_constraint 1 eq {/y GA_value def} if erasepage x0 y0 moveto x y /proc load exec stroke awaitevent begin Name /EnterEvent eq { overcan setcanvas overmat setmatrix } if Action /UpTransition eq { end exit } if /x XLocation store /y YLocation store end } loop erasepage /GA_constraint null store /GA_value null store [x y] } fork end } def } { % not defined in X11/NeWS beta 2 % These have been fixed in OpenWindows2.0 /overlayerase {} def % beta2 /overlaydraw {} def % beta2 } ifelse % The rest of this crud is for beta 2 bugs that were fixed in pre-fcs. version (1.0) eq { % beta 2 (not pre-fcs) % Fixes fatal debugger bug: /executive { % - => - (Execute current file) countdictstack 1 eq {200 dict begin} if % make sure there is a userdict currentprocess /ErrorDetailLevel 1 put /execfile currentfile dup null eq {pop (%stdin) (r) file} if def (Welcome to %NeWS Version %\n) [XNeWS?{(X11/)} {()} ifelse version] printf { % restart loop for errors. % Removed references to execfile (screws up debugger). % { execfile cvx exec } stopped pop % execfile status not { quit } if % quit if file closed { currentprocess /Stdout get cvx exec } stopped pop currentprocess /Stdout get status not { quit } if % quit if file closed ExecutiveErrorHandler } loop } def % Another patch for the debugger bug just in case: /execfile { currentprocess /Stdout get } def % Keep killprocess "errors" from being caught by the debugger. % (assuming debug.ps is already loaded.) % DbgErrorDict /killprocess undef { % send to LiteMenu: % Beta 2 bug, litemenu.ps, class LiteMenu /&ShowThingDict 20 dict dup begin /fonttype {setfont dup truetype exec} def /colortype {setcolor dup truetype exec} def /integertype {rmoveto dup truetype exec} def /realtype {rmoveto dup truetype exec} def /stringtype {0 currentfont fontdescent rmoveto show} def /nametype {iconfont setfont IconString show} def /arraytype { dup xcheck {/paint exch exec} {aload pop dup truetype exec} ifelse } def /packedarraytype /arraytype load def /dicttype {/paint exch send} def end def /&ThingSizeDict 20 dict dup begin /fonttype {setfont dup truetype exec} def /colortype {setcolor dup truetype exec} def /integertype {pop pop dup truetype exec} def /realtype {pop pop dup truetype exec} def /stringtype {stringwidth pop currentfont fontheight} def /nametype {iconfont setfont IconString stringbbox 4 2 roll pop pop} def /arraytype { dup xcheck {/size exch exec} {aload pop dup truetype exec} ifelse } def /packedarraytype /arraytype load def /dicttype {/size exch send} def end def % Beta 2 bug, litemenu.ps, class LiteMenu (% This is a string so //&ThingSizeDict is scanned at the right time. /ThingSize { % thing => width height //&ThingSizeDict begin gsave dup truetype exec grestore end } def ) cvx exec % Beta 2 bug, litemenu.ps, class LiteMenu (% This is a string so //&ShowThingDict is scanned at the right time. /ShowThing { % thing x y => - //&ShowThingDict begin gsave moveto dup truetype exec grestore end } def ) cvx exec } LiteMenu send { % send to Item: % Beta 2 bug, liteitem.ps, class Item /ThingSize { % thing textfont => width height gsave setfont % dup type { % X11/NeWS font type = dicttype, so use 'truetype' dup truetype { /stringtype {stringwidth pop currentfont fontheight} /nametype { dup { load } stopped pop xcheck { false exch cvx exec } { iconfont setfont iconstring stringbbox 4 2 roll pop pop } ifelse } /nulltype {0 0} /Default {0 0} } case grestore } def % Beta 2 bug, liteitem.ps, class Item /ShowThing { % thing color x y textfont => - gsave setfont translate setcolor 0 0 moveto % moveto establishs current pt. % dup type { % X11/NeWS font type = dicttype, so use 'truetype' dup truetype { /stringtype {0 currentfont fontdescent rmoveto show} /nametype { dup { load } stopped pop xcheck { true exch cvx exec } { iconfont setfont iconstring show } ifelse } /nulltype {pop} /Default {pop} } case grestore } def % Beta 2 bug, liteitem.ps, class Item /EraseThing { % thing color x y textfont => - gsave % X11/NeWS: {load} stopped => ... `load` true, but {load} errored => ... true % 4 index dup type /nametype eq exch { load } stopped pop xcheck and { 4 index dup type /nametype eq exch { load } errored pop xcheck and { 5 -1 roll exch ThingSize rectpath setcolor fill } { ShowThing } ifelse grestore } def } Item send { % send to SimpleScrollbar: % Beta 2 bug, liteitem.ps, class SimpleScrollbar % /ScrollDownArrow 16 16 1 { } { < % X11/NeWS: matrix arg isn't ignored! % > } buildimage def /ScrollDownArrow 16 16 1 [16 0 0 -16 0 16] { < 07F8 0FF8 0818 0818 0818 0818 781F F81F 8002 4004 2008 1010 0820 0440 0280 0100 > } buildimage def % Arrgh, it's still hosing me! I'm mad now! /PaintArrow { gsave translate scale setshade .5 .1 moveto .1 .9 lineto .5 .6 lineto .9 .9 lineto closepath fill grestore } def } SimpleScrollbar send } if % version 1.0 (beta 2 bugs) end % systemdict % end of X11/NeWS compatibility crud } { % else if not X11/NeWS (install NeWS 1.1 compatibility stuff) systemdict begin /truetype { type } ?def /RootUserDict 10 dict def end % systemdict } ifelse systemdict /shareddict known not { /shareddict growabledict def } def % End of compatibility crud. You can empty your barf bag now. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Icky system globals and merciless kludges systemdict begin /array? { % obj => bool type dup /arraytype eq exch /packedarraytype eq or } def /comment { pop } def % Reap dead debuggers /rd { systemdict /DbgDicts known { [ DbgDicts {pop} forall ] { dup /State get /zombie eq { dup killprocess DbgDicts exch undef } { pop } ifelse } forall } if } def rd /_ViewCanvas null def /_SendUpdateStack { count array astore aload null /UpdateStack _SendViewEvent % { flush } errored { % { dbgstop } errored quit % } if } def /_SendViewEvent { % ClientData Action Name => - createevent begin /Name exch def /Action exch def /ClientData exch def /Canvas currentprocess /Interests get 0 get % event /ClientData get /ViewCanvas get % can def currentdict end sendevent } def /_ReadyProcess { { currentprocess XNeWS? { dup /ProcessName (Spike) put } if createevent begin /Canvas _ViewCanvas def /Name /ProcessReady def /Action currentprocess def count array astore aload /ClientData exch def currentdict end sendevent createevent begin /Name 20 dict def Name begin /ExecIt { /ClientData get exec _SendUpdateStack } def /ReplaceStack { dup /Action get dup type /stringtype ne { pop } { { print flush } errored { { dbgstop } errored clear currentprocess killprocessgroup } if } ifelse /ClientData get count 1 roll count 1 sub {pop} repeat aload pop } def /DropDead { { dbgstop } errored { (Ayyyeee!\n) print flush } errored clear currentprocess killprocessgroup } def end % Name /ClientData 20 dict def ClientData begin /ViewCanvas _ViewCanvas def % Stash! end % ClientData currentdict end expressinterest % The /execfile kludge is to get around the fact that /execfile is a % function defined in systemdict in X11/NeWS pre fcs, instead of being % a file defined in userdict by executive, as in earlier versions. % The problem is that "dbgstart" checks for /execfile in userdict to % tell if an executive has already been started, and if it's not (or % even if it is, in our case), it starts one. (and executive doesn't % return, so we've lost control!) (Supposedly a call to "executive" % occurs right before "_ReadyProcess" on the input stream.) So until % such a time as "dbgstart" knows how to tell an executive has already % been started, we must fool it... /execfile dup load def dbgstart 256 { rd % reap dead rebuggers dstack { eventloop } stopped { (\nI'm confused...\n) print pause pause ExecutiveErrorHandler pause pause } if (\nTry again...\n) print pause pause } repeat (\nGame over, man!\n) print } fork createevent begin /Name /ExecIt def /Process exch def currentdict end { currentfile dup null eq { clear exit } if token { 1 index createevent copy % ev1 ob ev2 dup /ClientData 4 -1 roll % ev1 ev2 /CD obj [ exch ] cvx put % ev1 ev2 sendevent } { clear exit } ifelse } loop } def /eventloop { { awaitevent } loop } def /dstack { currentprocess /DictionaryStack get dup length (dstack[%]: ) printf { smart-name print ( ) print } forall (\n) print } def /enter-eventloop { dstack eventloop } def % This does not exit when you type "exit"...(invalidexit error) /enter-executive { { dstack executive exit } loop } def /enter { currentprocess /Interests get length 0 eq /enter-executive /enter-eventloop ifelse exch send dstack } def % Debugger Aliases /dbe {dbgbreakenter} def /dbx {dbgbreakexit} def /dc {dbgcontinue} def /dcb {dbgcontinuebreak} def /dcc {dbgcopystack dbgcontinue} def /dcs {dbgcopystack} def /de {dbgenter} def /deb {dbgenterbreak} def /dgb {dbggetbreak} def /dk {dbgkill} def /dkb {dbgkillbreak} def /dlb {dbglistbreaks} def /dmp {dbgmodifyproc} def /dp {dbgpatch} def /dpe {dbgprintfenter} def /dpx {dbgprintfexit} def /dw {dbgwhere} def /dwb {dbgwherebreak} def /dx {dbgexit} def % Useful aliases /fb {framebuffer} def /ls {[currentdict {pop} forall] ==} def XNeWS? not { % XXX? /revokekbdinterests { % [ int1 int2 ... intn ] can => - removefocusinterest % aload pop revokeinterest revokeinterest revokeinterest {{revokeinterest} errored {pop} if} forall } store } if { /getmenuaction { % index => action dup null ne { MenuActions 1 index MenuActions length 1 sub min get % Execute actions that are names! (This is so we can have the executable % name of a submenu, or a functions to compute the menu action!) dup type /nametype eq { exec } if } {nullproc} ifelse exch pop } def } LiteMenu send XNeWS? { % ick! /Primary dup framebuffer /new ClassSelection send exch setselection } if %% XNeWS? {ClassSelection begin} if currentdict /old-setselection known not { /old-setselection /setselection load def /setselection { % dict rank 2 copy old-setselection createevent begin /Name /SelectionChanged def /Action exch def /ClientData exch def currentdict end sendevent } def } if %% XNeWS? {end} if /select-object { % obj => - 20 dict begin /SelectionType /object def /ContentsPostScript 1 index def /ContentsAscii exch (%) sprintf def /SelectionObjSize 1 def /SelectionResponder null def /Canvas currentcanvas def % XXX? /SelectionHolder currentprocess def % XXX? currentdict end /PrimarySelection setselection } def /select-pointer { % obj index => - 20 dict begin /SelectionType /pointer def /SelectionStartIndex exch def /ContentsPostScript exch def /ContentsAscii /ContentsPostScript load /SelectionStartIndex load get (%) sprintf def /SelectionObjSize 1 def /SelectionResponder null def /Canvas currentcanvas def % XXX? /SelectionHolder currentprocess def % XXX? currentdict end /PrimarySelection setselection } def /select-interval { % obj start len => - 20 dict begin /SelectionType /interval def /SelectionObjSize exch def /SelectionStartIndex exch def /SelectionLastIndex SelectionStartIndex SelectionObjSize add 1 sub def /ContentsPostScript exch def /ContentsAscii /ContentsPostScript load SelectionStartIndex cvi SelectionObjSize cvi getinterval (%) sprintf def /SelectionResponder null def /Canvas currentcanvas def % XXX? /SelectionHolder currentprocess def % XXX? currentdict end /PrimarySelection setselection } def /dissect-selection { % seldict => obj dup selection-type { /empty { pop null % null } /unknown { % seldict } /text { /ContentsAscii get % string } /object { /ContentsPostScript get % obj } /pointer { dup /ContentsPostScript get % seldict container exch /SelectionStartIndex get % container index 1 index type /dicttype eq { 2 copy known } true ifelse { get % obj } { pop pop null % null } ifelse } /interval { dup /ContentsPostScript get % seldict container exch dup /SelectionStartIndex get cvi % container seldict start exch /SelectionLastIndex get % container start last 1 index sub 1 add cvi % container start len getinterval % obj } /Default { % seldict } } case } def /selection-type { % seldict => name dup null ne { dup /SelectionType known { dup /SelectionType get dup null ne exch /UnknownRequest ne and } false ifelse { /SelectionType get } { dup /ContentsAscii known { pop /text } { pop /unknown } ifelse } ifelse } { pop /empty } ifelse } def /interesting-keys [ /SelectionType /ContentsAscii /ContentsPostScript /SelectionStartIndex /SelectionLastIndex ] def XNeWS? { NewWorld? { /LiteSelectionDict 100 dict def /setselection { % LiteSelectionDict begin exch def end } def /request-selection { % rank => seldict LiteSelectionDict 1 index known { LiteSelectionDict exch get } { pop null } ifelse } def } { % not NewWorld? /request-selection { % rank => seldict 10 dict begin interesting-keys { null def } forall currentdict end exch selectionrequest } def } ifelse } { /request-selection { % rank => seldict dup getselection dup null ne { exch pop } { pop 10 dict begin interesting-keys { null def } forall currentdict end exch selectionrequest } ifelse } def } ifelse /selected-object { % - => obj /PrimarySelection request-selection dissect-selection } def /selected-pointer? { % - => false / collection index true /PrimarySelection request-selection dup selection-type /pointer eq { dup /ContentsPostScript get exch /SelectionStartIndex get true 2 index type /dicttype eq { 3 copy pop known not { % invalid pointer pop pop pop false } if } if } { pop false } ifelse } def /selected-interval? { % - => false / collection start last true /PrimarySelection request-selection dup selection-type /interval eq { dup /ContentsPostScript get exch dup /SelectionStartIndex get exch /SelectionLastIndex get true } { pop false } ifelse } def /selected-pointer-or-interval? { % - => false / collection first last true /PrimarySelection request-selection dup selection-type { /interval { dup /ContentsPostScript get exch dup /SelectionStartIndex get exch /SelectionLastIndex get true } /pointer { dup /ContentsPostScript get exch /SelectionStartIndex get dup true 2 index type /dicttype eq { 3 copy pop known not { % invalid pointer pop pop pop false } if } if } /Default { pop false } } case } def % NeWS-print 0.996 % Written by Josh Siegel % Munged by Don Hopkins /Externals 512 dict def /ExternalsBack 512 dict def Externals /Count 0 put /string-magic dictbegin (\b) 0 get (\\b) def (\f) 0 get (\\f) def (\n) 0 get (\\n) def (\r) 0 get (\\r) def (\t) 0 get (\\t) def (\() 0 get (\\\() def (\)) 0 get (\\\)) def (\\) 0 get (\\\\) def dictend def /fixstring { 10 dict begin /len 0 def /out 1 index length 3 mul string def { dup string-magic exch known { string-magic exch get } { cvis } ifelse out len 2 index putinterval /len exch length len add def } forall out 0 len cvi getinterval dup length string copy end } def /stringer { % proc => string dup type cvlit { /arraytype { pause /arraylvl arraylvl 1 add store dup xcheck { /the_string the_string ( {\n) append store { stringer } forall /the_string the_string ( }\n) append store } { /the_string the_string ( [\n) append store { stringer } forall /the_string the_string ( ]\n) append store } ifelse /arraylvl arraylvl 1 sub store } /nametype { dup xcheck { the_string arraylvl 0 eq (% /% cvx ) (% %) ifelse sprintf /the_string exch store } { the_string (% /%) sprintf /the_string exch store } ifelse } /operatortype { 255 string cvs dup length 2 sub 1 exch getinterval the_string arraylvl 0 eq (% /% cvx ) (% %) ifelse sprintf /the_string exch store } /stringtype { fixstring the_string (% \(%\)) sprintf /the_string exch store } /marktype { (mark ) % [ DANGER! ] } /booleantype /integertype /realtype /nulltype { the_string (% %) sprintf /the_string exch store } /Default { dup type /dicttype ne dictlvl 0 ne or arraylvl 0 ne or { ExternalsBack 1 index known { ExternalsBack exch get % name } { Externals begin Count /Count Count 1 add def end % obj count 1 index type (&%_%) sprintf % obj name Externals 1 index 3 index put % obj name ExternalsBack 3 -1 roll 2 index put % name } ifelse the_string ( //) append exch append /the_string exch store } { /dictlvl dictlvl 1 add store /the_string the_string ( dictbegin\n) append store { pause /the_string the_string (\t) append store exch stringer stringer /the_string the_string ( def\n) append store } forall /the_string the_string ( dictend \n) append store /dictlvl dictlvl 1 sub store } ifelse } def } case } def /tokeout { % obj => string 10 dict begin /cnt Externals /Count get def /dictlvl 0 def /arraylvl 0 def /the_string () def stringer the_string cnt Externals /Count get ne { (Externals begin\n%\nend\n) sprintf } def end } def % Short readable names /ShortNameDict 40 dict def ShortNameDict begin /nametype { dup xcheck (%) (/%) ifelse sprintf } def /dicttype { dup maxlength exch length (<%/%>) sprintf } def /arraytype { dup length exch xcheck ({%}) ([%]) ifelse sprintf } def /packedarraytype /arraytype load def /stringtype { dup length 80 gt { 0 80 getinterval ((%)...) } ((%)) ifelse sprintf } def /marktype { pop (mark) } def /eventtype { dup /Name get short-name exch /IsInterest get (interest(%)) (event(%)) ifelse sprintf } def /canvastype { gsave dup setcanvas clippath emptypath { 0 0 } { pathbbox points2rect 4 2 roll pop pop exch % h w } ifelse framebuffer setcanvas 3 -1 roll dup /Parent get null eq { pop (can(%,%)) sprintf } { getcanvaslocation exch (can(%,%,%,%)) sprintf } ifelse grestore } def XNeWS? { /fonttype { dup type /fonttype eq { pop (fontid) } { dup fontscale exch /FontName get (%%) sprintf } ifelse } def /processtype { dup /Execee get exch dup /State get exch dup /ProcessName known { /ProcessName get } (anonymous) ifelse (proc('%',%,%)) sprintf } def } { % not XNeWS? /processtype { % One or more of these is causing a core dump some of the time... (NeWS 1.1) % dup /Interests get length exch % dup /ExecutionStack get length exch % CORE DUMP % dup /DictionaryStack get length exch % dup /OperandStack get length exch % dup /Execee get exch % /State get % (proc(%,%,o%,d%,e%,i%)) sprintf dup /Execee get exch /State get (proc(%,%)) sprintf } def } ifelse % XNeWS? end % ShortNameDict /short-name { dup truetype ShortNameDict 1 index known { ShortNameDict exch get exec } { pop 80 string cvs } ifelse } def /smart-name { dup smart-type ( ) append exch short-name append } def /SmartTypeDict 40 dict def SmartTypeDict begin /dicttype { dup systemdict eq { pop (systemdict) } { % TODO: Detect the process's userdict ... magic-type } ifelse } def /canvastype { % dup framebuffer eq { % pop (framebuffer) % } { % magic-type % } ifelse magic-type } def /eventtype { magic-type } def /processtype { magic-type } def /fonttype { magic-type } def /integertype { dup floor sub 0 eq (integer) (real) ifelse } def end % SmartTypeDict /smart-type { % obj => str dup truetype % obj type SmartTypeDict 1 index known { SmartTypeDict exch get exec % str } { % obj type pop short-type % str } ifelse } def /magic-type { dup type /fonttype eq { false } { dup /ParentDictArray known } ifelse { dup /ParentDictArray get type /nametype ne } % Detect bogus classes! { false } ifelse { dup /ClassName known { % class /ClassName get 64 string cvs } { % instance % ugly ugly! /ClassName exch send 64 string cvs (.) exch append } ifelse } { short-type } ifelse } def /short-type { % obj => str truetype 20 string cvs 0 1 index length 4 sub getinterval } def systemdict /quicksort known not { % % quicksort by Don Woods at Sun Microsystems, Inc. % /quicksort { % array proc => array (sorted, reuses same storage) 10 dict begin /Bigger? exch cvx def % a b bigger? => t if a -- sorts array in place, using Bigger? for comparisons dup length dup 2 gt { % A N % the next lines (until but not incl /Key...) subsort three elements % so we can use the median as the partitioning element; this improves % performance for the case where the array is initially nearly sorted, % but is not strictly necessary for the algorithm to work (it does % seem to improve average runtime by about 10%) 2 copy 1 sub 2 copy 2 idiv 1 index 0 % A N A N-1 A (N-1)/2 A 0 6 copy get 5 1 roll get 3 1 roll get % above & A[N-1] A[(N-1)/2] A[0] 2 copy Bigger? {exch} if % subsort for three elements 3 1 roll 2 copy Bigger? {exch} if % ... (call them min mid max) 3 -1 roll 2 copy Bigger? {exch} if % ... subsort finished 9 index % A N A N-1 A (N-1)/2 A 0 min mid max N 3 eq { 5 2 roll put 4 1 roll put put % store min/mid/max back pop pop % pop A & N } { % else store mid at 0, max at N-1, min at (N-1)/2, then partition 3 -1 roll 5 2 roll put exch 4 1 roll put put % A N /Key 2 index 0 get def % partitioning value 0 % A N 0, also known as A j i { % main partitioning loop % incr i until i=j or A[i]>=A[0]; note A[j] is rangecheck { 1 add 2 copy gt { % i++; A j i j>i? dup 3 index exch get % A j i A[i] Key exch Bigger? not {exit} if } {exit} ifelse } loop % decr j until A[j]<=A[0]; happens at j=i-1 if not sooner exch { % A i j 1 sub dup 3 index exch get % A i j A[j] Key Bigger? not {exit} if } loop 2 copy gt {exit} if % if i>=j, finished partition % swap A[j] & A[i]; stack has: A i j 2 index 4 copy exch get % A i j A A i A[j] 4 1 roll get % A i j A[j] A A[i] 3 index exch put % A i j A[j] 4 copy exch pop put pop exch % A j i } loop % finish partition by exchanging A[j] with A[0]; stack has: A i j exch pop 2 copy 4 copy get % A j A j A j A[j] exch pop 0 exch put Key put % A j % now recur on A[0..j-1] and A[j+1..N-1] 2 copy 1 add 1 index length 1 index sub % A j A j+1 N-1 getinterval 3 1 roll 0 exch getinterval % A[j+1..N-1] A[0..j-1] 2 copy length exch length gt {exch} if % put smaller on top quickrecur quickrecur % tail recursion avoids deep stack } ifelse % =3 or >3 elements } { % handle 1- and 2-element cases specially for efficiency 2 eq { dup aload pop Bigger? {aload 3 1 roll exch 3 -1 roll astore} if } if pop % pop the array } ifelse } def % quickrecur % end of quicksort } if % quicksort not known % This function in systemdict makes sure ClassName is always in a % dictionary on the dict stack. Objects all have their own class % name. This function provides names for /systemdict and /userdict. % It returns the dictionary itself for other dictionaries. % % The use of this is a little bad and hacky because /ClassName is used % as a method for any object (including classes themselves), even though % it is not an advertised method in class Object. % /ClassName { % - => name | dict currentdict dup userdict eq {pop /userdict} if dup systemdict eq {pop /systemdict} if } ?def end % systemdict %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Userdict Utilities /shift-names 10 dict def shift-names begin /Meta false def /Shift false def /Control false def end % shift-names /update-shifts { shift-names {store} forall /KeyState get { shift-names 1 index known { true store } { pop } ifelse } forall } def /key-names 40 dict def key-names begin 8 (Backspace) def 9 (Tab) def 10 (Newline) def 13 (Return) def 27 (Escape) def 32 (Space) def 127 (Delete) def end % key-names /key-name { % key => string dup type /integertype eq { dup 127 and key-names 1 index known { key-names exch get } { dup 32 lt { 64 add cvis (^%) sprintf } { cvis } ifelse } ifelse exch 128 ge { (Meta-%) sprintf } if } { (%) sprintf } ifelse } def /comment-string { % obj => string dup array? { dup length 2 ge { dup 1 get /comment eq { 0 get } if } if } if (%) sprintf } def /destroy { % dummy destroy method for items } def % Forward messages on to stack /prompt { {} execute-it } def /execute-it { /execute-it dialog-item send } def /exec-it { /exec-it dialog-item send } def /push-it { /push-it dialog-item send } def /kbd-select-object { gsave can setcanvas select-object grestore } def /kbd-select-pointer { gsave can setcanvas select-pointer grestore } def /kbd-select-interval { gsave can setcanvas select-interval grestore } def % This is here because the scanner doesn't believe that \r's end comments! /remove-returns { % str => str' dup (\r) search not { pop } { % str rest \r pre length 1 add exch pop % str rest len 3 -1 roll dup length string copy % rest len str' 3 1 roll { % str' rest len 2 index 1 index 1 sub 10 put exch (\r) search { % str' len rest \r pre length 1 add exch pop % str' len rest len 3 -1 roll add % str' rest len } { % str' len rest pop pop exit } ifelse } loop } ifelse } def % Quantize the font size to a multiple of .5 so we don't blow up the % font cache. (This is mainly for X11/NeWS.) /scalefontquant { % font size => font 2 mul round 2 div scalefont } def % Stolen from: % stickem version 1.0 % Written by Josh Siegel (Wed Jun 29 1988) XNeWS? { /find_canvas { % x y => [canvases] canvasesunderpoint } def } { % NeWS 1.1 % getxyloc returns the position of the next left-button % mouse up event. It passes all other events. /getxyloc { % => x y gsave % ??? framebuffer setcanvas % ??? 10 dict begin createevent dup /Priority 20 put dup /Name /LeftMouseButton put dup /Action /UpTransition put /foobar exch def foobar expressinterest { awaitevent dup /Name get /LeftMouseButton eq { exit } if redistributeevent } loop foobar revokeinterest dup /XLocation get exch /YLocation get end grestore % ??? } def % find_tree traverses the canvas tree passed to it and calls % check_canvas to check to see if the point is in the % canvas. It is also a example of a recursive NeWS routine. /find_tree { % canvas => found? dup null eq { pop false } { dup /Mapped get { dup check_canvas { dup [ exch ] answer exch append /answer exch def /TopChild get { dup null eq { pop true exit } if dup find_tree { pop true exit } if /CanvasBelow get } loop } { pop false } ifelse } { pop false } ifelse } ifelse } def % Check canvas checks to see if the point is inside of the % clipping path of the canvas. This is VERY important for things % like the clock where the clipping path is round. % /check_canvas { % canvas => boolean framebuffer setcanvas % ??? dup getcanvaslocation % can xwin ywin ypnt exch sub % can xwin ypnt-ywin exch xpnt exch sub exch % can xpnt-xwin ypnt-ywin 3 -1 roll setcanvas clipcanvaspath pointinpath % boolean framebuffer setcanvas } def % find_canvas is a convient front end to the whole system. % I use a local dictionary to help in garbage collected in case % this routine is later used as part of a larger piece of code. /find_canvas { % x y => [canvas] gsave % ??? framebuffer setcanvas % ??? 10 dict begin /answer [ ] def /ypnt exch def /xpnt exch def framebuffer find_tree answer end grestore % ??? } def } ifelse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % CyberMenu class definition /CyberMenu systemdict /SoftMenu known { SoftMenu } { PieMenu } ifelse def /PulloutCyberMenu PulloutPieMenu def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NeWSScrollBar item definition systemdict begin % this is for textcan.ps /NeWSScrollbar SimpleScrollbar [] classbegin /setbgcolor { % color - => - /BoxFillColor exch def /ButtonFillColor BoxFillColor def } def classend def end % systemdict %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % StructItem class definition % This huge blob implements the data doo-dads. % It just kept getting bigger and bigger, before I realized what % was happening. This class should be factored out into several % classes... (I'll probably just reimplement it in NDE from % scratch.) /StructItem LabeledItem dictbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Instance variables /Shrink .9 def /Pad 3 def /Point null def /x 0 def /y 0 def /Levels 0 def /DL null def /ItemFrame 2 def /ItemRadius 5 def /ItemBorder 6 def /ItemButton [PointButton AdjustButton MenuButton] def /StackI null def /LayoutLock null def /LastX 0 def /LastY 0 def /LastTime 0 def /Clicks 1 def /TrackProc null def /DX 0 def /DY 0 def /TabX 0 def /TabY 0 def /TabWidth 0 def /TabHeight 0 def /PinX 0 def /layout-proc /layout-struct def /click-proc /click-transfer def /transfer-proc /paste-obj def /display-proc /display-tree-struct def /erase-proc /erase-label def /label-proc /object-label def /lw null def /lh null def /lx null def /ly null def /BigWidth 64 def /BigHeight 64 def /Filter? false def /OpenToRight? false def /ShowFan? true def /BackingCanvas null def /PopupCanvas null def dictend classbegin % Good god this has gotten bigger than dictbegin can handle! XNeWS? not { 300 currentdict extend pop } if %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class variables /ItemProperties [ /ItemLabelFont /ItemTextColor /ItemFillColor % /ItemBorderColor % /PopupTextColor /PopupFillColor /PopupShadowColor ] def /Properties [ /Font /Point ] def /StartPoint 12 def /DoubleClickTime 2 60 div def /DoubleClickDistanceSquared 8 dup mul def /CanvasYFudge 2 store /Sort? true def /SubStructureIndent 10 def /LineGap 30 def /Icon? false def /SortBy /by-name def % /UseBackingCanvas? ColorDisplay? def /UseBackingCanvas? true def /ItemLabelFont /Helvetica-Bold findfont 14 scalefontquant def /PopupX 5 def /PopupY -5 def ColorDisplay? { /PopupShadowColor .25 .25 .25 rgbcolor def /PopupTextColor .1 0 .7 rgbcolor def /PopupFillColor .75 .85 .85 rgbcolor def } { /PopupShadowColor .25 .25 .25 rgbcolor def /PopupTextColor 1 1 1 rgbcolor def /PopupFillColor 0 0 0 rgbcolor def } ifelse XNeWS? { % How about something sexy... % /ItemFont /AvantGarde-Book findfont def % Normal font % /ItemXFont /AvantGarde-BookOblique findfont def % Executable font % /ItemSFont /AvantGarde-Book findfont def % Small font % /ItemFont /GillSans findfont def % Normal font % /ItemXFont /GillSans-Italic findfont def % Executable font % /ItemSFont /GillSans findfont def % Small font /ItemFont /LucidaSans findfont def % Normal font /ItemXFont /LucidaSans-Italic findfont def % Executable font /ItemSFont /LucidaSans findfont def % Small font /SmallPointSize 7 def % Use small font when smaller than this. } { % NeWS 1.1 /ItemFont /Courier-Bold findfont def % Normal font /ItemXFont /Courier-BoldOblique findfont def % Executable font /ItemSFont /Courier findfont def % Small font /SmallPointSize 10 def % Use small font when smaller than this. } ifelse %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Initialization stuff /new { % Collection Index notifyproc parentcanvas => instance 4 2 roll 2 copy get type (% \267) sprintf % notify parent cont ind label 5 1 roll 2 array astore % label notify parent object 3 1 roll /Right % label object notify parent loc 3 1 roll % label object loc notify parent /new super send begin ItemCanvas /Transparent false put % ItemCanvas /Transparent true put ItemCanvas /Retained ItemParent /Retained get put /LayoutLock createmonitor def /xhair /xhair_m ItemCanvas setstandardcursor /PopupCanvas ItemCanvas newcanvas def PopupCanvas /SaveBehind true put currentdict end } def /ensure-DL { DL null eq { Collection Index Levels grow-struct /DL exch store /ObjectWidth 0 store } if ObjectWidth 0 eq ObjectHeight 0 eq or { perform-layout } if } def /makestartinterests { /makestartinterests super send [ exch aload pop /DoTransfer {/DoTransfer /Self GetFromCurrentEvent send} null ItemCanvas eventmgrinterest dup /Exclusivity true put dup /Self self PutInEventMgrInterest ] } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Event handlers /DoTransfer { % event => - unblockinputqueue % ??? ItemBegin /it self store CurrentEvent update-shifts do-search ob null eq { % pththth } { % Are we transfering something to where it already is? CurrentEvent /ClientData get ob eq { % Transfering an object into itsself toggles its opened/closed state click-open } { % Beam me up, Scotty! ob begin /transfer-proc load end cvx { exec } fork pop pop } ifelse } ifelse ItemEnd pop % XXX? } def /ClientDown { unblockinputqueue % ??? ItemBegin /it self store currenttime LastTime sub DoubleClickTime lt CurrentEvent begin LastX XLocation sub dup mul LastY YLocation sub dup mul add /LastX XLocation store /LastY YLocation store end DoubleClickDistanceSquared lt and { /Clicks Clicks 1 add store } { /Clicks 1 store } ifelse /LastTime currenttime store CurrentEvent update-shifts CurrentEvent /Name get MenuButton eq { event-in-tab? { show-tab-menu } { show-struct-menu } ifelse } { CurrentEvent /Name get PointButton eq { % CurrentEvent recallevent event-in-tab? { items FillColor self slipslideitem } { do-search ob null eq { items FillColor self slipslideitem } { Clicks 1 eq { make-selection } { TrackProc null ne { TrackProc killprocess } if click-exec } ifelse } ifelse } ifelse } { CurrentEvent /Name get AdjustButton eq { event-in-tab? { toggle-icon } { do-search ob null eq { } { NotifyUser } ifelse } ifelse } if } ifelse } ifelse ItemEnd } def /old-make-selection { TrackProc null ne { TrackProc killprocess } if 2 60 div blockinputqueue /TrackProc { 20 dict begin /TipX null def /TipY null def /OldIndex null def /StartIndex null def /LastIndex null def /Multiple? false def obs length 1 le { /MySiblings [ob] def } { obs dup length 2 sub get /MySiblings 1 index /Branches get dup null eq { pop nullarray } if 2 index /Controls get dup null eq { pop } { append } ifelse def /TipX 1 index /TipX get def /TipY exch /TipY get def /Multiple? ob /C get array-or-string? Shift and def } ifelse /StartIndex 0 MySiblings { /I get ob /I get eq { exit } if 1 add } forall def /LastIndex StartIndex def ItemCanvas createoverlay setcanvas ObjectX ObjectY ObjectHeight add translate currentcursorlocation { newpath pop pop /LastIndex 0 MySiblings { /Y get y le { exit } if 1 add } forall MySiblings length 1 sub min store Multiple? not { /StartIndex LastIndex store } if TipX null ne { TipX 1 add TipY moveto MySiblings StartIndex LastIndex min get begin X Y H add 1 sub lineto end MySiblings StartIndex LastIndex max get begin X Y 1 add lineto end closepath fill } if MySiblings StartIndex LastIndex min get begin X 1 sub Y H add moveto end StartIndex LastIndex min 1 StartIndex LastIndex max { MySiblings exch get begin X W add dup Y H add lineto Y lineto end } for MySiblings StartIndex LastIndex max get begin X 1 sub Y lineto end closepath Shift { stroke } { fill } ifelse OldIndex LastIndex ne { /OldIndex LastIndex store Multiple? { % Don't select part of control panel MySiblings StartIndex get /C get MySiblings LastIndex get /C get eq { MySiblings StartIndex get /C get StartIndex LastIndex 2 copy gt {exch} if MySiblings exch get /I get exch MySiblings exch get /I get exch 1 index sub 1 add kbd-select-interval } if } { MySiblings LastIndex get Shift { % Shift to select array index /I get kbd-select-object } { dup /C get exch /I get kbd-select-pointer } ifelse } ifelse } if } getanimated unblockinputqueue waitprocess /MySiblings null store /TrackProc null store end } fork store } def /make-selection { TrackProc null ne { TrackProc killprocess } if 2 60 div blockinputqueue /TrackProc { unblockinputqueue 20 dict begin /px0 null def /py0 null def /px1 null def /py1 null def /prp null def /TipX null def /TipY null def /OldIndex null def /StartIndex null def /LastIndex null def /Multiple? false def obs length 1 le { /MySiblings [ob] def } { obs dup length 2 sub get /MySiblings 1 index /Branches get dup null eq { pop nullarray } if 2 index /Controls get dup null eq { pop } { append } ifelse store /TipX 1 index /TipX get def /TipY exch /TipY get def /Multiple? ob /C get array-or-string? Shift and def } ifelse /StartIndex 0 MySiblings { /I get ob /I get eq { exit } if 1 add } forall def /LastIndex StartIndex store ItemCanvas createoverlay setcanvas ObjectX ObjectY ObjectHeight add translate currentcursorlocation { pop pop /LastIndex 0 MySiblings { /Y get y le { exit } if 1 add } forall MySiblings length 1 sub min store OldIndex LastIndex ne { Multiple? not { /StartIndex LastIndex store } if /prp [ % Make polyrectpath MySiblings StartIndex LastIndex min get begin /px0 X 1 sub store /py0 Y H add store end /px1 px0 store /py1 py0 store StartIndex LastIndex 2 copy gt { exch } if % from to 1 exch { % i MySiblings exch get begin X W add px1 /px1 2 index store sub % dx Y py1 /py1 2 index store sub % dx dy end } for -1 add % bop height by 1 MySiblings StartIndex LastIndex max get /W get neg ] store newpath TipX null ne { TipX 1 add TipY moveto MySiblings StartIndex LastIndex min get begin X Y H add 1 sub lineto end MySiblings StartIndex LastIndex max get begin X Y 1 add lineto end closepath } if px0 py0 prp polyrectpath px0 PopupX add py0 PopupY add prp polyrectpath PopupCanvas /Mapped false put PopupCanvas reshapecanvas PopupCanvas /Transparent false put PopupCanvas /SaveBehind true put % PopupCanvas /SaveBehind false put PopupCanvas /Mapped true put gsave PopupCanvas setcanvas PopupShadowColor setcolor clippath fill px0 PopupX add py0 PopupY add prp polyrectpath clip clippath PopupFillColor setcolor fill PopupTextColor setcolor PopupX PopupY ObjectHeight sub translate false BackingCanvas imagemaskcanvas grestore /OldIndex LastIndex store Multiple? { % Don't select part of control panel MySiblings StartIndex get /C get MySiblings LastIndex get /C get eq { MySiblings StartIndex get /C get StartIndex LastIndex 2 copy gt {exch} if MySiblings exch get /I get exch MySiblings exch get /I get exch 1 index sub 1 add kbd-select-interval } if } { MySiblings LastIndex get Shift { % Shift to select array index /I get kbd-select-object } { dup /C get exch /I get kbd-select-pointer } ifelse } ifelse } if } getanimated waitprocess /MySiblings null store /TrackProc null store PopupCanvas /Mapped false put end } fork store } def /make-selection { TrackProc null ne { TrackProc killprocess } if 2 60 div blockinputqueue /TrackProc { unblockinputqueue 20 dict begin /px0 null def /py0 null def /px1 null def /py1 null def /prp null def /TipX null def /TipY null def /Obj null def /Dragged? false def ItemCanvas createoverlay setcanvas ObjectX ObjectY ObjectHeight add translate currentcursorlocation { pop pop gsave ItemCanvas setcanvas Dragged? { PopupX PopupY translate } if do-search grestore Obj ob ne ob null ne and { Obj null ne Dragged? not and { /Dragged? true store } if /Obj ob store obs length 1 gt { obs dup length 2 sub get begin TipX null ne { TipX 1 add TipY moveto ob begin X Y 2 copy H add 1 sub lineto 1 add lineto end % ob closepath } if end % ob' } if ob begin X Y 1.1 sub round W 1 add H 1.3 add round rectpath X PopupX add Y 1.1 sub PopupY add round W 1 add H 1.3 add round rectpath end % ob PopupCanvas /Mapped false put PopupCanvas reshapecanvas PopupCanvas /Transparent false put % PopupCanvas /SaveBehind true put PopupCanvas /SaveBehind false put PopupCanvas /Mapped true put gsave PopupCanvas setcanvas ob begin X PopupX add round Y 1.1 sub PopupY add round W 1 add H 1.3 add round rectpath end % ob gsave gsave clippath pathbbox points2rect grestore rectpath PopupShadowColor setcolor eofill grestore clip % PopupFillColor setcolor fill % PopupTextColor setcolor % PopupX PopupY ObjectHeight sub translate % false BackingCanvas imagemaskcanvas PopupX PopupY ObjectHeight sub translate ColorDisplay? { PopupFillColor setbackcolor PopupTextColor setcolor BackingCanvas imagecanvas } { % the colors are ignored in monochrome PopupFillColor setbackcolor PopupTextColor setcolor % So we do this... 3 setrasteropcode BackingCanvas imagecanvas } ifelse grestore pause Shift { % Shift to select array index ob /I get kbd-select-object } { ob /C get ob /I get kbd-select-pointer } ifelse } if } getanimated waitprocess /TrackProc null store PopupCanvas /Mapped false put end } fork store } def /show-tab-menu { userdict /it self put CurrentEvent /showat TabMenu send } def /show-struct-menu { ItemBegin do-search ob null eq { /ob DL store } if ob null ne { CurrentEvent /showat StructMenu send } if ItemEnd } def /ClientUp { StopItem } def /click-exec { Shift { click-step } { ob /Obj get exec-it } ifelse } def /click-transfer { unblockinputqueue % null blockinputqueue { % unblockinputqueue % (Aaah, that feels much better -- thanks Stan!) gsave 10 dict begin Shift { % Shift to select the index ob /I get } { ob /Obj get } ifelse /thing exch def /thing load kbd-select-object /str /thing load smart-name def ItemLabelFont setfont fboverlay setcanvas currentcursorlocation { lineto str show } getanimated waitprocess aload pop % x y createevent begin /Name /DoTransfer def /YLocation exch def /XLocation exch def /Action 1 dict def Action begin /Source /thing load def end % We're sneaking this in so DoTransfer can tell if we're transfering % something to where it already is, in which case we just do a % click-open, to open or close the object's internal structure. /ClientData ob def currentdict sendevent end grestore } fork pop } def /click-magic { % Invoke magic editing function... obs length 1 gt { { ob /C get dup array-or-string? { pop currentdict } if begin ob /Obj get use-parent-obj cvx exec end } fork pop pause } if } def % click-proc /click-edit { % Invoke magic editing function... obs length 1 gt { { ob /C get dup array-or-string? { pop currentdict } if begin ob /C get ob /I get get cvx change-parent-obj end } fork pop pause } if } def % click-proc /click-user { % Invoke magic editing function... obs length 1 gt { { ob /C get dup array-or-string? { pop currentdict } if begin ob /C get ob /I get get change-parent-obj end } fork pop pause } if } def /click-push { push-obj } def /old-click-step { [ ob /C get ob /I get get ] cvx exec-it } def /click-step { gsave ItemCanvas createoverlay setcanvas ObjectX ObjectY ObjectHeight add translate ob dup begin X Y W H rectpath end [ exch /Obj get /gsave load % Whip me beat me make me check bad writes! currentstate /setstate load /erasepage load /grestore load ] cvx fill exec-it obs length 1 le { /MySiblings [ob] store }{ obs dup length 2 sub get /MySiblings 1 index /Branches get dup null eq { pop nullarray } if store } ifelse /StartIndex 0 MySiblings { /I get ob /I get eq { exit } if 1 add } forall store /LastIndex StartIndex store currentcursorlocation { newpath pop pop /LastIndex 0 MySiblings { /Y get y le { exit } if 1 add } forall MySiblings length 1 sub min store { StartIndex LastIndex ge { exit } if /StartIndex StartIndex 1 add store MySiblings StartIndex get dup begin newpath X Y W H rectpath end [ exch /Obj get /gsave load % Whip me beat me make me check bad writes! currentstate /setstate load /erasepage load /grestore load ] cvx fill exec-it } loop } getanimated waitprocess /MySiblings null store grestore } def /click-type-dict 100 dict def click-type-dict begin /integertype { Shift 1 -1 ifelse add } def /realtype { Shift -1 1 ifelse add } def /booleantype { not } def end % click-type-dict /click-type { ob /Obj get dup type click-type-dict 1 index known { click-type-dict exch get cvx exec replace-obj } { pop pop %%% /click-proc load cvx exec } ifelse } def /click-forkunix { ob /C get ob /I get get dup type /stringtype eq {{forkunix}} {{cvx exec forkunix}} ifelse fork pop pop } def /click-dragcanvas { { ob /C get ob /I get get dup /Parent get null eq { pop } { gsave setcanvas false dragcanvas grestore obs { begin } forall ItemTextColor setcolor ObjectX ObjectY ObjectHeight add translate currentdict end draw-struct obs length 1 sub { end } repeat } ifelse } fork pop } def /click-dragimage { { ob /C get ob /I get get % % can gsave dup createoverlay setcanvas ob /C get % EditorDict begin % EditorDict currentcursorlocation { 2 copy y0 sub ViewY exch sub /ViewY exch store x0 sub ViewX exch sub /ViewX exch store /y0 exch store /x0 x store ViewX ViewY ViewWidth ViewHeight rectpath } getanimated waitprocess pop end % EditorDict obs { begin } forall ItemCanvas setcanvas ItemTextColor setcolor ObjectX ObjectY ObjectHeight add translate currentdict end draw-struct obs length 1 sub { end } repeat grestore } fork pop } def /handle-click { % - => - ob null ne { % obs /begin load forall ob begin /click-proc load end % ob % obs length /end load repeat cvx exec } if % pop % ??? the notifyproc should not pop the event } def /open-icon { Icon? { /ObjectWidth OW store /ObjectHeight OH store currentdict /Icon? undef redo-shape } if } def /close-icon { Icon? not { gsave /OW ObjectWidth def /OH ObjectHeight def Font setfont Str stringbbox points2rect /IconH exch def /IconW exch def pop pop /ObjectWidth IconW store /ObjectHeight IconH store grestore /Icon? true def redo-shape } if } def /toggle-icon { DL begin Icon? { open-icon } { close-icon } ifelse end /LastTime 0 store } def /open-icon-obj { ob null ne { ob /Icon? undef } if redo-layout } def /close-icon-obj { ob null ne { ob /Icon? true put } if redo-layout } def /open-item-props { /ob DL store /obs [DL] store /item-props open-editor } def /click-select { Clicks 1 eq { % first click ob null ne { Shift { % Shift to select the index ob /I get } { ob /Obj get } ifelse Control { exec-it /LastTime 0 store } { kbd-select-object } ifelse } if } { click-open } ifelse } def /click-open { ob null ne { DL begin Icon? end { toggle-icon } { Shift { ob /L get 1 add open-struct } { ob /L get 0 eq { 1 open-struct } { close-struct } ifelse } ifelse } ifelse } if } def /event-in-tab? { ItemBegin newpath label-bbox rectpath CurrentEvent begin XLocation YLocation end pointinpath ItemEnd } def /ClientExit { StopItem } def /Silent? { % - => bool Meta Control Shift or and } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Menu callbacks /push-array-obj { ob /Obj get % [stack] selected-object % [stack] top 1 index type /stringtype eq 1 index type /integertype ne and { pop pop } { 1 index type /stringtype eq { cvis } { [ exch ] } ifelse % [stack] [top] 1 index exch append % [stack] [stack top] exch xcheck { cvx } if replace-obj } ifelse } def /pop-array-obj { ob /Obj get dup length 0 eq { pop } { dup dup length 1 sub get kbd-select-object 0 1 index length 1 sub getinterval replace-obj } ifelse } def /prepend-to-array-obj { selected-object dup array-or-string? not { pop } { % [sel] ob /Obj get % [sel] {obj} dup type /stringtype eq % [sel] {obj} objstring? 1 index type /stringtype eq xor { % [sel] {obj} % incompatible types pop pop % } { % [sel] {obj} exch 1 index % {obj} [sel] {obj} append % {obj} [sel obj] exch xcheck { cvx } if % {sel obj} replace-obj % } ifelse } ifelse } def /append-to-array-obj { selected-object dup array-or-string? not { pop } { % [sel] ob /Obj get % [sel] {obj} dup type /stringtype eq % [sel] {obj} objstring? 1 index type /stringtype eq xor { % [sel] {obj} % incompatible types pop pop % } { % [sel] {obj} dup 3 -1 roll % {obj} {obj} [sel] append % {obj} [obj sel] exch xcheck { cvx } if % {obj sel} replace-obj % } ifelse } ifelse } def /top-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select part of this array } { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get {} forall Len Start neg roll Start Len Last sub 1 sub add Start roll ] ob /Obj get dup type /stringtype eq { % [65 66 67] (abc) exch 0 exch { % (abc) 0 65 3 copy put pop 1 add } forall pop pop } { copy pop } ifelse end ob /Obj get replace-obj } ifelse } if } def /bottom-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select a part of this array } { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get {} forall Len Start sub Len Last sub 1 sub roll ] ob /Obj get dup type /stringtype eq { % [65 66 67] (abc) exch 0 exch { % (abc) 0 65 3 copy put pop 1 add } forall pop pop } { copy pop } ifelse end ob /Obj get replace-obj } ifelse } if } def /delete-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select a part of this array } { 10 dict begin /Last exch cvi def /Start exch cvi def /Cont exch cvlit def /Len Cont length def Cont 0 Start getinterval cvlit Cont Last 1 add Len Last 1 add sub getinterval cvlit append % [ ob /Obj get aload pop % Len Start sub % Len Last sub 1 sub roll % Last Start sub 1 add {pop} repeat % ] end ob /Obj get xcheck {cvx} if replace-obj } ifelse } if } def /splice-array-obj { selected-interval? { % collection start last 2 copy get dup array? { 2 index ob /Obj get eq { 10 dict begin /Last exch cvi def /Start exch cvi def /Len exch length def [ ob /Obj get 0 Start getinterval aload pop ob /Obj get Start Last Start sub 1 add getinterval ob /Obj get xcheck {cvx} if ob /Obj get Last 1 add Len Last sub 1 sub getinterval aload pop ] end ob /Obj get xcheck {cvx} if replace-obj } { pop pop pop % error: select an array or an interval of this array } ifelse } { pop pop pop % error: can't do that to strings! } ifelse } { selected-pointer? { % collection index 2 copy get dup array? { % collection index array 2 index ob /Obj get eq { 10 dict begin /Arr exch cvlit def /Start exch cvi def /Len exch length def [ ob /Obj get 0 Start getinterval aload pop Arr aload pop ob /Obj get Start 1 add Len Start sub 1 sub getinterval aload pop ] end ob /Obj get xcheck {cvx} if replace-obj } { pop pop pop % error: select an array or an interval of this array } ifelse } { pop pop pop % error: select an array or an interval of this array } ifelse } if } ifelse } def /def-in-dict-obj { selected-pointer? { % collection index exch 1 index get % index obj true } { selected-object dup null eq { pop false } { % index dup type /stringtype eq { cvn } if null % index object true } ifelse } ifelse { % index obj ob /Obj get 3 copy pop put % index obj pop ob /Obj get exch % dict index ob /Branches get null eq { pop pop } { % dict index 0 grow-struct % DL ob begin /Branches [ % DL mark Branches { % DL mark branch dup /I get counttomark 2 add index /I get eq {pop} if } forall counttomark 3 add -1 roll % mark branches... DL ] Sort? {SortBy quicksort} if def % end } ifelse % redo-layout } if } def /undef-in-dict-obj { selected-pointer? { % collection index exch pop ob /Obj get exch % dict index true } { selected-object null eq { pop false } { ob /Obj get exch % dict index dup type /stringtype eq { cvn } if % XXX: NeWS BUG in undef!! (Marja) true } ifelse } ifelse { % dict index ob /Obj get 1 index known not { pop } { % index ob /Obj get exch % dict index 2 copy get kbd-select-object undef % ob begin Branches null ne { /Branches [ Branches { begin /C load /I load known { currentdict } if end } forall ] def } if end redo-layout } ifelse % } if } def /break-obj { { clear ob /Obj get dup type /dicttype eq { dup /ParentDict known { { { ClassName dbgbreak } exch send } } { { countdictstack 1 sub { end } repeat dup begin currentdict 30 string cvs cvn dbgbreak } } ifelse } { { dup type dbgbreak } } ifelse { exec } fork pop pop } fork pop } def /begin-obj { ob /Obj get begin-it } def /enter-obj { ob /Obj get enter-it } def % Executes func in a bullet proof child process, with just Obj on stack. % Replaces Obj with whatever the process left on the top of the stack, % and updates the view. /change-obj { % func => - 20 dict begin /Obj ob /C get ob /I get get def /Func exch def /DbgErrorHandler { % Assumptions assumptions ... /errorname exch def currentprocess /OperandStack get currentprocess /ExecutionStack get currentprocess /DictionaryStack get /command $error /command get def /message $error /message get def /newerror true def /dstack exch def /estack exch def /ostack exch def /gstate currentstate def /interests currentprocess /Interests get def currentdict currentprocess killprocess % take me I'm yours } def % We should try to make this execute in the context of the cyber process. % Make sure things that depend on us still work... { clear /Obj load Func } fork end waitprocess modify-obj } def % Execute token with Externals on the dict stack, so externalized % //&type_123 object references are resolved. /tokein-obj { ob /Obj get type /stringtype eq { { clear Externals begin ob /Obj get remove-returns { { token { exch } { exit } ifelse } loop } errored { clear ob /Obj get } { count array astore cvx } ifelse end } fork waitprocess kbd-select-object } if } def /cvx-obj { { ob /Obj get cvx } errored {pop} { % replace-obj kbd-select-object } ifelse } def /cvn-obj { { ob /Obj get cvn } errored {pop} { % replace-obj kbd-select-object } ifelse } def /cvs-obj { { ob /Obj get 256 string cvs } errored {pop} { % replace-obj kbd-select-object } ifelse } def /tokeout-obj { ob /Obj get tokeout kbd-select-object } def /cvlit-obj { { ob /Obj get cvlit } errored {pop} { % replace-obj kbd-select-object } ifelse } def /cvi-obj { { ob /Obj get cvi } errored {pop} { % replace-obj kbd-select-object } ifelse } def /cvr-obj { { ob /Obj get cvr } errored {pop} { % replace-obj kbd-select-object } ifelse } def /load&push-obj { ob /Obj get load&push-it } def /load&push-it { % [ exch cvlit {dup load} /errored cvx { pop smart-name (%% ) (%Load: % is not defined!\n) printf } { exch smart-name 1 index smart-name exch (%% ) (%Load: % Push: %\n) printf } /ifelse cvx ] cvx execute-it } def /load-obj { ob Shift /I /Obj ifelse get load-it } def /load-it { % [ exch cvlit {dup load} /errored cvx { pop smart-name (%% ) (%Load: % is not defined!\n) printf } { exch smart-name 1 index smart-name exch (%% ) (%Load: % Select: %\n) printf select-object } /ifelse cvx ] cvx execute-it } def /pointsize-obj { % point => - dup /Default eq { pop ob /Point undef } { ob exch /Point exch put } ifelse redo-layout } def /shrink-obj { % shrink => - dup /Default eq { pop ob /Shrink undef } { ob exch /Shrink exch put } ifelse redo-layout } def /update-obj { % ... } def /open-obj { % levels => - dup 0 eq { pop close-struct } { open-struct } ifelse } def /set-open-direction { % bool => - { /Right { ob /OpenToRight? true put } /Below { ob /OpenToRight? false put } /Default { ob /OpenToRight? undef } } case } def /open-right-obj { % levels => - /Right set-open-direction open-obj } def /open-below-obj { % levels => - /Below set-open-direction open-obj } def /set-show-fan { % bool => - dup { true false { ob exch /ShowFan? exch put } /Default { pop ob /ShowFan? undef } } case } def /push-obj { ob Shift /I /Obj ifelse get push-it } def /push-it { [ exch [ exch ] 0 /get cvx /dup cvx /smart-name cvx (%% ) (%Push: %\n) /printf cvx ] cvx execute-it } def /begin-it { [ exch [ exch ] 0 /get cvx /dup cvx /smart-name cvx (%% ) (%Begin: %\n) /printf cvx /begin cvx /dstack cvx ] cvx execute-it } def /enter-it { [ exch [ exch ] 0 /get cvx /dup cvx /smart-name cvx (%% ) (%Enter: %\n) /printf cvx /enter cvx ] cvx execute-it } def /insert-before-obj { } def /insert-after-obj { } def /molecule-obj { ob /Obj get start_visualizer } def % construct a reference to a piece of substructure relative to the % top level object /reference-obj { obs length 2 lt { {} } { [ obs dup 1 exch length 1 sub getinterval { /I get cvlit /get cvx } forall ] cvx kbd-select-object } ifelse } def /exec-obj { ob /Obj get Shift {[exch]cvx} if exec-it } def /exec-it { % obj => - { [ exch cvlit /cvx cvx /dup cvx /smart-name cvx (%% ) (%Exec: %\n) /printf cvx cvx /exec cvx ] cvx execute-it } fork pop pop pause } def /paste-obj { selected-object replace-obj } def /replace-obj { % obj => - ob begin replace-struct end Silent? not { redo-layout } if ob DL eq StackI null ne and { % Tell processes if we changed its stack. /ReplaceStack items StackI get send } if } def /modify-obj { % obj => - LayoutLock { ob begin gsave % ItemCanvas setcanvas BackingCanvas setcanvas 0 ObjectHeight translate /erase-proc load cvx exec C I 3 -1 roll put make-label change-label grestore ItemBegin paint-struct ItemEnd end } monitor ob DL eq StackI null ne and { % Tell processes if we changed its stack. /ReplaceStack items StackI get send } if } def /make-label { % - => str /Obj /C load /I load get def % get default if not defined (don't use parent's) currentdict /label-proc known { /label-proc load } { self /label-proc get } ifelse cvx exec } def % func is passed the object, and the object is replaced by % whatever's left on the top of stack. /transform-obj { % func => - LayoutLock { ob begin gsave % ItemCanvas setcanvas BackingCanvas setcanvas 0 ObjectHeight translate /erase-proc load cvx exec C I 2 copy get 4 -1 roll {errored pop} fork waitprocess exch pop exch pop put pop pop make-label change-label grestore end } monitor ob DL eq StackI null ne and { % Tell processes if we changed its stack. /ReplaceStack items StackI get send } if } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Moving and shaping /just-reshape { % Core dumps X11/NeWS beta 1: % ItemCanvas null ne { ItemCanvas /Mapped false put } if /ItemHeight exch store /ItemWidth exch store ItemWidth 0 eq ItemHeight 0 eq or { /DL null store } if ensure-DL adjust-geometry ItemWidth ItemHeight /reshape super send gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore % ItemCanvas /Mapped true put } def /reshape { % x y w h => - just-reshape location move } def /just-move { % x y => - /move super send } def /move { % x y => - label-bbox /lh exch store /lw exch store % x y lx ly 2 index add /ly exch store % x y lx 2 index add /lx exch store % x y ly 0 max /ClientHeight win send lh sub min ly sub add exch lx 0 max /ClientWidth win send lw sub min lx sub add exch cvi exch cvi exch /move super send snaps-here? pop Index ThisI eq { /paint-hilite win send } if StackI null ne StackI Index ne and { /MoveMe TellStack } if } def /redo-layout { gsave ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate perform-layout redo-shape grestore } def /redo-shape { %location 10 10 just-reshape location 10 10 reshape damage-view } def /label-bbox { % x y w h TabX TabY TabWidth TabHeight } def /tab-top { % - => y location TabY add TabHeight add exch pop } def /tab-bottom { % - => y location TabY add exch pop } def /label-rect { % X Y w h location TabY add exch TabX add exch TabWidth TabHeight } def /object-bbox { % x y w h ObjectX ItemBorder sub ObjectY ItemBorder sub % x y ObjectWidth ItemBorder dup add add % w ObjectHeight ItemBorder dup add add % h } def /ItemPath { ItemRadius label-bbox rrectpath ItemRadius object-bbox rrectpath } def /AdjustItemSize { % - => - [uses item context] ObjectLoc { /Right /Left /RightBelow /RightAbove /LeftBelow /LeftAbove { /ItemWidth ItemBorder 3 mul ItemGap add LabelWidth add ObjectWidth add store /ItemHeight ItemBorder 2 mul LabelHeight ObjectHeight max add store } /Top /Bottom /AboveLeft /AboveRight /BelowLeft /BelowRight { /ItemWidth ItemBorder 2 mul LabelWidth ObjectWidth max add store /ItemHeight ItemBorder 3 mul ItemGap add LabelHeight add ObjectHeight add store } } case } def /CalcObj&LabelXY { % - => - [uses item context] ObjectLoc { /RightAbove { /LabelX ItemBorder def /LabelY ItemBorder store /ObjectX ItemBorder dup add LabelWidth add ItemGap add store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store /TabHeight LabelHeight ItemBorder dup add add def } /RightBelow /Right { /LabelX ItemBorder store /LabelY ItemHeight ItemBorder sub LabelHeight sub store /ObjectX ItemBorder dup add LabelWidth add ItemGap add store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store /TabHeight LabelHeight ItemBorder dup add add def } /LeftAbove { /LabelX ItemBorder dup add ItemGap add ObjectWidth add store /LabelY ItemBorder store /ObjectX ItemBorder store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemGap sub ItemRadius dup add sub store /TabY LabelY ItemBorder sub store /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store /TabHeight LabelHeight ItemBorder dup add add def } /LeftBelow /Left { /LabelX ItemBorder dup add ItemGap add ObjectWidth add store /LabelY ItemHeight ItemBorder sub LabelHeight sub store /ObjectX ItemBorder store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemGap sub ItemRadius dup add sub store /TabY LabelY ItemBorder sub store /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store /TabHeight LabelHeight ItemBorder dup add add def } /AboveRight /Top { /LabelX ItemBorder def /LabelY ItemBorder store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder dup add LabelHeight add ItemGap add store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add add def } /AboveLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub store /LabelY ItemBorder store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder dup add LabelHeight add ItemGap add store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add add def } /BelowRight /Bottom { /LabelX ItemBorder store /LabelY ItemBorder dup add ObjectHeight add ItemGap add store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder store /TabX LabelX ItemBorder sub store /TabY LabelY ItemGap sub ItemRadius dup add sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add def } /BelowLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub store /LabelY ItemBorder dup add ObjectHeight add ItemGap add store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder store /TabX LabelX ItemBorder sub store /TabY LabelY ItemGap sub ItemRadius dup add sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add def } } case /PinX LabelX LabelWidth add 2 sub store } def /adjust-geometry { /ItemLabel nice-item-label store LabelSize /LabelHeight exch def /LabelWidth exch def AdjustItemSize CalcObj&LabelXY /BackingCanvas null def } def /nice-item-label { Collection Index get smart-type (% \267) sprintf } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Display /paint { ItemBegin damagepath emptypath not { pathbbox points2rect newpath rectpath } if clipcanvas PaintItem newpath clipcanvas ItemEnd } def /PaintItem { LayoutLock { ItemRadius label-bbox rrectpath ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius label-bbox rrectframe ItemBorderColor setcolor eofill } if ItemRadius object-bbox rrectpath ObjectX 1 add ObjectY 1 add ObjectWidth 2 sub ObjectHeight 2 sub rectpath ItemFillColor setcolor eofill ItemFrame 0 gt { ItemFrame ItemRadius object-bbox rrectframe ItemBorderColor setcolor eofill } if ShowLabel paint-struct } monitor } def /paint-struct { %{ gsave ensure-DL UseBackingCanvas? { BackingCanvas null eq { /BackingCanvas ObjectWidth .4 add round ObjectHeight .4 add round 2 copy mul 0 eq { pop pop 1 1 } if 1 [ 1 0 0 -1 0 7 index ] % w h d [1 0 0 -1 0 h] null buildimage % can def BackingCanvas setcanvas % ItemFillColor fillcanvas 1 fillcanvas % ItemTextColor setcolor 0 setgray 0 ObjectHeight translate DL draw-struct ItemCanvas setcanvas } if ObjectX ObjectY translate ItemTextColor setcolor ItemFillColor setbackcolor BackingCanvas imagecanvas } { ItemTextColor setcolor ObjectX ObjectY ObjectHeight add translate DL draw-struct } ifelse grestore %} fork waitprocess pop } def /damage-view { gsave %ItemParent setcanvas bbox rectpath extenddamage %paint ItemCanvas setcanvas clippath extenddamage grestore } def % distillery display stubs /_fill {fill} def /_eofill {eofill} def /_stroke {stroke} def /_show {show} def /_newpath {newpath} def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Accessers /Collection { ItemObject 0 get cvlit } def /Index { ItemObject 1 get cvlit } def /array? { % obj => bool type dup /arraytype eq exch /packedarraytype eq or } def /array-or-string-dict 5 dict def array-or-string-dict begin /arraytype dup def /packedarraytype dup def /stringtype dup def end % array-or-string-dict /array-or-string? { % obj => bool type //array-or-string-dict exch known } def currentdict /array-or-string-dict undef %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Structure stuff /do-search { /it self store DL begin Icon? end { /obs [ DL ] store /ob DL store } { gsave ObjectX ObjectY ObjectHeight add translate DL % CurrentEvent begin XLocation YLocation end currentcursorlocation search-struct /obs exch store obs length 0 eq { null } { obs dup length 1 sub get } ifelse /ob exch store grestore } ifelse } def % Return the path down the display list to the substructure enclosing (x,y). /search-struct { % dict x y => [ dl1 dl2 ... dln ] { % keep return stack from overflowing 10 dict begin /ssy exch def /ssx exch def [ exch { do-search-struct % unsucessful search exit } loop % catch possible exit dup true eq { pop } if ] end } fork % dict x y process 4 1 roll pop pop pop waitprocess } def % This keeps overflowing the fucking execution stack in NeWS 1.1! /do-search-struct { % dl => dl dl' dl'' dl''' ... begin %gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore %pause pause %gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore ssx X ge { ssy Y ge { ssx X W add le { ssy Y H add le { currentdict end % dl dup /Controls get % dl controls dup null eq { pop } { { do-search-struct } forall % dl .. dn mark | dl dup true eq { exit } if % exit if something found } ifelse % dl dup /Branches get % dl branches dup null eq { pop } { { do-search-struct } forall % dl ... dn mark | dl dup true eq { exit } if % exit if something found } ifelse % We were found, but none of our children, leave true on % top of stack to unwind search. true exit } if } if } if } if end } def /do-search-struct { % dl => dl dl' dl'' dl''' ... begin %gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore %pause pause %gsave X Y W H rectpath 0 setgray 5 setrasteropcode fill grestore ssx X ge { ssy Y ge { ssx X W add le { ssy Y H add le { currentdict end % dl dup /Controls get % dl controls dup null eq { pop } { { do-search-struct } forall % dl .. dn mark | dl dup true eq { exit } if % exit if something found } ifelse % dl dup /Branches get % dl branches dup null eq { pop } { { do-search-struct } forall % dl ... dn mark | dl dup true eq { exit } if % exit if something found } ifelse % We were found, but none of our children, leave true on % top of stack to unwind search. true exit } if } if } if } if end } def /close-struct { DL /Icon? undef ob /L 0 put ob /Branches null put ob /Controls null put Silent? not { redo-layout } if } def % TODO: Open up special editors on different object types. % Numberic keypad % Boolean toggle % Color sliders % Font finder % Canvas view % Visual graphics state editors % String editor % CyberSpace projection % Event's XLocation YLocation should be relative to the event's Canvas, or % framebuffer if null. /use-parent-obj { obs length 1 gt { /obs obs 0 1 index length 1 sub getinterval store /ob obs dup length 1 sub get store } if } def /change-parent-obj { % func use-parent-obj change-obj } def /make-button { % dl => dl dup /label-proc /button-label put dup /display-proc /display-button put } def /make-edit-button { % dl => dl make-button dup /click-proc /click-edit put } def /make-magic-button { % dl => dl make-button dup /click-proc /click-magic put } def /make-user-button { % dl => dl dup /click-proc /click-user put dup /label-proc /value-label put dup /display-proc /display-button put } def /struct-editors 50 dict def struct-editors begin % ------------------------------------------------------------------------ /step { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin % Make fresh copies so user can change scalars /++ {Step add} def currentdict /++ cvx 0 grow-struct make-edit-button /-- {Step sub} def currentdict /-- cvx 0 grow-struct make-edit-button /Step 1 def currentdict /Step cvx 0 grow-struct end ] def % force a real send: Silent? not { /redo-layout null self exch pop send } if } def /shift { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin % Make fresh copies so user can change scalars (**) {Shift mul} def currentdict (**) cvn cvx 0 grow-struct make-edit-button (//) {Shift div} def currentdict (//) cvn cvx 0 grow-struct make-edit-button /Shift 10 def currentdict /Shift cvx 0 grow-struct end ] def Silent? not { /redo-layout null self exch pop send } if } def /digit { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin Controls null ne { Controls aload pop } if % Make fresh copies so user can change scalars 0 1 9 { dup [ /floor load 10 /mul load 5 index /add load ] cvx def currentdict exch 0 grow-struct make-edit-button } for /Rubout [ 10 /div load /floor load ] cvx def currentdict /Rubout 0 grow-struct make-edit-button /Clear [ /pop load 0 ] cvx def currentdict /Clear 0 grow-struct make-edit-button /+- /neg load def currentdict /+- cvx 0 grow-struct make-edit-button end ] def Silent? not { /redo-layout null self exch pop send } if } def /boolean { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin Controls null ne { Control aload pop } if /True true def currentdict /True 0 grow-struct make-edit-button /False false def currentdict /False 0 grow-struct make-edit-button /Not /not load def currentdict /Not 0 grow-struct make-edit-button /Random [/random cvx .5 /lt cvx] cvx def currentdict /Random 0 grow-struct make-edit-button end ] def Silent? not { /redo-layout null self exch pop send } if } def /element { open-obj-branches Silent? not { /redo-layout null self exch pop send } if } def /filter { Branches null eq { /Branches C I 1 grow-struct 1 index get def } if /Controls [ % XXX: Will this work? Controls null ne { Controls aload pop } if 20 dict begin /Recompute { ob begin /Obj /C load /I load get def end ContainerRef 0 ob /Obj get put ob /Branches [ Container array-or-string? { IndexRef 0 0 put } if Container { ObjectRef exch 0 exch put Container array-or-string? { IndexRef 0 2 copy get 1 add put } { IndexRef exch 0 exch put } ifelse mark false /Filter load cvx { exec } errored { cleartomark } { dup type /booleantype ne { pop false } if { cleartomark Container Index 0 grow-struct } { cleartomark } ifelse } ifelse } forall ] Order put ObjectRef 0 null put ContainerRef 0 null put IndexRef 0 null put Silent? not { /redo-layout null self exch pop send } if } def currentdict /Recompute 0 grow-struct make-magic-button /ObjectRef [ null ] def /Object ObjectRef cvx def /ContainerRef [ null ] def /Container ContainerRef cvx def /IndexRef [ null ] def /Index IndexRef cvx def % Filters may call: Container Index Object /Filter % - => interesting? false def currentdict /Filter 0 grow-struct /Keys 100 dict def currentdict /Keys 1 grow-struct /Order [ /Obj load array-or-string? /by-value /by-name ifelse /quicksort cvx ] cvx def currentdict /Order 0 grow-struct % /View null def % currentdict /View 0 grow-struct % counttomark 1 sub /ViewIndex exch def ] currentdict end 3 1 roll def begin Recompute end } def /scroller { Branches null eq { /Branches C I 1 grow-struct 1 index get def } if % currentdict /AllBranches known not { /AllBranches Branches def % } if /Controls [ % XXX: Will this work? Controls null ne { Controls aload pop } if 20 dict begin /Recompute { /Offset Offset ob /Obj get length 1 sub min 0 max def ob /Branches ob /AllBranches get Offset 1 index length 1 index sub Size min cvi getinterval put /Scroll (% : %..% of %, %) [ ob /Str get Offset Offset ob /Branches get length add 1 sub ob /AllBranches get length 2 index 1 index div 100 mul round 5 string cvs (%) append ] sprintf def Silent? not { /redo-layout null self exch pop send } if } def /Scroll (nothingness) def currentdict /Scroll 0 grow-struct % /Top { % /Offset 0 def % Recompute % } def % currentdict /Top 0 grow-struct % dup /click-proc /click-magic put % % /Bottom { % /Offset ob /Obj get length Size sub def % Recompute % } def % currentdict /Bottom 0 grow-struct % dup /click-proc /click-magic put /Back { /Offset Offset Size sub def Recompute } def currentdict /Back 0 grow-struct make-magic-button /Next { /Offset Offset Size add def Recompute } def currentdict /Next 0 grow-struct make-magic-button /Offset 0 def % currentdict /Offset 0 grow-struct /Size 10 def currentdict /Size 0 grow-struct Controls null ne { Controls aload pop } if ] currentdict end 3 1 roll def begin Recompute end } def /user { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin /User selected-object def currentdict /User 0 grow-struct make-user-button end ] def Silent? not { /redo-layout null self exch pop send } if } def % Pop open pointers to instances of this name on the dictionary stack. /definitions { /Controls [ Controls null ne { Controls aload pop } if mark obs aload pop { dup mark eq { pop /getdictstack dialog-item send exit } { dup /ClassEditor known { begin cleartomark /C load end % ClassEditorDict /ClassDicts get /getdictstack dialog-item send append exit } { pop } ifelse } ifelse } loop % Remove redundant dictionaries 100 dict begin dup {null def} forall [ exch { % dict currentdict 1 index known { currentdict 1 index undef % dict } { pop % } ifelse } forall ] end { dup ob /Obj get known { ob /Obj get 0 grow-struct dup /label-proc /reference-label put } { pop } ifelse } forall ] dup length 0 eq { pop pop } { def } ifelse Silent? not { /redo-layout null self exch pop send } if } def XNeWS? { /class { ob /C get ob /I get get dup /ParentDictArray known not {pop} { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin % ClassEditorDict /Obj ob /C get ob /I get get def /Instance? Obj /ClassName known not def /Class Obj Instance? { /ParentDictArray get } if def /ClassDicts [ Class /ParentDictArray get aload pop Class Instance? { Obj } if ] def /MethodDict 1000 dict def /ClassVarDict 1000 dict def /ClassName dup Obj send def currentdict /ClassName 0 grow-struct ClassDicts { { Class /InstanceVars get 2 index known not { dup xcheck 1 index array? and { MethodDict 2 index dup put } { ClassVarDict 2 index dup put } ifelse } if pop pop } forall pause pause } forall currentdict /ClassDicts 0 grow-struct Instance? not { /SubClasses dup Class send def currentdict /SubClasses 0 grow-struct pause pause } if /InstanceVars [ Class /InstanceVars get { pop (%) sprintf } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /InstanceVars 0 grow-struct dup /ClassEditor true put pause pause /ClassVars [ ClassVarDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /ClassVars 0 grow-struct dup /ClassEditor true put pause pause /Methods [ MethodDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /Methods 0 grow-struct dup /ClassEditor true put pause pause /Obj null def /Class null def /MethodDict null def /ClassVarDict null def end % ClassEditorDict ] def Silent? not { /redo-layout null self exch pop send } if } ifelse } def } { /class { ob /C get ob /I get get dup /ParentDict known not {pop} { /Controls [ Controls null ne { Controls aload pop } if 20 dict begin /Obj ob /C get ob /I get get def /Instance? Obj /ClassName known not def /Class Obj Instance? { /ParentDict get } if def /ClassDicts [ Obj /ParentDictArray get aload pop Obj ] def /MethodDict 1000 dict def /ClassVarDict 1000 dict def ClassDicts { { Class /InstanceVarDict get 2 index known not { dup xcheck 1 index array? and { MethodDict 2 index dup put } { ClassVarDict 2 index dup put } ifelse } if pop pop } forall pause pause } forall currentdict /ClassDicts 0 grow-struct Instance? not { /SubClasses [ /SubClasses Class send { (%) sprintf } forall ] {gt} quicksort [ exch { cvn dup where { exch get } if } forall ] def currentdict /SubClasses 0 grow-struct pause pause } if /InstanceVars [ Class /InstanceVarDict get { pop (%) sprintf } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /InstanceVars 0 grow-struct dup /ClassEditor true put pause pause /ClassVars [ ClassVarDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /ClassVars 0 grow-struct dup /ClassEditor true put pause pause /Methods [ MethodDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /Methods 0 grow-struct dup /ClassEditor true put pause pause /Obj null def /Class null def /MethodDict null def /ClassVarDict null def end ] def Silent? not { /redo-layout null self exch pop send } if } ifelse } def } ifelse /canvas { ob /C get ob /I get get type /canvastype ne {pop} { /Controls [ Controls null ne { Controls aload pop } if 10 dict begin /CanvasBBoxView ob /C get ob /I get get def currentdict /CanvasBBoxView 0 grow-struct dup begin /layout-proc /layout-canvasbbox def /display-proc /display-canvasbbox def /erase-proc /erase-nothing def /click-proc /click-dragcanvas def /transfer-proc /transfer-reparent def end % This needs to be fixed to work under X11/NeWS. % But it uses too much space anyway... Needs to be its own type of editor. % /CanvasImageView ob /C get ob /I get get def % currentdict /CanvasImageView 0 grow-struct % dup begin % /layout-proc /layout-canvasimage def % /display-proc /display-canvasimage def % /erase-proc /erase-nothing def % /click-proc /click-dragimage def % /transfer-proc /transfer-reparent def % end % % /ViewX 0 def % /ViewY 0 def % % CanvasImageView canvas-rect % x y w h % 4 2 roll pop pop % w h % BigHeight min exch BigWidth min exch % % /ViewHeight exch def % /ViewWidth exch def % currentdict /ViewWidth 0 grow-struct % currentdict /ViewHeight 0 grow-struct /Children [ ob /C get ob /I get get /TopChild get { dup null eq { pop exit } if dup /CanvasBelow get } loop ] def currentdict /Children 0 grow-struct end ] def Silent? not { /redo-layout null self exch pop send } if } ifelse } def % Pop open item property editor /item-props { /Controls [ Controls null ne { Controls aload pop } if ItemProperties { dup dup load promote self exch 0 grow-struct % dup /label-proc /reference-label put } forall ] def Silent? not { /redo-layout null self exch pop send } if } def % ------------------------------------------------------------------------ end % struct-editors /open-editor { % name => - struct-editors 1 index known not { pop nhh } { gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin struct-editors exch get exec end grestore } ifelse } def /open-struct-editor { % - => - gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin C I get dup type dup struct-editors exch known not { pop pop } { struct-editors exch get exec } ifelse end % Silent? not { redo-layout } if grestore } def /open-struct { % levels => - gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin grow-substruct end Silent? not { redo-layout } if grestore } def % (dl on dictstack) /replace-struct { % obj => - % Oh, lordy, lordy, lordy! mark exch C I 3 -1 roll { put } errored { cleartomark } { cleartomark C I L grow-struct begin /Branches Branches % /Controls Controls /C dup load /I dup load % /L L /Obj dup load /Str Str /X X /Y Y /W W /H H /Font Font end def def def def def def def def def def def % def } ifelse } def % DL on dict stack /grow-substruct { % l => - /L exch def /Branches C I L grow-struct 1 index get def } def /composite-type-dict 30 dict def composite-type-dict begin { /arraytype /dicttype /canvastype /processtype /eventtype /fonttype /stringtype % use special string editor % X11/NeWS: /packedarraytype /colormapentrytype /environmenttype /colormaptype % X11/NeWS pre-fcs bug causes panic when we open these! /visualtype /cursortype } { true def } forall end % composite-type-dict /composite? { % obj => bool type //composite-type-dict exch known } def /forbidden-dict 50 dict def forbidden-dict begin /Interests null def /Process null def /BuildChar null def /Encoding null def /WidthArray null def /ParentDictArray null def /ParentDict null def /TopCanvas null def /BottomCanvas null def /TopChild null def /CanvasAbove null def /CanvasBelow null def /Parent null def end % forbidden-dict /forbidden? { forbidden-dict exch known Filter? and } def % Collection Index Levels => dict /grow-struct { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { /hourg /hourg_m ItemCanvas setstandardcursor do-grow-struct } monitor /xhair /xhair_m ItemCanvas setstandardcursor } def % label-proc /object-label { % - => str /Obj load % short-name currentdict DL eq { short-name } { smart-name I short-name ( : ) append exch append } ifelse } def % label-proc /button-label { Branches null eq { I 80 string cvs % Insert spaces to make button easier to press, and so round % caps don't overlap label. ( % ) sprintf } { object-label } ifelse } def % label-proc /value-label { Branches null eq { /Obj load smart-name % Insert spaces to make button easier to press, and so round % caps don't overlap label. ( % ) sprintf } { object-label } ifelse } def % label-proc /reference-label { % - => str /C load smart-name ( ) append /I load short-name append ( : ) append /Obj load smart-name append } def /do-grow-struct { % Container Index Levels => DL pause 32 dict begin /L exch def cvlit /I exch def cvlit /C exch def /Obj null def /Str make-label def % updates /Obj /X 0 def /Y 0 def /W 0 def /H 0 def /StrY 0 def /TipX null def /TipY null def L 0 gt { I forbidden? not { /Obj load dup type dup /stringtype ne exch /fonttype ne and { composite? } {pop false} ifelse } false ifelse } { false } ifelse { open-obj-branches currentdict /Controls known not { /Controls null def } if } { /Branches null def /Controls null def } ifelse currentdict end } def /open-obj-branches { /Obj load dup array-or-string? { /Branches exch [ exch { pop /Obj load counttomark 1 sub L 1 sub do-grow-struct } forall ] def } { % Bullet proofing against invalidaccess errors on magic dicts % (i.e. unimplemented accessors in threaded interpreter) currentprocess /errordict get currentprocess /errordict 2 index 100 dict copy dup /invalidaccess {pop} put dup /unimplemented {pop} put put exch /Branches exch [ exch { pop /Obj load exch L 1 sub do-grow-struct } forall ] Sort? {SortBy quicksort} if def currentprocess /errordict 3 -1 roll put } ifelse } def % /SortBy default: /by-name { /Str get exch /Str get lt } def /by-value { /Str get cvr exch /Str get cvr lt } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Layout /perform-layout { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { { /hourg /hourg_m ItemCanvas setstandardcursor /ItemLabel nice-item-label store init-format DL do-layout /ObjectHeight DL /H get store adjust-geometry } fork waitprocess pop } monitor /xhair /xhair_m ItemCanvas setstandardcursor } def /init-format { /Point StartPoint def /x 0 def /y 0 def /ObjectWidth 0 def /ObjectHeight 0 def } def % /LineHeight { % Font fontheight 1 add % } def /do-layout { % dict => - begin /layout-proc load cvx exec end pause } def % /old-layout-struct { % - => - % /Str make-label def % /Obj load xcheck Point SmallPointSize gt and { % /Font ItemXFont Point scalefontquant def % } { % /Font Point SmallPointSize le % ItemSFont ItemFont ifelse Point scalefontquant def % } ifelse % Font setfont % /X x def % /Y y def % /W Str stringwidth pop LineGap add def % Branches null eq { % Icon? or % /H LineHeight def % } { % /x x W add store % Point % /Point Point Shrink mul store % Branches { % do-layout % } forall % /Point exch store % /x x W sub store % 0 0 % w h % Branches { % begin % exch W max % exch H add % end % } forall % W H % LineHeight max 1 max /H exch def % /TipX X W add LineGap sub def % /TipY Y H 2 div sub def % W add /W exch def % } ifelse % /Y Y H sub def % /StrY Y Font fontdescent add H LineHeight sub 2 div add def % /y Y store % /ObjectWidth ObjectWidth x W add LineGap sub max store % } def % layout-proc /layout-struct { % - => - /Str make-label def /Obj load xcheck Point SmallPointSize gt and { /Font ItemXFont Point scalefontquant def /LineHeight Font fontheight .5 add 1 max def } { /Font Point SmallPointSize le ItemSFont ItemFont ifelse Point scalefontquant def /LineHeight Font fontheight .5 add 1 max def } ifelse Font setfont /X x def /Y y def /W Str stringwidth pop Pad dup add add def /StrX X Pad add def Branches null eq { % Icon? or /H LineHeight def /Y Y H sub def /StrY Y Font fontdescent add H LineHeight sub 2 div add def /y Y store } { OpenToRight? { /x x W add Pad add LineGap add store /y y Pad sub store } { /x x SubStructureIndent add Pad add LineGap add store /y y LineHeight sub Pad sub store } ifelse Point /Point Point Shrink mul store Branches /do-layout load forall /Point exch store OpenToRight? { /x x W sub Pad sub LineGap sub store } { /x x SubStructureIndent sub Pad sub LineGap sub store } ifelse 0 % w Branches { /W get max } forall % W Branches length 0 eq { 0 % W H /TipY Y H 2 div sub def } { Branches 0 get begin Y H add end % TopY Branches dup length 1 sub get /Y get % TopY BottomY 2 copy add 2 div % TopY BottomY TipY /TipY exch def % TopY BottomY sub % W H } ifelse OpenToRight? { % W H LineHeight max 0 max Pad dup add add /H exch def % LineHeight max 0 max /H exch def /TipX X W add Pad add def W add Pad add LineGap add /W exch def /Y Y H sub Pad sub def /StrY Y Font fontdescent add H Pad sub LineHeight sub 2 div add Pad add def /y Y store } { % W H 1 max LineHeight add Pad dup add add /H exch def /TipX x SubStructureIndent add Pad add def SubStructureIndent add Pad add LineGap add W max Pad add /W exch def /Y Y H sub def /StrY Y Font fontdescent add H LineHeight sub add def /y Y store } ifelse } ifelse Controls null ne { /x x SubStructureIndent add store % /x x LineGap 2 div add store /y y Pad sub store % XXX? Point /Point Point Shrink mul store Controls /do-layout load forall /Point exch store % /x x LineGap 2 div sub store /x x SubStructureIndent sub store 0 % w Controls { /W get max } forall % W Controls length 0 eq { 0 % W H } { Controls 0 get begin Y H add end % TopY Controls dup length 1 sub get /Y get % TopY BottomY sub % W H } ifelse /Y Y 2 index sub Pad dup add sub def % /H exch H add def /W exch LineGap 2 div add W max def /H exch H add Pad dup add add def /W exch SubStructureIndent add Pad add W max def /y Y store } if /ObjectWidth ObjectWidth x W add max store } def /canvas-rect { % can => w h gsave setcanvas clippath pathbbox points2rect grestore } def % layout-proc /layout-canvasbbox { /Str make-label def /Font ItemFont Point scalefontquant def C I get dup type /canvastype ne { pop 1 1 } { % size of parent or of self if null parent dup /Parent get dup null ne { exch } if pop canvas-rect % x y w h 4 2 roll pop pop % w h } ifelse /ParentH exch def /ParentW exch def /LineHeight Point 5 mul 1 max def /H LineHeight Pad dup add add def % why the extra pad??? /W LineHeight ParentH div ParentW mul Pad dup add add def /X x def /Y y H sub def /y Y store /ObjectWidth ObjectWidth x W add max store } def % layout-proc /layout-canvasimage { /Str make-label def /Font ItemFont Point scalefontquant def % C I get dup type /canvastype ne { pop 1 1 } { % % size of parent or of self if null parent % dup /Parent get dup null ne { exch } if % pop canvas-rect % x y w h % 4 2 roll pop pop % w h % } ifelse /LineHeight Point 5 mul 1 max def /H C /ViewHeight get Pad dup add add def /W C /ViewWidth get Pad dup add add def /X x def /Y y H sub def /y Y store /ObjectWidth ObjectWidth x W add max store } def /transfer-reparent { % if it's a canvas, and we're a canvas, reparent it into our canvas. % XXX: TODO! } def /draw-struct { % dict => - pause begin Icon? { gsave Font setfont 0 Font fontdescent IconH sub 2 copy moveto Str _show translate -2 ItemRadius Str stringbbox points2rect insetrrect rrectpath % 0 setlinewidth % ItemBorderColor setcolor 0 setgray _stroke grestore } { gsave % get default if not defined (don't use parent's) currentdict /display-proc known { /display-proc load } { self /display-proc get } ifelse cvx exec grestore } ifelse end } def % The arcto's trigger a pathforall bug with still.ps ... % display-proc /bad-display-button { _newpath X Y 1 add moveto X W add Y 1 add % x1 y1 2 copy H 2 div add % x1 y1 x2 y2 Pad arcto pop pop pop pop % X W add Y H add % x1 y1 X Y H add % x1 y1 x2 y2 Pad arcto pop pop pop pop X Y H add lineto _stroke display-tree-struct } def % display-proc /display-button { _newpath X Y 1 add moveto % X Y moveto W Pad sub 0 rlineto Pad Pad rlineto % 0 H Pad dup add sub rlineto 0 H Pad dup add sub 1 sub rlineto Pad neg Pad rlineto Pad W sub 0 rlineto _stroke display-tree-struct } def % display-proc /display-tree-struct { show-obj Branches null ne { show-structure-lines show-insides } if Controls null ne { show-control-lines show-controls } if } def % display-proc /display-canvasbbox { X Pad add Y Pad add translate W Pad dup add sub ParentW div H Pad dup add sub ParentH div scale _newpath 0 0 ParentW ParentH rectpath .5 setgray _fill C I get % can dup type /canvastype eq { dup /Parent get null eq } true ifelse { pop } { gsave dup /Parent get setcanvas dup getcanvaslocation grestore translate canvas-rect % x y w h rectpath % % ItemBorderColor setcolor 0 setgray _fill } ifelse } def % display-proc /display-canvasimage { X Y translate _newpath 0 0 W H rectpath gsave .5 setgray _fill grestore % ItemBorderColor setcolor _stroke 0 setgray _stroke Pad Pad translate 0 0 W Pad dup add sub H Pad dup add sub rectpath clip _newpath C I get % can dup type /canvastype eq { dup /Parent get null eq } true ifelse { pop } { gsave dup canvas-rect % x y w h C /ViewX get neg C /ViewY get neg translate scale % x y pop pop % imagecanvas grestore } ifelse } def /show-obj { gsave 0 setgray Font setfont StrX StrY moveto Str _show grestore } def % erase-proc /erase-nothing { } def % erase-proc /erase-label { gsave Font setfont StrX StrY translate Str stringbbox points2rect % x y w h exch Pad add exch % fudge the width rectpath % X Y W H rectpath ItemFillColor setcolor fill grestore } def /erase-lines { Branches null ne { Branches length 0 ne { gsave newpath TipX 1 sub Y Branches 0 get /X get TipX sub 2 add H rectpath ItemFillColor setcolor fill grestore } if } if } def /old-change-label { % str => - gsave Font setfont Str stringwidth pop exch /Str exch def Str stringwidth pop exch sub dup 0 eq Branches null eq or { pop show-obj } { erase-lines /TipX exch TipX add def TipX Branches 0 get /X get Pad 4 mul sub TipX lt { /TipX TipX LineGap add def /redo-layout null self exch pop send } { show-structure-lines show-obj } ifelse } ifelse grestore } def /change-label { % str => - OpenToRight? { old-change-label } { /Str exch def show-obj } ifelse } def % /show-structure-lines { % TipX TipY % Branches length 0 eq { % 2 copy moveto Pad dup rlineto % moveto Pad dup neg rlineto % _stroke % } { % Branches 0 get % first % begin % 2 copy moveto % X Pad sub Y H add lineto % Pad 5 mul 0 rlineto % _stroke % end % ShowFan? { % Branches 0 1 index length 1 sub getinterval { % begin % 2 copy moveto % X Pad sub Y lineto % Pad 2 mul 0 rlineto % _stroke % end % } forall % } if % Branches dup length 1 sub get begin % moveto % X Pad sub Y lineto % Pad 5 mul 0 rlineto % _stroke % end % } ifelse % OpenToRight? not { % TipX TipY moveto % Pad neg 0 rlineto % TipX Pad sub StrY Font fontdescent sub lineto % _stroke % } if % } def % /show-structure-lines { % ItemBorderColor setcolor 0 setgray % 1 setlinewidth Branches length 0 eq { TipX TipY moveto Pad 0 rlineto _stroke } { C I get dup type /arraytype ne { pop } { xcheck { % draw { } % TODO: Make braces! Branches 0 get begin Y H add end % TopY Branches dup length 1 sub get /Y get % TopY BottomY sub 2 div % FanHeight TipX LineGap add % FanHeight x TipY 2 index add % FanHeight x y moveto % FanHeight LineGap neg 1 index -2 div rlineto LineGap 4 div % FanHeight dx 1 index -4 div % FanHeight dx dy rlineto % FanHeight _stroke TipX LineGap add % FanHeight x TipY 2 index sub % FanHeight x y moveto % FanHeight LineGap neg 1 index 2 div rlineto LineGap 4 div % FanHeight dx 1 index 4 div % FanHeight dx dy rlineto % FanHeight pop % _stroke } { % draw [ ] TipX LineGap add % x Branches 0 get begin Y H add end % x y moveto % LineGap neg 0 rlineto TipX % x Branches dup length 1 sub get /Y get % x y lineto % LineGap 0 rlineto _stroke } ifelse } ifelse TipX TipY % x y Branches 0 get begin 2 copy moveto X Y H add lineto Pad 5 mul 0 rlineto _stroke end ShowFan? { Branches 0 1 index length 1 sub getinterval { begin 2 copy moveto X Y lineto Pad 2 mul 0 rlineto _stroke end } forall } if Branches dup length 1 sub get begin moveto % X Y lineto Pad 5 mul 0 rlineto _stroke end } ifelse TipX TipY moveto Pad neg 0 rlineto OpenToRight? not { TipX Pad sub StrY Font fontdescent sub lineto } if _stroke } def /show-insides { Branches { draw-struct } forall } def /show-control-lines { Controls null ne { Controls length 0 ne { % ItemBorderColor setcolor 0 setgray Controls dup length 1 sub get begin X dup Y moveto end StrY Font fontdescent sub lineto _stroke } if } if } def /show-controls { Controls { draw-struct } forall } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Printing /write-DL { DL print-struct } def /print-struct { { LayoutLock { gsave ItemCanvas setcanvas erasepage % ObjectX ObjectY ObjectHeight add translate StillDict begin 10 dict begin /_usefont? true def /_out? true def /_output_tx 0 def /_output_ty 0 def /_output_sx 1 def /_output_sy 1 def _stillbegin /UseBackingCanvas? false def ItemRadius label-bbox rrectpath % label-bbox rectpath ItemFillColor setcolor _fill ItemFrame 0 gt { ItemFrame ItemRadius label-bbox rrectframe % ItemFrame label-bbox rectframe ItemBorderColor setcolor _eofill } if ItemRadius object-bbox rrectpath % object-bbox rectpath ItemFillColor setcolor _fill ItemFrame 0 gt { ItemFrame ItemRadius object-bbox rrectframe % ItemFrame object-bbox rectframe ItemBorderColor setcolor _eofill } if % ShowLabel: ItemLabel ItemTextColor LabelX LabelY ItemLabelFont gsave setfont moveto setcolor % Assuming a string Thing... 0 currentfont fontdescent rmoveto _show grestore ItemTextColor setcolor ObjectX ObjectY ObjectHeight add translate 1 setlinewidth DL draw-struct _stillend end % 10 dict end % StillDict grestore } monitor } fork waitprocess pop } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stack stuff /execute-it { % obj => - /exec-and-update dialog-item send } def /TellStack { % message => - createevent begin /Name exch def /ClientData Index def /Action StackI def /Canvas ItemParent def currentdict end sendevent } def /pack { StackI null ne { /PackStack items StackI get send } if } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Snap dragging /pinned? { % y h => bool location pop PinX add 3 1 roll % x y h 6 exch % x y w h pin-rect rectsoverlap } def % items backgroundcolor => - (interactively move item) /moveinteractive { ItemBegin 20 dict begin /GA_constraint 0 def /GA_value /calc_GA_value load def currentcursorlocation /DY exch def /DX exch def currentcanvas /Mapped true put initmatrix % [1 0 0 1 0 0] setmatrix /Canvas currentcanvas def /dragframe? ColorDisplay? def /absmovecanvas { gsave Canvas setcanvas % [1 0 0 1 0 0] setmatrix yo add exch xo add exch movecanvas grestore } def currentcursorlocation /yo exch neg def /xo exch neg def clippath pathbbox /height exch def /width exch def pop pop currentcanvas /Parent get createoverlay setcanvas 0 0 dragframe? { Canvas /Mapped false put pause pause { yo add exch xo add exch gsave Canvas setcanvas 2 copy movecanvas grestore translate ItemPath initmatrix }} {{ absmovecanvas newpath }} ifelse % leave a proc on stack for getanimated getanimated waitprocess aload pop dragframe? { Canvas /Mapped true put % absmovecanvas } { pop pop } ifelse end ItemEnd } def /SnapIn { ThisI StackI ne { StackI null ne { /PopMe TellStack } if /StackI ThisI store /PushMe TellStack } if } def /SnapOut { StackI null ne StackI Index ne and { /PopMe TellStack /StackI null store } if } def /snaps-here? { % - => bool ThisI null eq ThisI Index eq or {false} { /pin-rect dialog-item send label-rect rectsoverlap dup { SnapIn } { SnapOut } ifelse } ifelse } def /calc_GA_value { StackI Index eq { currentcursorlocation pop % cx } { StackI null eq { snaps-here? { location pop DX add % ix } { currentcursorlocation pop % cx } ifelse } { location TabY add TabHeight /pinned? items StackI get send not { SnapOut pop currentcursorlocation pop % cx } { % ix { location pop PinX add } items StackI get send % ItemX PinX PinX sub % ItemX ItemGoal exch 1 index exch sub % ItemGoal ItemDelta currentcursorlocation pop % ItemGoal ItemDelta CurX' 2 index exch sub % ItemGoal ItemDelta CurDelta DX add dup abs TabWidth gt { SnapOut pop pop pop currentcursorlocation pop DX sub } { 1 index abs 1 index abs gt {exch} if % ItemGoal Close Far pop % ItemGoal Close % .2 mul sub sub } ifelse DX add } ifelse } ifelse } ifelse } def /NextPos { % - => x y location % x y label-bbox % X Y x y w h exch pop add % X Y x y+h 3 -1 roll add % X x Y+y+h exch 3 -1 roll add exch % X+x Y+y+h exch PinX add exch } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Storage managment /Free { SnapOut ItemCanvas /Retained false put unmap /DL null store % /ItemObject [[null] 0] store ItemLock { /free-items [ free-items aload pop Index ] store } monitor } def /init-attributes { { /ObjectWidth /ObjectHeight /DL /Shrink /layout-proc /click-proc /transfer-proc /display-proc /erase-proc /Point /OpenToRight? /ShowFan?} { InstanceVarDict 1 index get store } forall ItemProperties { unpromote } forall /ObjectLoc /Right store self /StartPoint undef adjust-geometry } def % obj => - /Reuse { Collection Index 3 -1 roll put % ItemCanvas /Retained true put ItemCanvas canvastotop init-attributes %ensure-DL %redo-layout } def /destroy { ItemCanvas /Retained false put unmap ItemEventMgr null ne { ItemEventMgr killprocess } if } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Pallets of useful functions % Pallets are meant to be pushed onto the stack, opened up, and used % like control panels by clicking on the functions. Double click the % point button, or set the click-action to click-exec, and clicking % the Adjust button. (After a few revolutions, the pallets will % automatically have click-exec actions, and the functions will look % like buttons. (By virtue of a general purpose view-saving facility.)) /Pallets 100 dict def Pallets begin /Debug dictbegin /break-exit { dbgexit dstack } def /break-kill { dbgkill dstack } def /break-list /dbglistbreaks load def /break-enter { dbgenter dstack } def /break-cont { dbgcontinue dstack } def /break-copy&cont { dbgcopystack dbgcontinue dstack } def /clear /clear load def /enter-it { selected-object enter } def /exit /exit load def /fix-typo { % undefined (select correct spelling) => - userdict begin dup cvlit [ selected-object (%) sprintf cvn cvx ] cvx def end exec } def /push-dictstack { currentprocess /DictionaryStack get } def /push-execstack { DbgImplicitBreak DbgGetExecStack } def /push-sendcontexts { DbgImplicitBreak /SendContexts get } def /push-process { DbgImplicitBreak } def /show-dictstack { dstack } def /show-execstack /dbgwhere load def dictend def /Window 20 dict begin /make-a-window! { /win framebuffer /new DefaultWindow send def { newprocessgroup /reshapefromuser win send /map win send } fork waitprocess pop /can /ClientCanvas win send def (%% The new window is called "win".\n) print (%% Its ClientCanvas is called "can".\n) print (%% Setting the currentcanvas to "can", ) print currentcanvas == can setcanvas } def dictend def /Menu dictbegin /dict-select { selected-object dup type /dicttype ne { pop } { [ exch { 1 index type /nametype eq { exch 40 string cvs exch } if [ exch [ exch ] 0 /get load /select-object cvx ] cvx } forall ] /new DefaultMenu send dup /MenuButton AdjustButton put dup /AdjustButton MenuButton put gsave framebuffer setcanvas currentcursorlocation /showat 4 -1 roll send grestore } ifelse } def dictend def end % Pallets %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % StructItem Menu definitions /nhh { gsave framebuffer setcanvas currentcursorlocation [ (Nothing)(Happens)(Here!) ] popmsg pop grestore } def XNeWS? { /MakePointSizeThings { % - => ...things... {1 3 5 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 28 30 32 34} { [ exch dup 3 string cvs exch { dup SmallPointSize le ItemSFont ItemFont ifelse } StructItem send exch scalefontquant ] } forall } def } { /MakePointSizeThings { % - => ...things... {1 2 4 6 8 10 12 14 16 18 20 22 24 28 32} { [ exch dup 3 string cvs exch { dup SmallPointSize le ItemSFont ItemFont ifelse } StructItem send exch scalefontquant ] } forall } def } ifelse /TabLocationMenu [ (LeftBelow) (LeftAbove) (AboveLeft) (AboveRight) (RightAbove) (RightBelow) (BelowRight) (BelowLeft) ] [ { currentkey cvn {/ObjectLoc exch def location 10 10 reshape damage-view} it send } ] /new CyberMenu send store TabLocationMenu /PieInitialAngle 360 16 div put /TabClickMenu [ (click-transfer) (click-forkunix) (click-exec) (click-magic) (click-push) (click-step) (click-select) (click-edit) ] [ {currentkey cvn {/click-proc exch def} it send} ] /new CyberMenu send def /ClickMenu [ (click-transfer) (click-forkunix) (click-exec) (click-magic) (click-push) (click-step) (click-select) (click-edit) ] [ {ob /click-proc currentkey cvn dup /null eq {pop undef} {put} ifelse} ] /new CyberMenu send def /TabViewMenu [ [ MakePointSizeThings ] % point size [ (true) (false) ] % fan [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] % open [ (/Below) (/Right) ] % direction [ 10 5 200 { 100 div 10 string cvs } for ] % shrink [ (close) (open) ] % icon nullarray % --- nullarray % click... ] [ (point size) {getmenuarg 0 get cvx exec {/StartPoint exch def redo-layout} it send} (fan) { getmenuarg cvx exec {/ShowFan? exch def paint} it send } (open) { getmenuarg cvi { DL null eq { pop } { /ob DL store open-obj } ifelse } it send } (direction) { getmenuarg cvx exec {set-open-direction redo-layout} it send } (shrink) { getmenuarg cvx exec 1000 mul floor 1000 div % X11/NeWS .9499 bug {/Shrink exch def redo-layout} it send } (icon) { getmenuarg (open) eq /open-icon /close-icon ifelse it send } (props) { /open-item-props it send } (click...) TabClickMenu ] /new PulloutCyberMenu send def TabViewMenu /LabelMinRadius 35 put %TabViewMenu /PieInitialAngle 135 put /ViewMenu [ [ MakePointSizeThings (/Default) ] % point size [ (true) (false) (/Default) ] % fan [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] % open [ (/Below) (/Right) (/Default) ] % direction [ 10 5 200 { 100 div 10 string cvs } for (/Default) ] % shrink [ (close) (open) ] % icon nullarray % --- nullarray % click... ] [ (point size) {getmenuarg 0 get cvx exec /pointsize-obj it send} (fan) {getmenuarg cvx exec {set-show-fan paint} it send} (open) {getmenuarg cvi /open-obj it send} (direction) {getmenuarg cvx exec {set-open-direction redo-layout} it send} (shrink) { getmenuarg cvx exec /shrink-obj it send} (icon) { getmenuarg (open) eq /open-icon-obj /close-icon-obj ifelse it send } (props) { /props /open-editor it send } (click...) ClickMenu ] /new PulloutCyberMenu send def ViewMenu /LabelMinRadius 35 put %ViewMenu /PieInitialAngle 135 put /TabMenu [ (Layout) {/redo-layout it send} (Tab...) TabLocationMenu (Zap) {/Free it send} (Paint) {/paint it send} (Print) {/write-DL it send} (View...) TabViewMenu ] /new CyberMenu send store /ConvertMenu [ (tokein) { /tokein-obj it send } (executable) { /cvx-obj it send } (name) { /cvn-obj it send } (string) { /cvs-obj it send } (tokeout) { /tokeout-obj it send } (literal) { /cvlit-obj it send } (integer) { /cvi-obj it send } (real) { /cvr-obj it send } ] /new CyberMenu send def /SelectMenu [ (Pointer) { ob /C get ob /I get kbd-select-pointer } (Index) { ob /I get kbd-select-object } (Object) { ob /C get ob /I get get kbd-select-object } (Container) { ob /C get kbd-select-object } ] /new CyberMenu send def /OpenMenu [ nullarray [ (1) (2) (3) (4) ] [ (1) (2) (3) (4) ] nullarray ] [ (---) {} (right) {getmenuarg cvi /open-right-obj it send} (below) {getmenuarg cvi /open-below-obj it send} (close) {0 /open-obj it send} ] /new PulloutCyberMenu send def /GutsMenu [ (it: item) { it kbd-select-object } (DL: item's DL) { /DL it send kbd-select-object } (userdict) { userdict kbd-select-object } (ob: DL object) { ob kbd-select-object } (obs: DL path) { obs kbd-select-object } ] /new CyberMenu send def /EtcMenu [ (molecule) { /molecule-obj it send } (select...) SelectMenu % (reference) { /reference-obj it send } (load) { /load-obj it send } (guts...) GutsMenu ] /new CyberMenu send def /TypeFont /Screen findfont 12 scalefontquant def /StructMenu [ nullarray [ [ { [ ob /Obj get type 30 string cvs 0 1 index length 4 sub getinterval % chop "type" TypeFont ] exch pop dup type exec } ] ] nullarray nullarray nullarray nullarray nullarray nullarray ] [ % Note: depends on fixed getmenuarg (push) {/push-obj it send} (type...) /FigureTypeAction cvx % (load) {/load-obj it send} (open...) OpenMenu (etc...) EtcMenu (exec) {/exec-obj it send} (convert...) ConvertMenu (paste) {/paste-obj it send} (view...) ViewMenu ] /new PulloutCyberMenu send def { /LabelMinRadius 25 def /FigureTypeAction { ob /Obj get truetype TypeActionDict 1 index known { TypeActionDict exch get cvx exec } { % pop { /nhh it send } OtherMenu } ifelse } def } StructMenu send /PalletMenu [ Pallets { pop 100 string cvs } forall ] {lt} quicksort [ { currentkey cvn { Pallets exch get push-it } dialog-item send } ] /new CyberMenu send def /CommandMenu [ (wet) {} (paint) {} ] /new CyberMenu send def /BreakMenu [ (userdict) { { clear countdictstack 2 sub { end } repeat userdict /CyberUserdict dbgbreak } fork pop } (stack) { { clear dialog-item /CyberStack /dbgbreak dialog-item send } fork pop } (window) { { clear win /CyberWindow /dbgbreak win send } fork pop } (struct) { { clear items 0 get /CyberStruct /dbgbreak 2 index send } fork pop } ] /new CyberMenu send def /DialogMenu [ nullarray [ MakePointSizeThings ] [(7) (11) (13) (15)] nullarray nullarray nullarray ] [ (dbgbreak...) BreakMenu (object size) {StructItem /StartPoint getmenuarg 0 get cvi put} (text size) {null getmenuarg cvi /changefont dialog-text send} (pack stack) {/PackStack it send} (reboot process) {/kbd-reboot dialog-item send} (reset input) {/kbd-reset it send} % (credits) { /display-credits win send } ] /new PulloutCyberMenu send def /SelectionMenu [ (push) {{Collection Index get push-it} it send} (load) {{Collection Index get load-it} it send} (exec) {{Collection Index get exec-it} it send} % (convert...) /ConvertMenu StructItem send (convert...) ConvertMenu ] /new CyberMenu send def /BackgroundMenu [ (Pallets...) PalletMenu (Framebuffer) { /push-framebuffer-children dialog-item send } (Canvases) { /push-selected-canvases dialog-item send } (Windows) { /push-windows dialog-item send } (Commands...) CommandMenu (Processes) { /push-processes dialog-item send } (Stack...) DialogMenu (Object) { /push-object dialog-item send } ] /new CyberMenu send def /Types { nulltype integertype realtype booleantype colortype marktype operatortype nametype stringtype shapetype monitortype graphicsstatetype cursortype filetype arraytype dicttype fonttype canvastype processtype eventtype % X11/NeWS: savetype packedarraytype colormapentrytype environmenttype colormaptype pathtype visualtype vmtype } def /TypeActionDict 50 dict def TypeActionDict begin /integertype /IntegerMenu def /realtype /RealMenu def /booleantype /BooleanMenu def /colortype /ColorMenu def /nametype /NameMenu def /stringtype /StringMenu def /graphicsstatetype /GraphicsstateMenu def /arraytype /ArrayMenu def /dicttype /DictMenu def /fonttype /FontMenu def /canvastype /CanvasMenu def /processtype /ProcessMenu def /eventtype /EventMenu def % /filetype /FileMenu def % /shapetype /ShapeMenu def % /cursortype /CursorMenu def % /monitortype /MonitorMenu def % /operatortype /OperatorMenu def % /nulltype /NullMenu def % /marktype /MarkMenu def % X11/NeWS: % /savetype /SaveMenu def /packedarraytype /ArrayMenu def % /colormapentrytype /ColormapentryMenu def % /environmenttype /EnvironmentMenu def % /colormaptype /ColormapMenu def % /pathtype /PathMenu def % /visualtype /VisualMenu def end % TypeActionDict % ======================================================================= % Type menus /IntegerMenu [ (step editor) {/step /open-editor it send} (shift editor) {/shift /open-editor it send} (digit editor) {/digit /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def /RealMenu IntegerMenu def % /RealMenu [ % (step editor) {/step /open-editor it send} % (shift editor) {/shift /open-editor it send} % (digit editor) {/digit /open-editor it send} % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def /BooleanMenu [ (true) {true /modify-obj it send} (false) {false /modify-obj it send} (not) {{not} /transform-obj it send} (boolean editor) {/boolean /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Color wheel pie menu % Don Hopkins % Class definition systemdict begin % ------------------------------------ % % ColorPieMenu /ColorPieMenu PieMenu dictbegin /LabelMinRadius 60 def /NumbRadius 25 def /Hue 0 def /Saturation 1 def /Brightness 1 def /Hues 20 def /HueRot null def /HueStep null def /SelectClientColor null def /RetainCanvas? false def /UseOverlay? false def dictend classbegin /new { % - => obj [() {}] /new super send begin /SelectClientColor exch def currentdict end } def /getmenuaction { {select-color} } def /PaintMenuFrame { MenuGSave MenuFillColor fillcanvas PieRadius dup translate newpath 0 0 PieRadius 0 360 arc closepath 0 0 PieRadius Border sub 0 360 arc closepath % 0 0 NumbRadius 0 360 arc closepath MenuBorderColor setcolor eofill grestore } def /PaintMenuItems { MenuGSave PieRadius dup translate /HueStep 1 Hues div def /HueRot 360 HueStep mul def gsave newpath 0 0 NumbRadius 0 360 arc 0 0 NumbRadius Border add 0 360 arc 0 0 Brightness sethsbcolor eofill newpath 0 0 NumbRadius Border add 0 360 arc closepath 0 0 PieRadius Border sub 0 360 arc closepath eoclip HueRot -2 div rotate 0 Hues { dup 1 Brightness sethsbcolor newpath 0 0 moveto 0 0 PieRadius HueRot -2 div dup neg arc fill HueRot rotate HueStep add } repeat pop grestore grestore } def /cvfixed { 16384 mul floor cvi -14 bitshift } def /SetMenuValue { % x y => - (Sets /MenuValue) /PieDistance 2 index cvr dup mul 2 index cvr dup mul add sqrt def exch atan /PieDirection exch def /Hue PieDirection 360 div def /Saturation PieDistance PieRadius min NumbRadius sub PieRadius NumbRadius sub div 1.3 mul .3 sub 0 max def /MenuValue PieDistance NumbRadius le { null } { % Hue cvfixed Saturation cvfixed Brightness cvfixed hsbcolor Hue Saturation Brightness hsbcolor } ifelse def } def /PaintMenuValue { % - => - (Hilite current item, un-hilite prev one.) MenuValue PaintSlice /PaintedValue MenuValue store } def /showat { /MenuValue null def /showat super send } def /PaintSlice { % slice => - MenuGSave pop PieRadius dup translate newpath MenuValue null eq { 0 0 NumbRadius 0 360 arc MenuFillColor setcolor fill } { 0 0 NumbRadius Border sub 0 360 arc MenuValue setcolor fill 0 0 NumbRadius 0 360 arc 0 0 NumbRadius Border sub 0 360 arc MenuBorderColor contrastswithcurrent MenuBorderColor MenuFillColor ifelse setcolor eofill } ifelse grestore } def /select-color { MenuValue null ne { SelectClientColor } if } def classend def % Menu definitions /color-menu-callback { % name color => - exch pop /replace-obj it send } def /menu:emacs-color-wheel { ColorName MenuValue color-menu-callback } /new ColorPieMenu send def /do-emacs-color-wheel { % { /HlFgColor /HlBgColor /BgColor /FgColor } MenuValue get /Color % dummy framebuffer /Color get { menu:emacs-color-wheel dup /ColorName 4 -1 roll put dup /Brightness /value getmenuarg exec put } { [ exch /value getmenuarg exec dup dup rgbcolor /color-menu-callback cvx ] cvx } ifelse } def /grayThing { % gray => - exch { /size { pop NumbRadius dup add dup } /paint { gsave newpath 0 0 NumbRadius Border sub 0 360 arc setgray fill 0 0 NumbRadius 0 360 arc 0 0 NumbRadius Border sub 0 360 arc MenuBorderColor setcolor eofill grestore } /value { } } case } def end % systemdict %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /ColorMenu [ [] [ 0 1 32 div 1 { [ exch /grayThing cvx ] cvx } for ] ] [ (user editor) {/user /open-editor it send} (Color...) /do-emacs-color-wheel cvx ] /new PulloutPieMenu send def ColorMenu /EraseArgs? false put ColorMenu /NumbRadius 25 put ColorMenu /LabelMinRadius 45 put ColorMenu /UseOverlay? false put %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /NameMenu [ (definitions editor) {/definitions /open-editor it send} (user editor) {/user /open-editor it send} % pop up menu of definitions? ] /new CyberMenu send def /GraphicsstateMenu [ (user editor) {/user /open-editor it send} ] /new CyberMenu send def /JuggleArrayMenu [ (pop) { /pop-array-obj it send } % to selection % rotate array member or subinterval to top (top) { /top-array-obj it send } % splice array member or unsplice subinterval (splice) { /splice-array-obj it send } % rotate array member or subinterval to bottom (bottom) { /bottom-array-obj it send } (push) { /push-array-obj it send } % selected object (append) { /append-to-array-obj it send } % selected array % selected array member or subinterval (delete) { /delete-array-obj it send } (prepend) { /prepend-to-array-obj it send } % selected array ] /new CyberMenu send def /ArrayMenu [ (juggle...) JuggleArrayMenu (element editor) {/element /open-editor it send} (scroller) {/scroller /open-editor it send} (filter editor) {/filter /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def /StringMenu ArrayMenu def % /StringMenu [ % (array...) ArrayMenu % (prepend) {nhh} % selected string % (append) {nhh} % selected string % (token) {nhh} % selected string % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def /DictMenu [ (def) { /def-in-dict-obj it send } % selected object (undef) { /undef-in-dict-obj it send } % selected key (or pointer index) (begin) { /begin-obj it send } (enter) { /enter-obj it send } (dbgbreak) { /break-obj it send } (scroller) {/scroller /open-editor it send} (filter editor) {/filter /open-editor it send} (user editor) {/user /open-editor it send} (class editor) {/class /open-editor it send} ] /new CyberMenu send def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Folio font pie menus % Don Hopkins /select-font { % font => - /replace-obj it send } def /point-sizes [ 1 6 8 10 12 14 16 18 20 22 24 26 28 30 32 ] def /def-font-menu { % /name [fonts...] /init => - 10 dict begin % localdict /init exch def /fonts exch def [ fonts { FontDirectory 1 index known { /name exch def /font name findfont def [ point-sizes { [ exch dup (% Point) sprintf exch font exch scalefont ] } forall ] } { pop } ifelse } forall ] [ fonts { FontDirectory 1 index known { [ exch dup findfont 16 scalefont ] { getmenuarg 1 get select-font } } { pop } ifelse } forall ] /new PulloutPieMenu send /init load 1 index send end % localdict def } def % ITC /AvantGardeMenu [ (AvantGarde-Book) (AvantGarde-BookOblique) (AvantGarde-DemiOblique) (AvantGarde-Demi) ] { /LabelMinRadius 50 def /PieInitialAngle 135 def /ArgBorder 3 def } def-font-menu /BookmanMenu [ (Bookman-Light) (Bookman-LightItalic) (Bookman-DemiItalic) (Bookman-Demi) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /ZapfMenu [ (ZapfChancery-MediumItalic) (ZapfDingbats) ] { /LabelMinRadius 40 def /ArgBorder 3 def } def-font-menu % Linotype /HelveticaMenu [ (Helvetica) (Helvetica-Oblique) (Helvetica-BoldOblique) (Helvetica-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /NewCenturySchlbkMenu [ (NewCenturySchlbk-Roman) (NewCenturySchlbk-Italic) (NewCenturySchlbk-BoldItalic) (NewCenturySchlbk-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /PalatinoMenu [ (Palatino-Roman) (Palatino-Italic) (Palatino-BoldItalic) (Palatino-Bold) ] { /LabelMinRadius 50 def /PieInitialAngle 135 def /ArgBorder 3 def } def-font-menu /TimesMenu [ (Times-Roman) (Times-Italic) (Times-BoldItalic) (Times-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu % Monotype /BemboMenu [ (Bembo) (Bembo-Italic) (Bembo-BoldItalic) (Bembo-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /GillSansMenu [ (GillSans) (GillSans-Italic) (GillSans-BoldItalic) (GillSans-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /RockwellMenu [ (Rockwell) (Rockwell-Italic) (Rockwell-BoldItalic) (Rockwell-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu % Bigelow & Holmes /Lucida-BrightMenu [ (Lucida-Bright) (Lucida-BrightItalic) (Lucida-BrightDemiBoldItalic) (Lucida-BrightDemiBold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /LucidaSansMenu [ (LucidaSans) (LucidaSans-Italic) (LucidaSans-BoldItalic) (LucidaSans-Bold) ] { /LabelMinRadius 40 def /PieInitialAngle 135 def } def-font-menu /LucidaSansTypewriterMenu [ (LucidaSansTypewriter) (LucidaSansTypewriter-Bold) ] { /LabelMinRadius 40 def } def-font-menu %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /ITCMenu [ [(AvantGarde) /AvantGarde-Book findfont 16 scalefont ] AvantGardeMenu [(Bookman) /Bookman-Light findfont 16 scalefont ] BookmanMenu [(Zapf) /ZapfChancery-MediumItalic findfont 16 scalefont ] ZapfMenu ] /new PieMenu send def /LinotypeMenu [ [ (Times) /Times-Roman findfont 16 scalefont ] TimesMenu [(Helvetica) /Helvetica findfont 16 scalefont ] HelveticaMenu [ (NewCenturySchlbk) /NewCenturySchlbk-Roman findfont 16 scalefont ] NewCenturySchlbkMenu [ (Palatino) /Palatino-Roman findfont 16 scalefont ] PalatinoMenu ] /new PieMenu send def /MonotypeMenu [ [ (Bembo) /Bembo findfont 16 scalefont ] BemboMenu [ (GillSans) /GillSans findfont 16 scalefont ] GillSansMenu [ (Rockwell) /Rockwell findfont 16 scalefont ] RockwellMenu ] /new PieMenu send def /Bigelow&HolmesMenu [ [ (LucidaSansTypewriter) /LucidaSansTypewriter findfont 16 scalefont ] LucidaSansTypewriterMenu [ (Lucida-Bright) /Lucida-Bright findfont 16 scalefont ] Lucida-BrightMenu [ (LucidaSans) /LucidaSans findfont 16 scalefont ] LucidaSansMenu ] /new PieMenu send def Bigelow&HolmesMenu /PieInitialAngle 270 put %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /SelectFontMenu [ [ (ITC) /Bookman-Light findfont 16 scalefont ] ITCMenu [ (Linotype) /Palatino-Roman findfont 16 scalefont ] LinotypeMenu [ (Bigelow & Holmes) /Lucida-Bright findfont 16 scalefont ] Bigelow&HolmesMenu [ (Monotype) /Bembo findfont 16 scalefont ] MonotypeMenu ] /new PieMenu send def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /FontMenu [ (user editor) {/user /open-editor it send} (Font...) SelectFontMenu ] /new CyberMenu send def /CanvasStateMenu [ (top) {ob /C get ob /I get get canvastotop} (map) {ob /C get ob /I get get /Mapped true put} (retain) {ob /C get ob /I get get /Retained true put} (unmap) {ob /C get ob /I get get /Mapped false put} (bottom) {ob /C get ob /I get get canvastobottom} (opaque) {ob /C get ob /I get get /Transparent false put} (unretain) {ob /C get ob /I get get /Retained false put} (transparent) {ob /C get ob /I get get /Transparent true put} ] /new CyberMenu send def /CanvasMenu [ (state...) CanvasStateMenu % (manager) {nhh} % select /Interests 0 /Process % (bbox) {nhh} % select [x y w h] % (setcanvas) {nhh} % changes proc's gstate % (zap) {nhh} % unretain & unmap whole tree (class editor) {/class /open-editor it send} (canvas editor) {/canvas /open-editor it send} (scroller) {/canvas /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def /ProcessMenu [ % XXX: Implement these!!! % (kill) {nhh} % (kill group) {nhh} % (suspend) {nhh} % (resume) {nhh} % (wait) {nhh} % select return value % (userdict) {nhh} % select userdict (class editor) {/class /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def /EventMenu [ % XXX: Implement these!!! % (express) {nhh} % Does this make any sense in this context? % (revoke) {nhh} % (sendevent) {nhh} (class editor) {/class /open-editor it send} (user editor) {/user /open-editor it send} ] /new CyberMenu send def % /FileMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /ShapeMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /CursorMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /MonitorMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /OperatorMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /NullMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def % % /MarkMenu [ % (user editor) {/user /open-editor it send} % ] /new CyberMenu send def /OtherMenu [ (user editor) {/user /open-editor it send} ] /new CyberMenu send def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TextStructItem class definition /TextStructItem StructItem dictbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Instance variables /I null def /MyStack null def /MyProcess null def /Scroller null def /ScrollerWidth 18 def /Notifier null def /NotifierHeight 24 def /SubItemGap 2 def /SubItemMgr null def /DeferedUpdateEvent null def /UpdateDelay .5 60 div def /PinHeight 0 def dictend classbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class Variables %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Methods /new { /new super send begin /MyStack [] def /ItemLabel (Stack \267) def currentdict end } def /push-selected-canvases { gsave fboverlay setcanvas 0 0 { moveto 20 20 rmoveto -40 -40 rlineto 40 0 rmoveto -40 40 rlineto } getanimated waitprocess aload pop find_canvas push-it grestore } def /push-windows { 10 dict begin /d 200 dict def [d] { currentprocess /ParentDict where { pop self } { currentdict } ifelse put } cvlit append cvx RootUserDict begin AllWin end % RootUserDict 10 { pause } repeat % Is this enough, or will 1 pause do it, or what? d push-it end % localdict } def XNeWS? { /push-processes { getprocesses push-it } def } { /push-processes { % How should we simulate this bugger in NeWS 1.1? % getprocesses push-it (You need NeWS/X!) push-it } def } ifelse /push-object { Object push-it % XXX: push opened object editor } def /push-framebuffer-children { framebuffer push-it % XXX: push opened canvas hierarchy editor } def /kbd-reset { /dialog-buf () store /dialog-string () store { psh-socket bytesavailable string readstring pop } errored {(\n%% Reset!\n) print} execute-it } def /shut-down { { psh-socket (\ndbgstop\nquit\n) writestring psh-socket flushfile } errored pop null null /DropDead TellMyProcess 1 60 div sleep } def /kbd-reboot { { /dialog-buf () store /dialog-string () store [ () (%% Reboot!) () ] false /writeatcaret dialog-text send shut-down psh-socket null ne { psh-socket status { psh-socket closefile } if } if /psh-socket null store % I don't know why I have to do this, but it sure helps... (i hope) items { % { LayoutLock monitorlocked { /LayoutLock createmonitor def } if { /LayoutLock createmonitor def } exch send } forall ensure-DL % { EventMgr null ne { EventMgr killprocess } if % /EventMgr Interests forkeventmgr store % KeyboardEventMgr null ne { KeyboardEventMgr killprocess } if % /KeyboardEventMgr { KeyboardHandler } fork store % } dialog-text send start-event-mgrs } fork pop } def /use-selected-process { selected-object dup type /processtype eq { set-process } if } def /ObjectSize { % - => w h % XXX bletch: ObjectWidth 0 eq ObjectHeight 0 eq or { /ObjectWidth ItemBorder dup add ItemWidth 1 index sub % w ScrollerWidth dup add SubItemGap add max store /ObjectHeight ItemHeight exch sub % w h ScrollerWidth NotifierHeight add SubItemGap add max store } if ObjectWidth ObjectHeight } def /adjust-geometry { LabelSize /LabelHeight exch def /LabelWidth exch def ObjectSize /ObjectHeight exch def /ObjectWidth exch def AdjustItemSize CalcObj&LabelXY } def /replace-obj { % obj => - Collection Index 2 index put kbd-select-object } def /toggle-icon {} def /show-tab-menu { /it self store CurrentEvent /showat DialogMenu send } def /show-struct-menu { /it self store /ob 20 dict store ob begin /C Collection def /I Index def /Obj Collection Index get def end CurrentEvent /showat SelectionMenu send } def /do-search { /it self store /ob null store } def /make-selection { % We ARE the selection. } def /pin-rect { % X Y w h location exch PinX add 3 sub exch % x y PinHeight 0 lt { PinHeight add } if ItemHeight PinHeight abs add 6 exch } def /exec-and-update { % func => - null /ExecIt TellMyProcess } def /TellMyProcess { % ClientData Action Name 8 { % wait up to 4 seconds if no process MyProcess null eq { .5 60 div sleep } { exit } ifelse } repeat MyProcess null eq { pop pop pop gsave framebuffer setcanvas currentcursorlocation [(No process!)] popmsg pop grestore } { createevent begin /Name exch def /Action exch def /ClientData exch def /Process MyProcess def currentdict end sendevent } ifelse } def /UpdateStack { % event => - DeferedUpdateEvent null ne { DeferedUpdateEvent recallevent } if /DeferedUpdateEvent CurrentEvent store DeferedUpdateEvent begin /Name /DeferedUpdate def /TimeStamp currenttime UpdateDelay add def end % event DeferedUpdateEvent sendevent pop } def /DeferedUpdate { % event => - /DeferedUpdateEvent null store dialog-promptlines 0 ne { /getcaretpos dialog-text send exch pop 1 exch dialog-promptlines 1 sub 0 max sub 2 copy /movecaret dialog-text send exch pop dialog-promptlines exch /deleteline dialog-text send } if [ dialog-string dialog-buf CurrentEvent /ClientData get length (NeWS[%]> %%) sprintf { (\n) search { % chop string up at newlines exch pop exch } { exit } ifelse } loop ] dup length /dialog-promptlines exch store false /writeatcaret dialog-text send pause CurrentEvent /ClientData get setoperandstack pop } def /ProcessReady { % event => - dup /ClientData get exch /Action get set-process } def /set-process { % stack process => - /MyProcess exch def setoperandstack { currentprocess (%% ) (%Hello, my name is %!\n) printf } execute-it } def /SelectionChanged { % event => - CurrentEvent /Action get /PrimarySelection eq { CurrentEvent /ClientData get % selection dup selection-type % selection type dup /text eq { pop dissect-selection Collection Index 2 index put (text: %) exch [ exch ] } { % selection type (%: %) [ 4 2 roll % fmt mark selection type exch % fmt mark type selection dissect-selection Collection Index 2 index put smart-name % fmt mark type name ] } ifelse sprintf /printstring Notifier send } if pop } def /makestartinterests { /makestartinterests super send [ exch aload pop /ProcessReady {/ProcessReady /Self GetFromCurrentEvent send} null ItemCanvas eventmgrinterest dup /Self self PutInEventMgrInterest /UpdateStack {/UpdateStack /Self GetFromCurrentEvent send} null ItemCanvas eventmgrinterest dup /Self self PutInEventMgrInterest /DeferedUpdate {/DeferedUpdate /Self GetFromCurrentEvent send} null ItemCanvas eventmgrinterest dup /Self self PutInEventMgrInterest /SelectionChanged {/SelectionChanged /Self GetFromCurrentEvent send} null null eventmgrinterest dup /Self self PutInEventMgrInterest /PushMe {/DoPushMe /Self GetFromCurrentEvent send} Index ItemParent eventmgrinterest dup /Self self PutInEventMgrInterest /PopMe {/DoPopMe /Self GetFromCurrentEvent send} Index ItemParent eventmgrinterest dup /Self self PutInEventMgrInterest /MoveMe {/DoMoveMe /Self GetFromCurrentEvent send} Index ItemParent eventmgrinterest dup /Self self PutInEventMgrInterest ] } def /DoPushMe { % event => - /ClientData get PushMe } def /DoPopMe { % event => - /ClientData get PopMe } def /DoMoveMe { % event => - ItemLock { SortStack ReplaceStack } monitor pop } def /PushMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall I ] store SortStack getoperandstack {Collection Index get} items I get send smart-name (%% Push: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /PopMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall ] store getoperandstack {Collection Index get} items I get send smart-name (%% Pop: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /ReplaceStack { ItemLock { getoperandstack null /ReplaceStack TellMyProcess } monitor } def /SortStack { ItemLock { MyStack { /tab-top exch items exch get send exch /tab-top exch items exch get send lt } quicksort pop } monitor } def % This code was designed to be rewritten! % To do: % Make the stack display premptable: Each pass it does one thing to make the % display look more like MyStack. (bottom to top priority) /SetStack { % stack => - ItemLock { ItemBegin 10 dict begin /NewStack exch def /OldStack 200 dict def MyStack { items 1 index get {Collection Index get} exch send OldStack 3 1 roll put } forall /MyStack [] store NewStack { % new pause /I null def OldStack { % new ind old dup 3 index eq { % new ind old xcheck 2 index xcheck eq { % new ind /I exch def exit % new } { pop } ifelse % new } { pop pop } ifelse % new } forall % new pause /I load null ne { pop % OldStack /I load undef /MyStack [ MyStack aload pop /I load ] store } { % new /MyStack [ MyStack aload length 3 add -1 roll % /MyStack [ ... new create-struct % /MyStack [ ... newind ] store % } ifelse } forall pause OldStack { % ind old pop % ind items exch get % item dup /StackI null put % XXX /Free exch send % pause } forall pause /Y tab-top def MyStack { % ind items exch get % item Y { % PrevTop dup tab-bottom exch sub % PrevTop below dup 0 lt { location 2 index sub just-move pause } if pop pop tab-top } 3 -1 roll send % NextTop /Y exch def % } forall % pin-rect % x y w h exch pop add exch pop % PinTop Y lt { % if we ran off the top of the stack, then pack it down. PackStack } if pause ItemEnd end } monitor } def /create-struct { % obj => i ItemLock { 20 dict begin /Obj exch def NextStackPos /NextY exch def /NextX exch def free-items length 0 eq { Stack SP /Obj load put Stack SP {handle-click} can /new StructItem send /It exch def /items [ items aload pop It ] store /I SP def /SP SP 1 add store It /StackI Index put createevent begin /Name /UpdateInterests def /Canvas ItemParent def /ClientData I def currentdict end sendevent } { /I free-items dup length 1 sub get def /It items I get def /free-items free-items 0 1 index length 1 sub getinterval store It /StackI Index put /Obj load /Reuse It send } ifelse NextX NextY { 2 copy 20 20 just-reshape exch PinX sub exch just-move map damage-view } It send I pause pause end } monitor } def /getoperandstack { % Don't use [ ... ] in case there are marks on the stack!! MyStack { {Collection Index get} exch items exch get send } forall MyStack length array astore } def /getdictstack { % - => dictstack MyProcess null eq { nullarray } { MyProcess /DictionaryStack get } ifelse } def /PackStack { 10 dict begin /Y tab-top def MyStack { items exch get Y { % PrevTop dup tab-bottom exch sub % PrevTop below location 2 index sub just-move pause pause pop pop tab-top } 3 -1 roll send /Y exch def pause pause } forall end pause } def /NextStackPos { % - => x y MyStack length 0 eq { NextPos } { MyStack dup length 1 sub get items exch get /NextPos exch send } ifelse } def /setoperandstack { SetStack } def /ClientExit { CurrentEvent /KeyState get { dup AdjustButton eq { { ItemBegin /StackI Index store /ThisI Index store ItemCanvas setcanvas location TabY add TabHeight 2 div add exch PinX add exch ItemParent createoverlay setcanvas { 2 setlinewidth exch pop x0 exch lineto } getanimated waitprocess aload pop % x y exch pop location exch pop sub dup 0 gt {ItemHeight sub 0 max} if /PinHeight exch store /paint-hilite win send ItemEnd } fork pop pop exit } if } forall StopItem } def /paint-struct { gsave ensure-DL /paint Scroller send /paint Notifier send dialog-can setcanvas /fixdamage dialog-text send grestore } def /DrawHilite { gsave can setcanvas location CanvasYFudge add translate ItemRadius object-bbox 4 -1 roll PopupX sub 4 -1 roll PopupY sub 4 2 roll rrectpath .5 setgray fill % -3 ItemRadius label-bbox insetrrect rrectpath % 2 setlinewidth 0 setgray stroke PinHeight 0 ne { 1 setlinecap 2 setlinewidth 0 setgray PinX 0 dup PinHeight add min 6 sub moveto 0 ItemHeight PinHeight abs add 12 add rlineto stroke 1 setlinecap 6 setlinewidth 0 setgray PinX 0 dup PinHeight add min moveto 0 ItemHeight PinHeight abs add rlineto gsave stroke grestore 2 setlinewidth 1 setgray stroke } if grestore } def /reshapefromuser { } def /reshape { /reshape super send gsave % ensure-DL ItemCanvas setcanvas ObjectX ScrollerWidth add SubItemGap add ObjectY translate 0 0 ObjectWidth ScrollerWidth sub SubItemGap sub ObjectHeight NotifierHeight sub SubItemGap sub rectpath dialog-can reshapecanvas dialog-can /Mapped true put /reshape dialog-text send ItemCanvas setcanvas { [ 1 0 1 TextHeight div dup CanHeight floor 1 sub mul null ] } dialog-text send /setrange Scroller send ObjectX ObjectY ScrollerWidth ObjectHeight NotifierHeight sub SubItemGap sub /reshape Scroller send /paint Scroller send ObjectX ObjectY ObjectHeight add NotifierHeight sub ObjectWidth NotifierHeight { /ObjectX 0 def /ObjectY 0 def reshape } Notifier send /paint Notifier send SubItemMgr null eq { /SubItemMgr dictbegin /Scroller Scroller def /Notifier Notifier def dictend forkitems store } if grestore } def /ensure-DL { dialog-text null eq { ItemCanvas /Retained true put /dialog-can ItemCanvas newcanvas store %% dialog-can /Retained true put %dialog-can /Transparent false put %dialog-can /Retained true put %dialog-can /Parent get dup /Transparent false put /Retained true put /dialog-text 200 dialog-can /new TextCanvas send store { /KeyDict 200 dict def KeyDict begin 0 { (prompt) comment prompt } def 127 { (erase character) comment % Rubout dialog-string length 0 ne { getcaretpos exch dup 1 gt { 1 sub exch movecaret getcaretpos 1 3 1 roll deletestring /dialog-string dialog-string dup length 1 sub 0 max 0 exch getinterval store } if } if } def 8 127 load def % Backspace 23 { (erase word) comment % ^W 0 { dialog-string length 1 index sub % i dup 0 le { pop exit } if 1 sub dialog-string exch get DelimDict exch known 1 index 0 ne and { exit } if 1 add } loop dup 0 eq { pop } { dup getcaretpos exch 2 index sub exch 2 copy movecaret deletestring /dialog-string dialog-string dup length 4 -1 roll sub 0 max 0 exch getinterval store } ifelse } def 24 { (erase line) comment % ^X getcaretpos exch dialog-string length sub 1 max exch 2 copy movecaret dialog-string length 3 1 roll deletestring /dialog-string () store } def 21 24 load def % ^U 13 { (exec line) comment % Return [ () () ] false writeatcaret dialog-string /dialog-enter dialog-item send /dialog-string () store /dialog-promptlines 0 dialog-buf { (\n) search { pop pop exch 1 add exch } { pop exit } ifelse } loop 1 add store } def 10 { (select line) comment % Newline [ () () ] false writeatcaret dialog-string kbd-select-object /dialog-string () store prompt } def 10 128 add { (input line) comment % Meta-Newline [ () () ] false writeatcaret dialog-string /dialog-newline dialog-item send /dialog-string () store prompt } def 19 { (insert selection) comment % ^S selected-object (%) sprintf [ 1 index ] false writeatcaret /dialog-string exch dialog-string exch append store } def 12 { (load) comment % ^L { (%% load\n) print load } execute-it } def 20 { (exchange) comment % ^T { (%% exch\n) print exch } execute-it } def 11 { (stack to selection) comment % ^K { (%% Stack to selection\n) print count 0 ne { select-object } if } /execute-it dialog-item send } def 25 { (selection to stack) comment % ^Y { (%% Selection to stack\n) print selected-object } /execute-it dialog-item send } def /FunctionR3 { (execute selection) comment selected-object % Since 'token' doesn't recognize \r's as ending comments, % if the selection has \r's in it, make a copy with \r's % mapped to \n's. dup type /stringtype eq { dup remove-returns exch 1 index ne { kbd-select-object } if } if { selected-object cvx dup (%) sprintf (\n) search { exch pop exch pop ( ...) append} if (%% ) (%Execute selection %\n) printf exec } /execute-it dialog-item send } def (x) 0 get 128 add /FunctionR3 load def % Meta-x (X) 0 get 128 add /FunctionR3 load def % Meta-X 3 { (reset input) comment % ^C /kbd-reset dialog-item send } def 255 { (reboot process) comment % Meta-Delete Control { [ () (Hey! This ain't no stinkin' MS-DOS!!!) () ] false writeatcaret } if /kbd-reboot dialog-item send } def 31 128 add 255 load def /FunctionR9 { (page up) comment /ScrollPageForward /FakeScroll dialog-scroll send } def (v) 0 get 128 add /FunctionR9 load def % Meta-v (V) 0 get 128 add /FunctionR9 load def % Meta-V /FunctionR15 { (page down) comment /ScrollPageBackward /FakeScroll dialog-scroll send } def 22 /FunctionR15 load def % ^V /FunctionR7 { (scroll up) comment /ScrollLineForward /FakeScroll dialog-scroll send } def (z) 0 get 128 add /FunctionR7 load def % Meta-z (Z) 0 get 128 add /FunctionR7 load def % Meta-Z /FunctionR13 { (scroll down) comment /ScrollLineBackward /FakeScroll dialog-scroll send } def 26 /FunctionR13 load def % ^Z /FunctionR11 { (scroll to bottom) comment 1 /ScrollTo dialog-scroll send } def (>) 0 get 128 add /FunctionR11 load def % Meta-> (.) 0 get 128 add /FunctionR11 load def % Meta-. /FunctionF10 { (help) comment % Alternate [ () (Key Bindings:) ()] false writeatcaret [ KeyDict { comment-string exch key-name (%: %) sprintf pause } forall ] {gt} quicksort { [ exch () ] false writeatcaret pause } forall prompt } def (?) 0 get 128 add /FunctionF10 load def % Meta-? (/) 0 get 128 add /FunctionF10 load def % Meta-/ /FunctionR1 { (describe key) comment [ () (Describe key: ) ] false writeatcaret /DescribingKey? true store } def (k) 0 get 128 add /FunctionR1 load def % Meta-k (K) 0 get 128 add /FunctionR1 load def % Meta-K /FunctionR2 { (bind selection to key) comment [ () selected-object smart-type (Bind selection %) sprintf (to key: ) ] false writeatcaret /BindingKey? true store } def (b) 0 get 128 add /FunctionR2 load def % Meta-b (B) 0 get 128 add /FunctionR2 load def % Meta-B /FunctionL9 { (find completions) comment [ dialog-string { DelimDict 1 index known { cleartomark mark } if } forall ] cvas dup length 0 eq { pop } { kbd-select-object { selected-object (%% Finding completions of ") print dup print (":\n) print currentprocess /DictionaryStack get 20 dict begin /DS exch def /pat exch def /found null def /complete null def % X11/NeWS pre fcs gives rangecheck errors when we try to cvs something % into a string it's too long for... % /str pat length string def /wholestr 256 string def /str wholestr 0 pat length getinterval def DS length 1 sub -1 0 { /i exch def DS i get { /val exch def % dup str cvs pat ne { pop } { dup wholestr cvs pop str pat ne { pop } { found null eq { /found 1 index 256 string cvs def /complete found def } { /found 1 index 256 string cvs def found length complete length lt { /complete found def } { 0 complete { found 2 index get ne { /complete complete 0 3 index getinterval store exit } if 1 add } forall pop } ifelse } ifelse /val load smart-name exch i (%: /% %\n) printf } ifelse } forall pause pause } for pause pause pause complete null eq { () } { complete pat length 1 index length 1 index sub getinterval } ifelse createevent begin /Name /InsertValue def /Action exch def /Canvas % Fails with more than one interest! % currentprocess /Interests get 0 get % event currentprocess /Interests get % the first interest expressed is the last on the list dup length 1 sub get % event /ClientData get /ViewCanvas get % can /Parent get % clientcanvas has keyboard interests! def currentdict end sendevent complete null ne { complete select-object } if end } execute-it } ifelse } def 27 128 add /FunctionL9 load def 27 { (complete) comment % Escape [ dialog-string { DelimDict 1 index known { cleartomark mark } if } forall ] cvas dup length 0 eq { pop } { kbd-select-object { selected-object currentprocess /DictionaryStack get 20 dict begin /DS exch def /pat exch def /found null def /complete null def % X11/NeWS pre fcs gives rangecheck errors when we try to cvs something % into a string it's too long for... % /str pat length string def /wholestr 256 string def /str wholestr 0 pat length getinterval def DS length 1 sub -1 0 { /i exch def DS i get { /val exch def % dup str cvs pat ne { pop } { dup wholestr cvs pop str pat ne { pop } { found null eq { /found 1 index 256 string cvs def /complete found def } { /found 1 index 256 string cvs def found length complete length lt { /complete found def } { 0 complete { found 2 index get ne { /complete complete 0 3 index getinterval store exit } if 1 add } forall pop } ifelse } ifelse pop } ifelse } forall pause } for pause complete null ne { complete pat length 1 index length 1 index sub getinterval createevent begin /Name /InsertValue def /Action exch def /Canvas currentprocess /Interests get 0 get % event /ClientData get /ViewCanvas get % can /Parent get % clientcanvas has keyboard interests! def currentdict end sendevent complete null ne { complete select-object } if } if end } execute-it } ifelse } def 4 { (completions) comment % ^D [ dialog-string { DelimDict 1 index known { cleartomark mark } if } forall ] cvas dup length 0 eq { pop } { kbd-select-object { selected-object (%% Completions of ") print dup print (":\n) print currentprocess /DictionaryStack get 20 dict begin /DS exch def /pat exch def /found null def /complete null def % X11/NeWS pre fcs gives rangecheck errors when we try to cvs something % into a string it's too long for... % /str pat length string def /wholestr 256 string def /str wholestr 0 pat length getinterval def DS length 1 sub -1 0 { /i exch def DS i get { /val exch def % dup str cvs pat ne { pop } { dup wholestr cvs pop str pat ne { pop } { found null eq { /found 1 index 256 string cvs def /complete found def } { /found 1 index 256 string cvs def found length complete length lt { /complete found def } { 0 complete { found 2 index get ne { /complete complete 0 3 index getinterval store exit } if 1 add } forall pop } ifelse } ifelse (% ) printf } ifelse } forall pause } for (\n) printf pause pause complete null ne { complete pat length 1 index length 1 index sub getinterval select-object } if end } execute-it } ifelse } def end % KeyDict /DelimDict 50 dict def DelimDict begin 0 1 32 { dup def } for (%/()<>[]{}) { dup def } forall end /typein { [1 index] false writeatcaret /dialog-string exch dialog-string exch append store } def /DescribingKey? false def /BindingKey? false def /key 0 def /KeyHitCallback { % event => dup update-shifts /Name get dup type /integertype eq { % Meta {128 add} if Meta {128 or} if } { (%) sprintf % X11/NeWS pre fcs bug: /foo cvn => typecheck error! Meta { (Meta%) sprintf } if Shift { (Shift%) sprintf } if Control { (Control%) sprintf } if cvn } ifelse /key exch def BindingKey? DescribingKey? or { BindingKey? { selected-object KeyDict key known { KeyDict key get } { null } ifelse kbd-select-object dup null eq { pop KeyDict key undef } { KeyDict exch key exch put } ifelse } if [ () KeyDict key known { KeyDict key get comment-string } { key type /integertype eq (self insert) (unbound) ifelse } ifelse key key-name (%: %) sprintf () ] false writeatcaret /BindingKey? false store /DescribingKey? false store prompt } { KeyDict key known { { KeyDict key get cvx exec } fork pop pause } { key type /integertype eq { key cvis typein } { % beep } ifelse } ifelse } ifelse } def /s null def /skip 0 def /newlines 0 def /i 0 def /a null def /pre null def /lastnl 0 def /InsertValueCallback { % string => - /skip dialog-string length store /s exch dialog-string exch append store /newlines 0 store /lastnl null store 0 1 s length 1 sub { /i exch store s i get 13 eq { s i 10 put } if s i get 10 eq { /newlines newlines 1 add store /lastnl i store pause } if } for lastnl null ne { s 0 lastnl 1 add cvi getinterval /dialog-enter dialog-item send pause pause pause /dialog-string s lastnl 1 add cvi 1 index length 1 index sub getinterval store pause } if /s s skip cvi 1 index length 1 index sub getinterval store /a newlines 1 add array store 0 1 newlines 1 sub { pause /i exch store s (\n) search pop /pre exch store pop /s exch store a i pre put } for /dialog-string dialog-string s append store a newlines s put a false writeatcaret /dialog-promptlines newlines 1 add % dialog-string length 0 eq { 1 add } if store } def % XXXX: Here be the start of the trouble. /KeyboardHandler { % - => - % --- Handler for keyboard, InsertValue, and Deselect events /KeyboardInterest can addkbdinterests def % X11/NeWS pre fcs: Now I don't get any key events at all when the % meta keys is held down. I used to get 0..127, and I was looking % for /Meta in the event KeyStates and or'ing in the 128 by hand, % but it stopped working, so now I have to do this... XNeWS? { % We want meta keys 128..255 as well as 0..127 % KeyboardInterest 0 get revokeinterest % is this necessary? 256 dict begin KeyboardInterest 0 get /Name get currentdict copy 128 1 255 { dup def } for KeyboardInterest 0 get /Name currentdict put end % KeyboardInterest 0 get expressinterest % is this necessary? } if /MoreInterests [ can addselectioninterests aload pop revokeinterest % Get rid of mouse interests % can addfunctionstringsinterest can addfunctionnamesinterest dup /Action 1 dict begin /DownTransition dup def currentdict end put % only want down transitions! ] def /dialog-proc currentprocess store { awaitevent dup /Name get { /DeSelect { dup /Action get /PrimarySelection eq { false DrawSelection /SelectionPath null store } if /Action get /InputFocus eq { InactivateCaret } if } /RestoreFocus { pop ReactivateCaret } /InsertValue { /Action get InsertValueCallback } /Ignore { pop } /Default { KeyHitCallback } } case } loop } def /destroy { % - => - /Scroller null store /Notifier null store KeyboardInterest null ne { { KeyboardInterest can revokekbdinterests } errored pop MoreInterests { { revokeinterest } errored pop } forall } if KeyboardEventMgr null ne { % added! -deh KeyboardEventMgr killprocess } if EventMgr null ne { EventMgr killprocess } if DelayedMoveProc null ne { % added! -deh DelayedMoveProc killprocess } if MouseDragEventMgr null ne { MouseDragEventMgr killprocess } if } def /CaretBlinkTime 3 def /CaretDutyCycle 0.95 def % Percentage on % This doesn't work: /FontHeight 12 def /FontName FontName def [ () (%% Ready!) () ] false writeatcaret oncaret } dialog-text send /Scroller [1 0 .005 .05 null] 1 {} ItemCanvas /new NeWSScrollbar send def /dialog-scroll Scroller store { /NotifyUser { null ItemValue /moveviewport dialog-text send } def /ClientDrag { DoScroll null ItemValue /moveviewport dialog-text send } def /FakeScroll { % motion => - ItemBegin /ScrollMotion exch def DoScroll EraseBox PaintBox NotifyUser ItemEnd } def /ScrollTo { % val => - ItemBegin /ItemValue exch def EraseBox PaintBox NotifyUser ItemEnd } def } Scroller send /Notifier (Selected:) () /Right {} ItemCanvas /new MessageItem send def { /LabelFont /Courier findfont 20 scalefontquant def /ItemFont /Courier-Bold findfont 20 scalefontquant def /ItemFrame 1 def } Notifier send } if } def /dialog-newline { % str => - psh-socket exch writestring psh-socket 10 write psh-socket flushfile } def % /dialog-enter { % str => - % /dialog-buf exch dialog-buf (%%\n) sprintf remove-returns store % { dialog-buf % { token } errored { % [(%% Syntax error!)] false /writeatcaret dialog-text send % kbd-reset exit % } { % { exch /dialog-buf exch store % [ exch ] cvx execute-it % } { % dialog-buf ( _FOO_) append token { % Ignore white space % exch pop /_FOO_ eq { % /dialog-buf () store % prompt % } if % } if % exit % } ifelse % } ifelse % pause % } loop % } def /dialog-enter { % str => - dialog-newline } def /destroy { shut-down SubItemMgr null ne { SubItemMgr killprocess /SubItemMgr null store } if dialog-text null ne { % {{destroy} errored pop} dialog-text send dialog-can /Retained false put /destroy dialog-text send /dialog-text null store /dialog-can null store } if MyProcess type /processtype eq { pause pause pause % maybe it will kill itsself MyProcess killprocessgroup } if /MyProcess null store /DeferedUpdateEvent null store /Stack null store /Pallets null store /destroy super send } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Nasty userdict variables /dialog-text null def /dialog-can null def /dialog-proc null def /dialog-string () def /dialog-buf () def /dialog-promptlines 0 def /dialog-item null def /dialog-scroll null def (NEWSSERVER) getenv dup () eq { (newsserverstr) pipe pop 100 string readstring pop 0 1 index length 1 sub getinterval } if (;) search pop (.) search pop pop pop /socket-port exch def pop /socket-host exch def /socket-file (%socketc) socket-port append socket-host append def /psh-socket null def /SP 0 def /Stack 256 array def Stack 0 {By Don Hopkins (don@brillig.umd.edu)} put Stack 1 (Nothing!) put /ThisI null def /it null def /ob null def /obs null def /FillColor 1 1 1 rgbcolor def /ItemLock createmonitor def /items [] def /free-items [] def /Meta false def /Control false def /Shift false def /win null def /can null def /slidemgr null def /itemmgr null def /incoming null def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Item managment /createitems { ItemLock { /items [ Stack 0 {handle-click} can /new StructItem send 200 400 0 0 /reshape 5 index send Stack 1 {} can /new TextStructItem send { /ObjectWidth 600 def /ObjectHeight 200 def 30 20 0 0 reshape } 1 index send ] def /SP items length store /dialog-item items 1 get store {/PinHeight 600 def /StackI 1 def} dialog-item send /ThisI 1 store } monitor } def /slipslideitem { % items fillcolor item => - { ItemLock { gsave % dup 4 1 roll % item items fillcolor item { moveinteractive location move ItemCanvas canvastotop } exch send % item grestore } monitor } fork pop pop pop pop } def /update-slide-interests { % event => - CurrentEvent /ClientData get % Index items exch get % item dup /ItemCanvas get % item can MiddleMouseButton [/pop cvx items FillColor % item can name [ dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest expressinterest pop } def /update-start-interests { % event => - CurrentEvent /ClientData get % Index items exch get % item mark [/makestartinterests 3 index send aload pop] {dup xcheck {exec} {expressinterest} ifelse} forall cleartomark % event mark pop pop % } def /transfer-to-deck { % event => - unblockinputqueue % ??? gsave can setcanvas selected-object ItemLock { 20 dict begin /Obj exch def currentcursorlocation /NextY exch def /NextX exch def free-items length 0 eq { Stack SP /Obj load put Stack SP {handle-click} can /new StructItem send /It exch def /items [ items aload pop It ] store /I SP def /SP SP 1 add store It /StackI null put createevent begin /Name /UpdateInterests def /Canvas can def /ClientData I def currentdict end sendevent } { /I free-items dup length 1 sub get def /It items I get def /free-items free-items 0 1 index length 1 sub getinterval store It /StackI null put /Obj load /Reuse It send } ifelse NextX NextY { 2 copy 20 20 just-reshape exch PinX sub exch move map damage-view } It send pause pause end } monitor grestore pop } def /start-event-mgrs { % Create event manager to slide around the items. % Create a bunch of interests to move the items. % Note we actually create toe call-back proc to have the arguments we need. % The proc looks like: {items color "thisitem" slideitem}. % We could also have used the interest's clientdata dict. slidemgr null ne {slidemgr killprocess} if % { %XXX % /slidemgr [ % items { % key item % dup /ItemCanvas get % item can % MiddleMouseButton [items FillColor % item can name mark dict color % 6 -1 roll /slideitem cvx] cvx % can name proc % DownTransition % can name proc action % 4 -1 roll eventmgrinterest % interest % } forall % /UpdateInterests /update-slide-interests % null can eventmgrinterest % ] forkeventmgr store % } pop %XXX itemmgr null ne {itemmgr killprocess} if /itemmgr [ items iteminterests aload pop /UpdateInterests /update-start-interests null can eventmgrinterest /DoTransfer /transfer-to-deck null can eventmgrinterest ] forkeventmgr store { % send to dialog-item psh-socket null eq { MyProcess null ne { MyProcess killprocessgroup } if /MyProcess null store incoming null ne { incoming killprocess } if /incoming null store systemdict /_ViewCanvas ItemCanvas put /psh-socket { socket-file (r) file } errored { { newprocessgroup framebuffer setcanvas 500 500 [(Could not establish connection)] popmsg pop } fork pause pause pop currentprocess killprocessgroup } if store % /incoming { % { { psh-socket CanWidth string readline false eq { % [() (Lost it!) ()] false writeatcaret % % 1 60 div sleep % % /kbd-reboot dialog-item send % /incoming null store % currentprocess killprocess % } if % dialog-promptlines 0 ne { % getcaretpos exch pop 1 exch dialog-promptlines sub 1 add % dup dialog-promptlines exch deleteline % movecaret % /dialog-promptlines 0 store % } if % [ exch () % ] false writeatcaret % psh-socket bytesavailable 0 eq { prompt } if % } loop % } dialog-text send % } fork store /incoming { { { psh-socket CanWidth string readline false eq { [() (Lost it!) ()] false writeatcaret % 1 60 div sleep % /kbd-reboot dialog-item send /incoming null store currentprocess killprocess } if [ exch () psh-socket bytesavailable dup 0 eq { pop } { string psh-socket exch readstring not { exit } if { (\n) search not { exit } if exch pop exch } loop } ifelse ] false writeatcaret % psh-socket bytesavailable 0 eq { prompt } if } loop } dialog-text send } fork store psh-socket % (systemdict/dbgstart known not{(NeWS/debug.ps)run}if dbgstart\n_ReadyProcess\n) % (executive _ReadyProcess\n) % X11/NeWS pre fcs (/QUESTION /AUTHORITY executive _ReadyProcess\n) % OpenWindows V2 writestring psh-socket flushfile .5 60 div sleep } if } dialog-item send } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window class definition /DeckWindow DefaultWindow dictbegin /FrameLabel (CyberSpace Deck) def /IconLabel (CyberSpace Deck) def /IconImage /galaxy def dictend classbegin /dragframe? true def /PaintClient { paint-hilite % items paintitems } def /paint-hilite { ClientCanvas setcanvas erasepage /DrawHilite dialog-item send } def /ClientMenu BackgroundMenu def %% performance kludge %% systemdict /BackgroundMenu BackgroundMenu put /display-credits { gsave framebuffer setcanvas currentcursorlocation [ (CyberSpace Deck:) ( by Don Hopkins) (----------------) (Code stolen from:) ( Josh Siegel) ( Don Woods) ] popmsg pop grestore } def /DestroyClient { { newprocessgroup FrameCanvas /Mapped false put FrameCanvas /Retained false put ClientCanvas /Retained false put itemmgr type /processtype eq { itemmgr killprocess } if slidemgr type /processtype eq { slidemgr killprocess } if items null ne { items /items null store { /destroy exch send } forall } if /_ViewCanvas null store /PrimarySelection clearselection % XXX? /DestroyClient super send } fork pop } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Create objects /win framebuffer /new DeckWindow send def % Create a window %0 0 900 900 /reshape win send /reshapefromuser win send /can win /ClientCanvas get def % BOO HISS %can /Parent get /Retained true put createitems % /reshapefromuser win send /map win send start-event-mgrs breakpoint % so we can catch stdout from psh