%! % Structured PostScript Data Item % Don Hopkins % true setprintermatch statusdict begin 0 setjobtimeout end systemdict begin /StructItem LabeledItem dictbegin /LineGap 30 def /ItemLabelFont /Helvetica-Bold findfont 14 scalefont def /ItemFont /Courier findfont def /ItemXFont /Courier-Oblique findfont def /Shrink .8 def /Pad 3 def /StartPoint 14 def /Point StartPoint def /x 0 def /y 0 def /Levels 0 def /DL null def /ItemFrame 2 def /ItemRadius 5 def /ItemBorder 6 def /ItemButton [PointButton MenuButton] def /FromX 0 def /FromY 0 def /ToX 0 def /ToY 0 def /PrevI null def /NextI null def /StackI null def % /ItemBaseline null def % /ItemText null def /LayoutLock null def /Meta false def /Control false def /Shift false def /LastX 0 def /LastY 0 def /LastTime 0 def /DoubleClickTime 1 60 div def /CanvasYFudge 2 store dictend classbegin /new { % Collection Index notifyproc parentcanvas => instance % 4 2 roll 2 copy get 1 index (%: %) sprintf % notify parent cont ind label 4 2 roll dup (%:) 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 /Retained true put /LayoutLock createmonitor def currentdict end } def /PaintItem { ItemRadius label-bbox rrectpath ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius label-bbox rrectframe ItemBorderColor setcolor eofill } if ItemRadius object-bbox rrectpath ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius object-bbox rrectframe ItemBorderColor setcolor eofill } if ShowLabel paint-struct } store /ClientDown { CurrentEvent /Name get MenuButton eq { show-struct-menu } if } def /ClientUp { CurrentEvent /Name get PointButton eq { NotifyUser } if StopItem } def /PointMenu [ (2) (4) (6) (8) (10) (12) (14) (16) (18) (20) (22) (24) (28) (32) ] [ {currentkey cvi {/StartPoint exch def redo-layout} it send} ] /new DefaultMenu send def /LabelMenu [ (LeftBelow) (LeftAbove) (AboveLeft) (AboveRight) (RightAbove) (RightBelow) (BelowRight) (BelowLeft) ] [ { currentkey cvn {/ObjectLoc exch def location 10 10 reshape damage-view} it send} ] /new DefaultMenu send store LabelMenu /PieInitialAngle 360 16 div put /ShrinkMenu [ (.1) (.2) (.3) (.4) (.5) (.6) (.7) (.8) (.9) (1) ] [ {currentkey cvr {/Shrink exch def redo-layout} it send} ] /new DefaultMenu send def /StructMenu [ (Point...) PointMenu (Print) {/write-DL it send} (Shrink...) ShrinkMenu (Label...) LabelMenu ] /new DefaultMenu send store /SubStructMenu [ (Load) {{ob /Obj get load-it} it send} % (Open4) {{ob begin 4 grow-substruct end redo-layout} it send} (Clone) {{ob /Obj get copy-struct} it send} (Exec) {{ob /Obj get exec-it} it send} (Paste) {{ob begin C I get-selection replace-substruct end redo-layout} it send} ] /new DefaultMenu send def /exec-it { % obj => - { { userdict begin /Execee exch def PState setstate clear /PStack [ ThisI null ne { ThisI { % I items 1 index get % I item /PrevI exch send % I PrevI dup null eq { pop exit % I } if % I PrevI exch pop % PrevI } loop /FirstI 1 index store 50 { { Collection Index get NextI } exch items exch get send dup null eq {pop exit} if } repeat % 50 repeat just in case of loops! } if ] def PStack aload pop /Execee load cvx exec /PState currentstate store count array astore /QStack exch store QStack { % q true PStack { % q true p 2 index eq { pop pop false exit } if } forall { copy-struct } if } forall % PStack length 0 eq {/Empty} { PStack dup length 1 sub get } ifelse } errored { $error 20 dict copy copy-struct } if } fork pop } def /load-it { % obj => - { load } errored {pop} { copy-struct } ifelse } def /get-selection { % - => obj /PrimarySelection getselection dup null ne { dup /ContentsPostScript known { /ContentsPostScript get } { dup /ContentsAscii known { /ContentsAscii get } if } ifelse } if } def /set-selection { % obj => - 20 dict begin /ContentsPostScript 1 index def /ContentsAscii exch cvstring def /SelectionObjSize 1 def /SelectionResponder null def /Canvas can def /SelectionHolder itemmgr def currentdict end /PrimarySelection setselection } def /show-struct-menu { DL null ne { ItemBegin userdict /it self put userdict /ob null put gsave newpath label-bbox rectpath CurrentEvent begin XLocation YLocation end pointinpath grestore not { ObjectX ObjectY translate { userdict /ob currentdict put } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop } if userdict /ob get null eq { CurrentEvent /showat StructMenu send } { CurrentEvent /showat SubStructMenu send } ifelse ItemEnd } if } store /makestartinterests { /makestartinterests super send [ exch aload pop /Connect {/ClientConnect /Self GetFromCurrentEvent send} null ItemCanvas eventmgrinterest dup /Exclusivity true put dup /Self self PutInEventMgrInterest ] } def /scale-to-item { % normalX normalY => X Y ItemHeight mul exch ItemWidth mul location 4 -1 roll add 3 1 roll add exch } def /ClientExit { CurrentEvent /KeyState get { dup PointButton eq { { ItemBegin /ThisI Index store ItemCanvas setcanvas CurrentEvent begin /FromX XLocation ItemWidth div 0 max 1 min store /FromY YLocation ItemHeight div 0 max 1 min store end FromX FromY scale-to-item ItemParent createoverlay setcanvas { 2 setlinewidth lineto } getanimated waitprocess aload pop % x y % DisconnectNext createevent begin /Name /Connect def /ClientData Index def % /Process itemmgr def % Gotta do this or it doesn't get the event % WHY AREN'T XLocation and XLocation transformed??? gsave framebuffer setcanvas currentcursorlocation %transform /YLocation exch def /XLocation exch def { FrameY BorderBottom add add exch FrameX BorderLeft add add exch } win send /YLocation exch def /XLocation exch def grestore currentdict end sendevent ItemEnd } fork pop exit } if } forall StopItem } def /FormsLoop? { % I => bool { dup null eq {pop false exit} if dup Index eq {pop true exit} if items exch get /PrevI get } loop } def /ClientConnect { gsave CurrentEvent /ClientData get Index eq { /ThisI Index store DisconnectPrev DisconnectNext draw-connections } { /ThisI Index store DisconnectPrev DisconnectNext CurrentEvent begin ItemCanvas setcanvas /PrevI ClientData store XLocation ItemWidth div 0 max 1 min YLocation ItemHeight div 0 max 1 min end Index /ConnectNext items PrevI get send draw-connections } ifelse grestore } def /draw-connection { NextI null ne { FromX FromY scale-to-item 2 copy 6 0 360 arc closepath fill newpath moveto ToX ToY /scale-to-item items NextI get send lineto stroke } if } def /DisconnectNext { NextI null ne { items NextI get /NextI null def /DisconnectPrev exch send } if } def /DisconnectPrev { PrevI null ne { items PrevI get /PrevI null def /DisconnectNext exch send } if } def /ConnectNext { % X Y Index => - DisconnectNext /NextI exch def /ToY exch def /ToX exch def %(Connected % to %\n)[Index NextI]dbgprintf } def /reshape { % x y w h /ItemHeight exch def /ItemWidth exch def ItemWidth 0 eq ItemHeight 0 eq and { /DL null store } if ensure-DL adjust-geometry ItemWidth ItemHeight /reshape super send gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore location move } def /move { % x y label-bbox /lh exch def /lw exch def % x y lx ly 2 index add /ly exch def % x y lx 2 index add /lx exch def % 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 /move super send draw-connections } store /label-bbox { ObjectLoc { /RightAbove /Right /RightBelow { LabelX ItemBorder sub LabelY ItemBorder sub % x y ItemBorder LabelWidth add ItemGap add ItemRadius dup add add % w LabelHeight ItemBorder dup add add % h } /LeftAbove /Left /LeftBelow { LabelX ItemGap sub ItemRadius dup add sub % x LabelY ItemBorder sub % y ItemRadius dup add ItemGap add LabelWidth add ItemBorder add % w LabelHeight ItemBorder dup add add % h } /AboveRight /Top /AboveLeft { LabelX ItemBorder sub % x LabelY ItemBorder sub % y LabelWidth ItemBorder dup add add % w ItemBorder LabelHeight add ItemGap add ItemRadius dup add add % h } /BelowRight /Bottom /BelowLeft { LabelX ItemBorder sub % x LabelY ItemGap sub ItemRadius dup add sub % y LabelWidth ItemBorder dup add add % w ItemRadius dup add ItemGap add LabelHeight add ItemBorder add % h } } case % r x y w h } def /object-bbox { 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 def /ItemHeight ItemBorder 2 mul LabelHeight ObjectHeight max add def } /Top /Bottom /AboveLeft /AboveRight /BelowLeft /BelowRight { /ItemWidth ItemBorder 2 mul LabelWidth ObjectWidth max add def /ItemHeight ItemBorder 3 mul ItemGap add LabelHeight add ObjectHeight add def } ] case } store /CalcObj&LabelXY { % - => - [uses item context] ObjectLoc { /RightAbove /Right { /LabelX ItemBorder def /LabelY ItemBorder def /ObjectX ItemBorder dup add LabelWidth add ItemGap add def /ObjectY ItemHeight ObjectHeight sub 2 div def } /RightBelow { /LabelX ItemBorder def /LabelY ItemHeight ItemBorder sub LabelHeight sub def /ObjectX ItemBorder dup add LabelWidth add ItemGap add def /ObjectY ItemHeight ObjectHeight sub 2 div def } /LeftAbove /Left { /LabelX ItemBorder dup add ItemGap add ObjectWidth add def /LabelY ItemBorder def /ObjectX ItemBorder def /ObjectY ItemHeight ObjectHeight sub 2 div def } /LeftBelow { /LabelX ItemBorder dup add ItemGap add ObjectWidth add def /LabelY ItemHeight ItemBorder sub LabelHeight sub def /ObjectX ItemBorder def /ObjectY ItemHeight ObjectHeight sub 2 div def } /AboveRight /Top { /LabelX ItemBorder def /LabelY ItemBorder def /ObjectX ItemWidth ObjectWidth sub 2 div def /ObjectY ItemBorder dup add LabelHeight add ItemGap add def } /AboveLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub def /LabelY ItemBorder def /ObjectX ItemWidth ObjectWidth sub 2 div def /ObjectY ItemBorder dup add LabelHeight add ItemGap add def } /BelowRight /Bottom { /LabelX ItemBorder def /LabelY ItemBorder dup add ObjectHeight add ItemGap add def /ObjectX ItemWidth ObjectWidth sub 2 div def /ObjectY ItemBorder def } /BelowLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub def /LabelY ItemBorder dup add ObjectHeight add ItemGap add def /ObjectX ItemWidth ObjectWidth sub 2 div def /ObjectY ItemBorder def } } case } def /adjust-geometry { LabelSize /LabelHeight exch def /LabelWidth exch def AdjustItemSize CalcObj&LabelXY } def /Collection { ItemObject 0 get cvlit } def /Index { ItemObject 1 get cvlit } def /ensure-DL { DL null eq { Collection Index Levels grow-struct /DL exch store /ObjectWidth 0 store /ObjectHeight 0 store } if ObjectWidth 0 eq ObjectHeight 0 eq or { perform-layout } if } def /paint-struct { gsave ensure-DL ItemTextColor setcolor ObjectX ObjectY translate DL draw-struct grestore } def /damage-view { gsave %ItemParent setcanvas bbox rectpath extenddamage paint grestore } def /search-struct { % proc x y dict => proc x y begin dup Y ge { dup Y H add lt { % Path setpath newpath X Y W H rectpath 2 copy pointinpath { 2 index exec } { Branches null ne { Branches { search-struct } forall } if } ifelse } if } if end } def /click-popup { DL null ne { { gsave ItemCanvas setcanvas ObjectX ObjectY translate { gsave framebuffer setcanvas currentcursorlocation [/Obj load I C (%[%]: %) sprintf] popmsg pop grestore } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop grestore } fork pop } if } def /replace-substruct { % obj => - C I 3 -1 roll put C I 0 grow-struct begin /Branches Branches /C C /I I /L L /Obj dup load /Str Str /X X /Y Y /W W /H H end def def def def def def def def def def } def /grow-substruct { % l => - /L exch def /forbidden? {pop false} def /Branches C I L grow-struct 1 index get def currentdict /forbidden? undef } def /update-shifts { /Meta false store /Shift false store /Control false store CurrentEvent /KeyState get { dup { /Meta /Shift /Control {true store} /Default {pop} } case } forall } def /click-point { DL null ne { ItemBegin update-shifts ItemCanvas setcanvas CurrentEvent begin LastX XLocation sub dup mul LastY YLocation sub dup mul add end 16 lt currenttime LastTime sub DoubleClickTime lt and { % multiple clicks ob null ne { click-open } if /LastTime currenttime store } { % first click userdict /it self put userdict /ob null put ObjectX ObjectY translate { userdict /ob currentdict put } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop userdict /ob get null eq { DL null ne { DL begin /Icon? Icon? not def end redo-layout } if /LastTime 0 store } { ob /Obj get set-selection /LastTime currenttime store } ifelse ItemCanvas setcanvas CurrentEvent begin /LastX XLocation store /LastY YLocation store end } ifelse ItemEnd } if } def /Icon? false def /click-open { DL null ne { gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY translate ob begin L 0 eq Shift or { L 1 add grow-substruct } { /L 0 def /Branches null def } ifelse end % ob Meta not { /redo-layout self null pop send } if grestore } if } def /clean-underneath { gsave ItemParent setcanvas grestore } def /perform-layout { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { /hourg /hourg_m ItemCanvas setstandardcursor /ItemLabel DL /Obj get type 20 string cvs store init-format DL layout-struct adjust-geometry } monitor /ptr /ptr_m ItemCanvas setstandardcursor } def /redo-layout { clean-underneath perform-layout location 10 10 reshape damage-view } def /composite? { % obj => bool type { /arraytype /dicttype /canvastype /processtype /eventtype /fonttype {true} /Default {false} } case } 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 } def /init-format { /Point StartPoint def /x 0 def /y 0 def /ObjectWidth 0 def /ObjectHeight 0 def } def /LineHeight { currentfont fontheight 1 add } def /grow-struct { % Container Index Levels => dict pause 20 dict begin /L exch def cvlit /I exch def cvlit /C exch def /Obj C I get def /Str () def /X 0 def /Y 0 def /W 0 def /H 0 def /Obj load composite? I forbidden? not and L 0 gt and { /Branches [ /Obj load dup type /arraytype eq { { pop /Obj load counttomark 1 sub L 1 sub grow-struct } } { { pop /Obj load exch L 1 sub grow-struct } } ifelse forall ] def } { /Branches null def } ifelse currentdict end } def /layout-struct { % dict => - pause begin /Str /Obj load I (%: %) sprintf def /Obj load xcheck Point 10 ge and { /Font ItemXFont Point scalefont def } { /Font ItemFont Point scalefont 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 Shrink mul store Branches { layout-struct } forall /Point Point Shrink div store /x x W sub store 0 Branches { /H get add } forall LineHeight max 1 max /H exch def } ifelse /y Y H add store /ObjectWidth ObjectWidth x W add LineGap sub max store /ObjectHeight ObjectHeight y max store end } def /draw-struct { % dict => - pause begin show-obj Branches null ne Icon? not and { currentpoint LineHeight 2 div add Branches { begin 2 copy moveto X Pad sub Y lineto Pad 2 mul 0 rlineto stroke end } forall Branches length 0 ne { Branches dup length 1 sub get begin 2 copy moveto X Pad sub Y H add lineto Pad 2 mul 0 rlineto stroke end } if pop pop Branches { draw-struct } forall } if end } def /write-DL { % { /f (DL.ps) (w) file def f (%!\n) writestring f (gsave 0 setgray 0 setlinewidth 20 20 translate\n) writestring DL print-struct f (grestore showpage\n) writestring f closefile } stopped pop } def /print-struct { % dict => - pause begin Font /FontMatrix get 0 get /Obj load xcheck ItemXFont ItemFont ifelse /FontName get (/% findfont % scalefont setfont\n) sprintf f exch writestring Font setfont Font fontdescent X Y 2 index add H LineHeight sub 2 div add 2 copy moveto exch (% % moveto\n) sprintf f exch writestring Str stringwidth rmoveto Str ( (%) show\n) sprintf f exch writestring neg 0 exch rmoveto Branches null ne Icon? not and { currentpoint LineHeight 2 div add Branches { begin 2 copy exch (% % moveto\n) sprintf f exch writestring X Pad sub Y exch ( % % lineto\n) sprintf f exch writestring Pad 2 mul 0 exch ( % % rlineto\n) sprintf f exch writestring f ( stroke\n) writestring end } forall Branches length 0 ne { Branches dup length 1 sub get begin 2 copy exch (% % moveto\n) sprintf f exch writestring X Pad sub Y H add exch ( % % lineto\n) sprintf f exch writestring Pad 2 mul 0 exch ( % % rlineto\n) sprintf f exch writestring f ( stroke\n) writestring end } if pop pop Branches { print-struct } forall } if end } def /show-obj { Font dup setfont fontdescent X Y 2 index add H LineHeight sub 2 div add moveto Str show neg 0 exch rmoveto } def /moveinteractive { % items backgroundcolor => - (interactively move item) ItemBegin currentcanvas mapcanvas false dragcanvas pop pop ItemEnd } def classend def % ======================================================================== /TextStructItem StructItem dictbegin dictend classbegin /reshape { % x y w h /ItemHeight exch def /ItemWidth exch def LabelSize /LabelHeight exch def /LabelWidth exch def ItemValue ItemFont ThingSize /ObjectHeight exch def /ObjectWidth exch def AdjustItemSize /ObjectWidth ItemWidth 2 ItemBorder mul sub def ObjectLoc /Right eq ObjectLoc /Left eq or { /ObjectWidth ObjectWidth LabelWidth sub ItemGap sub def } if CalcObj&LabelXY /ItemBaseline ObjectY ItemFont fontdescent add def ItemWidth ItemHeight /reshape super send ItemFont setfont % this is so the text caret will be right! TextBegin /ItemText ItemCanvas ObjectX ItemBaseline ItemValue /new LiteText send store TextEnd } def /maketextinterest { % - => - (express selninterest; install callbacks) % Add selection interests ItemCanvas addselectioninterests % Insert the callback procs for these interests aload pop /ClientData 10 dict dup /CallBack { % private seln callback pop } put put /ClientData 10 dict dup /CallBack { % std seln callback dup /Name get { /SetSelectionAt { dup /Action get /Rank get /PrimarySelection eq { /StartItem CurrentEvent /Interest get /ClientData get /Self get send } if } } case } put dup /Self self put put } def /restorefocus {TextBegin /starttext ItemText send TextEnd} def % - -> - /removefocus {TextBegin /stoptext ItemText send TextEnd} def % - -> - /inserttext { % str/char -> - TextBegin %ItemFrame 0 gt { % 2 0 0 ItemWidth ItemHeight insetrect rectpath clip %} if dup type /stringtype eq { {/inserttext ItemText send} forall } { /inserttext ItemText send } ifelse SetTextValue NotifyUser TextEnd } def /PaintItem { /PaintItem super send /ItemObject ItemValue store ShowObject ItemBorderColor setcolor ObjectX ObjectY moveto ObjectWidth 0 rlineto stroke } def /StartItem { TextBegin CurrentTextItem null ne { /stoptext CurrentTextItem /ItemText get send } if self SetCurrentTextItem /starttext ItemText send CurrentEvent begin XLocation YLocation end /settextxy ItemText send TextEnd } def /SetTextValue {/ItemValue ItemText /TextStr get store} def /TextBegin {ItemBegin} def /TextEnd {ItemEnd} def classend def % ======================================================================== % NeWS error handler using the object browser (NeWS1.1) % % Jeremy Huxtable % % Mon Jul 25 17:36:06 BST 1988 /MyErrorDict dictbegin StandardErrorNames { {MyErrorHandler} def } forall dictend def /MyErrorHandler { % Must be careful with manipulating the stacks here, as otherwise % our private stuff will appear in the browser! /errordict OldErrorDict store pop % Get rid of the "offending command" from stack % create a dictionary of useful info. Note that we must get the % process' stacks now as otherwise they disappear when the "killprocess" % is done. currentprocess /DictionaryStack get 7 dict begin /DictionaryStack exch def currentprocess /OperandStack get /OperandStack exch def /ExecutionStack currentprocess /ExecutionStack get 0 1 index length 4 sub getinterval def % Remove this error handler from exec stack /Interests currentprocess /Interests get def /Error $error /errorname get def /Executing $error /command get def /Process currentprocess def currentdict end /errordict MyErrorDict store } def /cvstring { % value => string dup type /stringtype eq { ((%)) sprintf } { dup type /nametype eq 1 index xcheck not and { (/%) sprintf } { 100 string cvs } ifelse } ifelse } def systemdict /Stack known not { /Stack 256 array def Stack 0 10 dict put Stack 0 get begin /foo {1{2{3 4 5}6}7} def /bar {{{{baz}}}} def /yow framebuffer def /rm rootmenu def end } if /SP 0 def end % systemdict /items [] def /createitems { /items [ Stack 0 {click-point} can /new StructItem send 20 20 0 0 /reshape 5 index send ] def } def /slideitem { % items fillcolor item => - gsave dup 4 1 roll % item items fillcolor item {ItemCanvas canvastotop moveinteractive location move} exch send % item % draw-connections grestore } def /copy-struct { % obj => - /SP items length store Stack SP 3 -1 roll put Stack SP /NotifyUser load can /new ClassName load send /items [ items aload pop counttomark 2 add index ] store 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 { 0 0 20 20 reshape move } 4 -1 roll send createevent begin /Name /UpdateInterests def /Canvas ItemParent def /ClientData items length 1 sub def currentdict end sendevent % items FillColor items dup length 1 sub get slideitem } store /layout-all { gsave items { /redo-layout exch send } forall /ClientCanvas win send setcanvas clippath extenddamage grestore } def /slidemgr null def /itemmgr null def /FirstI null def /ThisI null def /PStack null def /QStack null def /PState currentstate def /Execee null def /connect-background { ThisI null ne { {DisconnectNext /ThisI Index store} items ThisI get send draw-connections } if } def /draw-connections { gsave can setcanvas initclip erasepage 0 setgray 2 setlinewidth items {/draw-connection exch send} forall ThisI null ne { { gsave can setcanvas location CanvasYFudge add translate -3 ItemRadius label-bbox insetrrect rrectpath 2 setlinewidth stroke -3 ItemRadius object-bbox insetrrect rrectpath .5 setgray fill grestore } items ThisI get send } if grestore } store /update-slide-interests { CurrentEvent /ClientData get % Index items exch get % item dup /ItemCanvas get % item can MiddleMouseButton [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 } def /update-start-interests { CurrentEvent /ClientData get % Index items exch get % item mark [/makestartinterests 3 index send aload pop] {dup xcheck {exec} {expressinterest} ifelse} forall cleartomark /paint exch send } 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 /slidemgr [ items { % key item dup /ItemCanvas get % item can MiddleMouseButton [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 } forall /UpdateInterests /update-slide-interests null can eventmgrinterest ] forkeventmgr store itemmgr null ne {itemmgr killprocess} if /itemmgr [ items iteminterests aload pop /UpdateInterests /update-start-interests null can eventmgrinterest ] forkeventmgr store } def /MyWindow DefaultWindow dictbegin dictend classbegin /CreateFrameInterests { /CreateFrameInterests super send FrameInterests begin /ConnectEvent /Connect {connect-background} null ClientCanvas eventmgrinterest def end } def /DestroyClient { itemmgr type /processtype eq { itemmgr killprocess } if slidemgr type /processtype eq { slidemgr killprocess } if /DestroyClient super send } def classend def % Create and size a window. The size is chosen to accommodate the % items we are creating. Right before we map the window, we ask the % user to reshape the window. This is atypical, but gets the items % positioned the way we want them. /FillColor 1 1 1 rgbcolor def /win framebuffer /new MyWindow send def % Create a window { /PaintClient { draw-connections items paintitems } def /FrameLabel (PostScript Structure CyberSpace) def /IconLabel (CyberSpace) def /IconImage /galaxy def /ClientMenu [ (Layout all) { layout-all } ] /new DefaultMenu send def } win send % Install my stuff. 200 200 700 350 /reshape win send % Shape it. /can win /ClientCanvas get def % Get the window canvas can /Transparent false put can /Retained true put % Create all the items. createitems % Now let the user specify the window's size and position. Then map % the window. (See above) Then activate the items. % /ptr /ptr_m framebuffer setstandardcursor % /reshapefromuser win send % Reshape from user. /map win send % Map the window & install window event manager. % (Damage causes PaintClient to be called) start-event-mgrs