korp@TRIPOLI.EES.ANL.GOV (12/10/89)
Original-posting-by: korp@TRIPOLI.EES.ANL.GOV
Reposted-by: emv@math.lsa.umich.edu (Edward Vielmetti)
Posting-id: 891210.0623
Posting-number: Volume TEST, Number TEST
Archive-name: btol-1.1
Archive-site: tumtum.cs.umd.edu [128.8.128.49]
[This is an experimental alt.sources re-posting from the
newsgroup(s) comp.windows.news.
No attempt has been made to edit, clean, modify, or otherwise
change the contents of the original posting, or to contact the
author. Please consider cross-posting all sources postings to
alt.sources as a matter of course.]
[Comments on this service to emv@math.lsa.umich.edu (Edward Vielmetti)]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% BTOL -- VERSION 1.1
%%% (Better Than Op*n L**k)
%%%
%%%
%%% Version 1.1:
%%% Now includes support for tear off menus! There is also a
%%% minor programming change. After making the appropriate calls to
%%% Make*Control, one must now call MoveFrameControls explicitly.
%%%
%%% Version 1.0:
%%% This work was originaly generated to improve on the standard
%%% lite window and menu implementations. Besides, we were all getting
%%% tired of following those crazy pullright menus 4-5 levels deep.
%%%
%%% This is Version 1.0 of the BTOL window package
%%% Feel free to use this code as you like, provided this header is
%%% left intact. If you come up with neat new features, questions, bugs,
%%% ideas or whatever let us know, it would be greatly appreciated.
%%%
%%%
%%% Peter A. Korp
%%% Argonne National Laboratory
%%% Visual Interfaces Section
%%% korp@athens.ees.anl.gov
%%%
%%% David C. Mak
%%% Argonne National Laboratory
%%% Visual Interfaces Section
%%% mak@athens.ees.anl.gov
%%%
%%% David G. Zawada
%%% Argonne National Laboratory
%%% Visual Interfaces Section
%%% zawada@athens.ees.anl.gov
%%%
%%%
%%%
%%%
%%% BTOL provides NeWS application programmers with 5 new classes that
%%% allow for writing more visually appealing software. These classes
%%% implement new:
%%%
%%% 1) Buttons
%%% 2) Menu Buttons
%%% 3) Base Windows
%%% 4) Menus
%%% 5) Application Windows
%%%
%%% In Developing BTOL, we were aware of the standard lite API and
%%% attempted to adhere to it in general, but did not feel BTOL had
%%% to made 100% lite compatible. We feel it would require little
%%% time to actually make it compatible and will do this if there is
%%% enough user interest.
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class: BtolButton
%%%
%%% Purpose: To create a new button that conformed to our interface
%%%
%%% Useful methods:
%%%
%%% /new % label => instance
%%% - creates a new instance of BtolButton
%%% /resetcolors % - => -
%%% - reset button colors to specified defaults
%%% /sethue % hue => -
%%% - set the hue for hsb value of button
%%% /sethsb % color => -
%%% - set the hsb color for button
%%% /Activate % - => -
%%% - allows button notify proc notification
%%% /DeActivate % - => -
%%% - Grays out button and disallow notification
%%% /HiLite % - => -
%%% - HiLite the button
%%% /DeHiLite % - => -
%%% - DeHilite the button
%%%
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class: BtolMenuButton
%%%
%%% Purpose: Create a button that can have a submenu off of it
%%%
%%% Useful methods:
%%%
%%% /new % Pullright label notifyproc ParentMenu width height => instance
%%% - creates a new instance of BtolMenuButton
%%% /movesubmenu % - => -
%%% - moves the buttons submenu to its current x and y by mapping it
%%%
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class: BtolWindow
%%%
%%% Purpose: Create a window that has an array available for items that
%%% will go into window as well as eventmgr. The items are
%%% disposed of correctly when you destory the window
%%%
%%% Useful methods:
%%%
%%% /new % parentcanvas => instance
%%% - creates a new instance of BtolWindow
%%% /resetcolors % - => -
%%% - reset button colors to specified defaults
%%% /sethue % hue => -
%%% - set the hue for hsb value of button
%%% /sethsb % color => -
%%% - set the hsb color for button
%%% /hide % - => -
%%% - If used from a BtolAppwin, allows the AppWin to hide all of
%%% its children when it is deselected
%%% /unhide % - => -
%%% - If used from a BtolAppwin, allows the AppWin to show all of
%%% its children when it is selected
%%% /HiLiteFrame % - => -
%%% - HiLite the window
%%% /DeHiLiteFrame % - => -
%%% - DeHilite the window
%%% /CreateZapControl % - => -
%%% - Creates a control in upper right of window to zap window
%%% /CreateCloseControl % - => -
%%% - Creates a control in upper left of window to close windows
%%% /CreateResizeControl % - => -
%%% - Creates resize controls at bottom of screen
%%%
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class: BtolMenu
%%%
%%% Purpose: Create a menu that has walking submenus and conforms to BTOL
%%% UI
%%%
%%% Useful methods:
%%%
%%% /new % [menuitem names] [actions] => instance
%%% - creates a new instance of BtolMenu
%%% /resetcolors % - => -
%%% - reset menu colors to specified defaults
%%% /sethue % hue => -
%%% - set the hue for hsb value of button
%%% /sethsb % color => -
%%% - set the hsb color for menu
%%% /dragmenu % - => -
%%% - if this menu is a submenu it moves to parents right
%%% /detach % - => -
%%% - unmaps all submenus
%%% /getcmi % - => BtolMenuButton
%%% - get current menu item (Button that has its submenu showing)
%%% /flipcmi % BtolMenuButton => -
%%% - flip the state of current menu item
%%% /setcmi % BtolMenuButton => -
%%% - set the current menu item
%%% /AutoSize % - => -
%%% - after all the items are put in a menu run AutoSize to make
%%% all the menu items and label fit nice. (Run before mapping)
%%%
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class: BtolAppWin
%%%
%%% Purpose: Create an application window with BTOL look and feel
%%%
%%% Useful methods:
%%%
%%% /new % Framelabel => instance -or- canvas => instance
%%% - creates a new instance of BtolAppWindow
%%% /newsubwin % Framelabel => subwindow
%%% - create a subwindow for this application. It will automatically
%%% open and close correctly, with the main AppWin
%%% /sethue % hue => -
%%% - set the hue for hsb value of button
%%% /sethsb % color => -
%%% - set the hsb color for button
%%% /getappwin % - => BtolAppWin
%%% - return the AppWindow whose menu is currently showing
%%% /setappwin % BtolAppWin => -
%%% - set the current AppWindow to be this AppWin
%%% /destroychild % subwindow => -
%%% - destroys a child subwindow
%%% /destroychildren % [subwindows] => -
%%% - destroys several child subwindows
%%%
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Class structure of BTOL
%%% -----------------------
%%%
%%% ------------ -------------
%%% |LiteWindow| |LabeledItem|
%%% ------------ -------------
%%% | |
%%% ------v----- -----v------
%%% |BtolWindow| |BtolButton|
%%% ------------ ------------
%%% | |
%%% _________|__________ |
%%% | | |
%%% -------v------- ---v------ ------v---------
%%% |BtolAppWindow| |BtolMenu|<-----|BtolMenuButton|
%%% --------------- ---------- ----------------
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Example -1-
%%%
%%% A trivial BTOL program. We let the Btol code do all the work.
%%% /win framebuffer /new BtolAppWin send def
%%% {
%%% /PaintClient
%%% {
%%% 0 fillcanvas
%%% 0 1 random 100 mul { random mul random 144 mul random random random setrgbcolor
%%% moveto 240 100 lineto stroke } for
%%% } def
%%% reshapefromuser
%%% totop
%%% map
%%% } win send
%%%
%%% psh Example -1- again and watch how the menus interact
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Example -2-
%%%
%%% A simple sample application written for BTOL
%%%
%%% /AppFont /Courier findfont def
%%% /AppFontSize 18 def
%%%
%%% /changefontsize % dsize => -
%%% {
%%% /AppFontSize AppFontSize 3 -1 roll add 8 max store
%%%
%%% AppFont AppFontSize scalefont
%%% /paint win send
%%% } def
%%%
%%%
%%% /changefont % fontname => -
%%% {
%%% /AppFont exch findfont store
%%% 0 changefontsize
%%% } def
%%%
%%%
%%% /colormenu
%%% [() dup dup dup dup dup dup dup dup dup]
%%% [ {Hue /sethue /getappwin BtolAppWin send send} 9 { dup } repeat ]
%%% /new BtolMenu send
%%% dup /MenuItems get 0 1 9
%%% { dup 10 div /sethue 3 index 4 -1 roll get send } for pop
%%% def
%%%
%%% /sizemenu
%%% [(Enlarge by 2) (Enlarge by 10) (Reduce by 2) (Reduce by 10)]
%%% [ { 2 changefontsize } { 10 changefontsize } { -2 changefontsize } { -10 changefontsize } ] /new BtolMenu send def
%%%
%%% /fontmenu
%%% [
%%% (Courier) (Helvetica) (Times-Roman)
%%% ]
%%% [ { ItemLabel changefont } 2 index length 1 sub { dup } repeat ] /new BtolMenu send def
%%%
%%% /changefontmenu
%%% [ (Font) (Size) ]
%%% [ fontmenu sizemenu ] /new BtolMenu send def
%%%
%%% colormenu
%%% /sethue
%%% {
%%% /Hue exch def
%%% /HiLiteColor Hue 0.3 1 hsbcolor def
%%% /ShadowColor Hue 1 0.45 hsbcolor def
%%% /FaceColor Hue 0.4 .9 hsbcolor def
%%%
%%% HiLiteFrame
%%% paint
%%% }
%%% put
%%%
%%% /mainmenu
%%% [(Window Color) (Change Font) (Hide) (Quit)]
%%% [
%%% colormenu
%%% changefontmenu
%%% { /flipiconic /getappwin BtolAppWin send send }
%%% { /ZapNotify /getappwin BtolAppWin send send }
%%% ] /new BtolMenu send def
%%%
%%% {
%%% /FrameLabel (Example #2) def
%%% AutoSize
%%% } mainmenu send
%%%
%%%
%%% /win framebuffer /new BtolAppWin send def
%%% {
%%% CreateCloseControl
%%% CreateResizeControl
%%% /FrameMenu mainmenu def
%%% /FrameLabel (A BTOL window! Example #2) def
%%% /IconLabel (Example #2) def
%%% /PaintClient
%%% {
%%% gsave
%%% 0 fillcanvas
%%% 0 1 random 100 mul
%%% {
%%% random mul random 144 mul
%%% random random random setrgbcolor
%%% moveto 240 100 lineto stroke
%%% } for
%%% AppFont AppFontSize scalefont setfont
%%% 50 50 moveto (BTOL - it just looks better!) show
%%% grestore
%%% } def
%%% reshapefromuser
%%% ClientCanvas /Retained true put
%%% totop
%%% map
%%% } win send
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
%%% Have fun with the sample code and please let us know how you like
%%% the product.
%%% - Dave, Dave and Peter
%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
systemdict /LabeledItem known not { ($NEWSHOME/lib/NeWS/liteitem.ps) run } if
systemdict begin
% ============================= Btol Button Item =============================
/BtolButton LabeledItem
dictbegin
/Activated? true def
/Hue 0 def
/ShadowColor .1 .1 .1 rgbcolor def
/HiLiteColor .9 .9 .9 rgbcolor def
/FaceColor .7 .7 .7 rgbcolor def
/CurrentTextColor ShadowColor def
dictend
classbegin
/new % label notifyproc parentcanvas => instance
{
% fake a labeled item.
dup type /canvastype eq
{() /Center 4 2 roll} {() /Center 6 2 roll} ifelse
/new super send
begin
/ItemRadius 0 def
/ItemFrame 2 def
/ItemBorder null def %
/ItemID 0 def %%%DZpatch -- used in dock
currentdict
end
} def
/resetcolors
{
/ShadowColor .1 .1 .1 rgbcolor store
/HiLiteColor .9 .9 .9 rgbcolor store
/FaceColor .7 .7 .7 rgbcolor store
} def
/sethue % hue
{
/Hue exch def
/HiLiteColor Hue 0.3 1 hsbcolor def
/ShadowColor Hue 1 0.45 hsbcolor def
/FaceColor Hue 0.4 .9 hsbcolor def
} def
/sethsb % color -> -
{
/FaceColor exch def
} def
/reshape % x y w h => -
{
/ItemHeight exch def /ItemWidth exch def
LabelSize /LabelHeight exch def /LabelWidth exch def
ItemBorder null eq {/ItemBorder ItemFrame def} if
/ItemWidth ItemWidth
ItemBorder ItemGap add 2 mul LabelWidth add max def
/ItemHeight ItemHeight
ItemBorder ItemGap add 2 mul LabelHeight add max def
/LabelX ItemWidth LabelWidth sub 2 div LabelX add def
/LabelY ItemHeight LabelHeight sub 2 div LabelY add def
ItemLabel type /stringtype eq { % adjust for descenders
/LabelY LabelY ItemLabelFont fontdescent 2 div sub ItemBorder max def
} if
ItemRadius 0 gt ItemRadius .5 le and {
/ItemRadius ItemWidth ItemHeight min ItemRadius mul def
} if
ItemWidth ItemHeight /reshape super send
} def
/PaintItem
{
ItemValue true eq
{HiLightButton}
{PaintButton} ifelse
} def
/SetButtonValue % bool => -
{
/ItemValue exch store
ItemValue ItemPaintedValue ne {/paint self send} if
} def
/ClientDown
{
Activated? {true SetButtonValue} if
} def
/ClientUp
{
Activated?
{
ItemValue {NotifyUser} if
false SetButtonValue
StopItem
} if
} def
/ClientEnter {Activated? {true SetButtonValue} if} def
/ClientExit {Activated? {false SetButtonValue} if } def
/Activate
{
/CurrentTextColor ShadowColor store
/Activated? true def paint
} def
/DeActivate
{
gsave
/CurrentTextColor
FaceColor setcolor currenthsbcolor .2 sub hsbcolor def
/Activated? false def paint
grestore
} def
/HiLite
{
/State true store
paint
} def
/DeHiLite
{
/State false store
paint
} def
/HiLightButton
{
gsave
HiLiteColor setcolor
0 0 ItemWidth ItemHeight rectpath fill
HiLiteColor PaintShadow
ShadowColor PaintHiLite
HiLiteColor PaintFace
ItemFrame dup neg translate
PaintLabel
grestore
} def
/PaintButton
{
gsave
FaceColor setcolor
0 0 ItemWidth ItemHeight rectpath fill
ShadowColor PaintShadow
HiLiteColor PaintHiLite
FaceColor PaintFace
PaintLabel
grestore
} def
/PaintFace % FaceColor => -
{
setcolor
ItemFrame 0 0 ItemWidth ItemHeight insetrect rectpath fill
} def
/PaintShadow % ShadowColor => -
{
setcolor
0 0 moveto
ItemFrame ItemFrame rlineto
ItemWidth ItemFrame 2 mul sub 0 rlineto
0 ItemHeight ItemFrame 2 mul sub rlineto
ItemFrame ItemFrame rlineto
0 ItemHeight neg rlineto fill
} def
/PaintHiLite % HiLiteColor => -
{
setcolor
0 0 moveto
0 ItemHeight rlineto
ItemWidth 0 rlineto
ItemFrame neg dup rlineto
ItemWidth ItemFrame 2 mul sub neg 0 rlineto
0 ItemHeight ItemFrame 2 mul sub neg rlineto fill
} def
/PaintLabel
{
CurrentTextColor setcolor
ItemLabelFont setfont
ItemWidth 2 div ItemHeight
ItemLabelFont fontheight
ItemLabelFont fontdescent sub
sub 2 div
moveto ItemLabel cshow
} def
classend def
pause
pause
% =============================BtolMenuButton Item=============================
/BtolMenuButton BtolButton
dictbegin
/State false def
/ParentMenu null def
/PullRight? false def
/ArrowSize 0 def
/SubMenu null def
dictend
classbegin
/new % Pullright label notifyproc ParentMenu width height => instance
{
2 index /ClientCanvas get 3 1 roll 4 -1 roll 7 1 roll
/new super send
begin
/ItemValue false def
/ArrowSize ItemLabelFont fontheight 2 mul 3 div def
/PullRight? exch def
/ParentMenu exch def
0 0 move
PullRight?
{
/ItemWidth ItemWidth ArrowSize 1.5 mul add def
0 0 ItemWidth ItemHeight reshape
} if
currentdict
end
} def
/movesubmenu
{
SubMenu null ne ItemValue true eq and
{
/map SubMenu send
} if
} def
/resetcolors
{
/resetcolors super send
paint
PullRight?
{
/resetcolors SubMenu send
} if
} def
/sethue % hue => -
{
dup /sethue super send
paint
PullRight?
{
/sethue SubMenu send
}
{
pop
} ifelse
} def
/unmap
{
SubMenu null ne
{
/unmap SubMenu send
} if
} def
/ZapNotify
{
SubMenu null ne
{
/ZapNotify SubMenu send
} if
} def
/destroy
{
ZapNotify
} def
/PaintItem
{
%State true eq PullRight? and { /paint SubMenu send } if
ItemValue true eq
State true eq or
{HiLightButton}
{PaintButton} ifelse
gsave
PullRight?
{
ItemValue true eq
State true eq or
{ ItemFrame dup neg translate } if
ShadowColor setcolor
ItemWidth ArrowSize 1.5 mul sub
ItemHeight 2 div translate
0 ArrowSize 2 div neg moveto
0 ArrowSize 2 div lineto
.866 ArrowSize mul 0 lineto
stroke
HiLiteColor setcolor
.866 ArrowSize mul 0 moveto
0 ArrowSize 2 div neg lineto
stroke
} if
grestore
} def
/PaintLabel
{
CurrentTextColor setcolor
10 ItemHeight
ItemLabelFont fontheight
ItemLabelFont fontdescent sub
sub 2 div
moveto ItemLabel show
} def
classend def
pause
pause
/BtolWindow LiteWindow
dictbegin
/items null def
/itemmgr null def
/IsUp? false def
/ControlInterests null def
/ControlMgr null def
/FrameTextColor 0 0 0 rgbcolor def
/MenuLabel () def
/BorderWidth 0 def
/BorderLeft 1 def
/BorderBottom 1 def
/BorderRight 1 def
/BorderTop 0 def
/ControlSize 0 def
/ControlFrame 2 def
/IconFrame 2 def
/ShadowColor .1 .1 .1 rgbcolor def
/HiLiteColor .9 .9 .9 rgbcolor def
/FaceColor .7 .7 .7 rgbcolor def
/Resizable? false def
/Closable? false def
/Zappable? false def
dictend
classbegin
/new % parentcanvas => window
{
/new super send
begin
/ClientMenu null def
/ControlInterests 15 dict store
/FrameFillColor FaceColor def
/FrameTextColor ShadowColor def
/FrameFont /Times-Roman findfont 18 scalefont def
/BorderTop FrameFont fontheight 1.5 mul store
/ControlSize FrameFont fontheight store
/IconFont /Helvetica findfont 10 scalefont def
currentdict
end
} def
/map
{
/IsUp? true def
/map super send
} def
/unmap
{
/IsUp? false def
/unmap super send
} def
/unhide
{
IsUp? { /map super send } if
} def
/hide
{
IsUp? { /unmap super send } if
} def
/resetcolors
{
/ShadowColor .1 .1 .1 rgbcolor store
/HiLiteColor .9 .9 .9 rgbcolor store
/FaceColor .7 .7 .7 rgbcolor store
} def
/sethue % hue
{
/Hue exch def
/HiLiteColor Hue 0.3 1 hsbcolor def
/ShadowColor Hue 1 0.45 hsbcolor def
/FaceColor Hue 0.4 .9 hsbcolor def
/FrameFillColor FaceColor def
/FrameTextColor ShadowColor def
} def
/ZapNotify
{
ClientCanvas /Retained false put
FrameCanvas /Retained false put
ClientCanvas 0 0 0 0 rectpath reshapecanvas
FrameCanvas 0 0 0 0 rectpath reshapecanvas
FrameEventMgr null ne { FrameEventMgr killprocess } if
itemmgr null ne {itemmgr killprocess} if
ControlMgr null ne { ControlMgr killprocess } if
currentdict /ZapControl undef
currentdict /CloseControl undef
currentdict /LeftStretchControl undef
currentdict /MiddleStretchControl undef
currentdict /RightStretchControl undef
currentdict /ControlMgr undef
currentdict /FrameEventMgr undef
currentdict /ClientCanvas undef
currentdict /FrameCanvas undef
currentdict /ControlInterests undef
currentdict /FrameInterests undef
currentdict /items undef
} def
/CloseNotify { flipiconic } def
/destroy
{
ZapNotify
} def
/PaintFrame %
{
PaintFrameBorder
0 FrameHeight BorderTop sub 1 add
FrameWidth 1 sub BorderTop 1 sub rectpath
gsave
FrameFillColor setcolor fill
grestore
FrameTextColor setcolor stroke
PaintFrameControls
PaintFrameLabel
} def
/HiLiteFrame
{
/FrameFillColor ShadowColor def
/FrameTextColor HiLiteColor def
paintframe
} def
/DeHiLiteFrame
{
/FrameFillColor FaceColor def
/FrameTextColor ShadowColor def
paintframe
} def
/IconPaintFace % FaceColor => -
{
setcolor
IconFrame 0 0 IconWidth IconHeight insetrect rectpath fill
} def
/IconPaintShadow % ShadowColor => -
{
setcolor
0 0 moveto
IconFrame dup rlineto
IconWidth IconFrame 2 mul sub 0 rlineto
0 IconHeight IconFrame 2 mul sub rlineto
IconFrame dup rlineto
0 IconHeight neg rlineto fill
pause
} def
/IconPaintHiLite % HiLiteColor => -
{
setcolor
0 0 moveto
0 IconHeight rlineto
IconWidth 0 rlineto
IconFrame neg dup rlineto
IconWidth IconFrame 2 mul sub neg 0 rlineto
0 IconHeight IconFrame 2 mul sub neg rlineto fill
pause
} def
/PaintIconLabel
{
IconFont setfont
0 IconHeight IconFont fontheight 1.5 mul sub
IconWidth IconFont fontheight 1.5 mul
rectpath ShadowColor setcolor fill
HiLiteColor setcolor
IconWidth 2 div
IconHeight IconFont fontheight sub moveto
IconLabel cshow
pause
} def
/PaintIcon
{
gsave
IconCanvas setcanvas
FaceColor fillcanvas
IconImage null ne
{
0 0 moveto IconImage showicon
} if
IconLabel null ne
{
PaintIconLabel
} if
HiLiteColor IconPaintHiLite
ShadowColor IconPaintShadow
grestore
} def
/CreateFrameInterests % - => - (Create frame control interests)
{
FrameInterests begin
/FrameTopEvent
PointButton /totop
DownTransition FrameCanvas eventmgrinterest def
/FrameMoveEvent
AdjustButton /slide
DownTransition FrameCanvas eventmgrinterest def
/FrameMenuEvent
MenuButton {}
DownTransition FrameCanvas eventmgrinterest def
/FrameDamageEvent
/Damaged /FixFrame
null FrameCanvas eventmgrinterest def
/FrameEnterEvent
/EnterEvent /EnterFrame
[0 2] FrameCanvas eventmgrinterest def
/FrameExitEvent
/ExitEvent /ExitFrame
[0 2] FrameCanvas eventmgrinterest def
/FrameDoItEvent
/DoItEvent {gsave /ClientData get cvx exec grestore}
/Window null eventmgrinterest def
/FrameIconicFcnKeyEvent
/WindowFunction /flipiconic
/FlipIconic FrameCanvas eventmgrinterest def
/FrameFrontFcnKeyEvent
/WindowFunction /totop
/FlipFront FrameCanvas eventmgrinterest def
/IconMenuEvent {} def
end
} def
pause
/CreateCloseControl
{
gsave
FrameCanvas setcanvas
/CloseControl FrameCanvas newcanvas dup begin
/Mapped true def
/EventsConsumed /AllEvents def
end def
/Closable? true def
ControlInterests begin
/FrameCloseEvent
PointButton /CloseNotify
DownTransition CloseControl eventmgrinterest def
end
ControlMgr null ne {ControlMgr killprocess} if
/ControlMgr ControlInterests forkeventmgr store
0 0 ControlSize dup rectpath CloseControl reshapecanvas
grestore
} def
/CreateZapControl
{
gsave
FrameCanvas setcanvas
/ZapControl FrameCanvas newcanvas dup begin
/Mapped true def
/EventsConsumed /AllEvents def
end def
/Zappable? true def
ControlInterests begin
/FrameZapEvent
PointButton /destroy
DownTransition ZapControl eventmgrinterest def
end
ControlMgr null ne {ControlMgr killprocess} if
/ControlMgr ControlInterests forkeventmgr store
0 0 ControlSize dup rectpath ZapControl reshapecanvas
grestore
} def
/CreateResizeControl
{
gsave
/Resizable? true def
/BorderBottom FrameFont fontheight 2 div 10 max def
FrameCanvas setcanvas
ShapeClientCanvas
/LeftStretchControl FrameCanvas newcanvas dup begin
/Mapped true def
/EventsConsumed /AllEvents def
end def
/MiddleStretchControl FrameCanvas newcanvas dup begin
/Mapped true def
/EventsConsumed /AllEvents def
end def
/RightStretchControl FrameCanvas newcanvas dup begin
/Mapped true def
/EventsConsumed /AllEvents def
end def
ControlInterests begin
/FrameLeftStretchEvent
PointButton {totop stretchcorner}
DownTransition LeftStretchControl eventmgrinterest def
/FrameMiddleStretchEvent
PointButton {totop stretchwindowedge}
DownTransition MiddleStretchControl eventmgrinterest def
/FrameRightStretchEvent
PointButton {totop stretchcorner}
DownTransition RightStretchControl eventmgrinterest def
end
ControlMgr null ne {ControlMgr killprocess} if
/ControlMgr ControlInterests forkeventmgr store
0 0
15 BorderBottom
rectpath LeftStretchControl reshapecanvas
0 0
FrameWidth 30 sub BorderBottom
rectpath MiddleStretchControl reshapecanvas
0 0
15 BorderBottom
rectpath RightStretchControl reshapecanvas
grestore
} def
/CreateIconInterests % - => - (Create icon control interests)
{
FrameInterests begin
/IconOpenEvent
PointButton /flipiconic
DownTransition IconCanvas eventmgrinterest def
/IconMoveEvent
AdjustButton /slide
DownTransition IconCanvas eventmgrinterest def
/IconMenuEvent {} def
/IconDamageEvent
/Damaged /FixIcon
null IconCanvas eventmgrinterest def
/IconIconicFcnKeyEvent
/WindowFunction /flipiconic
/FlipIconic IconCanvas eventmgrinterest def
/IconFrontFcnKeyEvent
/WindowFunction /totop
/FlipFront IconCanvas eventmgrinterest def
end
} def
/CreateFrameControls % - => - (Create frame control canvases/items)
{
} def
/CreateFrameCanvas % - => - (Create empty frame canvas)
{
/FrameCanvas ParentCanvas newcanvas def
/ptr /ptr_m FrameCanvas setstandardcursor
} def
/CreateFrameMenu { } def
/CreateIconMenu { } def
/MoveFrameControls % - => - ([Re]set frame control shapes)
{
gsave
Closable?
{
CloseControl setcanvas
ControlFrame FrameHeight BorderTop sub BorderTop
ControlSize sub 2 div add
movecanvas
} if
Zappable?
{
ZapControl setcanvas
FrameWidth ControlSize ControlFrame add sub FrameHeight
BorderTop sub BorderTop ControlSize sub 2 div add
movecanvas
} if
Resizable?
{
LeftStretchControl setcanvas
0 0 movecanvas
MiddleStretchControl setcanvas
0 0
FrameWidth 30 sub BorderBottom
rectpath MiddleStretchControl reshapecanvas
15 0 movecanvas
RightStretchControl setcanvas
FrameWidth 15 sub 0 movecanvas
} if
grestore
} def
/PaintFrameBorder { % - => - (Paint frame border areas)
ShadowColor strokecanvas
} def
/PaintFocus { } def
/PaintFrameLabel {
gsave
FrameTextColor setcolor FrameFont setfont
FrameWidth 2 div FrameHeight FrameFont fontheight sub moveto
FrameLabel cshow
grestore
} def
/ControlPaintFace % FaceColor => -
{
setcolor
ControlFrame 0 0 ControlSize dup insetrect rectpath fill
} def
/ControlPaintShadow % ShadowColor => -
{
setcolor
0 0 moveto
ControlFrame dup rlineto
ControlSize ControlFrame 2 mul sub 0 rlineto
0 ControlSize ControlFrame 2 mul sub rlineto
ControlFrame dup rlineto
0 ControlSize neg rlineto fill
} def
pause
/ControlPaintHiLite % HiLiteColor => -
{
setcolor
0 0 moveto
0 ControlSize rlineto
ControlSize 0 rlineto
ControlFrame neg dup rlineto
ControlSize ControlFrame 2 mul sub neg 0 rlineto
0 ControlSize ControlFrame 2 mul sub neg rlineto fill
} def
/PaintFrameControls
{
gsave
Closable?
{
CloseControl setcanvas
FaceColor setcolor
clippath fill
ShadowColor ControlPaintShadow
HiLiteColor ControlPaintHiLite
FaceColor ControlPaintFace
ShadowColor setcolor
ControlFrame dup 2 div add 0 0 ControlSize dup insetrect
rectpath fill
FaceColor setcolor
ControlFrame dup add 0 0 ControlSize
dup ControlFrame sub insetrect
rectpath fill
} if
Zappable?
{
ZapControl setcanvas
FaceColor setcolor
clippath fill
ShadowColor ControlPaintShadow
HiLiteColor ControlPaintHiLite
FaceColor ControlPaintFace
ShadowColor setcolor
2
{
ControlFrame dup add dup moveto
ControlSize ControlFrame dup add sub dup lineto
ControlFrame dup add ControlSize ControlFrame
dup add sub moveto
ControlSize ControlFrame dup add sub
ControlFrame dup add lineto
stroke
-1 0 translate
} repeat
} if
Resizable?
{
LeftStretchControl setcanvas
FaceColor fillcanvas
ShadowColor strokecanvas
MiddleStretchControl setcanvas
FaceColor fillcanvas
ShadowColor strokecanvas
RightStretchControl setcanvas
FaceColor fillcanvas
ShadowColor strokecanvas
} if
grestore
} def
/reshape
{
/reshape super send
MoveFrameControls
} def
classend
def
pause
pause
/BtolMenu BtolWindow
dictbegin
/CMI null def
/MenuActions null def
/MenuChoices null def
/MenuItemFont /Helvetica findfont 14 scalefont def
/MenuLabelFont /Helvetica-Bold findfont 14 scalefont def
/MenuItems [] def
/MenuItemsEM null def
/ParentMenu null def
/Pinned? false def
dictend
classbegin
/new % [menu items names] [actions] => window
{
framebuffer /new super send
begin
/MenuActions exch store
/MenuChoices exch store
/FrameFont MenuLabelFont def
/FrameFillColor ShadowColor def
/FrameTextColor HiLiteColor def
/BorderWidth 0 def
/BorderLeft 0 def
/BorderRight 0 def
/BorderBottom 0 def
/BorderTop MenuLabelFont fontheight 10 add def
0 100 1 1 reshape
CreateZapControl
0 0 1 1 rectpath ZapControl reshapecanvas
ClientCanvas /Retained true put
MakeMenuItems
currentdict
end
} def
/dragmenu
{
ParentMenu null ne
{
gsave
framebuffer setcanvas
ParentMenu /FrameCanvas get getcanvaslocation
ParentMenu begin
FrameHeight add exch
FrameWidth add exch
end
FrameHeight sub move
grestore
} if
} def
/move
{
/move super send
CMI null ne
{
pause
/dragmenu CMI /SubMenu get send
} if
} def
/slide
{
{
GetCanvas setcanvas
InteractionLock
{
20 dict begin
/absmove
{
gsave
%Canvas setcanvas [1 0 0 1 0 0] setmatrix
yo add exch xo add exch move
grestore
pause
} def
gsave
[1 0 0 1 0 0] setmatrix % initmatrix
/Canvas currentcanvas def
currentcursorlocation
/yo exch neg def /xo exch neg def
clippath pathbbox
/height exch def /width exch def pop pop
Canvas parentcanvas createoverlay setcanvas
0 0
{ absmove newpath }
getanimated waitprocess aload pop
absmove
grestore
end
} monitor
ParentMenu null ne Pinned? not and {detach} if
} fork pop
} def
/map
{
MenuItems
{
/SubMenu get dup null ne
{
{Pinned? {map} if } exch send
}
{
pop
} ifelse
} forall
CMI null ne
{
/map CMI /SubMenu get send
} if
/map super send
} def
/unmap
{
/unmap super send
CMI null ne
{
/unmap CMI /SubMenu get send
} if
MenuItems
{
/SubMenu get dup null ne
{
{Pinned? {unmap} if } exch send
}
{
pop
} ifelse
} forall
} def
/totop
{
MenuItems
{
/SubMenu get dup null ne
{
{Pinned? {totop} if } exch send
}
{
pop
} ifelse
} forall
CMI null ne
{
/totop CMI /SubMenu get send
} if
/totop super send
} def
/unmapsubmenus % - => -
{
CMI null ne
{
/unmapsubmenus CMI /SubMenu get send
} if
unmap
} def
/resetcolors
{
/resetcolors super send
HiLiteFrame
MenuItems
{
/resetcolors exch send
} forall
} def
/sethue % hue
{
dup /sethue super send
HiLiteFrame
MenuItems
{
1 index /sethue 3 -1 roll send
} forall
pop
} def
/flipcmi % BtolMenuButton => -
{
dup CMI eq
{
dup /State get
{
pop
null setcmi
}
{
setcmi
} ifelse
}
{
setcmi
} ifelse
} def
/setcmi % BtolMenuButton => - %%% cmi(Current Menu Item)
{
CMI null ne
{
/DeHiLite CMI send
/unmapsubmenus CMI /SubMenu get send
} if
/CMI exch store
CMI null ne
{
CMI /SubMenu get /Pinned? get
{
/CMI null store
}
{
/HiLite CMI send
{AutoSize totop dragmenu map}
CMI /SubMenu get send
} ifelse
} if
} def
/getcmi % - => BtolMenuButton
{
CMI
} def
/detach
{
Pinned? not
{
/Pinned? true store
0 0 ControlSize dup rectpath ZapControl reshapecanvas
MoveFrameControls
PaintFrameControls
} if
{CMI null ne {/DeHiLite CMI send /CMI null def} if} ParentMenu send
} def
/ReshapeMenuItems % - => -
{
/tmp MenuItems 0 get /ItemHeight get def
0 1 MenuItems length 1 sub
{
1 FrameHeight BorderTop sub tmp 1 add 3 index 1 add mul sub
FrameWidth 2 sub tmp /reshape MenuItems 7 -1 roll get
send
} for
} def
/AutoSize % called after any change to the frame label or font
{
gsave
FrameFont setfont
/FrameWidth FrameLabel ( ) append stringwidth pop ControlSize 2 add dup add add def
grestore
MenuItems
{
/FrameWidth exch /ItemWidth get FrameWidth max store
pause
} forall
/FrameWidth FrameWidth 2 add def
/FrameHeight MenuItems length MenuItems 0 get
/ItemHeight get 1 add mul BorderTop add def
FrameX FrameY FrameWidth FrameHeight reshape
ReshapeMenuItems
} def
/MakeMenuItems % - => -
{
/MenuItems
[
0 1 MenuChoices length 1 sub
{
MenuActions 1 index get type /dicttype eq
{
MenuChoices
self
MenuActions 3 index get
begin
/ParentMenu exch def
/FrameLabel exch 2 index get def
end
true
MenuChoices 2 index get
{
self /flipcmi ParentMenu send
}
self 0 0
/new BtolMenuButton send dup
begin
/SubMenu MenuActions 4 -1 roll get def
/ItemLabelFont MenuItemFont def
end
}
{
false
MenuChoices 2 index get
MenuActions 4 -1 roll get
self 0 0
/new BtolMenuButton send dup
begin
/ItemLabelFont MenuItemFont def
end
} ifelse
0 0 /move 3 index send
pause
} for
] def
/MenuItemsEM MenuItems forkitems def
AutoSize
} def
/PaintClient
{
MenuItems paintitems
} def
/CreateFrameInterests { % - => - (Create frame control interests)
FrameInterests begin
/FrameTopEvent
PointButton /totop
DownTransition FrameCanvas eventmgrinterest def
/FrameMoveEvent
AdjustButton /slide
DownTransition FrameCanvas eventmgrinterest def
/FrameDamageEvent
/Damaged /FixFrame
null FrameCanvas eventmgrinterest def
end
} def
/ZapNotify
{
MenuItems {/ZapNotify exch send} forall
MenuItemsEM null ne { MenuItemsEM killprocess } if
/ZapNotify super send
currentdict /MenuItems undef
currentdict /ParentMenu undef
currentdict /CMI undef
} def
/destroy
{
Pinned?
{
unmap
0 0 1 1 rectpath ZapControl reshapecanvas
/Pinned? false store
}
{
ZapNotify
} ifelse
} def
/CreateFrameMenu {} def
/flipiconic {} def
classend
def
pause
pause
/BtolAppWin BtolWindow
dictbegin
/Childern null def
dictend
classbegin
/AppWindow null def
/TmpAppWin null def
/new % label => instance
{
dup type /stringtype eq {framebuffer} {() exch} ifelse
/new super send
begin
/FrameLabel exch def
/IconLabel FrameLabel def
/FrameMenu
[(Info ...) (Hide) (Quit)]
[
{}
{ /flipiconic /getappwin BtolAppWin send send }
{ /ZapNotify /getappwin BtolAppWin send send }
]
/new BtolMenu send def
FrameMenu /FrameLabel FrameLabel put
/AutoSize FrameMenu send
/PaintClient
{
FaceColor fillcanvas
} def
FrameX FrameY 1 1 reshape
CreateZapControl
currentdict
AppWindow null ne { /totop AppWindow send } if
/Children [] def
end
} def
/newsubwin
{
framebuffer /new BtolWindow send dup dup
/Children Children dup length 1 add 4 -1 roll arrayinsert def
self exch
begin
/ParentApp exch def
/FrameLabel 3 -1 roll def
ParentApp begin
ShadowColor FaceColor HiLiteColor
end
/HiLiteColor exch def
/FaceColor exch def
/ShadowColor exch def
/IconLabel FrameLabel def
/FrameFillColor ShadowColor def
/FrameTextColor HiLiteColor def
/PaintClient { FaceColor fillcanvas } def
/totop
{
ParentApp /FrameMenu get /FrameCanvas get /CanvasAbove get null ne
ParentApp /FrameMenu get /FrameCanvas get /CanvasBelow get FrameCanvas ne or
{
ParentApp /setappwin ParentApp send
/totop super send
/totop ParentApp /FrameMenu get send
} if
} def
/destroy { /unmap self send } def
FrameX FrameY 1 1 reshape
end
} def
/flipiconic
{
/unmap self send
/Iconic? Iconic? not def
IconX null eq
{
FrameX FrameY FrameHeight add IconHeight sub /move self send
} if
ZoomProc
/map self send
Iconic? not
{
self setappwin
/totop FrameMenu send
/map FrameMenu send
}
{
/unmap FrameMenu send
}
ifelse
} def
/map
{
Iconic? not { Children { /unhide exch send } forall } if
/map super send
} def
/unmap
{
Iconic? not { Children { /hide exch send } forall } if
/unmap super send
} def
/paint %
{
AppWindow self eq
%FrameMenu /FrameCanvas get /Mapped get
{ /paint FrameMenu send } if
/paint super send
} def
/totop % - => -
{
self setappwin
FrameMenu /FrameCanvas get /CanvasAbove get null ne
FrameMenu /FrameCanvas get /CanvasBelow get FrameCanvas ne or
{
/totop super send
/totop FrameMenu send
} if
} def
/resetcolors
{
/resetcolors super send
FrameMenu null ne
{
/resetcolors FrameMenu send
/paint FrameMenu send
} if
} def
/sethue % hue => -
{
dup /sethue super send
FrameMenu null ne { /sethue FrameMenu send } { pop } ifelse
AppWindow self eq
{
HiLiteFrame
painticon
} if
} def
/getappwin % - => CurrentAppWindow
{
AppWindow
} def
/setappwin % BtolAppWin => -
{
/TmpAppWin exch store
AppWindow TmpAppWin ne
{
AppWindow null ne
{
{
/unmap FrameMenu send
DeHiLiteFrame
} AppWindow send
} if
/AppWindow TmpAppWin store
AppWindow null ne
{
{
/map FrameMenu send
HiLiteFrame
} AppWindow send
} if
} if
} def
/setmenu % BtolMenu => -
{
} def
/ZapNotify
{
/ZapNotify FrameMenu send
Children { /ZapNotify exch send } forall
self getappwin eq {/AppWindow null store} if
/ZapNotify super send
} def
/destroy
{
ZapNotify
} def
/arrayindex % array value => index true | false
{
2 dict begin
/i 0 def
/v exch def
false
exch {
/v load eq {pop i true exit} {/i i 1 add def} ifelse
} forall
currentdict /v undef
currentdict /i undef
end
} def
/destroychild % BtolWin => -
{
dup
Children exch arrayindex
{
/Children Children 3 -1 roll arraydelete store
/ZapNotify exch send
}
{
pop
console (Not a child of win\n) [] fprintf
} ifelse
} def
/destroychildren % [BtolWin] => -
{
{
dup
Children exch arrayindex
{
/Children Children 3 -1 roll arraydelete store
/ZapNotify exch send
}
{
pop
console (Not a child of win\n) [] fprintf
} ifelse
} forall
} def
/DeHiLiteFrame
{
Children { /DeHiLiteFrame exch send } forall
/DeHiLiteFrame super send
} def
/HiLiteFrame
{
Children { /HiLiteFrame exch send } forall
/HiLiteFrame super send
} def
classend
def
pause
pause
end