%! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % PostScript Structure CyberSpace % Copyright (C) 1989 % By Don Hopkins % All rights reserved. % % WARNING WARNING! DANGER! DANGER WILL ROBINSON! DANGER! % This is *gross* code. I mean UUUUUGLY! I wrote it the week before Usenix. % You're damn right it needs to be rewritten. But you get the idea, ehe? systemdict begin statusdict begin 0 setjobtimeout end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Load necessary stuff systemdict /NeWSScrollbar known not { (NEWSHOME) getenv (/clientsrc/client/nterm/NeWSSbar.ps) append LoadFile pop } if systemdict /TextCanvas known not { (NEWSHOME) getenv (/clientsrc/client/nterm/textcan.ps) append LoadFile pop } if %systemdict /PieMenu known not { % (NeWS/piemenu.ps) LoadFile pop %} if systemdict /PieMenu known systemdict /PulloutPieMenu known not and { (NeWS/pullout.ps) LoadFile pop } if %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % StructItem class definition /StructItem LabeledItem dictbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Instance variables /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 /ItemButton [PointButton AdjustButton MenuButton] def /StackI null def /LayoutLock null def /LastX 0 def /LastY 0 def /LastTime 0 def /DX 0 def /DY 0 def /TabX 0 def /TabY 0 def /TabWidth 0 def /TabHeight 0 def /PinX 0 def /StartIndex 0 def /LastIndex 0 def /MySiblings null def /View /layout-struct def /Click /click-struct def /lw null def /lh null def /lx null def /ly null def dictend classbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class variables /DoubleClickTime 1 60 div def /CanvasYFudge 2 store /Sort? true def /LineGap 30 def /ItemLabelFont /Helvetica-Bold findfont 14 scalefont def /ItemFont /Courier findfont def /ItemXFont /Courier-Oblique findfont def /Icon? false def /SortBy /by-name def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 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 /Retained true put /LayoutLock createmonitor def /xhair /xhair_m ItemCanvas setstandardcursor 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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Event handlers /ClientDown { CurrentEvent update-shifts CurrentEvent /Name get MenuButton eq { event-in-tab? { show-tab-menu } { show-struct-menu } ifelse } { CurrentEvent /Name get AdjustButton eq { CurrentEvent recallevent event-in-tab? { items FillColor self slideitem } { do-search ob null eq { items FillColor self slideitem } { make-selection } ifelse } ifelse } { CurrentEvent /Name get PointButton eq { event-in-tab? { toggle-icon } { do-search ob null eq { } { NotifyUser } ifelse } ifelse } if } ifelse } ifelse } def /make-selection { obs length 1 le { /MySiblings [ob] store /TipY null def /Multiple? false def }{ obs dup length 2 sub get /MySiblings 1 index /Branches get store /TipY exch dup /Y get exch /H get 2 div add def /Multiple? ob /C get type /arraytype eq Shift and def } ifelse /StartIndex 0 MySiblings { /I get ob /I get eq { exit } if 1 add } forall store /LastIndex StartIndex store 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 TipY null ne { ob /X get LineGap sub TipY moveto MySiblings StartIndex LastIndex min get begin X Pad sub Y H add lineto end MySiblings StartIndex LastIndex max get begin X Pad sub Y 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 LineGap sub 1 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 } getanimated waitprocess ob /C get Multiple? { StartIndex LastIndex 2 copy gt {exch} if 1 index sub 1 add kbd-select-interval } { MySiblings LastIndex get /I get Shift { kbd-select-object pop } { kbd-select-pointer } ifelse } ifelse /MySiblings null store } store /show-tab-menu { userdict /it self put CurrentEvent /showat TabMenu send } def /show-struct-menu { ItemBegin do-search ob null ne { CurrentEvent /showat StructMenu send } if ItemEnd } store /ClientUp { StopItem } def /click-exec { ItemBegin ItemCanvas setcanvas CurrentEvent begin LastX XLocation sub dup mul LastY YLocation sub dup mul add end do-search ob null ne { ob /Obj get exec-it } if ItemEnd } def /click-point { /Click load cvx exec } 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 /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 /click-struct { ItemCanvas setcanvas CurrentEvent begin LastX XLocation sub dup mul LastY YLocation sub dup mul add end 4 lt currenttime LastTime sub DoubleClickTime lt and not { % first click ob null ne { Shift { % Shift to select the index ob /I get } { ob /Obj get } ifelse /LastTime currenttime store Control { exec-it /LastTime 0 store } { kbd-select-object } ifelse } if ItemCanvas setcanvas CurrentEvent begin /LastX XLocation store /LastY YLocation store end } { % double clicks 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 /LastTime 0 store } ifelse } store /event-in-tab? { ItemBegin newpath label-bbox rectpath CurrentEvent begin XLocation YLocation end pointinpath ItemEnd } def /ClientExit { StopItem } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Menu definitions /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 /LocationMenu [ (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 LocationMenu /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 /ClickMenu [ (click-struct) (click-exec) ] [ {currentkey cvn {/Click exch def} it send} ] /new DefaultMenu send def /TabMenu [ (Point...) PointMenu (Paint) {/paint it send} (Click..) ClickMenu (Zap) {/Free it send} (Shrink...) ShrinkMenu (Layout) {/redo-layout it send} (Location...) LocationMenu (Print) {/write-DL it send} ] /new DefaultMenu send store /ChangeMenu [ (toke in) { /token-obj it send } (executable){ /cvx-obj it send } (name) { /cvn-obj it send } (string) { /cvs-obj it send } (toke out) { /tokout-obj it send } (literal) { /cvlit-obj it send } (integer) { /cvi-obj it send } (real) { /cvr-obj it send } ] /new DefaultMenu send def /UtilMenu [ (undef) { /undef-obj it send } (molecule) { /molecule-obj it send } (select) { ob /Obj get kbd-select-object } (--) {} (nulldef) { /nulldef-obj it send } (--) {} (reference) { /reference-obj it send } (--) {} ] /new DefaultMenu send def UtilMenu /PieInitialAngle 45 put /StructMenu [ % Note: depends on fixed getmenuarg (push) {/push-obj it send} (type...) /FigureTypeAction cvx (load) {/load-obj it send} (util...) UtilMenu (exec) {/exec-obj it send} (change...) ChangeMenu (paste) {/paste-obj it send} (open) {getmenuarg cvi /open-obj it send} ] /PulloutPieMenu where { pop [ nullarray [ [ { gsave /Screen findfont 12 scalefont setfont ob /Obj get type 30 string cvs 0 1 index length 4 sub getinterval % drop "type" exch /paint eq { 0 currentfont fontdescent rmoveto show } { stringbbox points2rect 4 2 roll pop pop } ifelse grestore } ] ] nullarray nullarray nullarray nullarray nullarray [(0) (1) (2) (3) (4) (5) (6) (7)] ] exch /new PulloutPieMenu send def } { /new DefaultMenu send def StructMenu /getmenuarg {ob /L get 0 eq 1 0 ifelse} put } ifelse { /LabelMinRadius 25 def /FigureTypeAction { ob /Obj get type { /arraytype { /ArrayMenu it send } /stringtype { /StringMenu it send } /dicttype { /DictMenu it send } /processtype { /ProcessMenu it send } /canvastype { /CanvasMenu it send } /eventtype { /EventMenu it send } /Default { { gsave framebuffer setcanvas currentcursorlocation [ (Nothing)(Happens)(Here!) ] popmsg pop grestore } } } case } def } StructMenu send /ArrayMenu [ (prepend) { /prepend-to-array-obj it send } % selected array (push) { /push-array-obj it send } % selected object (append) { /append-to-array-obj it send } % selected array (pop) { /pop-array-obj it send } % to selection ] /new DefaultMenu send def /StringMenu [ (prepend) {} % selected string (forall) {} % selected function (append) {} % selected string ] /new DefaultMenu send def /DictMenu [ (def) { /def-in-dict-obj it send } % selected function (merge) {} % selected dict ] /new DefaultMenu send def /ProcessMenu [ (kill) {} (kill group) {} (suspend) {} (resume) {} (wait) {} % select return value (userdict) {} % select userdict ] /new DefaultMenu send def /CanvasMenu [ (manager) {} % select /Interests 0 /Process (bbox) {} % select [x y w h] (setcanvas) {} % changes proc's gstate (zap) {} % unretain & unmap whole tree ] /new DefaultMenu send def /EventMenu [ (express) {} % Does this make any sense in this context? (revoke) {} (sendevent) {} ] /new DefaultMenu send def % integer real file path color ... %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Menu callbacks /push-array-obj { ob /Obj get dup [ selected-object ] append exch xcheck { cvx } if replace-obj } 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 type /arraytype ne { pop } { % [sel] ob /Obj get % [sel] {obj} exch 1 index % {obj} [sel] {obj} append % {obj} [sel obj] exch xcheck { cvx } if % {sel obj} replace-obj } ifelse } def /append-to-array-obj { selected-object dup type /arraytype ne { pop } { % [sel] ob /Obj get % [sel] {obj} dup 3 -1 roll % {obj} {obj} [sel] append % {obj} [obj sel] exch xcheck { cvx } if % {obj sel} replace-obj % } ifelse } def /def-in-dict-obj { selected-pointer? { % collection index ob /Obj get % collection index dict 2 copy exch known 1 index type /dicttype eq or not { pop pop } { 1 index % collection index dict index 4 -2 roll get % dict index obj 3 copy put pop % dict index ob /Branches get null eq { pop pop } { 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 } ifelse } if } store % Execute token with Externals on the dict stack, so externalized % //&type_123 object references are resolved. /token-obj { { 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 replace-obj } def /cvx-obj { { ob /Obj get cvx } errored {pop} { replace-obj } ifelse } def /cvn-obj { { ob /Obj get cvn } errored {pop} { replace-obj } ifelse } def /cvs-obj { { ob /Obj get 256 string cvs } errored {pop} { replace-obj } ifelse } def /tokout-obj { ob /Obj get tokout replace-obj } def /cvlit-obj { { ob /Obj get cvlit } errored {pop} { replace-obj } ifelse } def /cvi-obj { { ob /Obj get cvi } errored {pop} { replace-obj } ifelse } def /cvr-obj { { ob /Obj get cvr } errored {pop} { replace-obj } ifelse } def /load&push-obj { ob /Obj get load&push-it } def /load&push-it { % [ exch cvlit {dup load} /errored cvx { pop (%% ) (%Load: % is not defined!\n) printf } { exch 1 index exch (%% ) (%Load: % Push: %\n) printf } /ifelse cvx ] cvx execute-it } def /load-obj { ob /Obj get load-it } def /load-it { % [ exch cvlit {dup load} /errored cvx { pop (%% ) (%Load: % is not defined!\n) printf } { exch 1 index exch (%% ) (%Load: % Select: %\n) printf select-object } /ifelse cvx ] cvx execute-it } def /open-obj { % levels => - dup 0 eq { pop close-struct } { open-struct } ifelse } def /push-obj { ob /Obj get push-it } def /push-it { [ exch [ exch ] 0 /get cvx /dup cvx (%% ) (%Push: %\n) /printf cvx ] cvx execute-it } def /nulldef-obj { ob /Obj get % dict dup type /dicttype ne { pop } { selected-object dup null eq { pop } { % dict key 2 copy null put ob /Branches get null eq { pop pop } { ob /L get grow-struct % DL ob begin /Branches [ % DL /B mark Branches { dup /I get counttomark 2 add index /I get eq {pop} if } forall % DL /B mark branches... counttomark 3 add -1 roll % /B mark branches... DL ] Sort? {SortBy quicksort} if def % end } ifelse redo-layout } ifelse } ifelse } store /undef-obj { ob /Obj get dup type /dicttype ne { pop } { selected-object dup null eq { pop } { 2 copy known { 2 copy undef ob begin Branches null ne { /Branches [ Branches { begin /C load /I load known { currentdict } if end } forall ] def } if end redo-layout } if } ifelse } ifelse } store /molecule-obj { systemdict /start_visualizer known not { (NeWS/molecule.ps) LoadFile pop } if 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 { {} } { [ objs dup 1 exch length 1 sub getinterval { /I get cvlit /get cvx } forall ] cvx kbd-select-object } ifelse } def /exec-obj { ob /Obj get exec-it } def /exec-it { % obj => - { [ exch cvlit /cvx cvx /dup cvx (%% ) (%Exec: %\n) /printf cvx cvx /exec cvx ] cvx execute-it } fork pop pause } def /paste-obj { selected-object replace-obj } def /replace-obj { % obj => - ob begin replace-struct end Meta 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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Moving and shaping /just-reshape { ItemCanvas null ne { ItemCanvas /Mapped false put } if /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 ItemCanvas /Mapped true put } def /reshape { % x y w h just-reshape location move } def /just-move { /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 /move super send snaps-here? pop Index ThisI eq {/paint-hilite win send} if StackI null ne StackI Index ne and { /MoveMe TellStack } if } store /redo-layout { perform-layout redo-shape } 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 } store /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 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 { /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 Collection Index get type (% \267) sprintf store LabelSize /LabelHeight exch def /LabelWidth exch def AdjustItemSize CalcObj&LabelXY } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Display /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 ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius object-bbox rrectframe ItemBorderColor setcolor eofill } if ShowLabel paint-struct } monitor } store /paint-struct { gsave ensure-DL ItemTextColor setcolor ObjectX ObjectY ObjectHeight add translate DL draw-struct grestore } def /damage-view { gsave %ItemParent setcanvas bbox rectpath extenddamage paint grestore } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Accessers /Collection { ItemObject 0 get cvlit } def /Index { ItemObject 1 get cvlit } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Structure stuff /old-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 %(x % y % X % Y % W % H % \n)[3 index 3 index X Y W H ]dbgprintf 2 copy pointinpath { 2 index exec } { Branches null ne { Branches { search-struct } forall } if } ifelse } if } if end } def /do-search { /it self store DL begin Icon? end { /obs [ DL ] store /ob DL store } { gsave ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate DL CurrentEvent begin XLocation YLocation end 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 ] 10 dict begin /ssy exch def /ssx exch def [ exch { do-search-struct % unsucessful search exit } loop % catch possible exit ] end } def /do-search-struct { % dl => dl dl' dl'' dl''' ... begin ssx X ge { ssy Y ge { ssx X W add le { ssy Y H add le { currentdict Branches end dup null eq { pop } { { do-search-struct } forall } ifelse exit % skip past all the ends on the execution stack } if } if } if } if end } store /close-struct { gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob /L 0 put ob /Branches null put Meta 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 Meta not { redo-layout } if grestore } def % (dl on dictstack) /replace-struct { % obj => - C I 3 -1 roll put C I L grow-struct begin /Branches Branches /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 /grow-substruct { % l => - /L exch def % /forbidden? {pop false} def /Branches C I L grow-struct 1 index get def % currentdict /forbidden? undef } 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 currentdict ob ne and % forbidden things must be be explicitly opened. } 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 /do-grow-struct { pause 32 dict begin /L exch def cvlit /I exch def cvlit /C exch def /Obj C I get def /Str /Obj load I (% = %) sprintf def /X 0 def /Y 0 def /W 0 def /H 0 def /StrY 0 def /LineX 0 def /Obj load composite? I forbidden? not and L 0 gt and { /Obj load dup type /arraytype eq { /Branches exch [ exch { pop /Obj load counttomark 1 sub L 1 sub do-grow-struct } forall ] def } { /Branches exch [ exch { pop /Obj load exch L 1 sub do-grow-struct } forall ] Sort? {SortBy quicksort} if def } ifelse } { /Branches null def } ifelse currentdict end } def % /SortBy default: /by-name { /Str get exch /Str get lt } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Layout /perform-layout { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { /hourg /hourg_m ItemCanvas setstandardcursor /ItemLabel Collection Index get type (% \267) sprintf store init-format DL do-layout /ObjectHeight DL /H get store adjust-geometry } 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 /View load cvx exec end pause } def /layout-struct { % - => - /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 { do-layout } forall /Point Point Shrink div 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 /LineX X W add LineGap 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 } store % dict => - /draw-struct { 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 0 setgray stroke grestore } { show-obj Branches null ne Icon? not and { LineX Y H 2 div add Branches length 0 ne { Branches 0 get begin 2 copy moveto X Pad sub Y H add lineto Pad 5 mul 0 rlineto stroke end Branches { begin 2 copy moveto X Pad sub Y lineto Pad 2 mul 0 rlineto stroke currentdict end draw-struct } forall Branches dup length 1 sub get begin 2 copy moveto X Pad sub Y lineto Pad 5 mul 0 rlineto stroke end } if pop pop } if } ifelse end } store /show-obj { Font setfont X StrY moveto Str show } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Printing % This needs to be brought up to date... /write-DL { % { /f (DL.ps) (w) file def f (%!\n) writestring f (gsave 0 setgray 0 setlinewidth 20 20 translate\n) writestring DL begin f H W (%%) (%BoundingBox: 0 0 % %\n) sprintf writestring end /cur-font-name null def /cur-font-size 0 def 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 1 index cur-font-size eq 1 index cur-font-name eq and { pop pop } { 2 copy /cur-font-name exch store /cur-font-size exch store (/% findfont % scalefont setfont\n) sprintf f exch writestring } ifelse Font setfont Font fontdescent StrY ObjectHeight add X (% % moveto ) sprintf f exch writestring Str ( (%) show\n) sprintf f exch writestring Branches null ne Icon? not and { X W add LineGap sub Y H 2 div add ObjectHeight add Branches { begin 2 copy exch (% % moveto ) sprintf f exch writestring X Pad sub Y ObjectHeight add exch (% % lineto ) sprintf f exch writestring Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring f (stroke\n) writestring currentdict end print-struct } forall Branches length 0 ne { Branches dup length 1 sub get begin 2 copy exch (% % moveto ) sprintf f exch writestring X Pad sub Y H add ObjectHeight add exch (% % lineto ) sprintf f exch writestring Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring f ( stroke\n) writestring end } if pop pop } if end } 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 } store % items backgroundcolor => - (interactively move item) /moveinteractive { ItemBegin 10 dict begin /GA_constraint 0 def /GA_value /calc_GA_value load def currentcursorlocation /DY exch def /DX exch def currentcanvas mapcanvas false dragcanvas end ItemEnd } store /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 items ThisI get 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 } store /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 ItemLock { /free-items [ free-items aload pop Index ] store } monitor } def /init-attributes { {/ObjectWidth /DL /Shrink /StartPoint /View /Click} { InstanceVarDict 1 index get store } forall /ObjectLoc /Right store adjust-geometry } store % obj => - /Reuse { Collection Index 3 -1 roll put ItemCanvas /Retained true put ItemCanvas canvastotop init-attributes %ensure-DL %redo-layout } store /destroy { ItemEventMgr null ne { ItemEventMgr killprocess } if ItemCanvas /Retained false put unmap } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TextStructItem class definition /TextStructItem StructItem dictbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Instance variables /I null def /MyStack null def /MyProcess null def /Scroller null def /ScrollerWidth 16 def /Notifier null def /NotifierHeight 16 def /SubItemGap 2 def /SubItemMgr null def /DeferedUpdateEvent null def /UpdateDelay .5 60 div def /PinHeight 0 def /DropShadow 6 def dictend classbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class Variables /TextWidth 700 def /TextHeight 200 def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % /new { /new super send begin /MyStack [] def /ItemLabel (processtype) def currentdict end } 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!) () ] true /writeatcaret dialog-text send shut-down psh-socket closefile /psh-socket null store 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 waitprocess pop } def /use-selected-process { selected-object dup type /processtype eq { set-process } if } def /adjust-geometry { LabelSize /LabelHeight exch def /LabelWidth exch def AdjustItemSize CalcObj&LabelXY } def /DialogMenu [ (process) {/use-selected-process it send} (reset) {/kbd-reset it send} (pack) {/PackStack it send} (reboot) {/kbd-reboot it send} ] /new DefaultMenu 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} (change...) /ChangeMenu StructItem send ] /new DefaultMenu send def /replace-obj { % obj => - Collection Index 2 index put kbd-select-object } 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 /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 { % DeferedUpdateEvent null ne { DeferedUpdateEvent recallevent } if /DeferedUpdateEvent CurrentEvent store DeferedUpdateEvent begin /Name /DeferedUpdate def /TimeStamp currenttime UpdateDelay add def end % event DeferedUpdateEvent sendevent } def /DeferedUpdate { % /DeferedUpdateEvent null store [ /getcaretpos dialog-text send pop 1 gt { () } if dialog-string dialog-buf CurrentEvent /ClientData get length (NeWS[%]> %%) sprintf { (\n) search { % chop string up at newlines exch pop exch } { exit } ifelse } loop ] true /writeatcaret dialog-text send pause CurrentEvent /ClientData get SetStack } def /ProcessReady { CurrentEvent dup /ClientData get exch /Action get set-process } def /set-process { % stack process => - /MyProcess exch def SetStack { currentprocess (%% ) (%Hello, my name is %!\n) printf } execute-it } def /SelectionChanged { CurrentEvent /Action get /PrimarySelection eq { CurrentEvent /ClientData get dissect-selection Collection Index 2 index put (%: %) [ 3 -1 roll dup type exch ] /printf Notifier send } if } 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 { CurrentEvent /ClientData get PushMe } def /DoPopMe { CurrentEvent /ClientData get PopMe } def /DoMoveMe { ItemLock { SortStack ReplaceStack } monitor } def /PushMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall I ] store SortStack GetStack {Collection Index get} items I get send 80 string cvs (%% Push: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /PopMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall ] store GetStack {Collection Index get} items I get send 80 string cvs (%% Pop: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /ReplaceStack { ItemLock { GetStack 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 } store % To do: % Make this 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 } store /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 {click-point} 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 aload pop pop ] 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 } store /GetStack { % 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 /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 } store /ClientExit { CurrentEvent /KeyState get { dup PointButton 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 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 DropShadow add 4 -1 roll DropShadow 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 } store /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 /reshape Notifier send /paint Notifier send /SubItemMgr dictbegin /Scroller Scroller def /Notifier Notifier def dictend forkitems store grestore } def /ensure-DL { /ObjectWidth TextWidth def %XXX /ObjectHeight TextHeight def %XXX dialog-text null eq { /dialog-can ItemCanvas newcanvas store /dialog-text 200 dialog-can /new TextCanvas send store { /KeyDict 200 dict def KeyDict begin 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 [ () () ] true writeatcaret dialog-string /dialog-enter dialog-item send /dialog-string () store } def 10 { (select line) comment % Newline [ () () ] true writeatcaret dialog-string kbd-select-object /dialog-string () store prompt } def 10 128 add { (input line) comment % Meta-Newline [ () () ] true writeatcaret dialog-string /dialog-newline dialog-item send /dialog-string () store prompt } def 19 { (insert selection) comment % ^S selected-object (%) sprintf [ 1 index ] true writeatcaret /dialog-string exch dialog-string exch append store } 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 27 { (execute selection) comment % Escape 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 64 string cvs (\n) search { exch pop exch pop } if (%% ) (%Execute selection %\n) printf exec } /execute-it dialog-item send } def 3 { (reset input) comment % ^C /kbd-reset dialog-item send } def 4 { (reboot process) comment % ^D /kbd-reboot dialog-item send } def /FunctionR9 { (page up) comment /ScrollPageForward /FakeScroll dialog-scroll send } def /FunctionR15 { (page down) comment /ScrollPageBackward /FakeScroll dialog-scroll send } def /FunctionR7 { (scroll down) comment /ScrollLineForward /FakeScroll dialog-scroll send } def /FunctionR13 { (scroll up) comment /ScrollLineBackward /FakeScroll dialog-scroll send } def /FunctionR11 { (scroll to bottom) comment 1 /ScrollTo dialog-scroll send } def /FunctionF10 { (help) comment % Alternate [ () (Key Bindings:) ()] true writeatcaret [ KeyDict { comment-string exch key-name (%: %) sprintf pause pause } forall ] /gt quicksort { [ exch () ] true writeatcaret pause } forall prompt } def /FunctionR1 { (describe key) comment [ () (Describe key: ) ] true writeatcaret /DescribingKey? true store } def /FunctionR2 { (bind selection to key) comment [ () selected-object (Bind selection %) sprintf (to key: ) ] true writeatcaret /BindingKey? true store } def /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 currentprocess /DictionaryStack get 20 dict begin /DS exch def /pat exch def /found null def /complete null def /str pat length string def DS length 1 sub -1 0 { /i exch def DS i get { /val exch def dup str cvs pat ne { pop } { found null eq { /found 1 index 250 string cvs def /complete found def } { /found 1 index 250 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 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 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 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] true 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 { (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 () ] true 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 /newlines 0 def /i 0 def /a null def /pre null def /lastnl 0 def /InsertValueCallback { % string => - /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 getinterval /dialog-enter dialog-item send pause pause pause /dialog-string s lastnl 1 add 1 index length 1 index sub getinterval store pause } if /s s dialog-string length 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 true writeatcaret } store /KeyboardHandler { % - => - % --- Handler for keyboard, InsertValue, and Deselect events /KeyboardInterest [ % Can addkbdinterests aload pop % Can addselectioninterests aload pop % % Get rid of LiteUI's mouse interests % revokeinterest % Can addfunctionnamesinterest % dup /Action /DownTransition put can addkbdinterests aload pop % XXX can=ClientCanvas can addselectioninterests aload pop % Get rid of LiteUI's mouse interests revokeinterest can addfunctionnamesinterest dup /Action /DownTransition put ] 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 } if } case } loop } def /destroy { % - => - KeyboardInterest null ne { KeyboardInterest can revokekbdinterests % XXX can=ClientCanvas } 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!) () ] true 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 (Selection:) () /Right {} ItemCanvas /new MessageItem send def { /ItemFont /Screen-Bold findfont 13 scalefont def /ItemFrame 1 def } Notifier send } if psh-socket null eq { MyProcess null ne { MyProcess killprocess } 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 255 string readline false eq { [() (Lost it!) ()] true writeatcaret % 1 60 div sleep % /kbd-reboot dialog-item send /incoming null store currentprocess killprocess } if [ exch getcaretpos pop 1 ne { () exch } if () ] true 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) writestring psh-socket flushfile } 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!)] true /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 } if } if exit } ifelse } ifelse pause } loop } 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 /destroy super send } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Icky system globals and merciless kludges /comment { pop } def % Reap dead debuggers /rd { [ DbgDicts {pop} forall ] { dup /State get /zombie eq { DbgDicts 1 index undef killprocess } { pop } ifelse } forall } def systemdict /DbgDicts known { rd } if /dirname { ob begin uniquecid dup 3 -1 roll (dir2dict % % | psh) sprintf forkunix [exch cidinterest1only] forkeventmgr waitprocess replace-struct end redo-layout } store /filename { (file2dict % | psh) sprintf forkunix } def /_ViewCanvas null def /_SendUpdateStack { count array astore aload null /UpdateStack _SendViewEvent { currentfile flushfile } 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 { 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 currentfile flushfile } errored { { dbgstop } errored quit } if } ifelse /ClientData get count 1 roll count 1 sub {pop} repeat aload pop } def /DropDead { { dbgstop } errored { (Ayyyeee!\n) print currentfile flushfile } errored quit } def end % Name /ClientData 20 dict def ClientData begin /ViewCanvas _ViewCanvas def % Stash! end % ClientData currentdict end expressinterest { awaitevent } loop quit } def /revokekbdinterests { % [ int1 int2 ... intn ] can => - removefocusinterest % aload pop revokeinterest revokeinterest revokeinterest {revokeinterest} forall } store /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 systemdict /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 /select-object { % obj => - 20 dict begin /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 /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 /SelectionObjSize exch def /SelectionStartIndex exch def /SelectionLastIndex SelectionStartIndex SelectionObjSize add 1 sub def /ContentsPostScript exch def /ContentsAscii /ContentsPostScript load SelectionStartIndex SelectionObjSize getinterval (%) sprintf def /SelectionResponder null def /Canvas currentcanvas def % XXX? /SelectionHolder currentprocess def % XXX? currentdict end /PrimarySelection setselection } def /dissect-selection { % seldict => obj dup null ne { dup /ContentsPostScript known { dup /ContentsPostScript get % seldict obj 1 index /SelectionStartIndex known { 1 index /SelectionLastIndex known { exch dup /SelectionStartIndex get % obj seldict start exch /SelectionLastIndex get % obj start last 1 index sub 1 add % obj start len getinterval % subobj } { exch /SelectionStartIndex get get % subobj } ifelse } { exch pop } ifelse % obj } { dup /ContentsAscii known { /ContentsAscii get } if } ifelse } if } def /selected-object { % - => obj /PrimarySelection getselection dissect-selection } def /selected-pointer? { % - => false / collection index true /PrimarySelection getselection dup null eq { false } { dup /ContentsPostScript known not { false } { dup /SelectionStartIndex known not { false } { dup /ContentsPostScript get exch /SelectionStartIndex get true } ifelse } ifelse } ifelse } 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 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 /tokout { % 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 end % systemdict %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Nasty userdict variables /dialog-text null def /dialog-can null def /dialog-proc null def /dialog-string () def /dialog-buf () def /dialog-item null def /dialog-scroll null def (NEWSSERVER) getenv (;) 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 /Pallets 100 dict def Stack 0 Pallets 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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % User Utilities % % 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 /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 } store /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 } store /comment-string { % obj => string dup type /arraytype eq { dup length 2 ge { dup 1 get /comment eq { 0 get } if } if } if (%) sprintf } def /destroy { % dummy destroy method } 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 /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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Pallets of useful functions Pallets begin /Debug dictbegin /dlb /dbglistbreaks cvx def /de /dbgenter cvx def /dx /dbgexit cvx def /dk /dbgkill cvx def /dc /dbgcontinue cvx def /dcc {dbgcopystack dbgcontinue} def /dw /dbgwhere cvx def /execstack {DbgImplicitBreak DbgGetExecStack} def /exec /exec cvx def /stack /stack cvx def /clear /clear cvx def /typo { % undefined (select correct spelling) => - userdict begin dup cvlit [ selected-object (%) sprintf cvn cvx ] cvx def end exec } def dictend def /Number dictbegin 0 {10 mul} def 1 {10 mul 1 add} def 2 {10 mul 2 add} def 3 {10 mul 3 add} def 4 {10 mul 4 add} def 5 {10 mul 5 add} def 6 {10 mul 6 add} def 7 {10 mul 7 add} def 8 {10 mul 8 add} def 9 {10 mul 9 add} def /Back {10 div floor} def /Reset {0 mul} def /Enter {0} def dictend def currentautobind false setautobind /Math { {add sub mul div idiv mod} {neg abs min max} {ceiling floor round truncate} {cos sin tan arcsin arccos arctan atan exp ln log sqrt} {random rand} {etc, etc, etc...} {(Add your own!)} } cvlit def /Stack { dup pop exch clear load def store get put aload forall [ ] } cvlit def /Window 20 dict begin /new { framebuffer /new DefaultWindow send { newprocessgroup /reshapefromuser 1 index send /map exch send } fork waitprocess pop dup /ClientCanvas get setcanvas (%% Now on ) print currentcanvas == } def dictend def setautobind end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Item managment /createitems { ItemLock { /items [ Stack 0 {click-point} can /new StructItem send 20 10 0 0 /reshape 5 index send Stack 1 {} can /new TextStructItem send 20 50 0 0 /reshape 5 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 /slideitem { % items fillcolor item => - ItemLock { gsave dup 4 1 roll % item items fillcolor item {ItemCanvas canvastotop moveinteractive location move} exch send % item grestore } monitor } def /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 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 ] forkeventmgr store } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window class definition /CyberWindow DefaultWindow dictbegin /FrameLabel (PostScript Structure CyberSpace) def /IconLabel (PS CyberSpace) def /IconImage /galaxy def dictend classbegin /PaintClient { paint-hilite items paintitems } def /paint-hilite { ClientCanvas setcanvas erasepage /DrawHilite dialog-item send } def /ClientMenu [ (Break Stack) { clear /BrokenStack /dbgbreak dialog-item send } (Credits) { /display-credits win send } (Break Window) { clear /BrokenWindow /dbgbreak win send } (Break Struct) { clear /BrokenStruct /dbgbreak items 0 get send } ] /new DefaultMenu send def /display-credits { gsave framebuffer setcanvas currentcursorlocation [ (NeWS CyberSpace:) ( by Don Hopkins) (----------------) (Code stolen from:) ( Josh Siegel) ( Don Woods) ] popmsg pop grestore } def /DestroyClient { { newprocessgroup itemmgr type /processtype eq { itemmgr killprocess } if slidemgr type /processtype eq { slidemgr killprocess } if items { /destroy exch send } forall /items null store /_ViewCanvas null store /PrimarySelection clearselection % XXX? ClientCanvas /Retained false put FrameCanvas /Retained false put FrameCanvas /Mapped false put /DestroyClient super send } fork pop } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Create objects /win framebuffer /new CyberWindow send store % Create a window 0 0 900 900 /reshape 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