%
% BlankScreen: Lights out!
%
% 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.
%
% DESCRIPTION:
%
% BlankScreen quietly monitors your keyboard and mouse for activity,
% invoking a screen-saver when there has been no activity in a user-
% selectable time period.  If, after another user-selectable time period,
% there has been no keyboard or mouse activity, BlankScreen quietly enters
% a "lock" mode which demands your login password before releasing your
% workstation.
%
% At invocation, the variables /BlankTime and /LockTime control the amount
% of idle time that causes blanking and amount of blanked time that leads
% to locking.  Changing these values later has no effect (to protect against
% accidents).  The default times for these values are three minutes
% and two minutes respectively.  If you find locking objectionable, you
% can disable it by setting /LockTime to 0.
%
% When blankscreen is restarted, it kills any other running (but
% unlocked) blankscreen processes.  This allows you to change the
% timer parameters without compromising the security of the
% locking function.
%
% If /BlankFKey is defined, it is the name of a function key to use to
% blank the screen on demand.  Similarly for /LockFKey.  I use the following:
%	/BlankFKey /FunctionF6 def  /LockFKey /FunctionF7 def
%
% The poem can be changed by assigning a different array of strings
% to /Poetry before invoking blankscreen.  A value of "null" disables
% the poetry entirely.
%
% The colors used in the blanking display can be changed by assigning values to
% the appropriate variables before invocation.  Interested parties should
% look at the first few lines of source.
%
% If you don't like the standard animation, there are other alternatives
% You can define the procedure "CreateAnimationObject" to override the
% default animation "PoetryThing".  The following definition will
% result in a bouncing globe instead:
%	/CreateAnimationObject { /new WorldBouncer send } def
% A other alternatives can be found within.  If you don't like any of these,
% you can write your own animation using any of the classes provided (since
% this procedure is invoked after all of the classes are defined).  If you
% need subclassing assistance, or have a nice animation you'd like to share,
% mail me.  If I get enough animations, I'll maintain a library and forward
% them to the the archives periodically.
%
% WARNINGS:
%
% This program checks passwords by trying to connect to your FTP
% server (yes, this is a hack).  You would do well to see if you can
% "ftp localhost" before you begin using this program.
%
% Additionally, either (USER) or (LOGNAME) must be in the environment
% for the locking mode to know who you are.
%
% If either of these two assumptions fails to hold, setting "LockTime"
% to 0 disables automatic locking, thus avoiding the problem.
%
% Because this program goes to great lengths to defeat the keyboard focus
% manager, it depends on things perhaps that might easily change from one
% release on NeWS to another.  I only know for sure that it works in
% NeWS 1.1 with a Sun-3 keyboard.
%
% Finally, "forkunix" must work (I don't know about non-UNIX NeWS
% implementations) and there must be a reasonably standard "date"
% command.
%
% NeWS Notes:
%
% Apparently, mouse transitions caught by a non-canvas specific and
% non-exclusive interests do not require redistribution, but key transitions
% do.  Since this seems much too arbitrary, I use an exclusive
% interest and redistribute everything.  Probably, I should be registering
% interests relative to a framebuffer overlay instead of a null canvas.
%
% Interests having dictionaries of procs for both their Name and Action
% do not execute either procedure but instead return both an event and array
% from awaitevent.  The array contains the two procedures that should have
% been executed.  Maybe I should have been using "forkeventmgr" anyway to
% avoid all of this hassle (then again, for security reasons, maybe not).
%
% Because a newly created process tends to get the same process table
% address as the last reclaimed dead process and because pending
% process-specific events are not scrubbed when their process dies,
% a process will occasionally receive an event sent to a previous
% incarnation of itself.  This can be a pain if you get two shuttle events,
% for instance, together driving a timing loop.  My solution is to include
% a "uniquecid" value as the action in both the event and the interest so
% that we can't get these bogus events.
%
% There are certain interesting techniques in here that you may feel free
% to borrow.  My favorite is the "condition" handler.  A close runner-up
% is the FTP password hack (thanks Don) and the date query.  Please
% do not use the keyboard handling as a model for input handling since
% this code intentionally subverts the very mechanisms you should
% generally be using.
%
% ------------
% Stan Switzer   sjs@ctt.bellcore.com
%
% 3/27/89 - SJS
%	Release 1.0
% 3/29/89 - SJS
%	Cleaned up animation and timing mechanisms

% Start a new dictionary here to prevent patching the locking code, prevent
% unauthorized access to the /Password entry, and to avoid systemdict
% namespace pollution.

100 dict begin { end } pop    % { end } pop is to fool formatters!

/default { % key val -> -   def into current dictionary, val is default
    1 index where { 2 index get exch pop } if def
} def

/BlankTime 180 default
/LockTime 120 default

/Testing? false def
% /Testing? true def

/conprint { pop pop } def
/Conprint { sprintf console exch writestring console flushfile } def
% /conprint /Conprint load def

