#!/usr/NeWS/bin/psh
%
% Date: Wed, 26 Apr 89 18:22:53 EDT
% To: NeWS-makers@brillig.umd.edu
% Subject: Windows in windows in windows (This one works)
% From: spectral!sjs@bellcore.com  (Stan Switzer)
% 
% The hackman always posts twice....  Apologies for any inconvenience.
% 
% The previous version of "winwin" didn't work.  Without going into too
% much detail let's just say that it worked here when I posted it, but
% it had no chance to work anywhere else (unless you had autobind off
% when you define your root menu).  I really have to watch those
% last-minute changes.
% 
% Anyway, this version is fixed (really).  It remains fragile in all
% ways detailed in the previous message, but it can be useful nonetheless.
% 
% As I said before, it is quite useful to set up several large winwin
% windows, each containing related subwindows.  In a way it's like
% having multiple desktops.
% 
% As always, enjoy,
% 
% Stan Switzer  sjs@ctt.bellcore.com  "Thou shalt not have no idea."
% --------------
%
% WinWin: Windows in windows in windows ...
%
% Copyright (C) 1989 by Stan Switzer. All rights reserved.
% This program is provided for unrestricted use, provided that this
% copyright message is preserved. There is no warranty, and no author
% or distributer accepts responsibility for any damage caused by this
% program.
%
%	Recursive window managment
%
% Stan Switzer   sjs@ctt.bellcore.com
%
% To be fixed:
%   	Highly succeptable to GC leaks resulting in canvases not being
%	released.  The event manager's bad habit of keeping a copy of
%	events around is a likely source of trouble.  I have fixed this
%	once and for all by patching the event manager but it still doesn't
%	eliminate the leaks!
%
% Frailties:
%   	Shared menus retain canvases whose parent could be anything.
%	The "fix" is to reparent the canvases.
%
%	Interests with null canvases are problematic.
%
%	Special behavior of "newcanvas" for framebuffer children is
%	annoying, and can't really be fixed completely by redefinition
%	owing to autobind.
%
%   	Shared menus make life interesting since their canvas's parent links
%	have to be changed on /popup.
%
%       I really don't know why it doesn't work when you have a root piemenu.
%       Current "solution" is to change the rootmenu back to regular menu for
%       the "winwin."
%
% NeWS Bugs:
%   	When a window is reshaped, where subwindows are and where they think
%	they are are two different things entirely.
%
%	Only true root overlay canvases cover their siblings!
%

/WinWin DefaultWindow [ ] classbegin
    /IconImage /client def
    /PaintIcon {
	/PaintIcon super send
	IconBorderColor strokecanvas
    } def
    /FrameLabel (Window Window) def
    /ClientMenu null def
    /CreateClientCanvas {
	/ClientCanvas FrameCanvas newcanvas def
	/ptr /ptr_m ClientCanvas setstandardcursor
	ClientCanvas begin
	    /Transparent false def
	    /Retained false def
	    /EventsConsumed /AllEvents def
	    /Mapped true def
	end
    } def
    /PaintFrameBorder { % - => - (Paint frame border areas)
	clippath pathbbox rectpath
	BorderLeft .5 sub BorderBottom .5 sub
	FrameWidth BorderLeft BorderRight add sub 1 add
	FrameHeight BorderBottom BorderTop add sub 1 add
	FramePath gsave FrameFillColor setshade eofill grestore
	FrameBorderColor setshade stroke FrameBorderColor strokecanvas
    } def

    /ForkFrameEventMgr {
	/FrameEventMgr FrameInterests forkeventmgr def
    } def

    /destroy {
	createevent dup begin
	    /Name /DoItEvent def
	    /Action /Window def
	    /ClientData [
		% /EventMgrDict cvx /CurrentEvent null /put cvx % GC leak
		ClientCanvas /framebuffer cvx /eq cvx { destroy } /if cvx
	    ] cvx def
	end sendevent
	% save some memory in case of GC leaks:
	ClientCanvas /Retained false put
	FrameCanvas /Retained false put
	% Kill some processes:
	/KillProcesses where {
	    /KillProcesses get { killprocess } forall
	    /KillProcesses null store
	} if
	% Kill some groups:
	/KillGroups where {
	    /KillGroups get { killprocessgroup } forall
	    /KillGroups null store
	} if
	% console (OK!\n) writestring console flushfile
	/destroy super send
    } def

    % we only drag the frame since draging the canvas doesn't work too
    % well when there are opaque children
    /slide { % - => -  (Interactively move window)
	{
	    Iconic? { /slide super send } {
		GetCanvas setcanvas
		InteractionLock { true dragcanvas } monitor
		currentcanvas ParentCanvas setcanvas getcanvaslocation
		/move self send
	    } ifelse
	} fork pop
    } def
