%! % 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? statusdict begin 0 setjobtimeout end systemdict begin /revokekbdinterests { % [ int1 int2 ... intn ] => - removefocusinterest % aload pop revokeinterest revokeinterest revokeinterest {revokeinterest} forall } store systemdict /NeWSScrollbar known not { (/usr/NeWS/clientsrc/client/nterm/NeWSSbar.ps) LoadFile } if systemdict /TextCanvas known not { (/usr/NeWS/clientsrc/client/nterm/textcan.ps) LoadFile } if /StructItem LabeledItem dictbegin /Shrink .8 def /Pad 3 def /StartPoint 14 def /Point StartPoint def /x 0 def /y 0 def /Levels 0 def /DL null def /UpdateDL? true def /ItemFrame 2 def /ItemRadius 5 def /ItemBorder 6 def /ItemButton [PointButton MenuButton] def /StackI null def /LayoutLock null def /Meta false def /Control false def /Shift false 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 /PinHeight 0 def /DropShadow 6 def dictend classbegin /DoubleClickTime 1 60 div def /CanvasYFudge 2 store /Sort? true def /SlidePower .4 store /SlideSpeed .05 60 div store /MaxV .1 store /LineGap 30 def /ItemLabelFont /Helvetica-Bold findfont 14 scalefont def /ItemFont /Courier findfont def /ItemXFont /Courier-Oblique findfont def /Icon? false def /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 currentdict end } def /PaintItem { ItemRadius label-bbox rrectpath ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius label-bbox rrectframe ItemBorderColor setcolor eofill } if ItemRadius object-bbox rrectpath ItemFillColor setcolor fill ItemFrame 0 gt { ItemFrame ItemRadius object-bbox rrectframe ItemBorderColor setcolor eofill } if ShowLabel paint-struct } store /ClientDown { CurrentEvent /Name get MenuButton eq { event-in-tab? { show-tab-menu } { show-struct-menu } ifelse } if } def /ClientUp { CurrentEvent /Name get PointButton eq { NotifyUser } if StopItem } def /PointMenu [ (2) (4) (6) (8) (10) (12) (14) (16) (18) (20) (22) (24) (28) (32) ] [ {currentkey cvi {/StartPoint exch def redo-layout} it send} ] /new DefaultMenu send def /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 /TabMenu [ (Point...) PointMenu (---) {} (Print) {/write-DL it send} (Zap) {/Free it send} (Shrink...) ShrinkMenu (---) {} (Location...) LocationMenu (Pack) {/pack it send} ] /new DefaultMenu send store /ChangeMenu [ (token) { /token-obj it send } (executable){ /cvx-obj it send } (name) { /cvn-obj it send } (string) { /cvs-obj it send } (tokout) { /tokout-obj it send } (literal) { /cvlit-obj it send } (integer) { /cvi-obj it send } (real) { /cvr-obj it send } ] /new DefaultMenu send def /token-obj { { ob /Obj get % XXX } errored {pop} { replace-obj } ifelse } 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 { cvs-obj % TEMP KLUDGE } 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 /EditMenu [ (undef) { /undef-obj it send } (emacs) {} % tokout to emacs (nulldef) { /nulldef-obj it send } (primary) {} % tokout to Primary selection ] /new DefaultMenu send def EditMenu /PieInitialAngle 45 put /StructMenu [ (push) {/push-obj it send} (load&push) {/load&push-obj it send} (load) {/load-obj it send} (edit...) EditMenu (exec) {/exec-obj it send} (change...) ChangeMenu (paste) {/paste-obj it send} (open) {/open-obj it send} ] /new DefaultMenu send def /load&push-obj { % % ob /Obj get select-object % ??? [ ob /Obj get 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-it { % % ob /Obj get select-object % ??? [ 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 /load-obj { % ob /Obj get load-it } def /open-obj { click-open } 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 dup type /dicttype ne { pop } { selected-object dup null eq { pop } { 2 copy null put 0 grow-struct ob begin Branches null ne { /Branches [ Branches { dup /I get counttomark 2 add index /I get eq {pop} if } forall counttomark 3 add -1 roll ] Sort? {SortBy quicksort} if def } if end 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 /exec-obj { ob /Obj get exec-it } def /exec-it { [ exch cvlit /cvx cvx /dup cvx (%% ) (%Exec: %\n) /printf cvx cvx /exec cvx ] cvx execute-it } def /execute-it { % obj => - /exec-and-update items StackI null eq ThisI StackI ifelse get send } def /paste-obj { selected-object replace-obj } def /replace-obj { % obj => - ob begin replace-substruct end redo-layout } def /event-in-tab? { ItemBegin newpath label-bbox rectpath CurrentEvent begin XLocation YLocation end pointinpath ItemEnd } def /show-tab-menu { userdict /it self put CurrentEvent /showat TabMenu send } def /show-struct-menu { ItemBegin userdict /it self put userdict /ob null put ObjectX ObjectY ObjectHeight add translate { userdict /ob currentdict put } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop userdict /ob get null ne { CurrentEvent /showat StructMenu send } if ItemEnd } store /scale-to-item { % normalX normalY => X Y ItemHeight mul exch ItemWidth mul location 4 -1 roll add 3 1 roll add exch } def /just-reshape { /ItemHeight exch def /ItemWidth exch def ItemWidth 0 eq ItemHeight 0 eq and { /UpdateDL? true store } if ensure-DL adjust-geometry ItemWidth ItemHeight /reshape super send gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore } 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 /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 /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 /pinned? { % y h => bool location pop PinX add 3 1 roll % x y h 6 exch % x y w h pin-rect rectsoverlap } store /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 /Collection { ItemObject 0 get cvlit } def /Index { ItemObject 1 get cvlit } def /ensure-DL { UpdateDL? { Collection Index Levels grow-struct /DL exch store /ObjectWidth 0 store /ObjectHeight 0 store /UpdateDL? false store } if ObjectWidth 0 eq ObjectHeight 0 eq or { perform-layout } if } def /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 /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 /click-popup { DL null ne { { gsave ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate { gsave framebuffer setcanvas currentcursorlocation [/Obj load I C (%[%]: %) sprintf] popmsg pop grestore } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop grestore } fork pop } if } def /replace-substruct { % obj => - C I 3 -1 roll put C I 0 grow-struct begin /Branches Branches /C C /I I /L L /Obj dup load /Str Str /X X /Y Y /W W /H H end def def def def def def def def def def def } def /grow-substruct { % l => - /L exch def /forbidden? {pop false} def /Branches C I L grow-struct 1 index get def currentdict /forbidden? undef } def /update-shifts { /Meta false store /Shift false store /Control false store CurrentEvent /KeyState get { dup { /Meta /Shift /Control {true store} /Default {pop} } case } forall } def /click-point { ItemBegin update-shifts event-in-tab? { point-tab } { point-struct } ifelse ItemEnd } def /point-tab { DL begin gsave /Icon? Icon? not def Icon? { /OW ObjectWidth def /OH ObjectHeight def Font setfont Str stringbbox points2rect /IconH exch def /IconW exch def /ObjectWidth IconW store /ObjectHeight IconH store } { /ObjectWidth OW store /ObjectHeight OH store } ifelse grestore end redo-shape /LastTime 0 store } def /point-struct { update-shifts 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 userdict /it self put DL begin Icon? end { userdict /ob DL put } { userdict /ob null put ObjectX ObjectY ObjectHeight add translate { userdict /ob currentdict put } CurrentEvent begin XLocation YLocation end DL search-struct pop pop pop } ifelse userdict /ob get null ne { Shift { % Shift to select the index ob /I get } { ob /Obj get } ifelse /LastTime currenttime store Control { exec-it /LastTime 0 store } { select-object } ifelse } if ItemCanvas setcanvas CurrentEvent begin /LastX XLocation store /LastY YLocation store end } { % double clicks ob null ne { DL begin Icon? end { point-tab } { click-open } ifelse } if /LastTime 0 store } ifelse } store /click-open { gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin L 0 eq Shift or { L 1 add grow-substruct } { /L 0 def /Branches null def } ifelse end % ob Meta not { redo-layout } if grestore } def /perform-layout { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { /hourg /hourg_m ItemCanvas setstandardcursor /ItemLabel Collection Index get type (% \267) sprintf store init-format DL layout-struct /ObjectHeight DL /Y get neg store adjust-geometry } monitor /ptr /ptr_m ItemCanvas setstandardcursor } def /redo-layout { perform-layout redo-shape } def /redo-shape { location 10 10 just-reshape damage-view } def /composite? { % obj => bool type { /arraytype /dicttype /canvastype /processtype /eventtype /fonttype {true} /Default {false} } case } def /forbidden-dict 50 dict def forbidden-dict begin /Interests null def /Process null def /BuildChar null def /Encoding null def /WidthArray null def /ParentDictArray null def /ParentDict null def /TopCanvas null def /BottomCanvas null def /TopChild null def /CanvasAbove null def /CanvasBelow null def /Parent null def end % forbidden-dict /forbidden? { forbidden-dict exch known } def /init-format { /Point StartPoint def /x 0 def /y 0 def /ObjectWidth 0 def /ObjectHeight 0 def } def /LineHeight { currentfont fontheight 1 add } def % Collection Index Levels => dict /grow-struct { pause 20 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 /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 grow-struct } forall ] def } { /Branches exch [ exch { pop /Obj load exch L 1 sub grow-struct } forall ] Sort? {SortBy quicksort} if def } ifelse } { /Branches null def } ifelse currentdict end } def /SortBy /by-name def /by-name { /Str get exch /Str get lt } def /layout-struct { % dict => - pause begin /Str /Obj load I (% = %) sprintf def /Obj load xcheck Point 10 ge and { /Font ItemXFont Point scalefont def } { /Font ItemFont Point scalefont def } ifelse Font setfont /X x def /Y y def /W Str stringwidth pop LineGap add def Branches null eq { % Icon? or /H LineHeight def } { /x x W add store /Point Point Shrink mul store Branches { layout-struct } forall /Point Point Shrink div store /x x W sub store 0 Branches { /H get add } forall LineHeight max 1 max /H exch def } ifelse /Y Y H 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 end } def % dict => - /draw-struct { pause begin Icon? { gsave Font setfont 0 Font fontdescent IconH sub moveto Str show 0 setlinewidth 0 setgray ItemBorder 2 sub ItemRadius ObjectX ObjectY ObjectWidth ObjectHeight insetrrect rrectpath stroke grestore } { show-obj Branches null ne Icon? not and { X W add LineGap sub Y H 2 div add Branches length 0 ne { Branches 0 get begin 2 copy moveto X Pad sub Y H add lineto W 0 rlineto stroke end Branches { begin 2 copy moveto X Pad sub Y lineto Pad dup add 0 rlineto stroke currentdict end draw-struct } forall Branches dup length 1 sub get begin 2 copy moveto X Pad sub Y lineto W 0 rlineto stroke end } if pop pop } if } ifelse end } store /show-obj { Font setfont X StrY moveto Str show } def /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 % 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 /TellStack { % message => - createevent begin /Name exch def /ClientData Index def /Action StackI def /Canvas ItemParent def currentdict end sendevent } def /SnapIn { ThisI StackI ne { StackI null ne { /PopMe TellStack } if /StackI ThisI store /PushMe TellStack } if } def /SnapOut { StackI null ne StackI Index ne and { /PopMe TellStack /StackI null store } if } def /snaps-here? { % - => bool ThisI null eq ThisI Index eq or {false} { /pin-rect 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 } 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 /Free { SnapOut ItemCanvas /Retained false put unmap ItemLock { /free-items [ free-items aload pop Index ] store } monitor } def /init-attributes { {/ObjectWidth /DL /UpdateDL? /Shrink /StartPoint /PinHeight} { 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 /pack { StackI null ne { /PackStack items StackI get send } if } def /ClientExit { StopItem } def classend def % ======================================================================== userdict begin /dialog-text null def /dialog-can null def /dialog-proc null def /dialog-string () def /dialog-scroll null def end /TextStructItem StructItem dictbegin /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 /DeferedStack null def /UpdateDelay .25 60 div def dictend classbegin /TextWidth 600 def /TextHeight 150 def /new { /new super send begin /MyStack [] def /ItemLabel (processtype) def currentdict end } def /kbd-reset { /dialog-buf () store /dialog-string () store {(\n%% Reset!\n) print} execute-it } def /shut-down { { psh-socket (\ndbgstop\nquit\n) writestring psh-socket flushfile } errored pop null {{dbgstop} errored quit} send-exec-event } def /kbd-reboot { /dialog-buf () store /dialog-string () store [()(%% Reboot!)()] true /writeatcaret dialog-text send { shut-down psh-socket closefile /psh-socket null store .5 60 div sleep ensure-DL start-event-mgrs } fork pop } def /select-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 [ (pack) {/PackStack it send} (reset) {/kbd-reset it send} (reboot) {/kbd-reboot it send} (process) {/select-process 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 => - select-object } def /show-tab-menu { userdict /it self put CurrentEvent /showat DialogMenu send } def /show-struct-menu { userdict /it self put userdict /ob 20 dict put ob begin /C Collection def /I Index def /Obj Collection Index get def end CurrentEvent /showat SelectionMenu send } 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 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 [ dialog-string dialog-buf CurrentEvent /ClientData get length (NeWS[%]> %%) sprintf { (\n) search { 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 { Collection Index CurrentEvent /ClientData get dissect-selection put (%: %) [ Collection Index get dup type exch 256 string cvs ] /printf Notifier send } 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 { LayoutLock { SortStack ReplaceStack } monitor } def /PushMe { % index => - LayoutLock { /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 { MyStack { /tab-top exch items exch get send exch /tab-top exch items exch get send lt } quicksort pop } store /PopMe { % index => - LayoutLock { /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 { GetStack {count 1 roll count 1 sub {pop} repeat aload pop} send-exec-event } 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 => - LayoutLock { 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 { % n pause /I null def OldStack { % n i o dup 3 index eq { % n i o xcheck 2 index xcheck eq { % n i /I exch def exit % n } { pop } ifelse % n } { pop pop } ifelse % n } forall % n pause /I load null ne { pop OldStack /I load undef /MyStack [ MyStack aload pop /I load ] store } { /MyStack [ MyStack aload length 3 add -1 roll create-struct ] store } ifelse } forall pause OldStack { pause pop items exch get dup /StackI null put % XXX /Free exch send } forall pause /Y tab-top def MyStack { items exch get 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 /Y exch def } forall pin-rect % x y w h exch pop add exch pop Y lt { PackStack } if pause ItemEnd end } monitor } store /GetStack { 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 % x y /NextStackPos { 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 { userdict begin /dialog-can ItemCanvas newcanvas store /dialog-text 200 dialog-can /new TextCanvas send store end % userdict { /KeyDict 100 dict def KeyDict begin 127 { % rubout dialog-string length 0 ne { /getcaretpos dialog-text send exch dup 1 gt { 1 sub exch /movecaret dialog-text send /getcaretpos dialog-text send 1 3 1 roll /deletestring dialog-text send /dialog-string dialog-string dup length 1 sub 0 max 0 exch getinterval store } if } if } def 8 127 load def 23 { % werase dialog-string length 0 ne { { /getcaretpos dialog-text send exch dup 1 gt { 1 sub exch /movecaret dialog-text send /getcaretpos dialog-text send 1 3 1 roll /deletestring dialog-text send /dialog-string dialog-string dup length 1 sub 0 max 0 exch getinterval store dialog-string length 0 eq { exit } if dialog-string dup length 1 sub 1 getinterval ( ) eq { exit } if } { exit } ifelse } loop } if } def 24 { % ^X /getcaretpos dialog-text send exch dialog-string length sub 1 max exch 2 copy /movecaret dialog-text send dialog-string length 3 1 roll /deletestring dialog-text send /dialog-string () store } def 21 24 load def % ^U 13 { [() ()] true /writeatcaret dialog-text send dialog-string /dialog-enter dialog-item send /dialog-string () store } def 10 { [() ()] true /writeatcaret dialog-text send dialog-string /dialog-newline dialog-item send /dialog-string () store } def 4 { % ^D /kbd-reboot dialog-item send } def 3 { % ^C /kbd-reset dialog-item send } def /FunctionR9 { % page up /ScrollPageForward /FakeScroll dialog-scroll send } def /FunctionR15 { % page down /ScrollPageBackward /FakeScroll dialog-scroll send } def /FunctionR7 { % scroll down /ScrollLineForward /FakeScroll dialog-scroll send } def /FunctionR13 { % scroll up /ScrollLineBackward /FakeScroll dialog-scroll send } def /FunctionR11 { % end 1 /ScrollTo dialog-scroll send } def end % KeyDict /KeyHitCallback { % key => 10 dict begin /Meta false def /Control false def /Shift false def KeyState { dup { /Meta /Control /Shift {true def} /Default {pop} } case } forall 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 KeyDict key known { KeyDict key get cvx exec } { key type /integertype eq { [(s) dup 0 key put] true /writeatcaret dialog-text send /dialog-string dialog-string (s) dup 0 key put append store } { key (/% ) sprintf [1 index] true /writeatcaret dialog-text send /dialog-string dialog-string 3 -1 roll append store } ifelse } ifelse end } def /InsertValueCallback { % string => - 10 dict begin dialog-string /dialog-enter dialog-item send /s exch def /newlines 0 def 0 1 s length 1 sub { /i exch def s i get 13 eq { s i 10 put } if s i get 10 eq { /newlines newlines 1 add def } if } for /a newlines 1 add array def 0 1 newlines 1 sub { /i exch def s (\n) search pop /pre exch def pop /s exch def a i pre put pre (\n) append /dialog-enter dialog-item send } for a newlines s put /dialog-string s store a true /writeatcaret dialog-text send } def /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 begin Name { /DeSelect { Action /PrimarySelection eq { false DrawSelection /SelectionPath null store } if Action /InputFocus eq { InactivateCaret } if } /RestoreFocus { ReactivateCaret } /InsertValue { Action /InsertValueCallback self send } /Ignore { } /Default { Name /KeyHitCallback self send } if } case end } 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 /FontHeight 12 def /FontName FontName def [()(%% Ready!)()] true /writeatcaret dialog-text send 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 /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 dialog-text send 1 60 div sleep kbd-reboot } if [ exch /getcaretpos dialog-text send pop 1 ne { () exch } if () ] true /writeatcaret dialog-text send psh-socket bytesavailable 0 eq { {} execute-it % Get another prompt } if } loop } fork store systemdict /_ViewCanvas ItemCanvas put psh-socket (systemdict/dbgstart known not{(NeWS/debug.ps)run}if dbgstart\n_InitProcess\n) writestring psh-socket flushfile } if } def /destroy { shut-down SubItemMgr null ne { SubItemMgr killprocess /SubItemMgr null store } if dialog-text null ne { % {{destroy} errored pop} dialog-text send /destroy dialog-text send /dialog-text null store } if } def classend 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 % ======================================================================== % NeWS error handler using the object browser (NeWS1.1) % % Jeremy Huxtable % % Mon Jul 25 17:36:06 BST 1988 /MyErrorDict dictbegin StandardErrorNames { {MyErrorHandler} def } forall dictend def /MyErrorHandler { % Must be careful with manipulating the stacks here, as otherwise % our private stuff will appear in the browser! /errordict OldErrorDict store pop % Get rid of the "offending command" from stack % create a dictionary of useful info. Note that we must get the % process' stacks now as otherwise they disappear when the "killprocess" % is done. currentprocess /DictionaryStack get 7 dict begin /DictionaryStack exch def currentprocess /OperandStack get /OperandStack exch def /ExecutionStack currentprocess /ExecutionStack get 0 1 index length 4 sub getinterval def % Remove this error handler from exec stack /Interests currentprocess /Interests get def /Error $error /errorname get def /Executing $error /command get def /Process currentprocess def currentdict end /errordict MyErrorDict store } def /cvstring { % value => string dup type /stringtype eq { ((%)) sprintf } { dup type /nametype eq 1 index xcheck not and { (/%) sprintf } { 100 string cvs } ifelse } ifelse } def /dirname { ob begin uniquecid dup 3 -1 roll (dir2dict % % | psh) sprintf forkunix [exch cidinterest1only] forkeventmgr waitprocess replace-substruct 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 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 cvstring def /SelectionObjSize 1 def /SelectionResponder null def /Canvas currentcanvas def /SelectionHolder currentprocess def currentdict end /PrimarySelection setselection } def /dissect-selection { % seldict => obj dup null ne { dup /ContentsPostScript known { /ContentsPostScript get } { dup /ContentsAscii known { /ContentsAscii get } if } ifelse } if } def /selected-object { % - => obj /PrimarySelection getselection dissect-selection } def end % systemdict /destroy {} def /dialog-newline { % str => - psh-socket exch writestring psh-socket 10 write psh-socket flushfile } def /dialog-buf () def /dialog-enter { % str => - /dialog-buf exch dialog-buf (%%\n) sprintf 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 ( _EOF_) append token { % Ignore white space exch pop /_EOF_ eq { /dialog-buf () store } if } if exit } ifelse } ifelse } loop } def /Stack 256 array def Stack 0 50 dict put Stack 0 get begin /Debug dictbegin /dlb {dbglistbreaks} def /de {dbgenter} def /dx {dbgexit} def /dk {dbgkill} def /dc {dbgcontinue} def /dcc {dbgcopystack dbgcontinue} def /dw {dbgwhere DbgImplicitBreak DbgGetExecStack} def /stack! {stack} def /exec! {exec} def /load! {load} def /pop! {pop} 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 /Clear {0 mul} def /Enter {0} def dictend def /Math dictbegin /add {add} def /sub {sub} def /mul {mul} def /div {div} def dictend def /Stack dictbegin /dup {dup} def /pop {pop} def /exch {exch} def /clear {clear} def /load {load} def /def {def} def /store {store} def /get {get} def /put {put} def dictend def end Stack 1 (This is a test!!!) put /SP 0 def /psh-socket 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 /incoming null def /dialog-can null def /dialog-text null def /dialog-string () def /exec-it { /exec-it items ThisI get send } def /push-it { /push-it items ThisI get send } def /ItemLock createmonitor def /items [] def /free-items [] def /find-item { % obj => i/null ItemLock { 10 dict begin /Obj cvlit def /I 0 def items { {Collection Index} exch send Obj eq {exit} ifelse /I I 1 add def } forall I items length eq {null} {I} ifelse end } monitor } def /type-text { } store /createitems { ItemLock { /items [ Stack 0 {click-point} can /new StructItem send 20 10 0 0 /reshape 5 index send Stack 1 {type-text} 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 /dialog-item null def /slideitem { % items fillcolor item => - gsave dup 4 1 roll % item items fillcolor item {ItemCanvas canvastotop moveinteractive location move} exch send % item grestore } def /create-struct { % obj => i ItemLock { 20 dict begin /Obj exch def NextStackPos /NextY exch def /NextX exch def free-items length 0 eq { Stack SP /Obj load put Stack SP {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 /display-credits { gsave framebuffer setcanvas currentcursorlocation [ (NeWS CyberSpace:) ( by Don Hopkins) (----------------) (Code stolen from:) ( Josh Siegel) ( Don Woods) ] popmsg pop grestore } def /slidemgr null def /itemmgr null def /FirstI null def /ThisI null def /PStack null def /QStack null def /DStack [systemdict userdict] def /PState currentstate def /Execee null 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 /slidemgr [ items { % key item dup /ItemCanvas get % item can MiddleMouseButton [items FillColor % item can name [ dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest } forall /UpdateInterests /update-slide-interests null can eventmgrinterest ] forkeventmgr store itemmgr null ne {itemmgr killprocess} if /itemmgr [ items iteminterests aload pop /UpdateInterests /update-start-interests null can eventmgrinterest ] forkeventmgr store } def /MyWindow DefaultWindow dictbegin dictend classbegin /DestroyClient { systemdict /_ViewCanvas null store /Stack null store /DStack null store itemmgr type /processtype eq { itemmgr killprocess } if slidemgr type /processtype eq { slidemgr killprocess } if items { /destroy exch send } forall /items null store /Primary clearselection % XXX? /DestroyClient super send } def classend def % % 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 /FillColor 1 1 1 rgbcolor def /win framebuffer /new MyWindow send def % Create a window { /PaintClient { paint-hilite items paintitems } def /paint-hilite { ClientCanvas setcanvas erasepage /DrawHilite dialog-item send } def /FrameLabel (PostScript Structure CyberSpace) def /IconLabel (CyberSpace) def /IconImage /galaxy def /ClientMenu [ (Credits) { display-credits } (KeyDict) { /KeyDict dialog-text send select-object } (Break) { clear /Broken /dbgbreak win send } ] /new DefaultMenu send def } win send % Install my stuff. 0 0 800 800 /reshape win send % Shape it. /can win /ClientCanvas get def % Get the window canvas can /Transparent false put can /Retained true put % Create all the items. createitems % Now let the user specify the window's size and position. Then map % the window. (See above) Then activate the items. % /ptr /ptr_m framebuffer setstandardcursor % /reshapefromuser win send % Reshape from user. /map win send % Map the window & install window event manager. % (Damage causes PaintClient to be called) start-event-mgrs