This is BTOL 1.1

korp at TRIPOLI.EES.ANL.GOV korp at TRIPOLI.EES.ANL.GOV
Sun Dec 10 17:21:30 AEST 1989


Original-posting-by: korp at TRIPOLI.EES.ANL.GOV
Reposted-by: emv at 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 at 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 at athens.ees.anl.gov
%%%
%%%                               David C. Mak
%%%                        Argonne National Laboratory
%%%                         Visual Interfaces Section
%%%                          mak at athens.ees.anl.gov
%%%
%%%                              David G. Zawada
%%%                       Argonne National Laboratory
%%%                        Visual Interfaces Section
%%%                         zawada at 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



More information about the Alt.sources mailing list