classend systemdict 3 1 roll put

/copymenu { % - => newmenu  -- a phony menu method
    self dup maxlength dict copy end begin
	/MenuCanvas null def
	/MenuWidth null def
	/MenuEventMgr null def
	/ChildMenu null def
	/MenuActions MenuActions dup length array copy def
	/MenuKeys MenuKeys dup length array copy def
	/MenuItems MenuItems dup length array copy def
	0 1 MenuActions length 1 sub { % for
	    dup getmenuaction
	    dup type { % case(type)  --  i menuaction
		/dicttype {
		    /copymenu exch send	% copy i menu'
		    MenuActions 2 index 2 index put
		    MenuItems 2 index MenuKeys
		    1 index get 3 index MakeMenuItem put
		}
		/arraytype { dup xcheck {
		    systemdict /forkunix get /forkunix cvx rebindit
		} if }
	    } case
	    pop pop
	} for
	currentdict end
} def

/flipstyle { % - => newmenu
    0 1 MenuActions length 1 sub {
	dup getmenuaction % fixed to use getmenuaction!
	dup type /dicttype eq {
	    /flipstyle exch send	% i menu'
	    MenuActions 3 1 roll put	% -
	} {pop pop} ifelse
    } for
    MenuKeys MenuActions /new DefaultMenu send
} def

currentdict framebuffer { begin } pop end % pop user dict
50 dict begin		% The things we do for recursive WinWins!
    /framebuffer exch def
    /fboverlay framebuffer createoverlay def
    /newcanvas {
	dup framebuffer eq exch
	systemdict /newcanvas get exec
	exch {
	    dup /Transparent false put
	    dup /Color get not { dup /Retained true put } if
	} if
    } def
    /win framebuffer /new WinWin send def
    /reshapefromuser win send
    /map win send
    win
    /win null def
end
exch begin { end } pop /win exch def

% systemdict /foo win put % pseudo-scientific visualizer
systemdict /NextSocket known not { systemdict /NextSocket 2011 put } if

/ServerSocket systemdict begin
    NextSocket /NextSocket NextSocket 1 add def
end def
/FakeServer (NEWSSERVER) getenv
  (;) search pop exch pop (.) search pop exch pop exch % sys addr port
  pop ServerSocket 20 string cvs
  (.) exch append append exch (;) exch append append def

/rebindit {	% proc key val => proc
    2 index	% proc key val proc
    &rebindit pop pop
} def

/&rebindit {	% key val proc => key val
    dup length 0 1 3 2 roll 1 sub {	% key val proc 0 1 lng-1 { ... } for
	2 copy get			% key val proc ix proc[ix]
	dup type /arraytype eq {	% another proc?
	    exch pop exch 4 1 roll	    % proc key val proc[ix]
	    &rebindit 3 -1 roll		    % key val proc
	} {				% key val
	    dup xcheck {		% executable
		4 index eq {	% ... and same as key?
		    % key val proc ix
		    1 index exch 3 index put % key val proc
		} {
		    pop
		} ifelse
	    } {
		pop pop
	    } ifelse
	} ifelse
    } for
    pop
} def

