don@BRILLIG.UMD.EDU (Don Hopkins) (03/11/89)
I will post instructions to this soon (I have to catch a flight!), but
as an experiment, try it out and see what you can figure out on your
own, and then when I send instructions, you can tell me what features
were hopelessly obscure. ;-)
Hints: FunctionF10 (Alternate) is "help". Double click the left button
on things to open them. Shift, Control, and Meta do special stuff.
Press L9 (Find) for completion!
-Don
%!
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% PostScript Structure CyberSpace
% Copyright (C) 1989
% By Don Hopkins
% 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
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% StructItem class definition
/StructItem LabeledItem
dictbegin
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Instance variables
/Shrink .8 def
/Pad 3 def
/StartPoint 14 def
/Point StartPoint def
/x 0 def
/y 0 def
/Levels 0 def
/DL null def
/ItemFrame 2 def
/ItemRadius 5 def
/ItemBorder 6 def
% /ItemButton [PointButton MenuButton] def
/ItemButton [PointButton AdjustButton MenuButton] def
/StackI null def
/LayoutLock null def
/LastX 0 def
/LastY 0 def
/LastTime 0 def
/DX 0 def /DY 0 def
/TabX 0 def /TabY 0 def /TabWidth 0 def /TabHeight 0 def
/PinX 0 def
/StartIndex 0 def
/LastIndex 0 def
/MySiblings null def
/View /layout-struct def
/Click /click-struct def
/lw null def
/lh null def
/lx null def
/ly null def
dictend
classbegin
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Class variables
/DoubleClickTime 1 60 div def
/CanvasYFudge 2 store
/Sort? true def
/LineGap 30 def
/ItemLabelFont /Helvetica-Bold findfont 14 scalefont def
/ItemFont /Courier findfont def
/ItemXFont /Courier-Oblique findfont def
/Icon? false def
/SortBy /by-name def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Initialization stuff
/new { % Collection Index notifyproc parentcanvas => instance
4 2 roll 2 copy get type (% \267) sprintf % notify parent cont ind label
5 1 roll 2 array astore % label notify parent object
3 1 roll /Right % label object notify parent loc
3 1 roll % label object loc notify parent
/new super send begin
ItemCanvas /Transparent false put
ItemCanvas /Retained true put
/LayoutLock createmonitor def
/xhair /xhair_m ItemCanvas setstandardcursor
currentdict end
} def
/ensure-DL {
DL null eq {
Collection Index Levels grow-struct
/DL exch store
/ObjectWidth 0 store
} if
ObjectWidth 0 eq ObjectHeight 0 eq or {
perform-layout
} if
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Event handlers
/ClientDown {
CurrentEvent update-shifts
CurrentEvent /Name get MenuButton eq {
event-in-tab? {
show-tab-menu
} {
show-struct-menu
} ifelse
} {
CurrentEvent /Name get AdjustButton eq {
CurrentEvent recallevent
event-in-tab? {
items FillColor self slideitem
} {
do-search
ob null eq {
items FillColor self slideitem
} {
make-selection
} ifelse
} ifelse
} {
CurrentEvent /Name get PointButton eq {
event-in-tab? {
toggle-icon
} {
do-search
ob null eq {
} {
NotifyUser
} ifelse
} ifelse
} if
} ifelse
} ifelse
} def
/make-selection {
obs length 1 le {
/MySiblings [ob] store
/TipY null def
/Multiple? false def
}{
obs dup length 2 sub get
/MySiblings 1 index /Branches get store
/TipY exch dup /Y get exch /H get 2 div add def
/Multiple?
ob /C get type /arraytype eq
Shift and
def
} ifelse
/StartIndex
0 MySiblings {
/I get ob /I get eq { exit } if
1 add
} forall
store
/LastIndex StartIndex store
ItemCanvas createoverlay setcanvas
ObjectX ObjectY ObjectHeight add translate
currentcursorlocation
{ newpath pop pop
/LastIndex
0 MySiblings {
/Y get y le {
exit
} if
1 add
} forall
MySiblings length 1 sub min
store
Multiple? not {
/StartIndex LastIndex store
} if
TipY null ne {
ob /X get LineGap sub TipY moveto
MySiblings StartIndex LastIndex min get begin
X Pad sub Y H add lineto
end
MySiblings StartIndex LastIndex max get begin
X Pad sub Y lineto
end
closepath
fill
} if
MySiblings StartIndex LastIndex min get begin
X 1 sub Y H add moveto
end
StartIndex LastIndex min 1 StartIndex LastIndex max {
MySiblings exch get begin
X W add LineGap sub 1 add dup Y H add lineto
Y lineto
end
} for
MySiblings StartIndex LastIndex max get begin
X 1 sub Y lineto
end
closepath
Shift { stroke } { fill } ifelse
} getanimated waitprocess
ob /C get
Multiple? {
StartIndex LastIndex 2 copy gt {exch} if
1 index sub 1 add
kbd-select-interval
} {
MySiblings LastIndex get /I get
Shift {
kbd-select-object pop
} {
kbd-select-pointer
} ifelse
} ifelse
/MySiblings null store
} store
/show-tab-menu {
userdict /it self put
CurrentEvent /showat TabMenu send
} def
/show-struct-menu {
ItemBegin
do-search
ob null ne {
CurrentEvent /showat StructMenu send
} if
ItemEnd
} store
/ClientUp {
StopItem
} def
/click-exec {
ItemBegin
ItemCanvas setcanvas
CurrentEvent begin
LastX XLocation sub dup mul LastY YLocation sub dup mul add
end
do-search
ob null ne {
ob /Obj get exec-it
} if
ItemEnd
} def
/click-point {
/Click load cvx exec
} def
/open-icon {
Icon? {
/ObjectWidth OW store
/ObjectHeight OH store
currentdict /Icon? undef
redo-shape
} if
} def
/close-icon {
Icon? not {
gsave
/OW ObjectWidth def
/OH ObjectHeight def
Font setfont Str stringbbox points2rect
/IconH exch def /IconW exch def
/ObjectWidth IconW store
/ObjectHeight IconH store
grestore
/Icon? true def
redo-shape
} if
} def
/toggle-icon {
DL begin
Icon? { open-icon } { close-icon } ifelse
end
/LastTime 0 store
} def
/click-struct {
ItemCanvas setcanvas
CurrentEvent begin
LastX XLocation sub dup mul LastY YLocation sub dup mul add
end
4 lt currenttime LastTime sub DoubleClickTime lt and not {
% first click
ob null ne {
Shift { % Shift to select the index
ob /I get
} {
ob /Obj get
} ifelse
/LastTime currenttime store
Control {
exec-it
/LastTime 0 store
} {
kbd-select-object
} ifelse
} if
ItemCanvas setcanvas
CurrentEvent begin
/LastX XLocation store /LastY YLocation store
end
} {
% double clicks
ob null ne {
DL begin Icon? end {
toggle-icon
} {
Shift {
ob /L get 1 add open-struct
} {
ob /L get 0 eq {
1 open-struct
} {
close-struct
} ifelse
} ifelse
} ifelse
} if
/LastTime 0 store
} ifelse
} store
/event-in-tab? {
ItemBegin
newpath label-bbox rectpath
CurrentEvent begin XLocation YLocation end pointinpath
ItemEnd
} def
/ClientExit {
StopItem
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Menu definitions
/PointMenu [
(2) (4) (6) (8) (10) (12) (14) (16) (18) (20) (22) (24) (28) (32)
] [
{currentkey cvi {/StartPoint exch def redo-layout} it send}
] /new DefaultMenu send def
/LocationMenu [
(LeftBelow) (LeftAbove) (AboveLeft) (AboveRight)
(RightAbove) (RightBelow) (BelowRight) (BelowLeft)
] [
{ currentkey cvn
{/ObjectLoc exch def location 10 10 reshape damage-view}
it send}
] /new DefaultMenu send store
LocationMenu /PieInitialAngle 360 16 div put
/ShrinkMenu [
(.1) (.2) (.3) (.4) (.5) (.6) (.7) (.8) (.9) (1)
] [
{currentkey cvr {/Shrink exch def redo-layout} it send}
] /new DefaultMenu send def
/ClickMenu [
(click-struct) (click-exec)
] [
{currentkey cvn {/Click exch def} it send}
] /new DefaultMenu send def
/TabMenu [
(Point...) PointMenu
(Paint) {/paint it send}
(Click..) ClickMenu
(Zap) {/Free it send}
(Shrink...) ShrinkMenu
(Layout) {/redo-layout it send}
(Location...) LocationMenu
(Print) {/write-DL it send}
] /new DefaultMenu send store
/ChangeMenu [
(toke in) { /token-obj it send }
(executable){ /cvx-obj it send }
(name) { /cvn-obj it send }
(string) { /cvs-obj it send }
(toke out) { /tokout-obj it send }
(literal) { /cvlit-obj it send }
(integer) { /cvi-obj it send }
(real) { /cvr-obj it send }
] /new DefaultMenu send def
/UtilMenu [
(undef) { /undef-obj it send }
(molecule) { /molecule-obj it send }
(select) { ob /Obj get kbd-select-object }
(--) {}
(nulldef) { /nulldef-obj it send }
(--) {}
(reference) { /reference-obj it send }
(--) {}
] /new DefaultMenu send def
UtilMenu /PieInitialAngle 45 put
/StructMenu [ % Note: depends on fixed getmenuarg
(push) {/push-obj it send}
(type...) /FigureTypeAction cvx
(load) {/load-obj it send}
(util...) UtilMenu
(exec) {/exec-obj it send}
(change...) ChangeMenu
(paste) {/paste-obj it send}
(open) {getmenuarg cvi /open-obj it send}
]
/PulloutPieMenu where { pop
[ nullarray
[ [ { gsave
/Screen findfont 12 scalefont setfont
ob /Obj get type 30 string cvs
0 1 index length 4 sub getinterval % drop "type"
exch /paint eq {
0 currentfont fontdescent rmoveto
show
} {
stringbbox points2rect 4 2 roll pop pop
} ifelse
grestore } ]
]
nullarray nullarray nullarray nullarray nullarray
[(0) (1) (2) (3) (4) (5) (6) (7)]
] exch
/new PulloutPieMenu send def
} {
/new DefaultMenu send def
StructMenu /getmenuarg {ob /L get 0 eq 1 0 ifelse} put
} ifelse
{ /LabelMinRadius 25 def
/FigureTypeAction {
ob /Obj get type {
/arraytype { /ArrayMenu it send }
/stringtype { /StringMenu it send }
/dicttype { /DictMenu it send }
/processtype { /ProcessMenu it send }
/canvastype { /CanvasMenu it send }
/eventtype { /EventMenu it send }
/Default {
{ gsave
framebuffer setcanvas
currentcursorlocation
[ (Nothing)(Happens)(Here!) ] popmsg pop
grestore }
}
} case
} def
} StructMenu send
/ArrayMenu [
(prepend) { /prepend-to-array-obj it send } % selected array
(push) { /push-array-obj it send } % selected object
(append) { /append-to-array-obj it send } % selected array
(pop) { /pop-array-obj it send } % to selection
] /new DefaultMenu send def
/StringMenu [
(prepend) {} % selected string
(forall) {} % selected function
(append) {} % selected string
] /new DefaultMenu send def
/DictMenu [
(def) { /def-in-dict-obj it send } % selected function
(merge) {} % selected dict
] /new DefaultMenu send def
/ProcessMenu [
(kill) {}
(kill group) {}
(suspend) {}
(resume) {}
(wait) {} % select return value
(userdict) {} % select userdict
] /new DefaultMenu send def
/CanvasMenu [
(manager) {} % select /Interests 0 /Process
(bbox) {} % select [x y w h]
(setcanvas) {} % changes proc's gstate
(zap) {} % unretain & unmap whole tree
] /new DefaultMenu send def
/EventMenu [
(express) {} % Does this make any sense in this context?
(revoke) {}
(sendevent) {}
] /new DefaultMenu send def
% integer real file path color ...
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Menu callbacks
/push-array-obj {
ob /Obj get
dup [ selected-object ] append
exch xcheck { cvx } if
replace-obj
} def
/pop-array-obj {
ob /Obj get
dup length 0 eq { pop } {
dup dup length 1 sub get kbd-select-object
0 1 index length 1 sub getinterval
replace-obj
} ifelse
} def
/prepend-to-array-obj {
selected-object dup type /arraytype ne { pop } { % [sel]
ob /Obj get % [sel] {obj}
exch 1 index % {obj} [sel] {obj}
append % {obj} [sel obj]
exch xcheck { cvx } if % {sel obj}
replace-obj
} ifelse
} def
/append-to-array-obj {
selected-object dup type /arraytype ne { pop } { % [sel]
ob /Obj get % [sel] {obj}
dup 3 -1 roll % {obj} {obj} [sel]
append % {obj} [obj sel]
exch xcheck { cvx } if % {obj sel}
replace-obj %
} ifelse
} def
/def-in-dict-obj {
selected-pointer? { % collection index
ob /Obj get % collection index dict
2 copy exch known
1 index type /dicttype eq or not { pop pop } {
1 index % collection index dict index
4 -2 roll get % dict index obj
3 copy put pop % dict index
ob /Branches get null eq { pop pop } {
0 grow-struct % DL
ob begin
/Branches [ % DL mark
Branches { % DL mark branch
dup /I get
counttomark 2 add index /I get
eq {pop} if
} forall
counttomark 3 add -1 roll % mark branches... DL
] Sort? {SortBy quicksort} if def %
end
} ifelse
redo-layout
} ifelse
} if
} store
% Execute token with Externals on the dict stack, so externalized
% //&type_123 object references are resolved.
/token-obj {
{ clear Externals begin
ob /Obj get remove-returns
{ { token { exch } { exit } ifelse
} loop
} errored {
clear ob /Obj get
} {
count array astore cvx
} ifelse
end
} fork waitprocess
replace-obj
} def
/cvx-obj {
{ ob /Obj get cvx } errored {pop} {
replace-obj
} ifelse
} def
/cvn-obj {
{ ob /Obj get cvn } errored {pop} {
replace-obj
} ifelse
} def
/cvs-obj {
{ ob /Obj get 256 string cvs } errored {pop} {
replace-obj
} ifelse
} def
/tokout-obj {
ob /Obj get tokout replace-obj
} def
/cvlit-obj {
{ ob /Obj get cvlit } errored {pop} {
replace-obj
} ifelse
} def
/cvi-obj {
{ ob /Obj get cvi } errored {pop} {
replace-obj
} ifelse
} def
/cvr-obj {
{ ob /Obj get cvr } errored {pop} {
replace-obj
} ifelse
} def
/load&push-obj {
ob /Obj get load&push-it
} def
/load&push-it { %
[ exch cvlit {dup load} /errored cvx
{ pop (%% ) (%Load: % is not defined!\n) printf }
{ exch 1 index exch (%% ) (%Load: % Push: %\n) printf }
/ifelse cvx ] cvx
execute-it
} def
/load-obj {
ob /Obj get load-it
} def
/load-it { %
[ exch cvlit {dup load} /errored cvx
{ pop (%% ) (%Load: % is not defined!\n) printf }
{ exch 1 index exch (%% ) (%Load: % Select: %\n) printf
select-object } /ifelse cvx ] cvx
execute-it
} def
/open-obj { % levels => -
dup 0 eq { pop close-struct } { open-struct } ifelse
} def
/push-obj {
ob /Obj get push-it
} def
/push-it {
[ exch [ exch ] 0 /get cvx
/dup cvx (%% ) (%Push: %\n) /printf cvx ] cvx
execute-it
} def
/nulldef-obj {
ob /Obj get % dict
dup type /dicttype ne { pop } {
selected-object dup null eq { pop } { % dict key
2 copy null put
ob /Branches get null eq { pop pop } {
ob /L get grow-struct % DL
ob begin
/Branches [ % DL /B mark
Branches {
dup /I get
counttomark 2 add index /I get
eq {pop} if
} forall % DL /B mark branches...
counttomark 3 add -1 roll % /B mark branches... DL
] Sort? {SortBy quicksort} if def %
end
} ifelse
redo-layout
} ifelse
} ifelse
} store
/undef-obj {
ob /Obj get
dup type /dicttype ne { pop } {
selected-object dup null eq { pop } {
2 copy known {
2 copy undef
ob begin
Branches null ne {
/Branches [
Branches {
begin /C load /I load known { currentdict } if end
} forall
] def
} if
end
redo-layout
} if
} ifelse
} ifelse
} store
/molecule-obj {
systemdict /start_visualizer known not {
(NeWS/molecule.ps) LoadFile pop
} if
ob /Obj get start_visualizer
} def
% construct a reference to a piece of substructure relative to the
% top level object
/reference-obj {
obs length 2 lt { {} } {
[ objs dup 1 exch length 1 sub getinterval {
/I get cvlit /get cvx
} forall
] cvx kbd-select-object
} ifelse
} def
/exec-obj {
ob /Obj get exec-it
} def
/exec-it { % obj => -
{ [ exch cvlit /cvx cvx
/dup cvx (%% ) (%Exec: %\n) /printf cvx
cvx /exec cvx ] cvx
execute-it
} fork pop pause
} def
/paste-obj {
selected-object
replace-obj
} def
/replace-obj { % obj => -
ob begin
replace-struct
end
Meta not { redo-layout } if
ob DL eq StackI null ne and { % Tell processes if we changed its stack.
/ReplaceStack items StackI get send
} if
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Moving and shaping
/just-reshape {
ItemCanvas null ne { ItemCanvas /Mapped false put } if
/ItemHeight exch def /ItemWidth exch def
ItemWidth 0 eq ItemHeight 0 eq and {
/DL null store
} if
ensure-DL
adjust-geometry
ItemWidth ItemHeight /reshape super send
gsave ItemCanvas setcanvas ItemFillColor fillcanvas grestore
ItemCanvas /Mapped true put
} def
/reshape { % x y w h
just-reshape
location move
} def
/just-move {
/move super send
} def
/move { % x y
label-bbox /lh exch store /lw exch store % x y lx ly
2 index add /ly exch store % x y lx
2 index add /lx exch store % x y
ly 0 max /ClientHeight win send lh sub min ly sub add exch
lx 0 max /ClientWidth win send lw sub min lx sub add exch
/move super send
snaps-here? pop
Index ThisI eq {/paint-hilite win send} if
StackI null ne StackI Index ne and {
/MoveMe TellStack
} if
} store
/redo-layout {
perform-layout
redo-shape
} def
/redo-shape {
%location 10 10 just-reshape
location 10 10 reshape
damage-view
} def
/label-bbox { % x y w h
TabX TabY TabWidth TabHeight
} def
/tab-top { % - => y
location TabY add TabHeight add exch pop
} def
/tab-bottom { % - => y
location TabY add exch pop
} store
/label-rect { % X Y w h
location TabY add exch TabX add exch TabWidth TabHeight
} def
/object-bbox { % x y w h
ObjectX ItemBorder sub ObjectY ItemBorder sub % x y
ObjectWidth ItemBorder dup add add % w
ObjectHeight ItemBorder dup add add % h
} def
/ItemPath {
ItemRadius label-bbox rrectpath
ItemRadius object-bbox rrectpath
} def
/AdjustItemSize { % - => - [uses item context]
ObjectLoc [
/Right /Left /RightBelow /RightAbove /LeftBelow /LeftAbove {
/ItemWidth ItemBorder 3 mul ItemGap add
LabelWidth add ObjectWidth add def
/ItemHeight ItemBorder 2 mul LabelHeight
ObjectHeight max add def
}
/Top /Bottom /AboveLeft /AboveRight /BelowLeft /BelowRight {
/ItemWidth ItemBorder 2 mul LabelWidth ObjectWidth max add def
/ItemHeight ItemBorder 3 mul ItemGap add
LabelHeight add ObjectHeight add def
}
] case
} store
/CalcObj&LabelXY { % - => - [uses item context]
ObjectLoc {
/RightAbove {
/LabelX ItemBorder def /LabelY ItemBorder store
/ObjectX ItemBorder dup add LabelWidth add ItemGap add store
/ObjectY ItemHeight ObjectHeight sub 2 div store
/TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
/TabWidth
ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store
/TabHeight LabelHeight ItemBorder dup add add def }
/RightBelow /Right {
/LabelX ItemBorder store
/LabelY ItemHeight ItemBorder sub LabelHeight sub store
/ObjectX ItemBorder dup add LabelWidth add ItemGap add store
/ObjectY ItemHeight ObjectHeight sub 2 div store
/TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
/TabWidth
ItemBorder LabelWidth add ItemGap add ItemRadius dup add add store
/TabHeight LabelHeight ItemBorder dup add add def }
/LeftAbove {
/LabelX ItemBorder dup add ItemGap add ObjectWidth add store
/LabelY ItemBorder store
/ObjectX ItemBorder store
/ObjectY ItemHeight ObjectHeight sub 2 div store
/TabX LabelX ItemGap sub ItemRadius dup add sub store
/TabY LabelY ItemBorder sub store
/TabWidth
ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store
/TabHeight LabelHeight ItemBorder dup add add def }
/LeftBelow /Left {
/LabelX ItemBorder dup add ItemGap add ObjectWidth add store
/LabelY ItemHeight ItemBorder sub LabelHeight sub store
/ObjectX ItemBorder store
/ObjectY ItemHeight ObjectHeight sub 2 div store
/TabX LabelX ItemGap sub ItemRadius dup add sub store
/TabY LabelY ItemBorder sub store
/TabWidth
ItemRadius dup add ItemGap add LabelWidth add ItemBorder add store
/TabHeight LabelHeight ItemBorder dup add add def }
/AboveRight /Top {
/LabelX ItemBorder def /LabelY ItemBorder store
/ObjectX ItemWidth ObjectWidth sub 2 div store
/ObjectY ItemBorder dup add LabelHeight add ItemGap add store
/TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
/TabWidth LabelWidth ItemBorder dup add add store
/TabHeight
ItemBorder LabelHeight add ItemGap add ItemRadius dup add add
def }
/AboveLeft {
/LabelX ItemWidth ItemBorder sub LabelWidth sub store
/LabelY ItemBorder store
/ObjectX ItemWidth ObjectWidth sub 2 div store
/ObjectY ItemBorder dup add LabelHeight add ItemGap add store
/TabX LabelX ItemBorder sub def /TabY LabelY ItemBorder sub store
/TabWidth LabelWidth ItemBorder dup add add store
/TabHeight
ItemBorder LabelHeight add ItemGap add ItemRadius dup add add
def }
/BelowRight /Bottom {
/LabelX ItemBorder store
/LabelY ItemBorder dup add ObjectHeight add ItemGap add store
/ObjectX ItemWidth ObjectWidth sub 2 div store
/ObjectY ItemBorder store
/TabX LabelX ItemBorder sub store
/TabY LabelY ItemGap sub ItemRadius dup add sub store
/TabWidth LabelWidth ItemBorder dup add add store
/TabHeight
ItemRadius dup add ItemGap add LabelHeight add ItemBorder add
def }
/BelowLeft {
/LabelX ItemWidth ItemBorder sub LabelWidth sub store
/LabelY ItemBorder dup add ObjectHeight add ItemGap add store
/ObjectX ItemWidth ObjectWidth sub 2 div store
/ObjectY ItemBorder store
/TabX LabelX ItemBorder sub store
/TabY LabelY ItemGap sub ItemRadius dup add sub store
/TabWidth LabelWidth ItemBorder dup add add store
/TabHeight
ItemRadius dup add ItemGap add LabelHeight add ItemBorder add
def }
} case
/PinX LabelX LabelWidth add 2 sub store
} def
/adjust-geometry {
/ItemLabel Collection Index get type (% \267) sprintf store
LabelSize /LabelHeight exch def /LabelWidth exch def
AdjustItemSize
CalcObj&LabelXY
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Display
/PaintItem {
LayoutLock {
ItemRadius label-bbox rrectpath
ItemFillColor setcolor fill
ItemFrame 0 gt {
ItemFrame ItemRadius label-bbox rrectframe
ItemBorderColor setcolor eofill
} if
ItemRadius object-bbox rrectpath
ItemFillColor setcolor fill
ItemFrame 0 gt {
ItemFrame ItemRadius object-bbox rrectframe
ItemBorderColor setcolor eofill
} if
ShowLabel
paint-struct
} monitor
} store
/paint-struct {
gsave
ensure-DL
ItemTextColor setcolor
ObjectX ObjectY ObjectHeight add translate
DL draw-struct
grestore
} def
/damage-view {
gsave
%ItemParent setcanvas bbox rectpath extenddamage
paint
grestore
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Accessers
/Collection {
ItemObject 0 get cvlit
} def
/Index {
ItemObject 1 get cvlit
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Structure stuff
/old-search-struct { % proc x y dict => proc x y
begin
dup Y ge {
dup Y H add lt {
% Path setpath
newpath X Y W H rectpath
%(x % y % X % Y % W % H % \n)[3 index 3 index X Y W H ]dbgprintf
2 copy pointinpath {
2 index exec
} {
Branches null ne {
Branches {
search-struct
} forall
} if
} ifelse
} if
} if
end
} def
/do-search {
/it self store
DL begin Icon? end {
/obs [ DL ] store
/ob DL store
} {
gsave
ItemCanvas setcanvas
ObjectX ObjectY ObjectHeight add translate
DL
CurrentEvent begin XLocation YLocation end
search-struct
/obs exch store
obs length 0 eq { null } {
obs dup length 1 sub get
} ifelse
/ob exch store
grestore
} ifelse
} def
% Return the path down the display list to the substructure enclosing (x,y).
/search-struct { % dict x y => [ dl1 dl2 ... dln ]
10 dict begin
/ssy exch def /ssx exch def
[ exch
{ do-search-struct
% unsucessful search
exit
} loop % catch possible exit
]
end
} def
/do-search-struct { % dl => dl dl' dl'' dl''' ...
begin
ssx X ge {
ssy Y ge {
ssx X W add le {
ssy Y H add le {
currentdict Branches end
dup null eq { pop } {
{ do-search-struct } forall
} ifelse
exit % skip past all the ends on the execution stack
} if
} if
} if
} if
end
} store
/close-struct {
gsave
DL /Icon? undef
ItemCanvas setcanvas
ObjectX ObjectY ObjectHeight add translate
ob /L 0 put
ob /Branches null put
Meta not { redo-layout } if
grestore
} def
/open-struct { % levels => -
gsave
DL /Icon? undef
ItemCanvas setcanvas
ObjectX ObjectY ObjectHeight add translate
ob begin
grow-substruct
end
Meta not { redo-layout } if
grestore
} def
% (dl on dictstack)
/replace-struct { % obj => -
C I 3 -1 roll put
C I L grow-struct
begin
/Branches Branches
/C dup load /I dup load % /L L
/Obj dup load /Str Str
/X X /Y Y /W W /H H
/Font Font
end
def def def def def def def def def def def
} def
/grow-substruct { % l => -
/L exch def
% /forbidden? {pop false} def
/Branches
C I L grow-struct
1 index get def
% currentdict /forbidden? undef
} def
/composite? { % obj => bool
type {
/arraytype /dicttype /canvastype
/processtype /eventtype /fonttype
{true}
/Default
{false}
} case
} def
/forbidden-dict 50 dict def
forbidden-dict begin
/Interests null def
/Process null def
/BuildChar null def
/Encoding null def
/WidthArray null def
/ParentDictArray null def
/ParentDict null def
/TopCanvas null def
/BottomCanvas null def
/TopChild null def
/CanvasAbove null def
/CanvasBelow null def
/Parent null def
end % forbidden-dict
/forbidden? {
forbidden-dict exch known
currentdict ob ne and % forbidden things must be be explicitly opened.
} def
% Collection Index Levels => dict
/grow-struct {
/xcurs /xcurs_m ItemCanvas setstandardcursor
LayoutLock {
/hourg /hourg_m ItemCanvas setstandardcursor
do-grow-struct
} monitor
/xhair /xhair_m ItemCanvas setstandardcursor
} def
/do-grow-struct {
pause
32 dict begin
/L exch def
cvlit /I exch def cvlit /C exch def
/Obj C I get def
/Str /Obj load I (% = %) sprintf def
/X 0 def
/Y 0 def
/W 0 def
/H 0 def
/StrY 0 def
/LineX 0 def
/Obj load composite?
I forbidden? not and
L 0 gt and {
/Obj load dup type /arraytype eq {
/Branches exch [ exch
{ pop /Obj load counttomark 1 sub L 1 sub do-grow-struct } forall
] def
} {
/Branches exch [ exch
{ pop /Obj load exch L 1 sub do-grow-struct } forall
] Sort? {SortBy quicksort} if def
} ifelse
} {
/Branches null def
} ifelse
currentdict end
} def
% /SortBy default:
/by-name {
/Str get exch /Str get lt
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Layout
/perform-layout {
/xcurs /xcurs_m ItemCanvas setstandardcursor
LayoutLock {
/hourg /hourg_m ItemCanvas setstandardcursor
/ItemLabel Collection Index get type (% \267) sprintf store
init-format DL do-layout
/ObjectHeight DL /H get store
adjust-geometry
} monitor
/xhair /xhair_m ItemCanvas setstandardcursor
} def
/init-format {
/Point StartPoint def
/x 0 def
/y 0 def
/ObjectWidth 0 def
/ObjectHeight 0 def
} def
/LineHeight {
Font fontheight 1 add
} def
/do-layout { % dict => -
begin
/View load cvx exec
end
pause
} def
/layout-struct { % - => -
/Str /Obj load I (% = %) sprintf def
/Obj load xcheck Point 10 ge and {
/Font ItemXFont Point scalefont def
} {
/Font ItemFont Point scalefont def
} ifelse
Font setfont
/X x def
/Y y def
/W Str stringwidth pop LineGap add def
Branches null eq { % Icon? or
/H LineHeight def
} {
/x x W add store
/Point Point Shrink mul store
Branches {
do-layout
} forall
/Point Point Shrink div store
/x x W sub store
0 0 % w h
Branches {
begin
exch W max
exch H add
end
} forall % W H
LineHeight max 1 max /H exch def
/LineX X W add LineGap sub def
W add /W exch def
} ifelse
/Y Y H sub def
/StrY Y Font fontdescent add H LineHeight sub 2 div add def
/y Y store
/ObjectWidth ObjectWidth x W add LineGap sub max store
} store
% dict => -
/draw-struct {
pause
begin
Icon? {
gsave
Font setfont
0 Font fontdescent IconH sub
2 copy moveto
Str show
translate
-2 ItemRadius
Str stringbbox points2rect
insetrrect rrectpath
0 setlinewidth
0 setgray
stroke
grestore
} {
show-obj
Branches null ne Icon? not and {
LineX
Y H 2 div add
Branches length 0 ne {
Branches 0 get begin
2 copy moveto
X Pad sub Y H add lineto
Pad 5 mul 0 rlineto
stroke
end
Branches {
begin
2 copy moveto
X Pad sub Y lineto
Pad 2 mul 0 rlineto
stroke
currentdict end
draw-struct
} forall
Branches dup length 1 sub get begin
2 copy moveto
X Pad sub Y lineto
Pad 5 mul 0 rlineto
stroke
end
} if
pop pop
} if
} ifelse
end
} store
/show-obj {
Font setfont
X StrY moveto
Str show
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Printing
% This needs to be brought up to date...
/write-DL { %
{ /f (DL.ps) (w) file def
f (%!\n) writestring
f (gsave 0 setgray 0 setlinewidth 20 20 translate\n) writestring
DL begin
f H W (%%) (%BoundingBox: 0 0 % %\n) sprintf writestring
end
/cur-font-name null def
/cur-font-size 0 def
DL print-struct
f (grestore showpage\n) writestring
f closefile
} stopped pop
} def
/print-struct { % dict => -
pause
begin
Font /FontMatrix get 0 get
/Obj load xcheck ItemXFont ItemFont ifelse /FontName get
1 index cur-font-size eq 1 index cur-font-name eq and { pop pop } {
2 copy /cur-font-name exch store /cur-font-size exch store
(/% findfont % scalefont setfont\n) sprintf
f exch writestring
} ifelse
Font setfont
Font fontdescent
StrY ObjectHeight add X
(% % moveto ) sprintf f exch writestring
Str ( (%) show\n) sprintf f exch writestring
Branches null ne Icon? not and {
X W add LineGap sub
Y H 2 div add ObjectHeight add
Branches {
begin
2 copy exch (% % moveto ) sprintf f exch writestring
X Pad sub Y ObjectHeight add exch (% % lineto ) sprintf
f exch writestring
Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring
f (stroke\n) writestring
currentdict end
print-struct
} forall
Branches length 0 ne {
Branches dup length 1 sub get begin
2 copy exch (% % moveto ) sprintf f exch writestring
X Pad sub Y H add ObjectHeight add exch (% % lineto ) sprintf
f exch writestring
Pad 2 mul 0 exch (% % rlineto ) sprintf f exch writestring
f ( stroke\n) writestring
end
} if
pop pop
} if
end
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Stack stuff
/execute-it { % obj => -
/exec-and-update dialog-item send
} def
/TellStack { % message => -
createevent begin
/Name exch def
/ClientData Index def
/Action StackI def
/Canvas ItemParent def
currentdict end sendevent
} def
/pack {
StackI null ne {
/PackStack items StackI get send
} if
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Snap dragging
/pinned? { % y h => bool
location pop PinX add 3 1 roll % x y h
6 exch % x y w h
pin-rect rectsoverlap
} store
% items backgroundcolor => - (interactively move item)
/moveinteractive {
ItemBegin
10 dict begin
/GA_constraint 0 def
/GA_value /calc_GA_value load def
currentcursorlocation
/DY exch def /DX exch def
currentcanvas mapcanvas false dragcanvas
end
ItemEnd
} store
/SnapIn {
ThisI StackI ne {
StackI null ne {
/PopMe TellStack
} if
/StackI ThisI store
/PushMe TellStack
} if
} def
/SnapOut {
StackI null ne StackI Index ne and {
/PopMe TellStack
/StackI null store
} if
} def
/snaps-here? { % - => bool
ThisI null eq ThisI Index eq or {false} {
/pin-rect items ThisI get send
label-rect
rectsoverlap dup {
SnapIn
} {
SnapOut
} ifelse
} ifelse
} def
/calc_GA_value {
StackI Index eq {
currentcursorlocation pop % cx
} {
StackI null eq {
snaps-here? {
location
pop DX add % ix
} {
currentcursorlocation pop % cx
} ifelse
} {
location TabY add TabHeight
/pinned? items StackI get send not {
SnapOut
pop currentcursorlocation pop % cx
} { % ix
{ location pop PinX add } items StackI get send % ItemX PinX
PinX sub % ItemX ItemGoal
exch 1 index exch sub % ItemGoal ItemDelta
currentcursorlocation pop % ItemGoal ItemDelta CurX'
2 index exch sub % ItemGoal ItemDelta CurDelta
DX add dup abs TabWidth gt {
SnapOut
pop pop pop currentcursorlocation pop DX sub
} {
1 index abs 1 index abs gt {exch} if % ItemGoal Close Far
pop % ItemGoal Close
% .2 mul sub
sub
} ifelse
DX add
} ifelse
} ifelse
} ifelse
} store
/NextPos { % - => x y
location % x y
label-bbox % X Y x y w h
exch pop add % X Y x y+h
3 -1 roll add % X x Y+y+h
exch 3 -1 roll add exch % X+x Y+y+h
exch PinX add exch
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Storage managment
/Free {
SnapOut
ItemCanvas /Retained false put
unmap
ItemLock {
/free-items [
free-items aload pop Index
] store
} monitor
} def
/init-attributes {
{/ObjectWidth /DL /Shrink /StartPoint /View /Click}
{ InstanceVarDict 1 index get store } forall
/ObjectLoc /Right store
adjust-geometry
} store
% obj => -
/Reuse {
Collection Index 3 -1 roll put
ItemCanvas /Retained true put
ItemCanvas canvastotop
init-attributes
%ensure-DL
%redo-layout
} store
/destroy {
ItemEventMgr null ne {
ItemEventMgr killprocess
} if
ItemCanvas /Retained false put
unmap
} def
classend def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% TextStructItem class definition
/TextStructItem StructItem
dictbegin
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Instance variables
/I null def
/MyStack null def
/MyProcess null def
/Scroller null def
/ScrollerWidth 16 def
/Notifier null def
/NotifierHeight 16 def
/SubItemGap 2 def
/SubItemMgr null def
/DeferedUpdateEvent null def
/UpdateDelay .5 60 div def
/PinHeight 0 def
/DropShadow 6 def
dictend
classbegin
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Class Variables
/TextWidth 700 def
/TextHeight 200 def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
/new {
/new super send begin
/MyStack [] def
/ItemLabel (processtype) def
currentdict end
} def
/kbd-reset {
/dialog-buf () store
/dialog-string () store
{ psh-socket bytesavailable string readstring pop
} errored
{(\n%% Reset!\n) print} execute-it
} def
/shut-down {
{ psh-socket (\ndbgstop\nquit\n) writestring
psh-socket flushfile
} errored pop
null null /DropDead TellMyProcess
1 60 div sleep
} def
/kbd-reboot {
{ /dialog-buf () store
/dialog-string () store
[ () (%% Reboot!) () ] true /writeatcaret dialog-text send
shut-down
psh-socket closefile
/psh-socket null store
ensure-DL
% { EventMgr null ne { EventMgr killprocess } if
% /EventMgr Interests forkeventmgr store
% KeyboardEventMgr null ne { KeyboardEventMgr killprocess } if
% /KeyboardEventMgr { KeyboardHandler } fork store
% } dialog-text send
start-event-mgrs
} fork waitprocess pop
} def
/use-selected-process {
selected-object dup type /processtype eq {
set-process
} if
} def
/adjust-geometry {
LabelSize /LabelHeight exch def /LabelWidth exch def
AdjustItemSize
CalcObj&LabelXY
} def
/DialogMenu [
(process) {/use-selected-process it send}
(reset) {/kbd-reset it send}
(pack) {/PackStack it send}
(reboot) {/kbd-reboot it send}
] /new DefaultMenu send def
/SelectionMenu [
(push) {{Collection Index get push-it} it send}
(load) {{Collection Index get load-it} it send}
(exec) {{Collection Index get exec-it} it send}
(change...) /ChangeMenu StructItem send
] /new DefaultMenu send def
/replace-obj { % obj => -
Collection Index 2 index put
kbd-select-object
} def
/show-tab-menu {
/it self store
CurrentEvent /showat DialogMenu send
} def
/show-struct-menu {
/it self store
/ob 20 dict store
ob begin
/C Collection def
/I Index def
/Obj Collection Index get def
end
CurrentEvent /showat SelectionMenu send
} def
/make-selection { % We ARE the selection.
} def
/pin-rect { % X Y w h
location exch PinX add 3 sub exch % x y
PinHeight 0 lt {
PinHeight add
} if
ItemHeight PinHeight abs add
6 exch
} def
/exec-and-update { % func => -
null /ExecIt TellMyProcess
} def
/TellMyProcess { % ClientData Action Name
8 { % wait up to 4 seconds if no process
MyProcess null eq { .5 60 div sleep } { exit } ifelse
} repeat
MyProcess null eq {
pop pop pop
gsave framebuffer setcanvas
currentcursorlocation [(No process!)] popmsg pop
grestore
} {
createevent begin
/Name exch def
/Action exch def
/ClientData exch def
/Process MyProcess def
currentdict end sendevent
} ifelse
} def
/UpdateStack { %
DeferedUpdateEvent null ne {
DeferedUpdateEvent recallevent
} if
/DeferedUpdateEvent CurrentEvent store
DeferedUpdateEvent begin
/Name /DeferedUpdate def
/TimeStamp currenttime UpdateDelay add def
end % event
DeferedUpdateEvent sendevent
} def
/DeferedUpdate { %
/DeferedUpdateEvent null store
[ /getcaretpos dialog-text send pop 1 gt { () } if
dialog-string dialog-buf
CurrentEvent /ClientData get length
(NeWS[%]> %%) sprintf
{ (\n) search { % chop string up at newlines
exch pop exch
} {
exit
} ifelse
} loop
]
true /writeatcaret dialog-text send
pause
CurrentEvent /ClientData get
SetStack
} def
/ProcessReady {
CurrentEvent dup /ClientData get
exch /Action get
set-process
} def
/set-process { % stack process => -
/MyProcess exch def
SetStack
{ currentprocess (%% ) (%Hello, my name is %!\n) printf } execute-it
} def
/SelectionChanged {
CurrentEvent /Action get /PrimarySelection eq {
CurrentEvent /ClientData get dissect-selection
Collection Index 2 index put
(%: %)
[ 3 -1 roll dup type exch ]
/printf Notifier send
} if
} def
/makestartinterests {
/makestartinterests super send
[ exch aload pop
/ProcessReady {/ProcessReady /Self GetFromCurrentEvent send}
null ItemCanvas eventmgrinterest
dup /Self self PutInEventMgrInterest
/UpdateStack {/UpdateStack /Self GetFromCurrentEvent send}
null ItemCanvas eventmgrinterest
dup /Self self PutInEventMgrInterest
/DeferedUpdate {/DeferedUpdate /Self GetFromCurrentEvent send}
null ItemCanvas eventmgrinterest
dup /Self self PutInEventMgrInterest
/SelectionChanged {/SelectionChanged /Self GetFromCurrentEvent send}
null null eventmgrinterest
dup /Self self PutInEventMgrInterest
/PushMe {/DoPushMe /Self GetFromCurrentEvent send}
Index ItemParent eventmgrinterest
dup /Self self PutInEventMgrInterest
/PopMe {/DoPopMe /Self GetFromCurrentEvent send}
Index ItemParent eventmgrinterest
dup /Self self PutInEventMgrInterest
/MoveMe {/DoMoveMe /Self GetFromCurrentEvent send}
Index ItemParent eventmgrinterest
dup /Self self PutInEventMgrInterest
]
} def
/DoPushMe {
CurrentEvent /ClientData get PushMe
} def
/DoPopMe {
CurrentEvent /ClientData get PopMe
} def
/DoMoveMe {
ItemLock {
SortStack ReplaceStack
} monitor
} def
/PushMe { % index => -
ItemLock {
/I exch def
/MyStack [
MyStack {
dup I eq {pop} if
} forall
I
] store
SortStack
GetStack
{Collection Index get} items I get send
80 string cvs (%% Push: ) exch append (\n) append
/ReplaceStack TellMyProcess
} monitor
} def
/PopMe { % index => -
ItemLock {
/I exch def
/MyStack [
MyStack {
dup I eq {pop} if
} forall
] store
GetStack
{Collection Index get} items I get send
80 string cvs (%% Pop: ) exch append (\n) append
/ReplaceStack TellMyProcess
} monitor
} def
/ReplaceStack {
ItemLock {
GetStack
null
/ReplaceStack TellMyProcess
} monitor
} def
/SortStack {
ItemLock {
MyStack {
/tab-top exch items exch get send exch
/tab-top exch items exch get send
lt
} quicksort pop
} monitor
} store
% To do:
% Make this premptable: Each pass it does one thing to make the
% display look more like MyStack. (bottom to top priority)
/SetStack { % stack => -
ItemLock {
ItemBegin 10 dict begin
/NewStack exch def
/OldStack 200 dict def
MyStack {
items 1 index get {Collection Index get} exch send
OldStack 3 1 roll put
} forall
/MyStack [] store
NewStack { % new
pause
/I null def
OldStack { % new ind old
dup 3 index eq { % new ind old
xcheck 2 index xcheck eq { % new ind
/I exch def exit % new
} { pop } ifelse % new
} { pop pop } ifelse % new
} forall % new
pause
/I load null ne {
pop %
OldStack /I load undef
/MyStack [
MyStack aload pop /I load
] store
} { % new
/MyStack [
MyStack aload length 3 add -1 roll % /MyStack [ ... new
create-struct % /MyStack [ ... newind
] store %
} ifelse
} forall
pause
OldStack { % ind old
pop % ind
items exch get % item
dup /StackI null put % XXX
/Free exch send %
pause
} forall
pause
/Y tab-top def
MyStack { % ind
items exch get % item
Y { % PrevTop
dup tab-bottom exch sub % PrevTop below
dup 0 lt {
location 2 index sub just-move
pause
} if
pop pop tab-top
} 3 -1 roll send % NextTop
/Y exch def %
} forall %
pin-rect % x y w h
exch pop add exch pop % PinTop
Y lt { % if we ran off the top of the stack, then pack it down.
PackStack
} if
pause
ItemEnd end
} monitor
} store
/create-struct { % obj => i
ItemLock {
20 dict begin
/Obj exch def
NextStackPos
/NextY exch def /NextX exch def
free-items length 0 eq {
Stack SP /Obj load put
Stack SP {click-point} can
/new StructItem send
/It exch def
/items [
items aload pop
It
] store
/I SP def
/SP SP 1 add store
It /StackI Index put
createevent begin
/Name /UpdateInterests def
/Canvas ItemParent def
/ClientData I def
currentdict end sendevent
} {
/I free-items dup length 1 sub get def
/It items I get def
/free-items [
free-items aload pop pop
] store
It /StackI Index put
/Obj load /Reuse It send
} ifelse
NextX NextY
{ 2 copy 20 20 just-reshape
exch PinX sub exch just-move
map damage-view
} It send
I
pause pause
end
} monitor
} store
/GetStack {
% Don't use [ ... ] in case there are marks on the stack!!
MyStack {
{Collection Index get} exch items exch get send
} forall
MyStack length array astore
} def
/PackStack {
10 dict begin
/Y tab-top def
MyStack {
items exch get
Y { % PrevTop
dup tab-bottom exch sub % PrevTop below
location 2 index sub just-move
pause pause
pop pop tab-top
} 3 -1 roll send
/Y exch def
pause pause
} forall
end
pause
} def
/NextStackPos { % - => x y
MyStack length 0 eq {
NextPos
} {
MyStack dup length 1 sub get items exch get
/NextPos exch send
} ifelse
} store
/ClientExit {
CurrentEvent /KeyState get {
dup PointButton eq {
{
ItemBegin
/StackI Index store
/ThisI Index store
ItemCanvas setcanvas
location TabY add TabHeight 2 div add exch PinX add exch
ItemParent createoverlay setcanvas
{ 2 setlinewidth exch pop x0 exch lineto }
getanimated waitprocess aload pop % x y
exch pop location exch pop sub
dup 0 gt {ItemHeight sub 0 max} if
/PinHeight exch store
/paint-hilite win send
ItemEnd
} fork pop exit
} if
} forall
StopItem
} def
/paint-struct {
gsave
ensure-DL
/paint Scroller send
/paint Notifier send
dialog-can setcanvas
/fixdamage dialog-text send
grestore
} def
/DrawHilite {
gsave can setcanvas
location CanvasYFudge add translate
ItemRadius object-bbox
4 -1 roll DropShadow add
4 -1 roll DropShadow sub
4 2 roll
rrectpath
.5 setgray fill
% -3 ItemRadius label-bbox insetrrect rrectpath
2 setlinewidth 0 setgray stroke
PinHeight 0 ne {
1 setlinecap
2 setlinewidth
0 setgray
PinX 0 dup PinHeight add min 6 sub moveto
0 ItemHeight PinHeight abs add 12 add rlineto
stroke
1 setlinecap
6 setlinewidth
0 setgray
PinX 0 dup PinHeight add min moveto
0 ItemHeight PinHeight abs add rlineto
gsave stroke grestore
2 setlinewidth
1 setgray
stroke
} if
grestore
} store
/reshape {
/reshape super send
gsave
ensure-DL
ItemCanvas setcanvas
ObjectX ScrollerWidth add SubItemGap add ObjectY translate
0 0
ObjectWidth ScrollerWidth sub SubItemGap sub
ObjectHeight NotifierHeight sub SubItemGap sub
rectpath dialog-can reshapecanvas
dialog-can /Mapped true put
/reshape dialog-text send
ItemCanvas setcanvas
{ [ 1 0 1 TextHeight div dup CanHeight floor 1 sub mul null ] }
dialog-text send
/setrange Scroller send
ObjectX ObjectY
ScrollerWidth ObjectHeight NotifierHeight sub SubItemGap sub
/reshape Scroller send
/paint Scroller send
ObjectX ObjectY ObjectHeight add NotifierHeight sub
ObjectWidth NotifierHeight
/reshape Notifier send
/paint Notifier send
/SubItemMgr
dictbegin
/Scroller Scroller def
/Notifier Notifier def
dictend forkitems
store
grestore
} def
/ensure-DL {
/ObjectWidth TextWidth def %XXX
/ObjectHeight TextHeight def %XXX
dialog-text null eq {
/dialog-can ItemCanvas newcanvas store
/dialog-text 200 dialog-can /new TextCanvas send store
{ /KeyDict 200 dict def
KeyDict begin
127 { (erase character) comment % Rubout
dialog-string length 0 ne {
getcaretpos
exch dup 1 gt {
1 sub exch
movecaret
getcaretpos
1 3 1 roll deletestring
/dialog-string dialog-string dup length 1 sub
0 max 0 exch getinterval store
} if
} if
} def
8 127 load def % Backspace
23 { (erase word) comment % ^W
0
{ dialog-string length 1 index sub % i
dup 0 le { pop exit } if
1 sub dialog-string exch get
DelimDict exch known 1 index 0 ne and {
exit
} if
1 add
} loop
dup 0 eq { pop } {
dup
getcaretpos exch 2 index sub exch
2 copy movecaret
deletestring
/dialog-string dialog-string dup length 4 -1 roll sub
0 max 0 exch getinterval store
} ifelse
} def
24 { (erase line) comment % ^X
getcaretpos
exch dialog-string length sub 1 max exch
2 copy
movecaret
dialog-string length 3 1 roll
deletestring
/dialog-string () store
} def
21 24 load def % ^U
13 { (exec line) comment % Return
[ () () ] true writeatcaret
dialog-string /dialog-enter dialog-item send
/dialog-string () store
} def
10 { (select line) comment % Newline
[ () () ] true writeatcaret
dialog-string kbd-select-object
/dialog-string () store
prompt
} def
10 128 add { (input line) comment % Meta-Newline
[ () () ] true writeatcaret
dialog-string /dialog-newline dialog-item send
/dialog-string () store
prompt
} def
19 { (insert selection) comment % ^S
selected-object (%) sprintf
[ 1 index ] true writeatcaret
/dialog-string exch dialog-string exch append store
} def
20 { (exchange) comment % ^T
{ (%% exch\n) print
exch
} execute-it
} def
11 { (stack to selection) comment % ^K
{ (%% Stack to selection\n) print
count 0 ne { select-object } if
} /execute-it dialog-item send
} def
25 { (selection to stack) comment % ^Y
{ (%% Selection to stack\n) print
selected-object
} /execute-it dialog-item send
} def
27 { (execute selection) comment % Escape
selected-object
% Since 'token' doesn't recognize \r's as ending comments,
% if the selection has \r's in it, make a copy with \r's
% mapped to \n's.
dup type /stringtype eq {
dup remove-returns exch 1 index ne {
kbd-select-object
} if
} if
{ selected-object cvx
dup 64 string cvs
(\n) search { exch pop exch pop } if
(%% ) (%Execute selection %\n) printf
exec
} /execute-it dialog-item send
} def
3 { (reset input) comment % ^C
/kbd-reset dialog-item send
} def
4 { (reboot process) comment % ^D
/kbd-reboot dialog-item send
} def
/FunctionR9 { (page up) comment
/ScrollPageForward /FakeScroll dialog-scroll send
} def
/FunctionR15 { (page down) comment
/ScrollPageBackward /FakeScroll dialog-scroll send
} def
/FunctionR7 { (scroll down) comment
/ScrollLineForward /FakeScroll dialog-scroll send
} def
/FunctionR13 { (scroll up) comment
/ScrollLineBackward /FakeScroll dialog-scroll send
} def
/FunctionR11 { (scroll to bottom) comment
1 /ScrollTo dialog-scroll send
} def
/FunctionF10 { (help) comment % Alternate
[ () (Key Bindings:) ()] true writeatcaret
[ KeyDict {
comment-string exch key-name
(%: %) sprintf
pause pause
} forall ]
/gt quicksort
{ [ exch () ] true writeatcaret
pause } forall
prompt
} def
/FunctionR1 { (describe key) comment
[ () (Describe key: ) ] true writeatcaret
/DescribingKey? true store
} def
/FunctionR2 { (bind selection to key) comment
[ () selected-object (Bind selection %) sprintf (to key: ) ]
true writeatcaret
/BindingKey? true store
} def
/FunctionL9 { (find completions) comment
[ dialog-string {
DelimDict 1 index known { cleartomark mark } if
} forall
] cvas
dup length 0 eq { pop } {
kbd-select-object
{ selected-object
currentprocess /DictionaryStack get
20 dict begin
/DS exch def
/pat exch def
/found null def
/complete null def
/str pat length string def
DS length 1 sub -1 0 { /i exch def
DS i get {
/val exch def
dup str cvs pat ne { pop } {
found null eq {
/found 1 index 250 string cvs def
/complete found def
} {
/found 1 index 250 string cvs def
found length complete length lt {
/complete found def
} {
0 complete {
found 2 index get ne {
/complete complete 0 3 index getinterval store
exit
} if
1 add
} forall
pop
} ifelse
} ifelse
/val load exch i (%: % = %\n) printf
} ifelse
} forall
pause pause
} for
pause pause pause
complete null eq { () } {
complete pat length 1 index length 1 index sub
getinterval
} ifelse
createevent begin
/Name /InsertValue def
/Action exch def
/Canvas
currentprocess /Interests get 0 get % event
/ClientData get /ViewCanvas get % can
/Parent get % clientcanvas has keyboard interests!
def
currentdict end sendevent
complete null ne { complete select-object } if
end
} execute-it
} ifelse
} def
end % KeyDict
/DelimDict 50 dict def
DelimDict begin
0 1 32 { dup def } for
(%/()<>[]{}) { dup def } forall
end
/typein {
[1 index] true writeatcaret
/dialog-string exch dialog-string exch append store
} def
/DescribingKey? false def
/BindingKey? false def
/key 0 def
/KeyHitCallback { % event =>
dup update-shifts
/Name get
dup type /integertype eq {
Meta {128 add} if
} {
Meta { (Meta%) sprintf } if
Shift { (Shift%) sprintf } if
Control { (Control%) sprintf } if
cvn
} ifelse
/key exch def
BindingKey? DescribingKey? or {
BindingKey? {
selected-object
KeyDict key known {
KeyDict key get
} { null } ifelse
kbd-select-object
dup null eq {
pop KeyDict key undef
} {
KeyDict exch key exch put
} ifelse
} if
[ ()
KeyDict key known {
KeyDict key get comment-string
} {
key type /integertype eq (self insert) (unbound) ifelse
} ifelse
key key-name
(%: %) sprintf
()
] true writeatcaret
/BindingKey? false store
/DescribingKey? false store
prompt
} {
KeyDict key known {
{ KeyDict key get cvx exec } fork pop
pause
} {
key type /integertype eq {
key cvis typein
} {
% beep
} ifelse
} ifelse
} ifelse
} def
/s null def
/newlines 0 def
/i 0 def
/a null def
/pre null def
/lastnl 0 def
/InsertValueCallback { % string => -
/s exch dialog-string exch append store
/newlines 0 store
/lastnl null store
0 1 s length 1 sub {
/i exch store
s i get 13 eq { s i 10 put } if
s i get 10 eq {
/newlines newlines 1 add store
/lastnl i store
pause
} if
} for
lastnl null ne {
s 0 lastnl 1 add getinterval
/dialog-enter dialog-item send
pause pause pause
/dialog-string
s lastnl 1 add 1 index length 1 index sub
getinterval
store
pause
} if
/s s dialog-string length 1 index length 1 index sub
getinterval store
/a newlines 1 add array store
0 1 newlines 1 sub {
pause
/i exch store
s (\n) search pop
/pre exch store
pop
/s exch store
a i pre put
} for
/dialog-string dialog-string s append store
a newlines s put
a true writeatcaret
} store
/KeyboardHandler { % - => -
% --- Handler for keyboard, InsertValue, and Deselect events
/KeyboardInterest [
% Can addkbdinterests aload pop
% Can addselectioninterests aload pop
% % Get rid of LiteUI's mouse interests
% revokeinterest
% Can addfunctionnamesinterest
% dup /Action /DownTransition put
can addkbdinterests aload pop % XXX can=ClientCanvas
can addselectioninterests aload pop
% Get rid of LiteUI's mouse interests
revokeinterest
can addfunctionnamesinterest
dup /Action /DownTransition put
] def
/dialog-proc currentprocess store
{ awaitevent dup /Name get {
/DeSelect {
dup /Action get /PrimarySelection eq {
false DrawSelection
/SelectionPath null store
} if
/Action get /InputFocus eq {
InactivateCaret
} if
}
/RestoreFocus {
pop ReactivateCaret
}
/InsertValue {
/Action get InsertValueCallback
}
/Ignore {
pop
}
/Default {
KeyHitCallback
} if
} case
} loop
} def
/destroy { % - => -
KeyboardInterest null ne {
KeyboardInterest can revokekbdinterests % XXX can=ClientCanvas
} if
KeyboardEventMgr null ne { % added! -deh
KeyboardEventMgr killprocess
} if
EventMgr null ne {
EventMgr killprocess
} if
DelayedMoveProc null ne { % added! -deh
DelayedMoveProc killprocess
} if
MouseDragEventMgr null ne {
MouseDragEventMgr killprocess
} if
} def
/CaretBlinkTime 3 def
/CaretDutyCycle 0.95 def % Percentage on
% This doesn't work:
/FontHeight 12 def
/FontName FontName def
[ () (%% Ready!) () ] true writeatcaret
oncaret
} dialog-text send
/Scroller
[1 0 .005 .05 null] 1 {} ItemCanvas /new NeWSScrollbar send
def
/dialog-scroll Scroller store
{
/NotifyUser {
null ItemValue /moveviewport dialog-text send
} def
/ClientDrag {
DoScroll null ItemValue /moveviewport dialog-text send
} def
/FakeScroll { % motion => -
ItemBegin
/ScrollMotion exch def
DoScroll
EraseBox PaintBox
NotifyUser
ItemEnd
} def
/ScrollTo { % val => -
ItemBegin
/ItemValue exch def
EraseBox PaintBox
NotifyUser
ItemEnd
} def
} Scroller send
/Notifier
(Selection:) () /Right {} ItemCanvas /new MessageItem send
def
{
/ItemFont /Screen-Bold findfont 13 scalefont def
/ItemFrame 1 def
} Notifier send
} if
psh-socket null eq {
MyProcess null ne { MyProcess killprocess } if
/MyProcess null store
incoming null ne { incoming killprocess } if
/incoming null store
systemdict /_ViewCanvas ItemCanvas put
/psh-socket { socket-file (r) file } errored {
{ newprocessgroup
framebuffer setcanvas
500 500 [(Could not establish connection)] popmsg pop
} fork pause pause pop
currentprocess killprocessgroup
} if store
/incoming {
{ { psh-socket 255 string readline false eq {
[() (Lost it!) ()] true writeatcaret
% 1 60 div sleep
% /kbd-reboot dialog-item send
/incoming null store
currentprocess killprocess
} if
[ exch
getcaretpos
pop 1 ne { () exch } if
()
] true writeatcaret
psh-socket bytesavailable 0 eq { prompt } if
} loop
} dialog-text send
} fork store
psh-socket
(systemdict/dbgstart known not{(NeWS/debug.ps)run}if dbgstart\n_ReadyProcess\n)
writestring
psh-socket flushfile
} if
} def
/dialog-newline { % str => -
psh-socket exch writestring
psh-socket 10 write
psh-socket flushfile
} def
/dialog-enter { % str => -
/dialog-buf exch dialog-buf (%%\n) sprintf remove-returns store
{ dialog-buf
{ token } errored {
[(%% Syntax error!)] true /writeatcaret dialog-text send
kbd-reset exit
} {
{ exch /dialog-buf exch store
[ exch ] cvx execute-it
} {
dialog-buf ( _FOO_) append token { % Ignore white space
exch pop /_FOO_ eq {
/dialog-buf () store
} if
} if
exit
} ifelse
} ifelse
pause
} loop
} def
/destroy {
shut-down
SubItemMgr null ne {
SubItemMgr killprocess
/SubItemMgr null store
} if
dialog-text null ne {
% {{destroy} errored pop} dialog-text send
dialog-can /Retained false put
/destroy dialog-text send
/dialog-text null store
/dialog-can null store
} if
/destroy super send
} def
classend def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Icky system globals and merciless kludges
/comment { pop } def
% Reap dead debuggers
/rd {
[ DbgDicts {pop} forall ] {
dup /State get /zombie eq {
DbgDicts 1 index undef
killprocess
} { pop } ifelse
} forall
} def
systemdict /DbgDicts known { rd } if
/dirname {
ob begin
uniquecid dup 3 -1 roll
(dir2dict % % | psh) sprintf forkunix
[exch cidinterest1only] forkeventmgr waitprocess
replace-struct
end
redo-layout
} store
/filename {
(file2dict % | psh) sprintf forkunix
} def
/_ViewCanvas null def
/_SendUpdateStack {
count array astore aload
null /UpdateStack _SendViewEvent
{ currentfile flushfile } errored {
{ dbgstop } errored quit
} if
} def
/_SendViewEvent { % ClientData Action Name => -
createevent begin
/Name exch def
/Action exch def
/ClientData exch def
/Canvas
currentprocess /Interests get 0 get % event
/ClientData get /ViewCanvas get % can
def
currentdict end sendevent
} def
/_ReadyProcess {
createevent begin
/Canvas _ViewCanvas def
/Name /ProcessReady def
/Action currentprocess def
count array astore aload
/ClientData exch def
currentdict end sendevent
createevent begin
/Name 20 dict def
Name begin
/ExecIt {
/ClientData get
exec
_SendUpdateStack
} def
/ReplaceStack {
dup /Action get dup type /stringtype ne { pop } {
{ print currentfile flushfile } errored {
{ dbgstop } errored quit
} if
} ifelse
/ClientData get
count 1 roll
count 1 sub {pop} repeat
aload pop
} def
/DropDead {
{ dbgstop } errored
{ (Ayyyeee!\n) print currentfile flushfile } errored
quit
} def
end % Name
/ClientData 20 dict def
ClientData begin
/ViewCanvas _ViewCanvas def % Stash!
end % ClientData
currentdict end expressinterest
{ awaitevent } loop
quit
} def
/revokekbdinterests { % [ int1 int2 ... intn ] can => -
removefocusinterest
% aload pop revokeinterest revokeinterest revokeinterest
{revokeinterest} forall
} store
/getmenuaction { % index => action
dup null ne {
MenuActions 1 index MenuActions length 1 sub min get
% Execute actions that are names! (This is so we can have the executable
% name of a submenu, or a functions to compute the menu action!)
dup type /nametype eq { exec } if
} {nullproc} ifelse
exch pop
} def
systemdict /old-setselection known not {
/old-setselection /setselection load def
/setselection { % dict rank
2 copy old-setselection
createevent begin
/Name /SelectionChanged def
/Action exch def
/ClientData exch def
currentdict end sendevent
} def
} if
/select-object { % obj => -
20 dict begin
/ContentsPostScript 1 index def
/ContentsAscii exch (%) sprintf def
/SelectionObjSize 1 def
/SelectionResponder null def
/Canvas currentcanvas def % XXX?
/SelectionHolder currentprocess def % XXX?
currentdict
end
/PrimarySelection setselection
} def
/select-pointer { % obj index => -
20 dict begin
/SelectionStartIndex exch def
/ContentsPostScript exch def
/ContentsAscii
/ContentsPostScript load
/SelectionStartIndex load get
(%) sprintf
def
/SelectionObjSize 1 def
/SelectionResponder null def
/Canvas currentcanvas def % XXX?
/SelectionHolder currentprocess def % XXX?
currentdict
end
/PrimarySelection setselection
} def
/select-interval { % obj start len => -
20 dict begin
/SelectionObjSize exch def
/SelectionStartIndex exch def
/SelectionLastIndex
SelectionStartIndex SelectionObjSize add 1 sub
def
/ContentsPostScript exch def
/ContentsAscii
/ContentsPostScript load
SelectionStartIndex SelectionObjSize getinterval
(%) sprintf
def
/SelectionResponder null def
/Canvas currentcanvas def % XXX?
/SelectionHolder currentprocess def % XXX?
currentdict
end
/PrimarySelection setselection
} def
/dissect-selection { % seldict => obj
dup null ne {
dup /ContentsPostScript known {
dup /ContentsPostScript get % seldict obj
1 index /SelectionStartIndex known {
1 index /SelectionLastIndex known {
exch dup /SelectionStartIndex get % obj seldict start
exch /SelectionLastIndex get % obj start last
1 index sub 1 add % obj start len
getinterval % subobj
} {
exch /SelectionStartIndex get get % subobj
} ifelse
} { exch pop } ifelse % obj
} {
dup /ContentsAscii known {
/ContentsAscii get
} if
} ifelse
} if
} def
/selected-object { % - => obj
/PrimarySelection getselection
dissect-selection
} def
/selected-pointer? { % - => false / collection index true
/PrimarySelection getselection
dup null eq { false } {
dup /ContentsPostScript known not { false } {
dup /SelectionStartIndex known not { false } {
dup /ContentsPostScript get
exch /SelectionStartIndex get
true
} ifelse
} ifelse
} ifelse
} def
% NeWS-print 0.996
% Written by Josh Siegel
% Munged by Don Hopkins
/Externals 512 dict def
/ExternalsBack 512 dict def
Externals /Count 0 put
/string-magic
dictbegin
(\b) 0 get (\\b) def
(\f) 0 get (\\f) def
(\n) 0 get (\\n) def
(\r) 0 get (\\r) def
(\t) 0 get (\\t) def
(\() 0 get (\\\() def
(\)) 0 get (\\\)) def
(\\) 0 get (\\\\) def
dictend
def
/fixstring {
10 dict
begin
/len 0 def
/out 1 index length 3 mul string def
{
dup string-magic exch known {
string-magic exch get
} {
cvis
} ifelse
out len 2 index putinterval
/len exch length len add def
} forall
out 0 len getinterval dup length string copy
end
} def
/stringer { % proc => string
dup type cvlit
{
/arraytype {
pause
/arraylvl arraylvl 1 add store
dup xcheck {
/the_string the_string ( {\n) append store
{
stringer
} forall
/the_string the_string ( }\n) append store
} {
/the_string the_string ( [\n) append store
{
stringer
} forall
/the_string the_string ( ]\n) append store
} ifelse
/arraylvl arraylvl 1 sub store
}
/nametype {
dup xcheck {
the_string
arraylvl 0 eq (% /% cvx ) (% %) ifelse
sprintf
/the_string exch store
} {
the_string (% /%) sprintf
/the_string exch store
} ifelse
}
/operatortype {
255 string cvs dup length 2 sub 1 exch getinterval
the_string
arraylvl 0 eq (% /% cvx ) (% %) ifelse
sprintf
/the_string exch store
}
/stringtype {
fixstring
the_string (% \(%\)) sprintf
/the_string exch store
}
/marktype {
(mark ) % [ DANGER! ]
}
/booleantype /integertype /realtype /nulltype {
the_string (% %) sprintf
/the_string exch store
}
/Default {
dup type /dicttype ne dictlvl 0 ne or arraylvl 0 ne or {
ExternalsBack 1 index known {
ExternalsBack exch get % name
} {
Externals begin Count /Count Count 1 add def end % obj count
1 index type (&%_%) sprintf % obj name
Externals 1 index 3 index put % obj name
ExternalsBack 3 -1 roll 2 index put % name
} ifelse
the_string ( //) append exch append /the_string exch store
} {
/dictlvl dictlvl 1 add store
/the_string the_string ( dictbegin\n) append store
{ pause
/the_string the_string (\t) append store
exch stringer stringer
/the_string the_string ( def\n) append store
} forall
/the_string the_string ( dictend \n) append store
/dictlvl dictlvl 1 sub store
} ifelse
} def
} case
} def
/tokout { % obj => string
10 dict
begin
/cnt Externals /Count get def
/dictlvl 0 def
/arraylvl 0 def
/the_string () def
stringer the_string
cnt Externals /Count get ne {
(Externals begin\n%\nend\n) sprintf
} def
end
} def
end % systemdict
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Nasty userdict variables
/dialog-text null def
/dialog-can null def
/dialog-proc null def
/dialog-string () def
/dialog-buf () def
/dialog-item null def
/dialog-scroll null def
(NEWSSERVER) getenv
(;) search pop
(.) search pop pop pop
/socket-port exch def
pop
/socket-host exch def
/socket-file (%socketc) socket-port append socket-host append def
/psh-socket null def
/SP 0 def
/Stack 256 array def
/Pallets 100 dict def
Stack 0 Pallets put
Stack 1 (Nothing!) put
/ThisI null def
/it null def
/ob null def
/obs null def
/FillColor 1 1 1 rgbcolor def
/ItemLock createmonitor def
/items [] def
/free-items [] def
/Meta false def
/Control false def
/Shift false def
/win null def
/can null def
/slidemgr null def
/itemmgr null def
/incoming null def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% User Utilities
%
% quicksort by Don Woods at Sun Microsystems, Inc.
%
/quicksort { % array proc => array (sorted, reuses same storage)
10 dict begin
/Bigger? exch cvx def % a b bigger? => t if a<b
dup quickrecur % start recursion
end
} def % quicksort
/quickrecur { % array => -- sorts array in place, using Bigger? for comparisons
dup length dup 2 gt { % A N
% the next lines (until but not incl /Key...) subsort three elements
% so we can use the median as the partitioning element; this improves
% performance for the case where the array is initially nearly sorted,
% but is not strictly necessary for the algorithm to work (it does
% seem to improve average runtime by about 10%)
2 copy 1 sub 2 copy 2 idiv 1 index 0 % A N A N-1 A (N-1)/2 A 0
6 copy get 5 1 roll get 3 1 roll get % above & A[N-1] A[(N-1)/2] A[0]
2 copy Bigger? {exch} if % subsort for three elements
3 1 roll 2 copy Bigger? {exch} if % ... (call them min mid max)
3 -1 roll 2 copy Bigger? {exch} if % ... subsort finished
9 index % A N A N-1 A (N-1)/2 A 0 min mid max N
3 eq {
5 2 roll put 4 1 roll put put % store min/mid/max back
pop pop % pop A & N
} { % else store mid at 0, max at N-1, min at (N-1)/2, then partition
3 -1 roll 5 2 roll put exch 4 1 roll put put % A N
/Key 2 index 0 get def % partitioning value
0 % A N 0, also known as A j i
{ % main partitioning loop
% incr i until i=j or A[i]>=A[0]; note A[j] is rangecheck
{ 1 add 2 copy gt { % i++; A j i j>i?
dup 3 index exch get % A j i A[i]
Key exch Bigger? not {exit} if
} {exit} ifelse
} loop
% decr j until A[j]<=A[0]; happens at j=i-1 if not sooner
exch { % A i j
1 sub dup 3 index exch get % A i j A[j]
Key Bigger? not {exit} if
} loop
2 copy gt {exit} if % if i>=j, finished partition
% swap A[j] & A[i]; stack has: A i j
2 index 4 copy exch get % A i j A A i A[j]
4 1 roll get % A i j A[j] A A[i]
3 index exch put % A i j A[j]
4 copy exch pop put pop exch % A j i
} loop
% finish partition by exchanging A[j] with A[0]; stack has: A i j
exch pop 2 copy 4 copy get % A j A j A j A[j]
exch pop 0 exch put Key put % A j
% now recur on A[0..j-1] and A[j+1..N-1]
2 copy 1 add 1 index length 1 index sub % A j A j+1 N-1
getinterval 3 1 roll 0 exch getinterval % A[j+1..N-1] A[0..j-1]
2 copy length exch length gt {exch} if % put smaller on top
quickrecur quickrecur % tail recursion avoids deep stack
} ifelse % =3 or >3 elements
} { % handle 1- and 2-element cases specially for efficiency
2 eq {
dup aload pop Bigger? {aload 3 1 roll exch 3 -1 roll astore} if
} if
pop % pop the array
} ifelse
} def % quickrecur
% end of quicksort
/shift-names 10 dict def
shift-names begin
/Meta false def
/Shift false def
/Control false def
end % shift-names
/update-shifts {
shift-names {store} forall
/KeyState get {
shift-names 1 index known { true store } { pop } ifelse
} forall
} store
/key-names 40 dict def
key-names begin
8 (Backspace) def
9 (Tab) def
10 (Newline) def
13 (Return) def
27 (Escape) def
32 (Space) def
127 (Delete) def
end % key-names
/key-name { % key => string
dup type /integertype eq {
dup 127 and
key-names 1 index known {
key-names exch get
} {
dup 32 lt {
64 add cvis (^%) sprintf
} {
cvis
} ifelse
} ifelse
exch 128 ge {
(Meta-%) sprintf
} if
} {
(%) sprintf
} ifelse
} store
/comment-string { % obj => string
dup type /arraytype eq {
dup length 2 ge {
dup 1 get /comment eq {
0 get
} if
} if
} if
(%) sprintf
} def
/destroy { % dummy destroy method
} def
% Forward messages on to stack
/prompt {
{} execute-it
} def
/execute-it {
/execute-it dialog-item send
} def
/exec-it {
/exec-it dialog-item send
} def
/push-it {
/push-it dialog-item send
} def
/kbd-select-object {
gsave
can setcanvas
select-object
grestore
} def
/kbd-select-pointer {
gsave
can setcanvas
select-pointer
grestore
} def
/kbd-select-interval {
gsave
can setcanvas
select-interval
grestore
} def
/remove-returns { % str => str'
dup (\r) search not { pop } { % str rest \r pre
length 1 add exch pop % str rest len
3 -1 roll dup length string copy % rest len str'
3 1 roll { % str' rest len
2 index 1 index 1 sub 10 put
exch (\r) search { % str' len rest \r pre
length 1 add exch pop % str' len rest len
3 -1 roll add % str' rest len
} { % str' len rest
pop pop exit
} ifelse
} loop
} ifelse
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Pallets of useful functions
Pallets begin
/Debug dictbegin
/dlb /dbglistbreaks cvx def
/de /dbgenter cvx def
/dx /dbgexit cvx def
/dk /dbgkill cvx def
/dc /dbgcontinue cvx def
/dcc {dbgcopystack dbgcontinue} def
/dw /dbgwhere cvx def
/execstack {DbgImplicitBreak DbgGetExecStack} def
/exec /exec cvx def
/stack /stack cvx def
/clear /clear cvx def
/typo { % undefined (select correct spelling) => -
userdict begin
dup cvlit [ selected-object (%) sprintf cvn cvx ] cvx def
end
exec
} def
dictend def
/Number dictbegin
0 {10 mul} def
1 {10 mul 1 add} def
2 {10 mul 2 add} def
3 {10 mul 3 add} def
4 {10 mul 4 add} def
5 {10 mul 5 add} def
6 {10 mul 6 add} def
7 {10 mul 7 add} def
8 {10 mul 8 add} def
9 {10 mul 9 add} def
/Back {10 div floor} def
/Reset {0 mul} def
/Enter {0} def
dictend def
currentautobind false setautobind
/Math {
{add sub mul div idiv mod}
{neg abs min max}
{ceiling floor round truncate}
{cos sin tan arcsin arccos arctan atan exp ln log sqrt}
{random rand}
{etc, etc, etc...}
{(Add your own!)}
} cvlit def
/Stack {
dup pop exch clear load def store get put aload forall [ ]
} cvlit def
/Window 20 dict begin
/new {
framebuffer /new DefaultWindow send
{ newprocessgroup
/reshapefromuser 1 index send
/map exch send
} fork waitprocess pop
dup /ClientCanvas get setcanvas
(%% Now on ) print currentcanvas ==
} def
dictend def
setautobind
end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Item managment
/createitems {
ItemLock {
/items [
Stack 0 {click-point} can
/new StructItem send
20 10 0 0 /reshape 5 index send
Stack 1 {} can
/new TextStructItem send
20 50 0 0 /reshape 5 index send
] def
/SP items length store
/dialog-item items 1 get store
{/PinHeight 600 def /StackI 1 def} dialog-item send
/ThisI 1 store
} monitor
} def
/slideitem { % items fillcolor item => -
ItemLock {
gsave
dup 4 1 roll % item items fillcolor item
{ItemCanvas canvastotop
moveinteractive location move} exch send % item
grestore
} monitor
} def
/update-slide-interests {
CurrentEvent /ClientData get % Index
items exch get % item
dup /ItemCanvas get % item can
MiddleMouseButton [items FillColor % item can name [ dict color
6 -1 roll /slideitem cvx] cvx % can name proc
DownTransition % can name proc action
4 -1 roll eventmgrinterest % interest
expressinterest
} def
/update-start-interests {
CurrentEvent /ClientData get % Index
items exch get % item
mark
[/makestartinterests 3 index send aload pop]
{dup xcheck {exec} {expressinterest} ifelse} forall
cleartomark
pop
} def
/start-event-mgrs {
% Create event manager to slide around the items.
% Create a bunch of interests to move the items.
% Note we actually create toe call-back proc to have the arguments we need.
% The proc looks like: {items color "thisitem" slideitem}.
% We could also have used the interest's clientdata dict.
slidemgr null ne {slidemgr killprocess} if
{ %XXX
/slidemgr [
items { % key item
dup /ItemCanvas get % item can
MiddleMouseButton [items FillColor % item can name mark dict color
6 -1 roll /slideitem cvx] cvx % can name proc
DownTransition % can name proc action
4 -1 roll eventmgrinterest % interest
} forall
/UpdateInterests /update-slide-interests
null can eventmgrinterest
] forkeventmgr store
} pop %XXX
itemmgr null ne {itemmgr killprocess} if
/itemmgr [
items iteminterests aload pop
/UpdateInterests /update-start-interests
null can eventmgrinterest
] forkeventmgr store
} def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Window class definition
/CyberWindow DefaultWindow
dictbegin
/FrameLabel (PostScript Structure CyberSpace) def
/IconLabel (PS CyberSpace) def
/IconImage /galaxy def
dictend
classbegin
/PaintClient {
paint-hilite
items paintitems
} def
/paint-hilite {
ClientCanvas setcanvas
erasepage
/DrawHilite dialog-item send
} def
/ClientMenu [
(Break Stack) { clear /BrokenStack /dbgbreak dialog-item send }
(Credits) { /display-credits win send }
(Break Window) { clear /BrokenWindow /dbgbreak win send }
(Break Struct) { clear /BrokenStruct /dbgbreak items 0 get send }
] /new DefaultMenu send def
/display-credits {
gsave
framebuffer setcanvas
currentcursorlocation
[ (NeWS CyberSpace:)
( by Don Hopkins)
(----------------)
(Code stolen from:)
( Josh Siegel)
( Don Woods)
] popmsg pop
grestore
} def
/DestroyClient {
{
newprocessgroup
itemmgr type /processtype eq { itemmgr killprocess } if
slidemgr type /processtype eq { slidemgr killprocess } if
items {
/destroy exch send
} forall
/items null store
/_ViewCanvas null store
/PrimarySelection clearselection % XXX?
ClientCanvas /Retained false put
FrameCanvas /Retained false put
FrameCanvas /Mapped false put
/DestroyClient super send
} fork pop
} def
classend def
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Create objects
/win framebuffer /new CyberWindow send store % Create a window
0 0 900 900 /reshape win send
/can win /ClientCanvas get def
% BOO HISS
can /Parent get /Retained true put
createitems
% /reshapefromuser win send
/map win send
start-event-mgrs