%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% %%% BTOL -- VERSION 1.0 %%% (Better Than Op*n L**k) %%% %%% 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 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 ItemFont 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 %%DZ fix -- block if %% PaintLabel ItemLabel type /stringtype eq { PaintLabel } { ItemLabel ShadowColor 0 0 ItemFont ShowThing } ifelse grestore } def /PaintButton { gsave FaceColor setcolor 0 0 ItemWidth ItemHeight rectpath fill ShadowColor PaintShadow HiLiteColor PaintHiLite FaceColor PaintFace %%DZ fix -- block if %% PaintLabel ItemLabel type /stringtype eq { PaintLabel } { ItemLabel ItemTextColor 0 0 ItemFont ShowThing } ifelse 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 ItemWidth 2 div ItemHeight ItemFont fontheight ItemFont 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 ItemFont 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 ItemFont fontheight ItemFont 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 MoveFrameControls /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 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 null def /MenuItemsEM null def /ParentMenu null 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 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 } fork pop } def /map { 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 } def /totop { CMI null ne { /totop CMI /SubMenu get send } if /totop super send } def /detach % - => - { CMI null ne { /detach 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 /detach CMI /SubMenu get send } if /CMI exch store CMI null ne { /HiLite CMI send {AutoSize totop dragmenu map} CMI /SubMenu get send } if } def /getcmi % - => BtolMenuButton { CMI } 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 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 { ZapNotify } 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