/Hacks dictbegin
    /framebuffer win /ClientCanvas get def
    /fboverlay framebuffer createoverlay def
    % /fboverlay { framebuffer createoverlay dup canvastotop } def
    /newcanvas {
	dup framebuffer eq exch
	systemdict /newcanvas get exec
	exch {
	    dup /Transparent false put
	    dup /Color get not { dup /Retained true put } if
	} if
    } def

    % note: we have to patch LiteWindow because newcanvas was autobound
    % and consequently the above definition has no effect.

    LiteWindow /CreateFrameCanvas get
        systemdict /newcanvas get /newcanvas cvx rebindit pop
    LiteWindow /CreateIconCanvas get
        systemdict /newcanvas get /newcanvas cvx rebindit pop

    % Likewise, LiteWindow ParentCanvas is defined as framebuffer in advance.
    % We'll fix this by defining it to be { framebuffer }.
    LiteMenu /ParentCanvas { framebuffer } put
    [
	DefaultMenu
	/PieMenu where { pop PieMenu dup DefaultMenu eq { pop } if } if
    ] { % forall
	{ % loop
	    dup null eq { pop exit } if
	    dup /showat known {
		dup /showat get systemdict /newcanvas get /newcanvas cvx
		rebindit % classdict showatproc
		0 get /CheckParent ne {
		    dup /showat 2 copy get
		    { CheckParent } {} modifyproc put
		} if
		dup /CheckParent {
		    MenuCanvas null ne {
			MenuCanvas /Parent ParentCanvas put
		    } if
		} put
	    } if
	    /ParentDict get
	} loop
    } forall

    % This is gross, gross, gross, but we must improve the hygiene of
    % the event manager:

    /forkeventmgr load 2 get 19 get dup 22 get /repeat load eq {
	dup 21 { { pop } repeat EventMgrDict /CurrentEvent null put } put
	22 /exec cvx put
    } {
	pop
    } ifelse

    /AllWin { % proc => - (Distributes proc to all windows!!)
	createevent dup begin
	    /Name /DoItEvent def
	    /Action /Window def
	    /ClientData [
		% /EventMgrDict cvx /CurrentEvent null /put cvx % GC leak
		framebuffer /framebuffer cvx /eq cvx [
		    7 index cvx /exec cvx
		] cvx /if cvx
	    ] cvx def
	end sendevent pop
    } def

    /^C { % kill the Window of Windows
	createevent dup begin
	    /Name /DoItEvent def
	    /Action /Window def
	    /ClientData [
		% /EventMgrDict cvx /CurrentEvent null /put cvx % GC leak
		framebuffer
		{
		    ClassName /WinWin eq {
			ClientCanvas eq { self /destroy exch send } if
		    } {
			pop
		    } ifelse
		} /exec cvx
	    ] cvx def
	end sendevent pop
    } def

    /exitcleanly load systemdict /^C get /^C cvx rebindit pop

    /forkunix {
	(NEWSSERVER) getenv
	(NEWSSERVER) //FakeServer putenv
	exch systemdict /forkunix get exec
	(NEWSSERVER) exch putenv
    } def
dictend def

Hacks /def load forall

framebuffer setcanvas PaintRoot

/rootmenu /copymenu rootmenu send def
/DefaultMenu LitePullRightMenu def /rootmenu /flipstyle rootmenu send def

/serverproc { % fork
    clear (%socketl) //ServerSocket 20 string cvs append (r) file
    { % loop
	dup mark exch acceptconnection
	{ % fork
	    Hacks end 200 dict begin { def } forall
	    initmatrix newprocessgroup
	    exch pop exch pop dup
	    getsocketpeername /OriginatingHost exch def

	    RemoteHostRegistry OriginatingHost known
	    OriginatingHost localhostname anchorsearch
	    { pop (.) anchorsearch
		{ pop pop RemoteHostRegistry localhostname known }
		{ pop false } ifelse }
	    { pop false } ifelse or
	    % Let through if no security wanted
	    NetSecurityWanted not or

	    { cvx exec }
	    { currentcursorlocation
		[ (Network security violation:)
		    (Rejected connection from ) OriginatingHost append ]
		popmsg } ifelse
	    currentprocess killprocessgroup
	} fork
	cleartomark
    } loop
} fork def

/rooteventmgr [
    /rootmenu where { pop
	MenuButton
	{ {/showat rootmenu send} fork pop }
	DownTransition framebuffer eventmgrinterest
    } if
    /Damaged { damagepath clipcanvas PaintRoot newpath clipcanvas}
    null framebuffer eventmgrinterest
] forkeventmgr def

win /KillProcesses [ serverproc rooteventmgr ] put
% win /KillGroups [ rooteventmgr ] put

