%! % Structured PostScript Data Item % Don Hopkins % systemdict begin /StructItem LabeledItem dictbegin /LineGap 30 def /ItemFont /Courier 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 % /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 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 { /PaintItem super send paint-struct } def /CalcObj&LabelXY { /ObjectX 0 store /ObjectY 0 store /LabelX 0 store /LabelY 0 store /CalcObj&LabelXY super send } def /ClientDown { CurrentEvent /Name get MenuButton eq { show-struct-menu } if } def /ClientUp { CurrentEvent /Name get PointButton eq { NotifyUser } if StopItem } def /StructMenu [ (2) {{/StartPoint 2 def redo-layout} it send} (4) {{/StartPoint 4 def redo-layout} it send} (6) {{/StartPoint 6 def redo-layout} it send} (8) {{/StartPoint 8 def redo-layout} it send} (10) {{/StartPoint 10 def redo-layout} it send} (12) {{/StartPoint 12 def redo-layout} it send} (14) {{/StartPoint 14 def redo-layout} it send} (16) {{/StartPoint 16 def redo-layout} it send} (18) {{/StartPoint 18 def redo-layout} it send} (20) {{/StartPoint 20 def redo-layout} it send} (22) {{/StartPoint 22 def redo-layout} it send} (24) {{/StartPoint 24 def redo-layout} it send} (26) {{/StartPoint 26 def redo-layout} it send} (28) {{/StartPoint 28 def redo-layout} it send} ] /new DefaultMenu send def /SubStructMenu [ (Clone) {{ob /Obj get copy-struct} it send} % (Open4) {{ob begin 4 grow-substruct end redo-layout} it send} (Copy) {{ob /Obj get set-selection} 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 => result { { 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 /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 ObjectX ObjectY translate { userdict /ob currentdict put } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop userdict /ob get null eq { CurrentEvent /showat StructMenu send } { CurrentEvent /showat SubStructMenu send } ifelse ItemEnd } if } def /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 { 0 max /ClientHeight win send ItemHeight sub min exch 0 max /ClientWidth win send ItemWidth sub min exch /move super send draw-connections } 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 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 Obj /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 2 1 ifelse 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 cvlit def /Str () def /X 0 def /Y 0 def /W 0 def /H 0 def Obj composite? I forbidden? not and L 0 gt and { /Branches [ Obj dup type /arraytype eq { { pop Obj counttomark 1 sub L 1 sub grow-struct } } { { pop Obj exch L 1 sub grow-struct } } ifelse forall ] def } { /Branches null def } ifelse currentdict end } def /layout-struct { % dict => - pause begin /Str Obj I (%: %) sprintf def /Font ItemFont Point scalefont def 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 /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 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 /items [ items aload pop Stack SP {click-point} can /new StructItem send ] store gsave can setcanvas currentcursorlocation grestore 0 0 /reshape items dup length 1 sub get send start-event-mgrs items FillColor items dup length 1 sub get slideitem } def /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 { { -4 bbox insetrect rectpath .5 setgray fill } items ThisI get send } if grestore } store /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 ] forkeventmgr store itemmgr null ne {itemmgr killprocess} if /itemmgr items forkitems 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