%! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Cyber Space Deck % Copyright (C) 1989. % By Don Hopkins. (don@brillig.umd.edu) % All rights reserved. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % This program is provided for UNRESTRICTED use provided that this % copyright message is preserved on all copies and derivative works. % This is provided without any warranty. No author or distributor % accepts any responsibility whatsoever to any person or any entity % with respect to any loss or damage caused or alleged to be caused % directly or indirectly by this program. This includes, but is not % limited to, any interruption of service, loss of business, loss of % information, loss of anticipated profits, core dumps, abuses of the % virtual memory system, or any consequential or incidental damages % resulting from the use of this program. % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % WARNING WARNING! DANGER! DANGER WILL ROBINSON! DANGER! % This is *gross* code. I mean UUUUUGLY! (And it used to be % even more contorted, if you can believe that.) % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 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 systemdict /start_visualizer known not { (NeWS/mics.ps) LoadFile pop } if end % systemdict /DefaultMenu systemdict /SoftMenu known { SoftMenu } { PieMenu } ifelse def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % StructItem class definition /StructItem LabeledItem dictbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Instance variables /Shrink .8 def /Pad 3 def /Point null 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 /layout-proc /layout-struct def /click-proc /click-select def /lw null def /lh null def /lx null def /ly null def /Filter? false def dictend classbegin %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Class variables /StartPoint 18 def /DoubleClickTime 2 60 div def /DoubleClickDistance 4 dup mul def /CanvasYFudge 2 store /Sort? true def /LineGap 30 def /ItemLabelFont /Helvetica-Bold findfont 14 scalefont def /ItemFont /Courier-Bold findfont def % Normal font /ItemXFont /Courier-BoldOblique findfont def % Executable font /ItemSFont /Courier findfont def % Small font /SmallPointSize 10 def % Use small font when smaller than this. /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 /Transparent true 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 { /it self store 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 /TipX null def /TipY null def /Multiple? false def }{ obs dup length 2 sub get /MySiblings 1 index /Branches get store /Pointers? false def /TipX 1 index /TipX get def /TipY exch /TipY get 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 TipX null ne { TipX 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 Multiple? { MySiblings StartIndex get /C get % Don't select part of control panel MySiblings LastIndex get /C get eq { MySiblings StartIndex get /C get StartIndex LastIndex 2 copy gt {exch} if MySiblings exch get /I get exch MySiblings exch get /I get exch 1 index sub 1 add kbd-select-interval } if } { MySiblings LastIndex get Shift { % Shift to select array index /I get kbd-select-object } { dup /C get exch /I get 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 eq { /ob DL store } if ob null ne { CurrentEvent /showat StructMenu send } if ItemEnd } store /ClientUp { StopItem } def /click-exec { ob /Obj get exec-it } def /click-magic { % Invoke magic editing function... obs length 1 gt { { ob /C get dup type /arraytype eq { pop currentdict } if begin ob /Obj get use-parent-obj cvx exec end } fork pop pause } if } def /click-edit { % Invoke magic editing function... obs length 1 gt { { ob /C get dup type /arraytype eq { pop currentdict } if begin ob /Obj get cvx change-parent-obj end } fork pop pause } if } def /click-push { push-obj } def /old-click-step { [ ob /Obj get ] cvx exec-it } def /click-step { gsave ItemCanvas createoverlay setcanvas ObjectX ObjectY ObjectHeight add translate ob dup begin X Y W H rectpath end [ exch /Obj get /gsave load % Whip me beat me make me check bad writes! currentstate /setstate load /erasepage load /grestore load ] cvx fill exec-it obs length 1 le { /MySiblings [ob] store }{ obs dup length 2 sub get /MySiblings 1 index /Branches get store } ifelse /StartIndex 0 MySiblings { /I get ob /I get eq { exit } if 1 add } forall store /LastIndex StartIndex store currentcursorlocation { newpath pop pop /LastIndex 0 MySiblings { /Y get y le { exit } if 1 add } forall MySiblings length 1 sub min store { StartIndex LastIndex ge { exit } if /StartIndex StartIndex 1 add store MySiblings StartIndex get dup begin newpath X Y W H rectpath end [ exch /Obj get /gsave load % Whip me beat me make me check bad writes! currentstate /setstate load /erasepage load /grestore load ] cvx fill exec-it } loop } getanimated waitprocess /MySiblings null store grestore } def /click-type-dict 100 dict def click-type-dict begin /integertype { Shift 1 -1 ifelse add } def /realtype { Shift -1 1 ifelse add } def /booleantype { not } def end % click-type-dict /click-type { ob /Obj get dup type click-type-dict 1 index known { click-type-dict exch get cvx exec replace-obj } { pop pop %%% /click-proc load cvx exec } ifelse } def /click-point { ItemBegin % do-search % already been done! ob null ne { ob begin /click-proc load end cvx exec } if ItemEnd } def /open-icon { Icon? { /ObjectWidth OW store /ObjectHeight OH store currentdict /Icon? undef redo-shape } if } def /close-icon { Icon? not { gsave /OW ObjectWidth def /OH ObjectHeight def Font setfont Str stringbbox points2rect /IconH exch def /IconW exch def /ObjectWidth IconW store /ObjectHeight IconH store grestore /Icon? true def redo-shape } if } def /toggle-icon { DL begin Icon? { open-icon } { close-icon } ifelse end /LastTime 0 store } def /click-select { ItemCanvas setcanvas CurrentEvent begin LastX XLocation sub dup mul LastY YLocation sub dup mul add end DoubleClickDistance 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 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 /top-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select part of this array } { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get aload pop Len Start neg roll Start Len Last sub 1 sub add Start roll ] ob /Obj get copy end ob /Obj get replace-obj } ifelse } if } def /bottom-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select a part of this array } { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get aload pop Len Start sub Len Last sub 1 sub roll ] ob /Obj get copy end ob /Obj get replace-obj } ifelse } if } def /delete-array-obj { selected-pointer-or-interval? { % collection start last 2 index ob /Obj get ne { pop pop pop % error: first select a part of this array } { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get aload pop Len Start sub Len Last sub 1 sub roll Last Start sub 1 add {pop} repeat ] end ob /Obj get xcheck {cvx} if replace-obj } ifelse } if } def /splice-array-obj { selected-interval? { % collection start last 2 index ob /Obj get eq { 10 dict begin /Last exch def /Start exch def /Len exch length def [ ob /Obj get 0 Start getinterval aload pop ob /Obj get Start Last Start sub 1 add getinterval ob /Obj get xcheck {cvx} if ob /Obj get Last 1 add Len Last sub 1 sub getinterval aload pop ] end ob /Obj get xcheck {cvx} if replace-obj } { pop pop pop % error: select an array or an interval of this array } ifelse } { selected-pointer? { % collection index 2 copy get dup type /arraytype eq { % collection index array 2 index ob /Obj get eq { 10 dict begin /Arr exch cvlit def /Start exch def /Len exch length def [ ob /Obj get 0 Start getinterval aload pop Arr aload pop ob /Obj get Start 1 add Len Start sub 1 sub getinterval aload pop ] end ob /Obj get xcheck {cvx} if replace-obj } { pop pop pop % error: select an array or an interval of this array } ifelse } { pop pop pop % error: select an array or an interval of this array } ifelse } if } ifelse } def /def-in-dict-obj { selected-pointer? { % collection index exch 1 index get % index obj true } { selected-object dup null eq { pop false } { % index dup type /stringtype eq { cvn } if null % index object true } ifelse } ifelse { % index obj ob /Obj get 3 copy pop put % index obj pop ob /Obj get exch % dict index ob /Branches get null eq { pop pop } { % dict index 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 } if } store /undef-in-dict-obj { selected-pointer? { % collection index exch pop ob /Obj get exch % dict index true } { selected-object null eq { pop false } { ob /Obj get exch % dict index dup type /stringtype eq { cvn } if % XXX: NeWS BUG in undef!! (Marja) true } ifelse } ifelse { % dict index ob /Obj get 1 index known not { pop } { % index ob /Obj get exch % dict index 2 copy get kbd-select-object undef % ob begin Branches null ne { /Branches [ Branches { begin /C load /I load known { currentdict } if end } forall ] def } if end redo-layout } ifelse % } if } def /break-obj { { clear ob /Obj get dup type /dicttype eq { dup /ParentDict known { { { ClassName dbgbreak } exch send } } { { countdictstack 1 sub { end } repeat dup begin currentdict 30 string cvs cvn dbgbreak } } ifelse } { { dup type dbgbreak } } ifelse { exec } fork pop pop } fork pop } def /change-obj { % func => - { { count 1 roll count 1 sub { pop } repeat ob /Obj get exch exec } errored pop } fork exch pop waitprocess modify-obj } def % Execute token with Externals on the dict stack, so externalized % //&type_123 object references are resolved. /tokein-obj { ob /Obj get type /stringtype eq { { 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 kbd-select-object } if } 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 /tokeout-obj { ob /Obj get tokeout kbd-select-object } 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 Shift /I /Obj ifelse 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 /pointsize-obj { % point => - dup null eq { pop ob /Point undef } { ob begin /Point exch def end } ifelse redo-layout } def /shrink-obj { % shrink => - dup null eq { pop ob /Shrink undef } { ob begin /Shrink exch def end } ifelse redo-layout } def /update-obj { % ... } def /open-obj { % levels => - dup 0 eq { pop close-struct } { open-struct } ifelse } def /push-obj { ob Shift /I /Obj ifelse get push-it } def /push-it { [ exch [ exch ] 0 /get cvx /dup cvx (%% ) (%Push: %\n) /printf cvx ] cvx execute-it } def /begin-it { [ exch [ exch ] 0 /get cvx /dup cvx (%% ) (%Begin: %\n) /printf cvx /begin cvx ] cvx execute-it } def /enter-it { [ exch [ exch ] 0 /get cvx /dup cvx (%% ) (%Enter: %\n) /printf cvx /enter cvx ] cvx execute-it } def /insert-before-obj { } store /insert-after-obj { } store /molecule-obj { ob /Obj get start_visualizer } def % construct a reference to a piece of substructure relative to the % top level object /reference-obj { obs length 2 lt { {} } { [ obs dup 1 exch length 1 sub getinterval { /I get cvlit /get cvx } forall ] cvx kbd-select-object } ifelse } def /exec-obj { ob /Obj get Shift {[exch]cvx} if 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 /modify-obj { % obj => - LayoutLock { ob begin gsave ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate erase-obj C I 3 -1 roll put object-label change-label grestore end } monitor 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 store /ItemWidth exch store ItemWidth 0 eq ItemHeight 0 eq and { /DL null store } if ensure-DL adjust-geometry ItemWidth ItemHeight /reshape super send gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore ItemCanvas /Mapped true put } def /reshape { % x y w h just-reshape location move } def /just-move { /move super send } def /move { % x y label-bbox /lh exch store /lw exch store % x y lx ly 2 index add /ly exch store % x y lx 2 index add /lx exch store % x y ly 0 max /ClientHeight win send lh sub min ly sub add exch lx 0 max /ClientWidth win send lw sub min lx sub add exch /move super send snaps-here? pop Index ThisI eq { /paint-hilite win send } if StackI null ne StackI Index ne and { /MoveMe TellStack } if } store /redo-layout { perform-layout redo-shape } def /redo-shape { %location 10 10 just-reshape location 10 10 reshape damage-view } def /label-bbox { % x y w h TabX TabY TabWidth TabHeight } def /tab-top { % - => y location TabY add TabHeight add exch pop } def /tab-bottom { % - => y location TabY add exch pop } def /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 store /ItemHeight ItemBorder 2 mul LabelHeight ObjectHeight max add store } /Top /Bottom /AboveLeft /AboveRight /BelowLeft /BelowRight { /ItemWidth ItemBorder 2 mul LabelWidth ObjectWidth max add store /ItemHeight ItemBorder 3 mul ItemGap add LabelHeight add ObjectHeight add store } } case } def /CalcObj&LabelXY { % - => - [uses item context] ObjectLoc { /RightAbove { /LabelX ItemBorder def /LabelY ItemBorder store /ObjectX ItemBorder dup add LabelWidth add ItemGap add store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store /TabHeight LabelHeight ItemBorder dup add add def } /RightBelow /Right { /LabelX ItemBorder store /LabelY ItemHeight ItemBorder sub LabelHeight sub store /ObjectX ItemBorder dup add LabelWidth add ItemGap add store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store /TabHeight LabelHeight ItemBorder dup add add def } /LeftAbove { /LabelX ItemBorder dup add ItemGap add ObjectWidth add store /LabelY ItemBorder store /ObjectX ItemBorder store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemGap sub ItemRadius dup add sub store /TabY LabelY ItemBorder sub store /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store /TabHeight LabelHeight ItemBorder dup add add def } /LeftBelow /Left { /LabelX ItemBorder dup add ItemGap add ObjectWidth add store /LabelY ItemHeight ItemBorder sub LabelHeight sub store /ObjectX ItemBorder store /ObjectY ItemHeight ObjectHeight sub 2 div store /TabX LabelX ItemGap sub ItemRadius dup add sub store /TabY LabelY ItemBorder sub store /TabWidth ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store /TabHeight LabelHeight ItemBorder dup add add def } /AboveRight /Top { /LabelX ItemBorder def /LabelY ItemBorder store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder dup add LabelHeight add ItemGap add store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add add def } /AboveLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub store /LabelY ItemBorder store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder dup add LabelHeight add ItemGap add store /TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemBorder LabelHeight add ItemGap add ItemRadius dup add add def } /BelowRight /Bottom { /LabelX ItemBorder store /LabelY ItemBorder dup add ObjectHeight add ItemGap add store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder store /TabX LabelX ItemBorder sub store /TabY LabelY ItemGap sub ItemRadius dup add sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add def } /BelowLeft { /LabelX ItemWidth ItemBorder sub LabelWidth sub store /LabelY ItemBorder dup add ObjectHeight add ItemGap add store /ObjectX ItemWidth ObjectWidth sub 2 div store /ObjectY ItemBorder store /TabX LabelX ItemBorder sub store /TabY LabelY ItemGap sub ItemRadius dup add sub store /TabWidth LabelWidth ItemBorder dup add add store /TabHeight ItemRadius dup add ItemGap add LabelHeight add ItemBorder add def } } case /PinX LabelX LabelWidth add 2 sub store } def /adjust-geometry { /ItemLabel nice-item-label store LabelSize /LabelHeight exch def /LabelWidth exch def AdjustItemSize CalcObj&LabelXY } def /nice-item-label { Collection Index get dup type { /dicttype { dup /ParentDictArray known { % class or instance dup /ClassName known { % class /ClassName get } { % instance /ClassName exch send (.%) sprintf } ifelse } { systemdict eq (systemdict) (dict) ifelse } ifelse } /canvastype { framebuffer eq (framebuffer) (canvas) ifelse } /Default { short-type } } case (% \267) sprintf } 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 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 % TODO: Open up special editors on different object types. % Numberic keypad % Boolean toggle % Color sliders % Font finder % Canvas view % Visual graphics state editors % String editor % CyberSpace projection % Event's XLocation YLocation should be relative to the event's Canvas, or % framebuffer if null. /use-parent-obj { obs length 1 gt { /obs obs 0 1 index length 1 sub getinterval store /ob obs dup length 1 sub get store } if } def /change-parent-obj { % func use-parent-obj change-obj } def /struct-editors 50 dict def struct-editors begin % ------------------------------------------------------------------------ /step { /Branches [ 20 dict begin % Make fresh copies so user can change scalars /++ {Step add} def currentdict /++ cvx 0 grow-struct dup /click-proc /click-edit put /-- {Step sub} def currentdict /-- cvx 0 grow-struct dup /click-proc /click-edit put /Step 1 def currentdict /Step cvx 0 grow-struct /Exec (neg) def currentdict /Exec cvx 0 grow-struct dup /click-proc /click-edit put end ] def Meta not { /redo-layout null self exch pop send } if } def /stepshift { /Branches [ 20 dict begin % Make fresh copies so user can change scalars /++ {Step add} def currentdict /++ cvx 0 grow-struct dup /click-proc /click-edit put /-- {Step sub} def currentdict /-- cvx 0 grow-struct dup /click-proc /click-edit put /Step 1 def currentdict /Step cvx 0 grow-struct (<<) {Base mul} def currentdict (<<) cvn cvx 0 grow-struct dup /click-proc /click-edit put (>>) {Base div} def currentdict (>>) cvn cvx 0 grow-struct dup /click-proc /click-edit put /Base 10 def currentdict /Base cvx 0 grow-struct /Exec (neg) def currentdict /Exec cvx 0 grow-struct dup /click-proc /click-edit put end ] def Meta not { /redo-layout null self exch pop send } if } def /digit { /Branches [ 20 dict begin % Make fresh copies so user can change scalars 0 1 9 { dup [ /floor load 10 /mul load 5 index /add load ] cvx def currentdict exch 0 grow-struct } for /Back [ 10 /div load /floor load ] cvx def currentdict /Back 0 grow-struct /Clear [ /pop load 0 ] cvx def currentdict /Clear 0 grow-struct /Exec (neg) def currentdict /Exec cvx 0 grow-struct end ] def Branches { /click-proc /click-edit put } forall Meta not { /redo-layout null self exch pop send } if } def /boolean { /Branches [ 20 dict begin /True true def currentdict /True 0 grow-struct /False false def currentdict /False 0 grow-struct /Not /not load def currentdict /Not 0 grow-struct /Exec [/random cvx .5 /lt cvx] cvx def currentdict /Exec 0 grow-struct end ] def Branches { /click-proc /click-edit put } forall Meta not { /redo-layout null self exch pop send } if } def /filter { Branches null eq { /Branches C I 1 grow-struct 1 index get def } if /Branches [ 20 dict begin /Recompute { ob begin /Obj /C load /I load get def end /View ob /Obj get def ob /Branches get ViewIndex get /Branches [ ContainerRef 0 /View load put Container type /arraytype eq { IndexRef 0 0 put } if Container { ObjectRef exch 0 exch put Container type /arraytype eq { IndexRef 0 2 copy get 1 add put } { IndexRef exch 0 exch put } ifelse mark false /Filter load cvx { exec } errored { cleartomark } { { cleartomark Container Index 0 grow-struct } { cleartomark } ifelse } ifelse } forall ] Order put ObjectRef 0 null put ContainerRef 0 null put IndexRef 0 null put Meta not { /redo-layout null self exch pop send } if } def currentdict /Recompute 0 grow-struct dup /click-proc /click-edit put /ObjectRef [ null ] def /Object ObjectRef cvx def /ContainerRef [ null ] def /Container ContainerRef cvx def /IndexRef [ null ] def /Index IndexRef cvx def % Filters may call: Container Index Object /Filter % - => interesting? false def currentdict /Filter 0 grow-struct /Keys 100 dict def currentdict /Keys 1 grow-struct /Order [ /Obj load type /arraytype eq /by-value /by-name ifelse /quicksort cvx ] cvx def currentdict /Order 0 grow-struct /View null def currentdict /View 0 grow-struct counttomark 1 sub /ViewIndex exch def ] currentdict end 3 1 roll def begin Recompute end } def /scroller { Branches null eq { /Branches C I 1 grow-struct 1 index get def } if % currentdict /AllBranches known not { /AllBranches Branches def % } if /Branches [ 20 dict begin /Recompute { /Offset Offset 0 max ob /Obj get length min def ob /Branches ob /Branches get 0 Controls 2 index length min getinterval ob /AllBranches get Offset 1 index length 1 index sub Size min getinterval append put /==== (Viewing %, %..% of % %) [ ob /Str get Offset Offset ob /Branches get length Controls sub add 1 sub ob /Branches get length 2 index 1 index div 100 mul 5 string cvs (%) append ] sprintf def Meta not { /redo-layout null self exch pop send } if } def /Top { /Offset 0 def Recompute } def currentdict /Top 0 grow-struct dup /click-proc /click-magic put /Bottom { /Offset ob /Obj get length Size sub def Recompute } def currentdict /Bottom 0 grow-struct dup /click-proc /click-magic put /Back { /Offset Offset Size sub def Recompute } def currentdict /Back 0 grow-struct dup /click-proc /click-magic put /Next { /Offset Offset Size add def Recompute } def currentdict /Next 0 grow-struct dup /click-proc /click-magic put /Offset 0 def % currentdict /Offset 0 grow-struct /Size 10 def currentdict /Size 0 grow-struct /==== (Viewing nothingness) def currentdict /==== 0 grow-struct /Controls counttomark 1 sub def ] currentdict end 3 1 roll def begin Recompute end } def /user { /Branches [ 20 dict begin /User selected-object def currentdict /User 0 grow-struct dup /click-proc /click-edit put end ] def Meta not { /redo-layout null self exch pop send } if } def % Pop open pointers to instances of this name on the dictionary stack. /definitions { /Branches [ /getdictstack dialog-item send { dup ob /Obj get known { ob /Obj get 0 grow-struct } { pop } ifelse } forall ] dup length 0 eq { pop pop } { def } ifelse Meta not { /redo-layout null self exch pop send } if } def /object { ob /C get ob /I get get dup /ParentDict known { /Branches [ 10 dict begin /Obj ob /C get ob /I get get def /Class Obj /ClassName known not { Obj /ParentDict get } if def /MethodDict 1000 dict def /ClassVarDict 1000 dict def [ Obj dup /ParentDictArray get aload pop ] { { Class /InstanceVarDict get 2 index known not { dup xcheck 1 index type /arraytype eq and { MethodDict 2 index dup put } { ClassVarDict 2 index dup put } ifelse } if pop pop } forall pause pause } forall /ClassName /ClassName Class send def currentdict /ClassName 0 grow-struct /InstanceVars [ Class /InstanceVarDict get { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /InstanceVars 0 grow-struct pause pause /ClassVars [ ClassVarDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /ClassVars 0 grow-struct pause pause /Methods [ MethodDict { pop 80 string cvs } forall ] {gt} quicksort [ exch { cvn } forall ] def currentdict /Methods 0 grow-struct pause pause /Obj null def /Class null def /MethodDict null def /ClassVarDict null def end ] def Meta not { /redo-layout null self exch pop send } if } if } def % ------------------------------------------------------------------------ end % struct-editors /open-editor { % name => - struct-editors 1 index known not { pop nhh } { gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin struct-editors exch get exec end grestore } ifelse } def /open-struct-editor { % - => - gsave DL /Icon? undef ItemCanvas setcanvas ObjectX ObjectY ObjectHeight add translate ob begin C I get dup type dup struct-editors exch known not { pop pop } { struct-editors exch get exec } ifelse end % 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 => - % Oh, lordy, lordy, lordy! 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 % DL on dict stack /grow-substruct { % l => - /L exch def /Branches C I L grow-struct 1 index get def } 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 Filter? and } 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 /ShortNameDict 40 dict def ShortNameDict begin /nametype { dup xcheck (%) (/%) ifelse sprintf } def /dicttype { dup length exch xcheck (dict{%}) (dict(%)) ifelse sprintf } def /arraytype { dup length exch xcheck ({%}) ([%]) ifelse sprintf } def /marktype { pop (mark) } def /eventtype { dup /Name get short-name exch /IsInterest get (interest(%)) (event(%)) ifelse sprintf } def /canvastype { gsave dup setcanvas clippath pathbbox points2rect 4 2 roll pop pop exch % h w framebuffer setcanvas 3 -1 roll getcanvaslocation exch (can(%,%,%,%)) sprintf grestore } def /processtype { % dup /Interests get length exch % dup /ExecutionStack get length exch % CORE DUMP % dup /DictionaryStack get length exch % dup /OperandStack get length exch % dup /Execee get exch % /State get % (proc(%,%,o%,d%,e%,i%)) sprintf dup /Execee get exch /State get (proc(%,%)) sprintf } def /stringtype { dup length 80 gt { 0 80 getinterval ((%)...) } ((%)) ifelse sprintf } def end % ShortNameDict /short-name { dup type ShortNameDict 1 index known { ShortNameDict exch get exec } { pop 80 string cvs } ifelse } def /short-type { % obj => str type 20 string cvs 0 1 index length 4 sub getinterval } def /object-label { % - => str C I get /Obj 1 index store short-name currentdict DL ne { I short-name ( : ) append exch append } if } def /do-grow-struct { % Container Index Levels => DL pause 32 dict begin /L exch def cvlit /I exch def cvlit /C exch def /Obj null def /Str object-label def % updates /Obj /X 0 def /Y 0 def /W 0 def /H 0 def /StrY 0 def /TipX 0 def /TipY 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 /by-value { /Str get cvr exch /Str get cvr lt } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Layout /perform-layout { /xcurs /xcurs_m ItemCanvas setstandardcursor LayoutLock { /hourg /hourg_m ItemCanvas setstandardcursor /ItemLabel nice-item-label 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 /layout-proc load cvx exec end pause } def /layout-struct { % - => - /Str object-label def /Obj load xcheck Point SmallPointSize gt and { /Font ItemXFont Point scalefont def } { /Font Point SmallPointSize le ItemSFont ItemFont ifelse 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 Point Shrink mul store Branches { do-layout } forall /Point exch 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 /TipX X W add LineGap sub def /TipY Y H 2 div 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 } def % 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 { show-lines show-insides } if } ifelse end } store /show-obj { Font setfont X StrY moveto Str show } def /erase-obj { gsave Font setfont X StrY translate Str stringbbox points2rect rectpath 1 setgray fill grestore } def /erase-lines { Branches null ne { gsave newpath TipX 1 sub Y Branches 0 get /X get TipX sub 2 add H rectpath 1 setgray fill grestore } if } def /change-label { % str => - gsave Font setfont Str stringwidth pop exch /Str exch def Str stringwidth pop exch sub dup 0 eq Branches null eq or { pop show-obj } { erase-lines /TipX exch TipX add def TipX Branches 0 get /X get Pad 4 mul sub TipX lt { /TipX TipX LineGap add def /redo-layout null self exch pop send } { show-lines show-obj } ifelse } ifelse grestore } def /show-lines { TipX TipY 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 end } 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 } def /show-insides { Branches { draw-struct } forall } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Printing % This needs to be brought up to date... /write-DL { % { /f (DL.ps) (w) file def f (%!\n) writestring f (gsave 0 setgray 0 setlinewidth 20 20 translate\n) writestring DL begin f H W (%%) (%BoundingBox: 0 0 % %\n) sprintf writestring end /cur-font-name null def /cur-font-size 0 def DL print-struct f (grestore showpage\n) writestring f closefile } stopped pop } def /print-struct { % dict => - pause begin Font /FontMatrix get 0 get /Obj load xcheck ItemXFont ItemFont ifelse /FontName get 1 index cur-font-size eq 1 index cur-font-name eq and { pop pop } { 2 copy /cur-font-name exch store /cur-font-size exch store (/% findfont % scalefont setfont\n) sprintf f exch writestring } ifelse Font setfont Font fontdescent StrY ObjectHeight add X (% % moveto ) sprintf f exch writestring Str ( (%) show\n) sprintf f exch writestring Branches null ne Icon? not and { X W add LineGap sub Y H 2 div add ObjectHeight add Branches { begin 2 copy exch (% % moveto ) sprintf f exch writestring X Pad sub Y ObjectHeight add exch (% % lineto ) sprintf f exch writestring Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring f (stroke\n) writestring currentdict end print-struct } forall Branches length 0 ne { Branches dup length 1 sub get begin 2 copy exch (% % moveto ) sprintf f exch writestring X Pad sub Y H add ObjectHeight add exch (% % lineto ) sprintf f exch writestring Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring f ( stroke\n) writestring end } if pop pop } if end } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Stack stuff /execute-it { % obj => - /exec-and-update dialog-item send } def /TellStack { % message => - createevent begin /Name exch def /ClientData Index def /Action StackI def /Canvas ItemParent def currentdict end sendevent } def /pack { StackI null ne { /PackStack items StackI get send } if } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Snap dragging /pinned? { % y h => bool location pop PinX add 3 1 roll % x y h 6 exch % x y w h pin-rect rectsoverlap } store % items backgroundcolor => - (interactively move item) /moveinteractive { ItemBegin 10 dict begin /GA_constraint 0 def /GA_value /calc_GA_value load def currentcursorlocation /DY exch def /DX exch def ItemCanvas /Transparent get { fillcanvas % items /bbox self send % items x y w h true dragcanvas currentcanvas mapcanvas % paint all items overlapping old item bbox & newly moved item % the mark ugly is just to avoid a local var dict; mainly % because of the self call above. mark 6 -1 roll { % x y w h mark item counttomark 2 eq {exch pop} if % x y w h mark item exch pop % x y w h item 5 copy % x y w h item x y w h item /bbox exch send rectsoverlap 1 index self eq or {/paint exch send} {pop} ifelse mark % x y w h mark } forall 5 {pop} repeat } { currentcanvas mapcanvas false dragcanvas % true dragcanvas currentcanvas mapcanvas pop pop } ifelse 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 dialog-item 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 /layout-proc /click-proc /Point} { 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 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % StructItem Menu definitions /nhh { gsave framebuffer setcanvas currentcursorlocation [ (Nothing)(Happens)(Here!) ] popmsg pop grestore } def /MakePointSizeThings { % - => ...things... {1 2 4 6 8 10 12 14 16 18 20 22 24 28 32} { [ exch dup 3 string cvs exch { dup SmallPointSize le ItemSFont ItemFont ifelse } StructItem send exch scalefont ] } forall } def /TabLocationMenu [ (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 TabLocationMenu /PieInitialAngle 360 16 div put /TabClickMenu [ (click-select) (click-type) (click-exec) (click-magic) (click-push) (click-step) (click-select) (click-edit) ] [ {currentkey cvn {/click-proc exch def} it send} ] /new DefaultMenu send def /TabViewMenu [ [ [(null) /ItemFont StructItem send 20 scalefont] MakePointSizeThings ] [ (null) .1 .1 2 { 5 string cvs } for ] nullarray [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] ] [ (Size) {getmenuarg 0 get cvi {/StartPoint exch def redo-layout} it send} (Shrink) {getmenuarg cvr {/Shrink exch def redo-layout} it send} (Click..) TabClickMenu (Open) { getmenuarg cvi { DL null eq { pop } { /open-obj DL send } ifelse } it send } ] /new PulloutPieMenu send def TabViewMenu /LabelMinRadius 35 put TabViewMenu /PieInitialAngle 135 put /TabMenu [ (Layout) {/redo-layout it send} (Tab...) TabLocationMenu (Zap) {/Free it send} (Paint) {/paint it send} (Print) {/write-DL it send} (View...) TabViewMenu ] /new DefaultMenu send store /ChangeMenu [ (tokein) { /tokein-obj it send } (executable) { /cvx-obj it send } (name) { /cvn-obj it send } (string) { /cvs-obj it send } (tokeout) { /tokeout-obj it send } (literal) { /cvlit-obj it send } (integer) { /cvi-obj it send } (real) { /cvr-obj it send } ] /new DefaultMenu send def /ClickMenu [ (null) (click-type) (click-exec) (click-magic) (click-push) (click-step) (click-select) (click-edit) ] [ {ob /click-proc currentkey cvn dup /null eq {pop undef} {put} ifelse} ] /new DefaultMenu send def /SelectMenu [ (Pointer) { ob /C get ob /I get kbd-select-pointer } (Index) { ob /I get kbd-select-object } (Object) { ob /C get ob /I get get kbd-select-object } (Container) { ob /C get kbd-select-object } ] /new DefaultMenu send def /EtcMenu [ (molecule) { /molecule-obj it send } (select...) SelectMenu (reference) { /reference-obj it send } ] /new DefaultMenu send def /ViewMenu [ [ [(null) /ItemFont StructItem send 18 scalefont] MakePointSizeThings ] [ (null) .1 .1 2 { 5 string cvs } for ] nullarray [ (0) (1) (2) (3) (4) (5) (6) (7) (8) ] ] [ (size) {getmenuarg 0 get cvx exec /pointsize-obj it send} (shrink) {getmenuarg cvx exec /shrink-obj it send} (click...) ClickMenu (open) {getmenuarg cvi /open-obj it send} ] /new PulloutPieMenu send def ViewMenu /LabelMinRadius 35 put ViewMenu /PieInitialAngle 135 put /TypeFont /Screen findfont 12 scalefont def /StructMenu [ nullarray [ [ { [ ob /Obj get type 30 string cvs 0 1 index length 4 sub getinterval % chop "type" TypeFont ] exch pop dup type exec } ] ] nullarray nullarray nullarray nullarray nullarray nullarray ] [ % Note: depends on fixed getmenuarg (push) {/push-obj it send} (type...) /FigureTypeAction cvx (load) {/load-obj it send} (etc...) EtcMenu (exec) {/exec-obj it send} (change...) ChangeMenu (paste) {/paste-obj it send} (view...) ViewMenu ] /new PulloutPieMenu send def { /LabelMinRadius 25 def /FigureTypeAction { ob /Obj get type TypeActionDict 1 index known { TypeActionDict exch get cvx exec } { pop { /nhh it send } } ifelse } def } StructMenu send /TypeActionDict 50 dict def TypeActionDict begin /integertype /IntegerMenu def /realtype /RealMenu def /booleantype /BooleanMenu def /colortype /ColorMenu def /nametype /NameMenu def /stringtype /StringMenu def /graphicsstatetype /GraphicsstateMenu def /arraytype /ArrayMenu def /dicttype /DictMenu def /fonttype /FontMenu def /canvastype /CanvasMenu def /processtype /ProcessMenu def /eventtype /EventMenu def /filetype /FileMenu def /shapetype /ShapeMenu def /cursortype /CursorMenu def /monitortype /MonitorMenu def /operatortype /OperatorMenu def /nulltype /NullMenu def /marktype /MarkMenu def end % TypeActionDict % ======================================================================= % Type menus /IntegerMenu [ (step editor) {/step /open-editor it send} (stepshift editor) {/stepshift /open-editor it send} (digit editor) {/digit /open-editor it send} (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /RealMenu [ (step editor) {/step /open-editor it send} (stepshift editor) {/stepshift /open-editor it send} (digit editor) {/digit /open-editor it send} (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /BooleanMenu [ (boolean editor) {/boolean /open-editor it send} (user editor) {/user /open-editor it send} (true) {nhh} (false) {nhh} (not) {nhh} ] /new DefaultMenu send def /ColorMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /NameMenu [ (definitions editor) {/definitions /open-editor it send} (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /StringMenu [ (prepend) {nhh} % selected string (append) {nhh} % selected string (token) {nhh} % selected string (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /GraphicsstateMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /JuggleArrayMenu [ (pop) { /pop-array-obj it send } % to selection % rotate array member or subinterval to top (top) { /top-array-obj it send } % splice array member or unsplice subinterval (splice) { /splice-array-obj it send } % rotate array member or subinterval to bottom (bottom) { /bottom-array-obj it send } (push) { /push-array-obj it send } % selected object (append) { /append-to-array-obj it send } % selected array % selected array member or subinterval (delete) { /delete-array-obj it send } (prepend) { /prepend-to-array-obj it send } % selected array ] /new DefaultMenu send def /ArrayMenu [ (juggle...) JuggleArrayMenu (scroller editor) {/scroller /open-editor it send} (filter editor) {/filter /open-editor it send} (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /DictMenu [ (def) { /def-in-dict-obj it send } % selected object (undef) { /undef-in-dict-obj it send } % selected key (or pointer index) (begin) { /begin-obj it send } (enter) { /enter-obj it send } (dbgbreak) { /break-obj it send } (scroller editor) {/scroller /open-editor it send} (filter editor) {/filter /open-editor it send} (user editor) {/user /open-editor it send} (object editor) {/object /open-editor it send} ] /new DefaultMenu send def /FontMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /CanvasMenu [ (manager) {nhh} % select /Interests 0 /Process (bbox) {nhh} % select [x y w h] (setcanvas) {nhh} % changes proc's gstate (zap) {nhh} % unretain & unmap whole tree (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /ProcessMenu [ (kill) {nhh} (kill group) {nhh} (suspend) {nhh} (resume) {nhh} (wait) {nhh} % select return value (userdict) {nhh} % select userdict (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /EventMenu [ (express) {nhh} % Does this make any sense in this context? (revoke) {nhh} (sendevent) {nhh} (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /FileMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /ShapeMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /CursorMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /MonitorMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /OperatorMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /NullMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send def /MarkMenu [ (user editor) {/user /open-editor it send} ] /new DefaultMenu send 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 24 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 (Primary \267) def currentdict end } def /kbd-reset { /dialog-buf () store /dialog-string () store { psh-socket bytesavailable string readstring pop } errored {(\n%% Reset!\n) print} execute-it } def /shut-down { { psh-socket (\ndbgstop\nquit\n) writestring psh-socket flushfile } errored pop null null /DropDead TellMyProcess 1 60 div sleep } def /kbd-reboot { { /dialog-buf () store /dialog-string () store [ () (%% Reboot!) () ] false /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 [ [(7) (11) (13) (15)] [ MakePointSizeThings ] nullarray nullarray ] [ (text size) {null getmenuarg cvi /changefont dialog-text send} (object size) {StructItem /StartPoint getmenuarg 0 get cvi put} (pack) {/PackStack it send} (reset) {/kbd-reset it send} ] /new PulloutPieMenu 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 /toggle-icon {} 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 /do-search { /it self store /ob null store } def /make-selection { % We ARE the selection. } def /pin-rect { % X Y w h location exch PinX add 3 sub exch % x y PinHeight 0 lt { PinHeight add } if ItemHeight PinHeight abs add 6 exch } def /exec-and-update { % func => - null /ExecIt TellMyProcess } def /TellMyProcess { % ClientData Action Name 8 { % wait up to 4 seconds if no process MyProcess null eq { .5 60 div sleep } { exit } ifelse } repeat MyProcess null eq { pop pop pop gsave framebuffer setcanvas currentcursorlocation [(No process!)] popmsg pop grestore } { createevent begin /Name exch def /Action exch def /ClientData exch def /Process MyProcess def currentdict end sendevent } ifelse } def /UpdateStack { % DeferedUpdateEvent null ne { DeferedUpdateEvent recallevent } if /DeferedUpdateEvent CurrentEvent store DeferedUpdateEvent begin /Name /DeferedUpdate def /TimeStamp currenttime UpdateDelay add def end % event DeferedUpdateEvent sendevent } def /DeferedUpdate { % /DeferedUpdateEvent null store dialog-promptlines 0 ne { /getcaretpos dialog-text send exch pop 1 exch dialog-promptlines 1 sub 0 max sub 2 copy /movecaret dialog-text send exch pop dialog-promptlines exch /deleteline dialog-text send } if [ dialog-string dialog-buf CurrentEvent /ClientData get length (NeWS[%]> %%) sprintf { (\n) search { % chop string up at newlines exch pop exch } { exit } ifelse } loop ] dup length /dialog-promptlines exch store false /writeatcaret dialog-text send pause CurrentEvent /ClientData get setoperandstack } def /ProcessReady { CurrentEvent dup /ClientData get exch /Action get set-process } def /set-process { % stack process => - /MyProcess exch def setoperandstack { currentprocess (%% ) (%Hello, my name is %!\n) printf } execute-it } def /SelectionChanged { CurrentEvent /Action get /PrimarySelection eq { (% %: %) [ CurrentEvent /ClientData get dup selection-type exch dissect-selection 1 index /text eq () { dup short-type } ifelse exch Collection Index 2 index put short-name ] /printf Notifier send } if } store /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 getoperandstack {Collection Index get} items I get send 80 string cvs (%% Push: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /PopMe { % index => - ItemLock { /I exch def /MyStack [ MyStack { dup I eq {pop} if } forall ] store getoperandstack {Collection Index get} items I get send 80 string cvs (%% Pop: ) exch append (\n) append /ReplaceStack TellMyProcess } monitor } def /ReplaceStack { ItemLock { getoperandstack null /ReplaceStack TellMyProcess } monitor } def /SortStack { ItemLock { MyStack { /tab-top exch items exch get send exch /tab-top exch items exch get send lt } quicksort pop } monitor } store % This code was designed to be rewritten! % To do: % Make the stack display 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 /getoperandstack { % 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 /getdictstack { % - => dictstack MyProcess null eq { nullarray } { MyProcess /DictionaryStack get } ifelse } 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 /setoperandstack { SetStack } def /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 /reshapefromuser { } def /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 null eq { /SubItemMgr dictbegin /Scroller Scroller def /Notifier Notifier def dictend forkitems store } if 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 [ () () ] false writeatcaret dialog-string /dialog-enter dialog-item send /dialog-string () store /dialog-promptlines 0 dialog-buf { (\n) search { pop pop exch 1 add exch } { pop exit } ifelse } loop 1 add store } def 10 { (select line) comment % Newline [ () () ] false writeatcaret dialog-string kbd-select-object /dialog-string () store prompt } def 10 128 add { (input line) comment % Meta-Newline [ () () ] false writeatcaret dialog-string /dialog-newline dialog-item send /dialog-string () store prompt } def 19 { (insert selection) comment % ^S selected-object (%) sprintf [ 1 index ] false writeatcaret /dialog-string exch dialog-string exch append store } def 12 { (load) comment % ^L { (%% load\n) print load } execute-it } 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 /FunctionR3 { (execute selection) comment 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 (x) 0 get 128 add /FunctionR3 load def % Meta-x (X) 0 get 128 add /FunctionR3 load def % Meta-X 3 { (reset input) comment % ^C /kbd-reset dialog-item send } def 255 { (reboot process) comment % Meta-Delete Control { [ () (Hey! This ain't no stinkin' MS-DOS!!!) () ] false writeatcaret } if /kbd-reboot dialog-item send } def 31 128 add 255 load def /FunctionR9 { (page up) comment /ScrollPageForward /FakeScroll dialog-scroll send } def (v) 0 get 128 add /FunctionR9 load def % Meta-v (V) 0 get 128 add /FunctionR9 load def % Meta-V /FunctionR15 { (page down) comment /ScrollPageBackward /FakeScroll dialog-scroll send } def 22 /FunctionR15 load def % ^V /FunctionR7 { (scroll up) comment /ScrollLineForward /FakeScroll dialog-scroll send } def (z) 0 get 128 add /FunctionR7 load def % Meta-z (Z) 0 get 128 add /FunctionR7 load def % Meta-Z /FunctionR13 { (scroll down) comment /ScrollLineBackward /FakeScroll dialog-scroll send } def 26 /FunctionR13 load def % ^Z /FunctionR11 { (scroll to bottom) comment 1 /ScrollTo dialog-scroll send } def (>) 0 get 128 add /FunctionR11 load def % Meta-> (.) 0 get 128 add /FunctionR11 load def % Meta-. /FunctionF10 { (help) comment % Alternate [ () (Key Bindings:) ()] false writeatcaret [ KeyDict { comment-string exch key-name (%: %) sprintf pause pause } forall ] /gt quicksort { [ exch () ] false writeatcaret pause pause pause } forall prompt } def (?) 0 get 128 add /FunctionF10 load def % Meta-? (/) 0 get 128 add /FunctionF10 load def % Meta-/ /FunctionR1 { (describe key) comment [ () (Describe key: ) ] false writeatcaret /DescribingKey? true store } def (k) 0 get 128 add /FunctionR1 load def % Meta-k (K) 0 get 128 add /FunctionR1 load def % Meta-K /FunctionR2 { (bind selection to key) comment [ () selected-object (Bind selection %) sprintf (to key: ) ] false writeatcaret /BindingKey? true store } def (b) 0 get 128 add /FunctionR2 load def % Meta-b (B) 0 get 128 add /FunctionR2 load def % Meta-B /FunctionL9 { (find completions) comment [ dialog-string { DelimDict 1 index known { cleartomark mark } if } forall ] cvas dup length 0 eq { pop } { kbd-select-object { selected-object (%% Finding completions of ") print dup print (":\n) print currentprocess /DictionaryStack get 20 dict begin /DS exch def /pat exch def /found null def /complete null def /str pat length string def DS length 1 sub -1 0 { /i exch def DS i get { /val exch def dup str cvs pat ne { pop } { found null eq { /found 1 index 250 string cvs def /complete found def } { /found 1 index 250 string cvs def found length complete length lt { /complete found def } { 0 complete { found 2 index get ne { /complete complete 0 3 index getinterval store exit } if 1 add } forall pop } ifelse } ifelse /val load exch i (%: /% %\n) printf } ifelse } forall pause pause } for pause pause pause complete null eq { () } { complete pat length 1 index length 1 index sub getinterval } ifelse createevent begin /Name /InsertValue def /Action exch def /Canvas currentprocess /Interests get 0 get % event /ClientData get /ViewCanvas get % can /Parent get % clientcanvas has keyboard interests! def currentdict end sendevent complete null ne { complete select-object } if end } execute-it } ifelse } def 27 128 add /FunctionL9 load def 27 { (complete) comment % Escape [ 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 pop } ifelse } forall pause } for pause complete null ne { complete pat length 1 index length 1 index sub getinterval createevent begin /Name /InsertValue def /Action exch def /Canvas currentprocess /Interests get 0 get % event /ClientData get /ViewCanvas get % can /Parent get % clientcanvas has keyboard interests! def currentdict end sendevent complete null ne { complete select-object } if } if end } execute-it } ifelse } def 4 { (completions) comment % ^D [ dialog-string { DelimDict 1 index known { cleartomark mark } if } forall ] cvas dup length 0 eq { pop } { kbd-select-object { selected-object (%% Completions of ") print dup print (":\n) print 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 (% ) printf } ifelse } forall pause } for (\n) printf pause pause complete null ne { complete pat length 1 index length 1 index sub getinterval 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] false 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 () ] false 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 /skip 0 def /newlines 0 def /i 0 def /a null def /pre null def /lastnl 0 def /InsertValueCallback { % string => - /skip dialog-string length store /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 skip 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 false writeatcaret /dialog-promptlines newlines 1 add % dialog-string length 0 eq { 1 add } if store } 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!) () ] false 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 /Courier-Bold findfont 22 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 CanWidth string readline false eq { [() (Lost it!) ()] false writeatcaret % 1 60 div sleep % /kbd-reboot dialog-item send /incoming null store currentprocess killprocess } if dialog-promptlines 0 ne { getcaretpos exch pop 1 exch dialog-promptlines sub 1 add dup dialog-promptlines exch deleteline movecaret /dialog-promptlines 0 store } if [ exch () ] false writeatcaret psh-socket bytesavailable 0 eq { prompt } if } loop } dialog-text send } fork store psh-socket (systemdict/dbgstart known not{(NeWS/debug.ps)run}if dbgstart\n_ReadyProcess\n) writestring psh-socket flushfile } if } def /dialog-newline { % str => - psh-socket exch writestring psh-socket 10 write psh-socket flushfile } def /dialog-enter { % str => - /dialog-buf exch dialog-buf (%%\n) sprintf remove-returns store { dialog-buf { token } errored { [(%% Syntax error!)] false /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 prompt } 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 MyProcess type /processtype eq { pause pause pause % maybe it will kill itsself MyProcess killprocess } if /MyProcess null store /DeferedUpdateEvent null store /destroy super send } def classend def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Icky system globals and merciless kludges systemdict begin /comment { pop } def % Reap dead debuggers /rd { [ DbgDicts {pop} forall ] { dup /State get /zombie eq { dup killprocess DbgDicts exch undef } { pop } ifelse } forall } def systemdict /DbgDicts known { rd } if /dirname { ob begin uniquecid dup 3 -1 roll (dir2dict % % | psh) sprintf forkunix [exch cidinterest1only] forkeventmgr waitprocess replace-struct end redo-layout } store /filename { (file2dict % | psh) sprintf forkunix } def /_ViewCanvas null def /_SendUpdateStack { count array astore aload null /UpdateStack _SendViewEvent { currentfile flushfile } errored { { dbgstop } errored quit } if } def /_SendViewEvent { % ClientData Action Name => - createevent begin /Name exch def /Action exch def /ClientData exch def /Canvas currentprocess /Interests get 0 get % event /ClientData get /ViewCanvas get % can def currentdict end sendevent } def /_ReadyProcess { createevent begin /Canvas _ViewCanvas def /Name /ProcessReady def /Action currentprocess def count array astore aload /ClientData exch def currentdict end sendevent createevent begin /Name 20 dict def Name begin /ExecIt { /ClientData get exec _SendUpdateStack } def /ReplaceStack { dup /Action get dup type /stringtype ne { pop } { { print currentfile flushfile } errored { { dbgstop } errored quit } if } ifelse /ClientData get count 1 roll count 1 sub {pop} repeat aload pop } def /DropDead { { dbgstop } errored { (Ayyyeee!\n) print currentfile flushfile } errored quit } def end % Name /ClientData 20 dict def ClientData begin /ViewCanvas _ViewCanvas def % Stash! end % ClientData currentdict end expressinterest 32 { rd % reap dead rebuggers dstack eventloop count 0 eq null { dup } ifelse /please eq { pop exit } if (There's no way out!\n) print } repeat (Oh, all right...\n) print quit } def systemdict begin /eventloop { { awaitevent } loop } def /dstack { currentprocess /DictionaryStack get dup length (dstack[%]: ) printf { dup maxlength exch length (%/% ) printf } forall currentdict /ParentDictArray known { currentdict /ClassName known { ClassName ( % class) printf } { ClassName ( % instance) printf } ifelse } if (\n) print } def /enter { { dstack eventloop } exch send dstack } def end % systemdict /revokekbdinterests { % [ int1 int2 ... intn ] can => - removefocusinterest % aload pop revokeinterest revokeinterest revokeinterest {{revokeinterest} errored {pop} if} 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 /SelectionType /object def /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 /SelectionType /pointer def /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 /SelectionType /interval def /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 selection-type { /empty { pop null % null } /unknown { % seldict } /text { /ContentsAscii get % string } /object { /ContentsPostScript get % obj } /pointer { dup /ContentsPostScript get % seldict container exch /SelectionStartIndex get % container index 1 index type /dicttype eq { 2 copy known } true ifelse { get % obj } { pop pop null % null } ifelse } /interval { dup /ContentsPostScript get % seldict container exch dup /SelectionStartIndex get % container seldict start exch /SelectionLastIndex get % container start last 1 index sub 1 add % container start len getinterval % obj } /default { % seldict } } case } def /evil-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 /selection-type { % seldict => name dup null ne { dup /SelectionType known { dup /SelectionType get null ne } false ifelse { /SelectionType get } { dup /ContentsAscii known { pop /text } { pop /unknown } ifelse } ifelse } { pop /empty } ifelse } store /evil-selection-type { % seldict => name dup null ne { dup /ContentsPostScript known { dup /SelectionStartIndex known { dup /SelectionLastIndex known { pop /interval } { pop /pointer } ifelse } { pop /object } ifelse } { pop /text } ifelse } { pop /empty } ifelse } store /interesting-keys [ /SelectionType /ContentsAscii /ContentsPostScript /SelectionStartIndex /SelectionLastIndex ] def /request-selection { % rank => seldict 10 dict begin interesting-keys { null def } forall currentdict end exch selectionrequest } def /selected-object { % - => obj /PrimarySelection request-selection dissect-selection } def /selected-pointer? { % - => false / collection index true /PrimarySelection request-selection dup selection-type /pointer eq { dup /ContentsPostScript get exch /SelectionStartIndex get true 2 index type /dicttype eq { 3 copy pop known not { % invalid pointer pop pop pop false } if } if } { pop false } ifelse } def /selected-interval? { % - => false / collection start last true /PrimarySelection request-selection dup selection-type /interval eq { dup /ContentsPostScript get exch dup /SelectionStartIndex get exch /SelectionLastIndex get true } { pop false } ifelse } def /selected-pointer-or-interval? { % - => false / collection first last true /PrimarySelection request-selection dup selection-type { /interval { dup /ContentsPostScript get exch dup /SelectionStartIndex get exch /SelectionLastIndex get true } /pointer { dup /ContentsPostScript get exch /SelectionStartIndex get dup true 2 index type /dicttype eq { 3 copy pop known not { % invalid pointer pop pop pop false } if } if } /Default { pop false } } case } 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 /tokeout { % 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-promptlines 0 def /dialog-item null def /dialog-scroll null def (NEWSSERVER) getenv (;) search pop (.) search pop pop pop /socket-port exch def pop /socket-host exch def /socket-file (%socketc) socket-port append socket-host append def /psh-socket null def /SP 0 def /Stack 256 array def /Pallets 100 dict def Stack 0 Pallets put Stack 1 (Nothing!) put /ThisI null def /it null def /ob null def /obs null def /FillColor 1 1 1 rgbcolor def /ItemLock createmonitor def /items [] def /free-items [] def /Meta false def /Control false def /Shift false def /win null def /can null def /slidemgr null def /itemmgr null def /incoming null def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % User Utilities % % quicksort by Don Woods at Sun Microsystems, Inc. % /quicksort { % array proc => array (sorted, reuses same storage) 10 dict begin /Bigger? exch cvx def % a b bigger? => t if a -- sorts array in place, using Bigger? for comparisons dup length dup 2 gt { % A N % the next lines (until but not incl /Key...) subsort three elements % so we can use the median as the partitioning element; this improves % performance for the case where the array is initially nearly sorted, % but is not strictly necessary for the algorithm to work (it does % seem to improve average runtime by about 10%) 2 copy 1 sub 2 copy 2 idiv 1 index 0 % A N A N-1 A (N-1)/2 A 0 6 copy get 5 1 roll get 3 1 roll get % above & A[N-1] A[(N-1)/2] A[0] 2 copy Bigger? {exch} if % subsort for three elements 3 1 roll 2 copy Bigger? {exch} if % ... (call them min mid max) 3 -1 roll 2 copy Bigger? {exch} if % ... subsort finished 9 index % A N A N-1 A (N-1)/2 A 0 min mid max N 3 eq { 5 2 roll put 4 1 roll put put % store min/mid/max back pop pop % pop A & N } { % else store mid at 0, max at N-1, min at (N-1)/2, then partition 3 -1 roll 5 2 roll put exch 4 1 roll put put % A N /Key 2 index 0 get def % partitioning value 0 % A N 0, also known as A j i { % main partitioning loop % incr i until i=j or A[i]>=A[0]; note A[j] is rangecheck { 1 add 2 copy gt { % i++; A j i j>i? dup 3 index exch get % A j i A[i] Key exch Bigger? not {exit} if } {exit} ifelse } loop % decr j until A[j]<=A[0]; happens at j=i-1 if not sooner exch { % A i j 1 sub dup 3 index exch get % A i j A[j] Key Bigger? not {exit} if } loop 2 copy gt {exit} if % if i>=j, finished partition % swap A[j] & A[i]; stack has: A i j 2 index 4 copy exch get % A i j A A i A[j] 4 1 roll get % A i j A[j] A A[i] 3 index exch put % A i j A[j] 4 copy exch pop put pop exch % A j i } loop % finish partition by exchanging A[j] with A[0]; stack has: A i j exch pop 2 copy 4 copy get % A j A j A j A[j] exch pop 0 exch put Key put % A j % now recur on A[0..j-1] and A[j+1..N-1] 2 copy 1 add 1 index length 1 index sub % A j A j+1 N-1 getinterval 3 1 roll 0 exch getinterval % A[j+1..N-1] A[0..j-1] 2 copy length exch length gt {exch} if % put smaller on top quickrecur quickrecur % tail recursion avoids deep stack } ifelse % =3 or >3 elements } { % handle 1- and 2-element cases specially for efficiency 2 eq { dup aload pop Bigger? {aload 3 1 roll exch 3 -1 roll astore} if } if pop % pop the array } ifelse } def % quickrecur % end of quicksort /shift-names 10 dict def shift-names begin /Meta false def /Shift false def /Control false def end % shift-names /update-shifts { shift-names {store} forall /KeyState get { shift-names 1 index known { true store } { pop } ifelse } forall } store /key-names 40 dict def key-names begin 8 (Backspace) def 9 (Tab) def 10 (Newline) def 13 (Return) def 27 (Escape) def 32 (Space) def 127 (Delete) def end % key-names /key-name { % key => string dup type /integertype eq { dup 127 and key-names 1 index known { key-names exch get } { dup 32 lt { 64 add cvis (^%) sprintf } { cvis } ifelse } ifelse exch 128 ge { (Meta-%) sprintf } if } { (%) sprintf } ifelse } store /comment-string { % obj => string dup type /arraytype eq { dup length 2 ge { dup 1 get /comment eq { 0 get } if } if } if (%) sprintf } def /destroy { % dummy destroy method } def % Forward messages on to stack /prompt { {} execute-it } def /execute-it { /execute-it dialog-item send } def /exec-it { /exec-it dialog-item send } def /push-it { /push-it dialog-item send } def /kbd-select-object { gsave can setcanvas select-object grestore } def /kbd-select-pointer { gsave can setcanvas select-pointer grestore } def /kbd-select-interval { gsave can setcanvas select-interval grestore } def /remove-returns { % str => str' dup (\r) search not { pop } { % str rest \r pre length 1 add exch pop % str rest len 3 -1 roll dup length string copy % rest len str' 3 1 roll { % str' rest len 2 index 1 index 1 sub 10 put exch (\r) search { % str' len rest \r pre length 1 add exch pop % str' len rest len 3 -1 roll add % str' rest len } { % str' len rest pop pop exit } ifelse } loop } ifelse } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Pallets of useful functions Pallets begin /Debug dictbegin /backtrace {DbgImplicitBreak DbgGetExecStack} def /clear /clear load def /continue { dbgcontinue dstack } def /copy&continue { dbgcopystack dbgcontinue dstack } def /dbgenter { dbgenter dstack } def /dbgexit { dbgexit dstack } def /dictstack { dstack } def /enter-it { selected-object enter } def /exec /exec load def /exit /exit load def /kill { dbgkill dstack } def /listbreaks /dbglistbreaks load def /redefine-it { % undefined (select correct spelling) => - userdict begin dup cvlit [ selected-object (%) sprintf cvn cvx ] cvx def end exec } def /stack /stack load def /where /dbgwhere load def dictend def /Number dictbegin 0 {10 mul} def 1 {10 mul 1 add} def 2 {10 mul 2 add} def 3 {10 mul 3 add} def 4 {10 mul 4 add} def 5 {10 mul 5 add} def 6 {10 mul 6 add} def 7 {10 mul 7 add} def 8 {10 mul 8 add} def 9 {10 mul 9 add} def /Back {10 div floor} def /Reset {0 mul} def /Enter {0} def dictend def currentautobind false setautobind /Math { {add sub mul div idiv mod} {neg abs min max} {ceiling floor round truncate} {cos sin tan arcsin arccos arctan atan exp ln log sqrt} {random rand} {etc, etc, etc...} {(Add your own!)} } cvlit def /Stack { dup pop exch clear load def store get put aload forall [ ] } cvlit def /Window 20 dict begin /new { framebuffer /new DefaultWindow send { newprocessgroup /reshapefromuser 1 index send /map exch send } fork waitprocess pop dup /ClientCanvas get setcanvas (%% Now on ) print currentcanvas == } def dictend def setautobind end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Item managment /createitems { ItemLock { /items [ Stack 0 {click-point} can /new StructItem send 20 10 0 0 /reshape 5 index send Stack 1 {} can /new TextStructItem send 20 50 0 0 /reshape 5 index send ] def /SP items length store /dialog-item items 1 get store {/PinHeight 600 def /StackI 1 def} dialog-item send /ThisI 1 store } monitor } def /slideitem { % items fillcolor item => - ItemLock { gsave dup 4 1 roll % item items fillcolor item {ItemCanvas canvastotop moveinteractive location move} exch send % item grestore } monitor } def /update-slide-interests { CurrentEvent /ClientData get % Index items exch get % item dup /ItemCanvas get % item can MiddleMouseButton [items FillColor % item can name [ dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest expressinterest } def /update-start-interests { CurrentEvent /ClientData get % Index items exch get % item mark [/makestartinterests 3 index send aload pop] {dup xcheck {exec} {expressinterest} ifelse} forall cleartomark pop } def /start-event-mgrs { % Create event manager to slide around the items. % Create a bunch of interests to move the items. % Note we actually create toe call-back proc to have the arguments we need. % The proc looks like: {items color "thisitem" slideitem}. % We could also have used the interest's clientdata dict. slidemgr null ne {slidemgr killprocess} if { %XXX /slidemgr [ items { % key item dup /ItemCanvas get % item can MiddleMouseButton [items FillColor % item can name mark dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest } forall /UpdateInterests /update-slide-interests null can eventmgrinterest ] forkeventmgr store } pop %XXX itemmgr null ne {itemmgr killprocess} if /itemmgr [ items iteminterests aload pop /UpdateInterests /update-start-interests null can eventmgrinterest ] forkeventmgr store } def %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Window class definition /DeckWindow DefaultWindow dictbegin /FrameLabel (CyberSpace Deck) def /IconLabel (CyberSpace Deck) def /IconImage /galaxy def dictend classbegin /dragframe? true def /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 } (Reboot) {/kbd-reboot dialog-item send} % (Credits) { /display-credits win send } (Break Window) { clear /BrokenWindow /dbgbreak win send } (Break Struct) { clear /BrokenStruct /dbgbreak % it or item 0: it null ne it items 0 get ifelse send } ] /new DefaultMenu send def /display-credits { gsave framebuffer setcanvas currentcursorlocation [ (CyberSpace Deck:) ( 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 DeckWindow send store % Create a window %0 0 900 900 /reshape win send /reshapefromuser win send /can win /ClientCanvas get def % BOO HISS can /Parent get /Retained true put createitems % /reshapefromuser win send /map win send start-event-mgrs