don@BRILLIG.UMD.EDU (Don Hopkins) (08/28/88)
%!
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% PieMenu class for 4Sight 1.1, using the SGI Iris 4D overlay plane.
% Copyright (C) 1988 by Don Hopkins.
%
% This is for 4Sight 1.1, Silicon Graphic's implementation of NeWS 1.1.
% It should be loaded in just after piemenu.ps.
% Don't load this unless you're running 4Sight.
%
% This program is provided free for unrestricted use and redistribution,
% provided that the headers remain intact. No author or distributor
% accepts any responsibility for any problems with this software.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
systemdict begin
% compat.ps was stripped!
/mapcanvas { /Mapped true put } def
/unmapcanvas { /Mapped false put } def
/savebehindcanvas { /SaveBehind true put } def
/SGIPieMenu SimplePieMenu
dictbegin
/RetainCanvas? false def
/SupressParent? true def
/CellHorizGap 0 def % Toolboxes use this? (/MenuLine...)
/CellWidth 0 def % Toolboxes use this? (/MenuLine...)
/CenterItems? false def % Toolboxes use this? (/MenuLine...)
dictend
classbegin
/MapMenu {
SupressParent? ChildMenu null ne and not {
/MapMenu super send
self { % What a bitch!
dup null eq {pop exit} if
% wtf did all that junk on the stack come from?
{MenuCanvas /DamageProc 2 index send} fork waitprocess pop
/ChildMenu get
} loop
} if
} def
/showat { % event => -
InteractionLock { % sgi
systemdict /MenuBusy 1 put % sgi
UI_private /AttachMode /softattached put % sgi
PaintedValue null ne MenuCanvas null ne and MenuWidth null ne and {
/MenuValue null store PaintMenuValue
} if
/PaintedValue null store
MenuEventMgr null ne {MenuEventMgr waitprocess pop} if
MenuWidth null eq {
/layout self send
MenuCanvas null ne {/reshape self send} if
} if
MenuCanvas null eq {
/MenuCanvas ParentCanvas newcanvas def
%MenuCanvas /Retained RetainCanvas? put
/reshape self send
MenuCanvas dup canvastotop /Transparent true put % sgi
/MenuPaintCanvas MenuCanvas createoverlay def % sgi
MenuPaintCanvas /Retained RetainCanvas? put % sgi
} if
gsave
framebuffer setcanvas
dup type /eventtype eq {
begin XLocation YLocation end
} if
PieRadius sub MouseYDelta add /MenuY exch def
PieRadius sub MouseXDelta add /MenuX exch def
clippath pathbbox /DeltaY exch def /DeltaX exch def pop pop
/DeltaY
MenuY MenuHeight add
dup DeltaY ge {
DeltaY exch sub
} {
dup MenuHeight lt {
MenuHeight exch sub
} { pop 0 } ifelse
} ifelse
def
/DeltaX
MenuX MenuWidth add
dup DeltaX ge {
DeltaX exch sub
} {
dup MenuWidth lt {
MenuWidth exch sub
} { pop 0 } ifelse
} ifelse
def
/MenuX MenuX DeltaX add store
/MenuY MenuY DeltaY add store
MenuCanvas savebehindcanvas
MenuCanvas setcanvas MenuX MenuY movecanvas
MenuCanvas canvastotop
grestore
% Defer the mapping till events already in the input queue
% have been processed.
MapMenuEvent null ne {
MapMenuEvent recallevent
} if
/MapMenuEvent
createevent begin
/Name /MapMenu def
% So active submenu pops up before already choosen parent!
/TimeStamp currenttime
ParentMenu null eq {MapLongDelay} {MapShortDelay} ifelse
add def
/Canvas MenuCanvas def
currentdict
end def
MapMenuEvent sendevent
/MenuValue null def
/GotDown false def
/activate self send
} monitor % sgi
} def
/popdown {
MapMenuEvent null ne {
MapMenuEvent recallevent
/MapMenuEvent null def
} if
MenuPaintCanvas /Mapped false put
MenuCanvas null ne {MenuCanvas unmapcanvas} if % spin needs this??
ParentMenu null ne {
ParentMenu /MenuCanvas get /DamageProc ParentMenu send pop
} if
RetainCanvas? not {
/MenuCanvas null store
/MenuInterests null store
% /MenuWidth null store
} if % framebuffer setcanvas?
ChildMenu null ne {
ChildMenu /ParentMenu null put
/popdown ChildMenu send
/ChildMenu null store
} if
ParentMenu null ne {
ParentMenu /ChildMenu null put
/ParentMenu null store
} if
RetainCanvas? not {
/MenuCanvas null store
/MenuPaintCanvas null store
/MenuInterests null store
% /MenuWidth null store
} if % framebuffer setcanvas?
MenuEventMgr null ne {
MenuEventMgr /MenuEventMgr null store killprocess
} if
} def
/makeinterests {
/MenuInterests [
MenuButton /UpProc UpTransition null eventmgrinterest
dup /Exclusivity true put
dup /Priority 5 put
MenuButton /DownProc DownTransition null eventmgrinterest
dup /Exclusivity true put
MouseDragged /DragProc null null eventmgrinterest
dup /Exclusivity true put
/EnterEvent /EnterProc null MenuCanvas eventmgrinterest
dup /Exclusivity true put
/ExitEvent /ExitProc null MenuCanvas eventmgrinterest
dup /Exclusivity true put
% /Damaged /DamageProc null MenuCanvas eventmgrinterest
/Damaged /paint null MenuCanvas eventmgrinterest
dup /Exclusivity true put
dup /Priority -5 put
AdjustButton /KerProc DownTransition null eventmgrinterest
dup /Exclusivity true put
AdjustButton /ChunkProc UpTransition null eventmgrinterest
dup /Exclusivity true put
% Kludge to refresh messed up retained menu canvases. Ssssh! Don't tell anyone.
PointButton {} DownTransition null eventmgrinterest
% PointButton /DamageProc UpTransition MenuCanvas eventmgrinterest
PointButton /MapMenu UpTransition MenuCanvas eventmgrinterest
/MapMenu /MapMenu null MenuCanvas eventmgrinterest
dup /Priority -5 put
] def
} def
/DrawMenuLine {pop} def
/domenu {
systemdict /MenuBusy 0 put
MenuValue getmenuaction dup type /dicttype eq {pop} {cvx exec} ifelse
} def
/DamageProc {
SupressParent? ChildMenu null ne and not {
/damaged currentcanvas def
dup getcanvaslocation
2 index setcanvas clipcanvaspath neg neg translate
damaged setcanvas clipcanvas
ParentMenu null ne {/DamageProc ParentMenu send} {pop} ifelse
/paint self send
true PaintedValue PaintSlice
newpath clipcanvas
} if
} def
% Pop back to the previous menu, if we're in this menu's center.
/ChunkProc {
MenuGSave
DragProc
MenuValue null eq {
SupressParent? ParentMenu null ne and {
% { popdown /paint ParentMenu send } fork pop
{ ParentMenu
dup /ChildMenu null put
/ParentMenu null def
{popdown} fork waitprocess
{ {MapMenu} errored {paint} if } exch send
} fork pop
} {
popdown
} ifelse
} if
grestore
} def
/MenuGSave {
gsave MenuFont setfont initmatrix MenuPaintCanvas setcanvas
} def
/reshape {
%MenuGSave % sgi
gsave % sgi
framebuffer setcanvas
newpath
PieRadius dup dup 0 360 arc
closepath
NumbHole {
PieRadius dup NumbRadius 1 sub 360 0 arcn closepath } if
SplatFactor { 6 { PieRadius dup add random mul } repeat
curveto } repeat
MenuCanvas eoreshapecanvas
/beye /beye_m MenuCanvas setstandardcursor
% So retained canvases don't have their old image upon popup:
RetainCanvas? {
MenuCanvas setcanvas
MenuFillColor fillcanvas
} if
grestore
} def
% Update the highlighted slice to show the current menu value.
/PaintMenuValue { % - => - (Hilite current item, un-hilite prev one.)
false PaintedValue PaintSlice
true MenuValue PaintSlice
/PaintedValue MenuValue store
} def
% Paint highlighting on a menu slice. If it's null, then do nothing.
% Draw an arrow, and a box around the key.
/PaintSlice { % draw key => -
dup null ne { % key
MenuGSave
exch { % keyNumber draw
/bgcolor MenuTextColor def
/fgcolor MenuFillColor def
} {
/bgcolor MenuFillColor def
/fgcolor MenuTextColor def
} ifelse
bgcolor setcolor
PieRadius dup translate
MenuItems exch get begin
% Draw an arrow pointing out in the direction of the slice.
HiLiteWithArrow? {
gsave
ang rotate
newpath
NumbRadius 0 moveto
LabelRadius Gap sub % r
dup .6 mul dup PieSliceWidth 3 div sin mul lineto
dup .9 mul 0 lineto
.6 mul dup PieSliceWidth -3 div sin mul lineto %
closepath
StrokeSelection {stroke} {fill} ifelse
grestore
} if
% Highlight the key Thing.
-4 2 X Y w h insetrrect rrectpath
StrokeSelection {
stroke
} {
fill
fgcolor setcolor
/Key load X Y ShowThing
} ifelse
end
grestore
} {pop pop} ifelse %
} def
/settitle {pop} def
classend def
/PieMenu SGIPieMenu def
/LayeredPieMenu SGIPieMenu
dictbegin
/MenuArgs [] def
/MenuArg null def
/PaintedArg null def
dictend
classbegin
% Need to make flipstype a no-op because /new takes a different number
% of args, and actions might depend on MenuArg!
/flipstyle {currentdict} def
/new { % args keys actions => menu
% -or- args keys/actions (one array) => menu
/new super send begin
/MenuArgs exch def
currentdict end
} def
/showat {
/showat super send
/MenuArg null def
} def
/DragProc {
ChildMenu null eq {
MenuGSave
PieRadius dup translate
CurrentEvent begin
XLocation DeltaX add
YLocation DeltaY add
end
SetMenuValue
MenuValue PaintedValue ne {
PaintMenuValue
} if
MenuArg PaintedArg ne {
PaintMenuArg
} if
grestore
} if
} def
/PaintMenuArg {
PaintedArg PaintArg
MenuArg PaintArg
/PaintedArg MenuArg store
} def
/PaintArg {
dup null ne {
/obsolete dbgbreak
MenuGSave
PieRadius dup translate
MenuBorderColor setcolor
5 setrasteropcode
100 string cvs
dup stringbbox points2rect
-.5 mul exch -.5 mul exch moveto
pop pop
show
grestore
} if
} def
/SetMenuValue { % x y => -
/SetMenuValue super send
/MenuArg
MenuValue null eq
MenuArgs length 0 eq or {
null
} {
PieDistance PieRadius 1 sub min NumbRadius sub
PieRadius NumbRadius sub div MenuArgs length mul floor
MenuArgs exch get
} ifelse
def
} def
/getmenuarg {
MenuArg
} def
classend def
systemdict /DontSetDefaultMenu known not {
PieMenu setdefaultmenu
} if
end % systemdict