%! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % 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 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? { 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 redo-shape currentdict /Icon? undef } if } def /close-icon { Icon? not { /ObjectWidth OW store /ObjectHeight OH store /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 } (--) {} (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 % 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 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 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 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 def /ObjectX ItemBorder dup add LabelWidth add ItemGap add def /ObjectY ItemHeight ObjectHeight sub 2 div def /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub def /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add def /TabHeight LabelHeight ItemBorder dup add add def } /RightBelow /Right { /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 /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub def /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add def /TabHeight LabelHeight ItemBorder dup add add def } /LeftAbove { /LabelX ItemBorder dup add ItemGap add ObjectWidth add def /LabelY ItemBorder def /ObjectX ItemBorder def /ObjectY ItemHeight ObjectHeight sub 2 div def /TabX LabelX ItemGap sub ItemRadius dup add sub def /TabY LabelY ItemBorder sub def /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add def /TabHeight LabelHeight ItemBorder dup add add def } /LeftBelow /Left { /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 /TabX LabelX ItemGap sub ItemRadius dup add sub def /TabY LabelY ItemBorder sub def /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add def /TabHeight LabelHeight ItemBorder dup add add 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 /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub def /TabWidth LabelWidth ItemBorder dup add add def /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add 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 /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub def /TabWidth LabelWidth ItemBorder dup add add def /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add 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 /TabX LabelX ItemBorder sub def /TabY LabelY ItemGap sub ItemRadius dup add sub def /TabWidth LabelWidth ItemBorder dup add add def /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add 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 /TabX LabelX ItemBorder sub def /TabY LabelY ItemGap sub ItemRadius dup add sub def /TabWidth LabelWidth ItemBorder dup add add def /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add def } } case /PinX LabelX LabelWidth add 2 sub def } 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 items StackI null eq ThisI StackI ifelse get 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 {{dbgstop} errored exit} send-exec-event 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 => - { exec count array astore aload createevent begin /Name /UpdateStack def /ClientData exch def /Canvas _ViewCanvas def currentdict end sendevent } send-exec-event } def /send-exec-event { % data action 6 { % wait up to 3 seconds if no process MyProcess null eq { .5 60 div sleep } { exit } ifelse } repeat MyProcess null eq { pop pop gsave framebuffer setcanvas currentcursorlocation [(No process!)] popmsg pop grestore } { createevent begin /Name /ExecIt def /Process MyProcess def /Action exch def /ClientData exch 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 {count 1 roll count 1 sub {pop} repeat aload pop} [ {Collection Index get} items I get send (%% ) (%Drag Push: %\n) sprintf /print cvx] append cvx send-exec-event } 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 /PopMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall ] store GetStack {count 1 roll count 1 sub {pop} repeat aload pop} [ {Collection Index get} items I get send (%% ) (%Drag Pop: %\n) sprintf /print cvx] append cvx send-exec-event } monitor } def /ReplaceStack { ItemLock { GetStack {count 1 roll count 1 sub {pop} repeat aload pop} send-exec-event } monitor } def % 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 completion) 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 /Canvas _ViewCanvas /Parent get def % XXX /Name /InsertValue def /Action exch 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_InitProcess\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 /_InitProcess { createevent begin /Canvas _ViewCanvas def /Name /ProcessReady def /Action currentprocess def count array astore aload /ClientData exch def currentdict end sendevent createevent begin /Name /ExecIt def currentdict end expressinterest { awaitevent dup /ClientData get exch /Action get exec {currentfile flushfile} errored {exit} if } 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 { % 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 } if } 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} { % Sort this stuff out: append astore copy getinterval putinterval arrayinsert arraydelete pickarray arrayop modifyproc LoadFile run and or xor not bitshift begin end currentdict forall for loop repeat case exit if ifelse stopped stop errored userdict systemdict cleartomark count counttomark index roll pop dup exch exec cvas cvad cvi cvis cvlit cvn cvr cvrs cvs cvx litstring array dict string dictbegin dictend length maxlength extend fork killprocess waitprocess currentprocess newprocessgroup killprocessgroup forkunix getenv putenv type xcheck nullproc nullarray nullstring nulldict eq ne gt lt ge le true false null printf print = == sprintf stack pstack po file readstring writestring read write readline flushfile token closefile readhexstring writehexstring bytesavailable fprintf currentfile status flush writeobject readcanvas writecanvas eowritecanvas writescreen eowritescreen movecanvas getcanvaslocation reshapecanvas eoreshapecanvas erasepage fillcanvas get put def store load undef known where send self super classbegin classend setautobind currentautobind pause sleep bind newpath closepath moveto lineto currentpath eocurrentpath setpath rlineto rmoveto currentpoint emptypath pointinpath extenddamage eoextenddamage dashpath strokepath flattenpath pathbbox pathforall pathforallvec stroke fill matrix concat concatmatrix currentmatrix setmatrix initmatrix defaultmatrix identmatrix rotate translate scale currentcursorlocation setcursorlocation getcanvascursor setcanvascursor setstandardcursor getcanvasshape setcanvasshape setgray setcolor currentcolor contrastwithcurrent currentgray setshade rgbcolor setrgbcolor currentrgbcolor hsbcolor sethsbcolor currenthsbcolor countdictstack countexecstack dictstack execstack awaitevent createevent CurrentEvent countinputqueue sendevent recallevent redistributeevent eventmgrinterest forkeventmgr forkitems getanimated getclick getfbclick getrect getwholerect expressinterest revokeinterest globalinterestlist createmonitor monitor monitorlocked currenttime lasteventtime localhostname vmstatus gsave grestore grestoreall initgraphics save restore dtransform transform itransform idtransform currentdash setdash currentflat setflat currentlinecap setlinecap currentlinejoin setlinejoin currentlinequality setlinequality currentlinewidth setlinewidth currentmiterlimit setmiterlimit currentprintermatch setprintermatch currentrasteropcode setrasteropcode currentstate setstate currentfont setfont findfont scalefont definefont findfilefont makefont fontascent fontdescent fontheight arc arcn arcto curveto rcurveto controlpoint rcontrolpoint ashow widthshow awidthshow cshow rshow show kshow showcursor showicon stringbbox stringwidth clip eoclip clipcanvas eoclipcanvas clipcanvaspath clippath eoclippath initclip framebuffer copyarea eocopyarea setcanvas currentcanvas buildimage newcanvas createcanvas createoverlay image imagecanvas imagemask imagemaskcanvas canvasabove canvasbelow topchildcanvas parentcanvas canvastotop canvastobottom insertcanvasabove insertcanvasbelow search anchorsearch rect rrect rectpath rrectpath insertrect insetrrect ovalpath ovalframe rectframe rrectframe points2rect rect2points rectsoverlap popmsg } pop } 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 /reshapefromuser 1 index send /map 1 index send 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 /Transparent false put %can /Retained true put createitems % /reshapefromuser win send /map win send start-event-mgrs