% Colors:
/SC { % key grayshade pastelhue-or-color -> -   set color
    dup type /colortype ne { .35 1 hsbcolor } if % pastel hue
    ColorDisplay? not 3 1 roll ifelse
    dup type /colortype ne { dup dup rgbcolor } if % gray value
    default
} def
/BlankColor 0 0 0 0 rgbcolor SC
/HourColor 1 .5 SC
/MinColor 1 .5  SC
/ClockColor 1 .5 SC
/TextColor 1 .5  SC
/QuoteColor 1 .5  SC
/QueryFillColor 1 1 1 1 rgbcolor SC
/QueryTextColor 0 0 0 0 rgbcolor SC
/RaspberryFillColor 1 1 1 1 rgbcolor SC
/RaspberryTextColor 0 0 0 0 rgbcolor SC

% Generally, I prefer that users wishing to change the displayed verses do
% so by defining the new verses before "running" this file.  This way, we
% can avoid unnecesary speciation of this program.

/Poetry [
    (`The time has come', the Walrus said,)
    (       `To talk of many things:)
    (Of shoes\320and ships\320and sealing wax\320)
    (       Of cabbages\320and kings\320)
    (And why the sea is boiling hot\320)
    (       And whether pigs have wings.')
    (                 \320 Lewis Carroll)
] default

% Likewise, I have defined hooks to specify your own animation.  Use them
% if at all possible.  Redefine either proc, as convenient, to create or
% select the animation.

/CreateAnimationObject { % passed the canvas on which to animate
    DefineAnimationClass % backward compatability
    /new AnimationClass send
} default

/DefineAnimationClass {  % defines the default animation class
    % /AnimationClass PoetryThing def
    % /AnimationClass WorldBouncer def
    % /AnimationClass WorldNeWSBouncer def
    % /AnimationClass ClockThing def
    % /AnimationClass BounceClockThing def
    % /AnimationClass StarField def
    % /AnimationClass SkyRockets def
    % /AnimationClass PoetryAndBouncer def
    % /AnimationClass WorldAndStars def
    % /AnimationClass Circulator def
    /AnimationClass Randomator def
} default

% We are going to be paranoid and hoist certain non-operator procs into
% our private dictionary to prevent insertion of trojan horses in the
% password collection and checking logic.  I know of a few holes here, but
% I don't see the point of documenting them, if you get my drift.  Still,
% considering how "append," for instance, is used in here, it is only
% prudent to protect ourselves.

/CopyProc { % proc -> proc'
    dup type /arraytype eq { % array?
	dup xcheck exch 0 exch { % forall -- exec? n item
	    CopyProc exch 1 add
	} forall
	array astore exch { cvx } if
    } if
} def

[ /append ] {  % hoist these global procs ...
    dup load CopyProc def
} forall

/GetDate { % - -> (str) true -or- false
    { 25 dict begin % fork (to keep events from being confused)
	/Interest createevent dup begin
	    /Name [ /TimeOut /Date ] def
	end dup expressinterest def
	/Timer Interest createevent copy dup begin
	    /Name /TimeOut def
	    /TimeStamp currenttime .25 add def
	end dup sendevent def
	(echo "createevent dup begin)
	(         /Name /Date def /Action (`date`)) append
	(      def end sendevent" | psh) append forkunix
	awaitevent dup /Name get /TimeOut eq {
	    pop [ false ]
	} {
	    Timer recallevent
	    /Action get [ exch true ]
	} ifelse
    end } fork waitprocess aload pop
} def
% GetDate stack

/GetHHMMSS { % - -> hh mm ss true -or- false
    GetDate {
	3 { ( ) search { % (true) post match pre
	    { exch pop () ne { exit } if ( ) search not { exit } if } loop
	} if } repeat
	( ) search 4 2 roll pop pop pop
	2 { (:) search pop exch pop cvi exch } repeat cvi
	true
    } {
	false
    } ifelse
} def
% GetHHMMSS

/Midnight {
    Midnightproc waitprocess pop
    /Midnightproc null store
    Midnight
} def
/Midnightproc { 
    /Midnight currenttime GetHHMMSS
    % try again if it didn't work (maybe server wasn't started yet)
    true { GetHHMMSS } ifelse
    % try still again if it didn't work (this time we'll wait a bit)
    true { 1 sleep GetHHMMSS } ifelse
    { % worked?
	3 -1 roll 60 mul 3 -1 roll add exch 60 div add sub store true
    } { % not worked?
	pop pop false
    } ifelse
} fork def

/Animator Object dictbegin
    /AnimatorProc null	def
    /CanW	  0	def
    /CanH	  0	def
    /Canvas	  null	def
dictend classbegin
    
    % public methods:
    /new { % canvas -> -
	/new super send begin
	    /Canvas exch def
	    gsave Canvas setcanvas clippath pathbbox
	    /CanH exch def /CanW exch def pop pop
	    currentdict
	end
    } def
    /animate { % bool -> -
	AnimatorProc null ne {  % Don't dance!
	    /AnimatorProc dup load killprocess null def
	} if
	{   % Dance!
	    /AnimatorProc { %fork
		Animate
	    } fork def
	} if
    } def
    /paint {
	GSave gsave FillColor fillcanvas grestore
	DoPaint grestore
    } def
    
    % Painting methods:
    /FillColor 0 def
    /TextColor TextColor def
    /Font currentfont def
    /GSave {
	gsave Canvas setcanvas TextColor setshade Font setfont
    } def
    /Paint nullproc def
    /DoPaint { Paint } def
    
    % Animation methods:
    /Interval 1 60 div def
    /Animate {
	InitAnimation
	createevent dup begin
	    /Name /Animator def
	    % shouldn't have to do this but newly created process sometimes
	    % spoofs as previous one and gets the old event even tho it is
	    % process-specific!
	    /Action uniquecid def
	end dup expressinterest createevent copy
	{
	    AnimateStep
	    dup begin
		/TimeStamp pause currenttime Interval add def
	    end sendevent
	    awaitevent % leave event on stack
	} loop
    } def
    /AnimateStep nullproc def
    /InitAnimation nullproc def

classend def

/AnimatedThing Animator dictbegin
    /X		  0	def
    /Y		  0	def
dictend classbegin
    
    % public methods:
    /new { % canvas -> -
	/new super send begin
	    DoubleBuffer? { InstallDoubleBuffer } if
	    currentdict
	end
    } def

    % random motion (default):
    /MoveRandom {
	CanW CanH Size
	3 -1 roll exch sub random mul cvi
	3 1 roll sub random mul cvi exch
	/Y exch store /X exch store
    } def
    /MoveThing /MoveRandom load def
    
    % Alternative bouncing motion scheme.
    %   just override as follows:
    %   /MoveThing { MoveBounce } def /InitAnimation { InitBounce } def
    /dX  8 def       /dY 0 def		% velocity
    /d2X 0 def       /d2Y -2 def    	% acceleration (default: down)
    /bounceX -1 def  /bounceY -.95 def	% rebound factors
    /countX 0 def    /countY 0 def     /maxCount 20 def
    /da2v { % d a -> v	    -- distance accel -> velocity
	mul dup 0 lt -2 2 ifelse mul sqrt cvi % (fizix 101)
    } def
    /Outside { % v x lowx highx -> false -or- closest true
	dup 3 index lt
	{ 4 1 roll pop pop 0 ge { true } { pop false} ifelse }
	{ pop dup 2 index gt
	    { exch pop exch 0 le { true } { pop false} ifelse }
	    { pop pop pop false } ifelse
	} ifelse
    } def
    /InitBounce { % reasonable way to intitialize a bounce
	/X 0 def /Y CanH Size exch pop sub def /dY 0 def
    } def
    /MoveBounce {
	/dX dX d2X   add  def   /dY dY d2Y   add  def  % acceleration
	/X  X  dX    add  def   /Y  Y  dY    add  def  % velocity
	Size % W H
	dX X 0 CanW 6 -1 roll sub Outside { % X rebound
	    /X exch def  /dX dX bounceX mul cvi def
	    /countX countX 1 add def countX maxCount ge {
		/dX CanW Size pop sub d2X da2v def
	    } if
	} { /countX 0 def } ifelse
	dY Y 0 CanH 5 -1 roll sub Outside { % Y rebound
	    /Y exch def  /dY dY bounceY mul cvi def
	    /countY countY 1 add def countY maxCount ge {
		/dY CanH Size exch pop sub d2Y da2v def
	    } if
	} { /countY 0 def } ifelse
    } def

    % Painting methods:
    /FillColor 0 def
    /TextColor TextColor def
    /Font currentfont def
    /GSave {
	gsave Canvas setcanvas TextColor setshade Font setfont
    } def
    /DoPaint {
	X Y moveto ComputeThing PaintThing
    } def
    /ComputeThing nullproc def
    /PaintThing { Paint } def

    % Double-buffering scheme:
    %   (a good argument for multiple inheritance)
    /DoubleBuffer? false def
    /InstallDoubleBuffer {
	BuildBufferCanvas
	/PaintThing {
	    gsave
	    currentpoint translate Size scale
	    BufferCanvas ImageToDisplay
	    grestore
	} def
	/ComputeThing {
	    gsave BufferCanvas setcanvas
	    gsave FillColor fillcanvas grestore
	    0 0 moveto Paint grestore
	} def
    } def
    /ImageToDisplay { true exch imagemaskcanvas } def
    /BuildBufferCanvas {
	/BufferCanvas Size 1 [ 3 index 0 0 5 index neg 0 1 index ]
	{ <00> } buildimage def
    } def

    % Animation methods:
    /Interval 3 60 div def
    /AnimateStep {
	GSave
	X Y Size  % for rectpath, after ComputeThing
	MoveThing ComputeThing
	rectpath currentcolor FillColor setshade fill setcolor
	X Y moveto PaintThing
	grestore
    } def

    % Default thing (a small rectangle)
    /Size { 20 20 } def % totally arbitrary
    /Paint {
	Size rect fill % totally arbitrary (gotta do something!)
    } def
    
classend def

/ClockThing AnimatedThing [] classbegin
    /ClockRad 36 def
    /MinHand { ClockRad .8 mul cvi } def
    /HourHand { ClockRad .45 mul cvi } def
    /PaintHand { % deg r -> -
	exch gsave rotate
	-4 -4 moveto 4 -4 lineto 0 exch lineto closepath fill
	grestore
    } def
    /PaintClock { % - -> -
	gsave ClockRad dup rmoveto currentpoint translate
	ClockColor setcolor
	gsave 12 { 30 rotate 
	    -2 ClockRad moveto 4 0 rlineto -2 -6 rlineto closepath fill
	} repeat grestore
	currenttime Midnight sub cvi dup 3600 mod 60 div
	HourColor setcolor
	-30 mul HourHand PaintHand
	MinColor setcolor
	60 mod -6 mul MinHand PaintHand
	grestore
    } def
    /Paint /PaintClock load def
    /Size { ClockRad dup add dup } def
classend def

/BounceClockThing ClockThing [] classbegin
    /DoubleBuffer? true def
    /MoveThing { MoveBounce } def
    /InitAnimation { InitBounce } def
    /Interval .1 60 div def
classend def

/PoetryThing ClockThing [] classbegin
    /Font /Times-Roman findfont 92 scalefont def
    /String (NeWS) def
    /Verses Poetry def
    /NVerses Verses null eq { 0 } { Verses length } ifelse def
    /Poetry? NVerses 0 gt def
    /ClockRad Poetry? 48 36 ifelse def
    /Vfont /Times-Roman findfont 14 scalefont def
    /LogoUp Poetry? 22 0 ifelse def
    /VerseNo 0 def
    /Verse { Verses VerseNo dup 0 lt 1 index NVerses ge or {
	pop /VerseNo 0 store 0 } if get } def
    /InitAnimation { /VerseNo -1 store } def
    /MoveThing { NextVerse /MoveThing super send } def
    /NextVerse { /VerseNo VerseNo 1 add store } def
    /Size {
	/Size super send exch
	GSave
	String stringwidth pop
	Vfont setfont Verses { stringwidth pop max } forall
	add exch
	2 array astore cvx /Size exch def
	Size
    } def
    /Paint {
	PaintClock
	ClockRad 2 mul 0 rmoveto
	gsave 0 LogoUp rmoveto String show grestore
	Poetry? {
	    Vfont dup setfont fontdescent 0 exch rmoveto
	    QuoteColor setcolor Verse show
	} if
    } def
classend def

/ImageBouncer AnimatedThing [ /ImageList /N ] classbegin
    % NB: abstract superclass
    /new { % imagelist canvas -> thing
	/new super send begin
	    /ImageList exch def
	    /N 0 def
	    currentdict
	end
    } def
    % class method!
    /genlist { % (prefix) (suffix) n -> [ imagelist ]
	[ 4 1 roll 1 exch 1 exch { % for: mark ... (pre) (suf) i
	    2 index exch (XXXX) cvs append 1 index append 3 1 roll
	} for pop pop ]
    } def
    /DoubleBuffer? true def
    /CurrImage { % - -> image
	ImageList N get
	dup type /stringtype eq {
	    pause readcanvas pause
	    ImageList N 2 index put
	} if
    } def
    /MoveThing {
	MoveBounce
	/N N 1 add dup ImageList length ge { pop 0 } if def
    } def
    /InitAnimation { InitBounce } def
    /ImageCanvas { false exch imagemaskcanvas } def
    /Paint {
	gsave currentpoint translate Size scale
	CurrImage ImageCanvas
	grestore
    } def
    /Interval .05 60 div def
classend def

/WorldBouncer ImageBouncer [] classbegin
    /new { % canvas -> thing
	(NEWSHOME) getenv (/smi/globes/globe) append (.im1) 30
	/genlist super send
	exch /new super send
    } def
    /Size { 64 64 } def
classend def

/WorldNeWSBouncer WorldBouncer [] classbegin
    /Font {
	/Times-Roman findfont /Size super send exch pop scalefont
	/Font 1 index def
    } def
    /Size {
	/Size super send exch
	gsave Font setfont (NeWS) stringwidth pop grestore add exch
	2 array astore cvx /Size exch def Size
    } def
    /Paint { 
	gsave currentpoint translate
	gsave Size exch pop dup scale CurrImage ImageCanvas grestore
	Size exch pop 0 moveto (NeWS) show
	grestore
    } def
classend def

/StarField Animator dictbegin
    /NStars 0 def
    /Count 0 def
dictend classbegin
    /maxCount 15 def
    /maxNStars 35 def
    /minNStars 15 def
    /AnimateStep {
	NStars {
	    CanW random mul cvi CanH random mul cvi moveto
	    random .4 le {  % blank a patch
		random 1 add 5.5 mul cvi 0
	    } { % color a patch
		random 1.2 mul 1 add cvi 1
	    } ifelse
	    setshade
	    dup rect fill
	} repeat
	/Count Count 1 sub def
	Count 0 lt {
	    /Count maxCount def
	    NStars minNStars gt { /NStars NStars 1 sub def } if
	} if
    } def
    /InitAnimation {
	/NStars maxNStars def
	/Count maxCount def
    } def
    /DoPaint { InitAnimation } def
    /Interval .1 60 div def
classend def

/SkyRockets AnimatedThing [ /State /dLim1 /dLim2 /explR ] classbegin
    /Interval .05 60 div def
    /InitAnimation { % Launch it:
	/State /Ball def
	/X CanW random mul cvi def
	/dX 30 random .5 sub mul cvi def
	/Y 0 def
	/dY CanH Size exch pop sub d2Y da2v def % to top
	/dY dY random 4 div .75 add mul cvi def % times .75 to 1.0
	/dLim1 dY -.7 random mul mul cvi def % explode
	/dLim2 dY -.85 random mul mul cvi def % fizzle
	dLim1 dLim2 lt { /dLim2 dLim1 /dLim1 dLim2 def def } if
    } def
    /MoveThing {
	MoveBounce
	dY dLim1 lt { /State /Explode def /explR 4 def } if
	dY dLim2 lt { InitAnimation } if
    } def
    /Size { 60 60 } def
    /Paint {
	gsave Size 2 idiv exch 2 idiv exch rmoveto currentpoint translate
	State { % case
	    /Ball {
		% -2 -2 5 5 rectpath fill
		0 0 3 0 360 arc fill
	    }
	    /Explode {
		6 { 120 random mul cvi rotate
		    explR random mul 0 moveto
		    explR 2 mul random .5 add mul 0 lineto stroke
		} repeat
		/explR explR 4 add def
	    }
	} case
	grestore
    } def
		
classend def

/Tandomator Object [ /Canvas /Animators ] classbegin % NB: abstract superclass
    /new { % canvas classarray -> obj
	/new super send begin
	    exch /Canvas exch def
	    /Animators exch [ exch { Canvas exch /new exch send } forall ] def
	    currentdict
	end
    } def
    /animate {
	Animators { 1 index exch /animate exch send } forall pop
    } def
    /paint {
	/paint Animators 0 get send
    } def
classend def

/PoetryAndBouncer Tandomator [] classbegin
    /new {
	[ PoetryThing WorldBouncer ] /new super send
    } def
classend def

/WorldAndStars Tandomator [] classbegin
    /new {
	[ StarField WorldBouncer ] /new super send
    } def
classend def
    
/Animations [ PoetryThing WorldBouncer WorldNeWSBouncer PoetryAndBouncer
    WorldAndStars ClockThing BounceClockThing StarField SkyRockets ] def

/Circulator Tandomator [ /Nanimators /Current /N ] classbegin
    /new { % canvas -> obj
	Animations /new super send begin
	    /Nanimators Animators length def
	    /N 0 def
	    currentdict
	end
    } def
    /Animations Animations def % default animation list
    /animate {
	Current null ne {
	    false /animate Current send
	    /Current null def
	} if
	{
	    /Current Animators N get def
	    true /animate Current send
	    /N N 1 add def N Nanimators ge { /N 0 def } if
	} if
    } def
    /paint {
	Current null ne { /paint Current send } if
    } def
classend def

/Randomator Circulator [] classbegin
    /animate {
	dup {
	    /N Nanimators random mul cvi dup Nanimators ge { pop 0 } if def
	} if
	/animate super send
    } def
classend def

DefineAnimationClass % define the chosen animation class

% GetUserid: ->
%		false   	 -- didn't work
%		(userid) true	 -- got user id
/GetUserid {
    (USER) { getenv } stopped {
	pop (LOGNAME) { getenv } stopped {
	    pop false
	} true ifelse
    } true ifelse
} def

% Check password using ftp server (Don Hopkins thought of using FTP).
%
% CheckPW: (userid) (password) ->
%		false   	 -- check didn't work
%		ok? true	 -- OK? is true iff PW is correct
%
% NOTE: we wish to distinguish failure of the checking procedure from
%	failure of the check itself.
/CheckPW {
    { 25 dict begin
	/Password exch def
	/User exch def
	/S (%socketc21) (rw) file def	     % socket
	/R { S exch readline } def	     % str -> str -- read from socket
	/W { S exch writestring S flushfile } def % str -> - -- write socket
	/SR { % (good) (bad) timeoutsec -> good? true -or- false -- srch
	    /Time exch 60 div def
	    /Interest createevent dup begin
		/Name /DoneEvent def
	    end dup expressinterest def
	    /Bad exch def
	    /Good exch def
	    /Match1 { anchorsearch { pop pop true } { pop false } ifelse } def
	    /Match {
		dup type /arraytype eq {
		    { Match1 { true exit } if } forall
		} {
		    Match1
		} ifelse
	    } def
	    /Str 200 string def
	    /Proc { % fork
		{ %  loop
		    Str R not { /Ugly exit } if
		    dup Good Match { /Good exit } if
		    dup Bad Match { /Bad exit } if
		    pop
		} loop exch pop
		Interest createevent copy dup /Action 4 -1 roll put sendevent
	    } fork def
	    /Timer Interest createevent copy dup begin
		/Action /TimeOut def
		/TimeStamp currenttime Time add def
	    end dup sendevent def
	    awaitevent /Action get
	    dup /TimeOut eq {
		Proc killprocess
		pop /Ugly
	    } {
		Timer recallevent
	    } ifelse
	    dup /Ugly eq {
		pop false
	    } {
		/Good eq true
	    } ifelse
	    Interest revokeinterest 
	} def
	
	{ % only once through:
	    (220 ) (xxx ) 15 SR
	    not { false exit } if not { false exit } if
	    (user ) User append (\n) append W
	    (331 ) [ (530 ) (500 ) ] 15 SR
	    not { false exit } if not { false exit } if
	    (pass ) Password append (\n) append W
	    (230 ) [ (530 ) (500 ) ] 20 SR not { false exit } if
	    true exit
	} loop
	dup 2 1 ifelse array astore
	(quit\n) W
	S closefile
    end } fork exch pop exch pop waitprocess aload pop
} def

/UserID GetUserid not (Unknown User) if def

Testing? {
    /win framebuffer /new DefaultWindow send def
    /reshapefromuser win send
    /map win send
    /CanvasToBlank /ClientCanvas win send def
} {
    /CanvasToBlank framebuffer def
} ifelse

/CoverCanvas { % canvas => canvas'
    gsave dup setcanvas
    newcanvas
    dup begin
	/Transparent false def
	/Retained false def
	/Mapped false def
    end
    clippath dup reshapecanvas
    /nouse /nouse_m 2 index setstandardcursor
    grestore
} def

/Blanket CanvasToBlank CoverCanvas def

/Animation Blanket CreateAnimationObject def

% Password query canvas:
/QueryW 350 def /QueryH 85 def /QueryR 10 def
/QueryMessage () def
/QueryFont /Times-Roman findfont 18 scalefont def
/QueryCanvas gsave Blanket dup setcanvas
newcanvas dup begin
    /Transparent false def
    /Retained false def
    /Mapped false def
end
clippath pathbbox 4 2 roll pop pop
exch QueryW sub 2 div exch QueryH sub 2 idiv translate
QueryR 0 0 QueryW QueryH rrectpath dup reshapecanvas
grestore def

% Error message canvas:
/RaspberryW 350 def /RaspberryH 85 def /RaspberryR 10 def
/Raspberry () def  % the error message
/RaspberryFont /Times-Roman findfont 18 scalefont def
/RaspberryCanvas gsave Blanket dup setcanvas
newcanvas dup begin
    /Transparent false def
    /Retained false def
    /Mapped false def
end
clippath pathbbox 4 2 roll pop pop
exch RaspberryW sub 2 div exch RaspberryH sub 2 idiv translate
RaspberryR 0 0 RaspberryW RaspberryH rrectpath dup reshapecanvas
grestore def

/PWstring 100 string def /PWpos 0 def
/Password () def
/AddPW {
    PWpos PWstring length lt {
	PWstring PWpos 3 -1 roll put
	/PWpos PWpos 1 add store
	/Password PWstring 0 PWpos getinterval store
    } { pop } ifelse % Thanks Don
} def
/DelPW {
    /PWpos PWpos 1 sub 0 max store
    /Password PWstring 0 PWpos getinterval store
} def
/ClearPW {
    /PWpos 0 store
    /Password PWstring 0 PWpos getinterval store
    0 1 Password length 1 sub { Password exch 0 put } for % zero PW string
} def

/seconds { 60 div } def

/Member? { % item array -> bool
    false 3 1 roll { % forall
	1 index eq { exch pop true exch } if
    } forall
    pop
} def

/Secure? { State { /Lock /Query /Check /Raspberry } Member? } def

/State null def

% Timer while in state:
/StateTimes 10 dict dup begin
    /Sleep 15 BlankTime 2 div min seconds def
    /Monitor BlankTime seconds def
    /Blank LockTime seconds def
    /Lock 0 def
    /Query 30 seconds def
    /Check 0 def
    /Raspberry 5 seconds def
end def

/MonitorMouse? true default

/Conditions [
    dictbegin  % Keyboard and mouse monitoring:
	/Condition  { State { /Monitor /Blank /Lock /Raspberry } Member? } def
	/Enter {
	    MonitorClicks expressinterest
	    MonitorMouse? { MonitorMouseDrag expressinterest } if
	} def
	/Leave {
	    MonitorClicks revokeinterest
	    MonitorMouseDrag /IsInterest get {
		MonitorMouseDrag revokeinterest
	    } if
	} def
    dictend
    dictbegin	% Mouse monitoring in "Monitor" state regardless:
	/Condition { State /Monitor eq } def
	/Enter {
	    MonitorMouseDrag /IsInterest get not {
		MonitorMouseDrag expressinterest
	    } if
	} def
    dictend
    dictbegin  % Screen is blanked:
	/Condition {
	    State { /Blank /Lock /Query /Check /Raspberry } Member?
	} def
	/Enter {
	    true /animate Animation send pause
	    Blanket canvastotop
	    Blanket /Mapped true put
	} def
	/Leave {
	    Blanket /Mapped false put
	    false /animate Animation send
	} def
	/Remain	{ Blanket canvastotop } def
    dictend
    dictbegin  % Querying:
	/Condition { State /Query eq } def
	/Enter {
	    ClearPW
	    /QueryMessage  (Enter Password.) store
	    QueryInterests /expressinterest load forall
	} def
	/Leave { QueryInterests /revokeinterest load forall } def
    dictend
    dictbegin  % Checking:
	/Condition { State /Check eq } def
	/Enter {
	    /QueryMessage  (Checking Password.) store
	    RepaintQuery
	    CheckInterest expressinterest
	} def
	/Leave { CheckInterest revokeinterest } store
    dictend
    dictbegin  % Querying or checking:
	/Condition { State { /Query /Check } Member? } def
	/Enter { QueryCanvas /Mapped true put } def
	/Leave { QueryCanvas /Mapped false put ClearPW } def
    dictend
    dictbegin  % Error Message
	/Condition { State /Raspberry eq } def
	/Enter { RaspberryCanvas /Mapped true put } def
	/Leave { RaspberryCanvas /Mapped false put } def
    dictend
] def

% General-purpose condition handler: monitors changes to boolean conditions
% and invokes associated handling routines.

/HandleConditions {
    0 begin
	Conditions { % forall
	    begin
		/Value Condition def % eveluate condition
		Prev Value {
		    { True Same Remain Was }	    % Is and was
		    { True Different Enter WasNot } % Is and was not
		} {
		    { False Different Leave Was }   % Is not and was
		    { False Same Desists WasNot }   % Is not and was not
		} ifelse ifelse
		/Prev Value def
	    end
	} forall
    end
} dup 0 dictbegin
    /Prev false def 	     % initial value of the condition
    /Condition {false} def   % Condition check proc
    { /True /False /Enter /Leave /Same
	/Different /Remain /Desists /Was /WasNot }
    { nullproc def } forall
dictend put def

% Change to a new state:
/newState { % state -> -
    (>> % -> %\n) [ State 3 index ] conprint
    /State exch store
    HandleConditions
    TimerEvent /IsQueued get {
	TimerEvent recallevent
    } if
    StateTimes State get dup 0 eq { pop } {
	(>> Time %\n) [ 2 index ] conprint
	TimerEvent dup /TimeStamp 4 -1 roll
	pause currenttime add put sendevent
    } ifelse
} def

/PaintQuery {
    QueryFillColor fillcanvas
    QueryFont setfont
    QueryTextColor setshade
    12 60 moveto (Userid:  ) show UserID show
    12 40 moveto (Password:  ) show
    % Password show
    (#%*&@!%&@#X?#No!*NeWS!*%$#@$@!) % cryptic missive
    dup length 0 exch PWpos min getinterval show
    2 0 rmoveto
    5 -5 rlineto -11 0 rlineto closepath fill
    30 15 moveto QueryMessage show
} def

/RepaintQuery {
    gsave QueryCanvas setcanvas
    PaintQuery
    grestore
} def

/PaintRaspberry {
    RaspberryFillColor fillcanvas
    RaspberryFont setfont
    RaspberryTextColor setshade
    RaspberryW Raspberry stringwidth pop sub .5 mul
    RaspberryH currentfont fontascent sub .5 mul moveto
    Raspberry show
} def

/RepairCanvas { % proc canvas -> -
    gsave setcanvas damagepath clipcanvas exec newpath clipcanvas grestore
} def

/ScreenBlank {
    % What to do when the timer expires:
    /TimerInterest createevent dup begin
	/Name 2 dict dup begin
	    /Timer {
		State { % case
		    /Sleep   { /Monitor newState }
		    /Monitor { /Blank newState }
		    /Default { /Lock newState }
		} case
	    } def
	end def
	% avoid spurious events from reuse of proocess tbl of killed proc:
	/Action uniquecid def
    end dup expressinterest def
    
    % External control:
    /ControlInterest createevent dup begin
	/Name /BlankScreen def
	/Action 5 dict dup begin
	    /Destroy {
		Secure? not { currentprocess killprocessgroup } if
	    } def
	    /BlankOrLock {
		State { % case
		    /Sleep /Monitor { /Blank newState }
		    /Default { /Lock newState }
		} case
	    } def
	    /Blank {
		Secure? not { /Blank newState } if
	    } def
	    /Lock {
		/Lock newState
	    } def
	    /Query {
		/Query newState
	    } def
	end def
    end dup expressinterest def
    
    % We clone this event from the interest to get the /Process value:
    /TimerEvent TimerInterest createevent copy dup begin
	/Name /Timer def
    end def
    
    /MonitorClicks createevent dup begin
	/Priority 20 def
	/Exclusivity true def
	/Action 1 dict dup begin
	    /DownTransition {
		Secure? {
		    /Query newState
		} {
		    dup redistributeevent pause
		    /Sleep newState
		} ifelse
	    } def
	end def
    end def

    /MonitorMouseDrag createevent dup begin
	/Priority 5 def
	/Name 1 dict dup begin
	    /MouseDragged {
		Secure? {
		    /Query newState
		} {
		    /Sleep newState
		} ifelse
	    } def
	end def
    end def
    
    /DamageInterests [
	createevent dup begin
	    /Name 1 dict dup begin
		/Damaged { {/paint Animation send} Blanket RepairCanvas } def
	    end def
	    /Canvas Blanket def
	end dup expressinterest
	createevent dup begin
	    /Name 1 dict dup begin
		/Damaged { {PaintRaspberry} RaspberryCanvas RepairCanvas } def
	    end def
	    /Canvas RaspberryCanvas def
	end dup expressinterest
    ] def

    % It is important to understand that this is THE HARD WAY to get keyboard
    % input and it is done this way solely to subvert the focus manager.
    % Normally, you would want to cooperate with the focus manager and use
    % addkbdinterests (which is MUCH simpler).
    
    /QueryInterests [
	createevent dup begin
	    /Name 1 dict dup begin
		/Damaged { {PaintQuery} QueryCanvas RepairCanvas } def
	    end def
	    /Canvas QueryCanvas def
	end
	createevent dup begin
	    /Priority 20 def
	    /Name ascii_keymap def
	    /Action 2 dict dup begin
		/DownTransition {
		    dup /Name get
		    dup 32 ge 1 index 127 lt and { % printable ASCII
			dup AddPW RepaintQuery
		    } if
		    dup 8 eq 1 index 127 eq or { % BS or DEL
			DelPW RepaintQuery
		    } if
		    dup 24 eq 1 index 21 eq or { % ^X or ^U
			ClearPW RepaintQuery
		    } if
		    dup 3 eq { % ^C
			/Lock newState
		    } if
		    dup 10 eq 1 index 13 eq or { % CR or LF
			/Check newState
			{
			    UserID Password ClearPW CheckPW { % worked
				null (Bad Password) ifelse
			    } (Check Failed) ifelse
			    CheckInterest createevent copy begin
				/Name /PWresult def
				/Action exch def
				currentdict
			    end sendevent
			} fork pop
		    } if
		    pop
		} def
	    end def
	    /Exclusivity true def
	end
	createevent dup begin % Handle shifts here
	    % priority below key processing
	    /Priority 19 def
	    /Name 20 dict dup begin
		keyboard_positions { % forall
		    dup 0 get type /arraytype ne { [ exch ] } if
		    % Name [ [key class] [key class] ... ]
		    { % forall
			aload pop /shift_key ne { pop } { % Name key
			    [	/dup cvx UI_private /begin cvx 5 index
				/do_shift_key cvx /end cvx ] cvx
			    % Name key { dup D begin Name do_shift_key end }
			    def % in /Name entry of this this interest
			} ifelse
		    } forall
		    pop
		} forall
	    end def
	    /Exclusivity true def
	end
	createevent dup begin % absorb all other KB input
	    % priority below shift processing
	    /Priority 18 def
	    /Exclusivity true def
	    /Action /DownTransition def
	end
    ] def
    
    /CheckInterest createevent dup begin
	/Name 1 dict dup begin
	    /PWresult {
		dup /Action get dup null eq { % OK
		    pop	/Sleep
		} {
		    /Raspberry exch def /Raspberry
		} ifelse newState
	    } def
	end def
	/Canvas QueryCanvas def    % avoid fraud!
    end def
    
    /Sleep newState
    
    { % Event processing loop:
	awaitevent
	dup type /arraytype eq {
	    /exec load forall
	} if
	(>> Event % % % -> %\n) exch
	[ exch begin Name Action Canvas end State ] conprint
    } loop
} def

% kill our illustrious predecessors
createevent dup begin
    /Name /BlankScreen def
    /Action /Destroy def
end sendevent

/BlankFKey where { pop
    BlankFKey {
	createevent dup begin
	    /Name /BlankScreen def
	    /Action /Blank def
	end sendevent
    } bindkey
} if

/LockFKey where { pop
    LockFKey {
	createevent dup begin
	    /Name /BlankScreen def
	    /Action /Lock def
	end sendevent
    } bindkey
} if

% let the dust settle before we enter the fray!
pause pause

BlankTime 0 ne { { newprocessgroup ScreenBlank } fork pop } if

{ begin } pop end  % do it this way to fool formatters!
