sjs@spectral.ctt.bellcore.com (Stan Switzer) (09/29/89)
It's been about six months since I posted "blankscreen 1.0." Since
then I've made a number of (umm...) improvements. Here's the bigger,
if not better, "blankscreen 1.1."
Extensive user documantation is contained in the header comments.
I'll just describe the new features and major caveats here.
New Features:
Easy (as such things go) to add your own animations
Contains a number of standard animations and animation base-classes
Menu Selection of animations
"Exit Desktop" button (can be disabled)
Inumerable bugs fixed and much unspeakable hackery cleaned-up
Major Caveats:
If you use "ksh" or "tcsh" or any shell other than "/bin/sh" or
"/bin/csh" read the WARNINGS section below. Basically, the
password checking hack will fail. The solution is to be sure that
/etc/shells contains the pathname of your login shell (anywhere
where you might log in) or to use one of the standard shells and
have your .login or .profile file exec your desired shell. Another
solution is to disable the "locking" feature. Enquire within...
Blankscreen is only known to work on NeWS 1.1 using Sun-3 style
keyboards. It very well might work elsewhere, but I be mighty
suprised.
I'll post a few example user-customization animations in a few days.
Enjoy,
Stan
----------------------
%
% 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 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 the
% workstation.
%
% Certain locking modes, for instance the default "Randomator," allow
% menu selections and, consequently, do not leave the "blanking mode" simply
% because of mouse motion. However, any key press or mouse button (except
% for the menu button, of course) will exit the blanking mode.
%
% 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
%
% Unless you define /BlankscreenExitButton to false before
% starting blankscreen, there will be an "EXit NeWS" button on the
% password-query display. If you press this button, you will exit
% NeWS entirely. Assuming that you started NeWS using
% "exec news_server" from your login shell, this option affords you a
% measure of security while allowing you to be a socially responsible
% user of shared facilities.
%
% The NeWS-clock 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 "Randomator". The following definition will
% result in a bouncing globe instead:
% /CreateAnimationObject { /new WorldBouncer send } def
% 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.
% (CreateAnimationObject is invoked after all of the classes are defined so
% it can define a new subclass and instantiate it.) If you
% need subclassing assistance, or have a nice animation you'd like to share,
% mail me. If I get enough animations, I'll start a library and forward
% it to the the archives periodically.
%
% It is safe to say that this is a case of a simple hack having
% gotten completely out of hand.
%
% 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. If your
% login shell is not /bin/sh or /bin/csh (for instance /.../ksh)
% you must make sure that the file /etc/shells contains the paths of all
% full-service shells or some systems will "protect" you from using
% FTP. The idea is to make it so that non-shell logins cannnot be used
% to "sneak in" and FTP out files; unfortunately, this policy is overly
% cautious. IF ANYONE HAS A BETTER IDEA FOR CHECKING PASSWORDS (without
% writing any C), PLEASE SEND ME MAIL.
%
% Additionally, either (USER) or (LOGNAME) must be in the environment
% for the locking mode to know who you are. (If you are running any
% of the usual varieties of UNIX, it will be.)
%
% If either of these assumptions fails to hold true, 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 that might easily change from one
% release of 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:
%
% I should probably be registering "global" 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 some 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
% 8/31/89 - SJS
% Various clean-up activities in preparation for 1.1 release
% Numerous hacks, tweaks and frobs.
% 9/28/89 - SJS
% Release 1.1
% Start a new dictionary here to prevent patching of the locking code, prevent
% unauthorized access to the /Password entry, and to avoid systemdict
% namespace pollution.
gsave 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
/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
% Is there to be a "server-exit button?"
/BlankscreenExitButton true default
% 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 for you to specify your own animation.
% Use them if at all possible. Redefine either proc, as convenient,
% to create and/or select the animation.
/CreateAnimationObject { % Canvas -> obj
/AnimationClass Randomator def % default
DefineAnimationClass % backward compatability
/new AnimationClass send
} default
/DefineAnimationClass { % defines the default animation class
% The user can redefine /AnimationClass here, using one of her own or
% one of the following:
% PoetryThing WorldBouncer WorldNeWSBouncer ClockThing
% BounceClockThing StarField SkyRockets PoetryAndBouncer
% WorldAndStars Circulator Randomator
} default
% By default we enable the color tricks, but they depend on the ability
% of the server to keep retained unmapped canvases:
/EnableColorTricks? true 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
/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
/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
% GetUserid: ->
% false -- didn't work
% (userid) true -- got user id
/GetUserid {
(USER) { getenv } errored {
pop (LOGNAME) { getenv } errored {
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
/BlanketCanvas framebuffer
gsave dup setcanvas
newcanvas
/ptr /ptr_m 2 index setstandardcursor
dup begin
/Transparent false def
/Retained false def
/Mapped false def
/EventsConsumed /AllEvents def
end
clippath dup reshapecanvas
grestore
def
% Base class for animations. Handles animation timing and graphics context.
% It is "abstract" in the sense that it doesn't make sense to instantiate it.
% It must first be subclassed.
/Animator Object dictbegin % abstract animator class
/AnimatorProc null def
/CanW 0 def
/CanH 0 def
/Canvas null def
dictend classbegin
% public methods:
/new { % canvas -> obj
/new super send begin
/Canvas exch def
gsave Canvas setcanvas clippath pathbbox grestore
/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
GSave FillColor fillcanvas grestore
} if
{ % Dance!
/AnimatorProc { %fork
GSave
InitAnimation
Animate
} fork def
} if
} def
/paint {
GSave gsave FillColor fillcanvas grestore
DoPaint grestore
} def
/monitor_drag true 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 {
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
% An "animated thing" class. Some graphical object moves around the screen,
% either randomly, according to a "gravitational" trajectory, or according
% to the whims of a subclass. It is semi-abstract in that it is intended to
% be subclassed, but will work if used directly (it paints a rectangle at
% random spots on the screen [big deal]). This class contains a useful
% double buffering mechanism--perhaps this one will work regardless of
% server canvas retaining policy.
/AnimatedThing Animator dictbegin % semi-abstract animation class
/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
/ColorBuffer? false def
/InstallDoubleBuffer {
/PaintThing {
gsave
currentpoint translate Size scale
BufferCanvas ImageBufferCanvas
grestore
} def
/ComputeThing {
gsave BufferCanvas setcanvas
gsave FillColor fillcanvas grestore
TextColor setshade 0 0 moveto Paint grestore
} def
ColorBuffer? {
/BuildBufferCanvas {
gsave framebuffer dup newcanvas exch setcanvas
0 0 moveto Size rect dup reshapecanvas grestore
dup /Retained true put
dup /Transparent false put
} def
/ImageBufferCanvas {
imagecanvas
} def
} if
/BufferCanvas BuildBufferCanvas def
} def
/BuildBufferCanvas {
% This would appear to be an officially recognized way
% to create a for-sure retained canvas (it has to be parentless)
% so we can't simply use newcanvas):
Size 1 [ 3 index 0 0 5 index neg 0 1 index ]
(some arbitrary initial image data) buildimage
} def
/ImageBufferCanvas {
true exch imagemaskcanvas
} def
% Animation methods:
/Interval 3 60 div def
/AnimateStep {
X Y Size % for rectpath, after ComputeThing
MoveThing ComputeThing
rectpath currentcolor FillColor setshade fill setcolor
X Y moveto PaintThing
} def
% Default thing (a small rectangle)
/Size { 20 20 } def % totally arbitrary
/Paint {
Size rect fill % totally arbitrary (gotta do something!)
} def
classend def
% A clock
/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
% A clock that bounces
/BounceClockThing ClockThing [] classbegin
/DoubleBuffer? true def
/MoveThing { MoveBounce } def
/InitAnimation { InitBounce } def
/Interval .1 60 div def
classend def
% Propoganda
/XBusters AnimatedThing [] classbegin
% The official logo of the Ad-Hoc Committee to Rid the World of the
% Evil Scourge of the X Windowing System
% (In fairness, X has some meritorious features: resource database,
% consistent command-line options, serviceable client-side toolkit
% support, liberal color management policy, lots of PD S/W, and a
% halfway decent terminal emulator, to name a few.)
/Interval 15 60 div def
/XColor ColorDisplay? { .5 1 .7 hsbcolor } .5 ifelse def
/NoColor ColorDisplay? { 0 1 .5 hsbcolor } .25 ifelse def
/XLogo { % n => - -- trace an n pt. X logo at current point
matrix currentmatrix exch dup scale currentpoint translate currentpoint
0 1 moveto .25 1 lineto .556 .59 lineto .093 0 lineto
0 0 lineto .381 .49 lineto closepath
1 0 moveto .75 0 lineto .444 .41 lineto .907 1 lineto
1 1 lineto .619 .51 lineto closepath
moveto setmatrix
} def
/NoSymbol { % n => - -- trace a "no" symbol at the current point
matrix currentmatrix exch dup scale currentpoint translate currentpoint
.5 .5 .5 0 360 arc closepath
.5 .5 .38 35 235 arcn closepath
.5 .5 .38 215 55 arcn closepath
moveto setmatrix
} def
/NoXLogo { % n => - -- trace an n pt. "no X" logo at current point
gsave dup NoSymbol NoColor setshade fill grestore
gsave dup .1 mul dup rmoveto dup .8 mul XLogo
XColor setshade fill grestore
pop
} def
/Paint { Size gsave scale 1 NoXLogo grestore } def
/Size { 300 dup } def
classend def
% Clock, logo, and poetry
/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
grestore
} def
/Paint {
PaintClock
ClockRad 2 mul 0 rmoveto
gsave 0 LogoUp rmoveto String show grestore
Poetry? {
gsave
Vfont dup setfont fontdescent 0 exch rmoveto
QuoteColor setcolor Verse show
grestore
} if
} def
classend def
% Abstract class to bounce a sequence of images
/ImageBouncer AnimatedThing [ /ImageList /N ] classbegin
% NB: abstract class
/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
/WColor .3 1 .4 hsbcolor def
/OColor .5 .5 .65 hsbcolor def
/TwiddleColors nullproc def % yuck (yuck)!
/Paint {
gsave currentpoint translate Size scale
ColorBuffer? { TwiddleColors } if
false CurrImage imagemaskcanvas
grestore
} def
/Interval .05 60 div def
classend def
% Bounce the world
/WorldBouncer ImageBouncer [] classbegin
/new { % canvas -> thing
GlobeList exch /new super send
} def
/TwiddleColors {
.5 .5 .5 0 360 arc OColor setcolor fill
WColor setcolor
} def
ColorDisplay? EnableColorTricks? and {
/ColorBuffer? true def
} if
/Size { 64 64 } def
classend def
% List of Globes, shared among various classes
/GlobeList (NEWSHOME) getenv (/smi/globes/globe) append (.im1) 30
/genlist ImageBouncer send def
% Crass commercialism
/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 false CurrImage imagemaskcanvas grestore
Size exch pop 0 moveto (NeWS) show
grestore
} def
/ColorBuffer false def
classend def
% A field of stars, though it might be taken for "granite"
/StarField Animator dictbegin
/NStars 0 def
/Count 0 def
dictend classbegin
/maxCount 10 def
/maxNStars 30 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
ColorDisplay? {
3 { random .3 mul .7 add } repeat rgbcolor
} 1 ifelse
} 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 .2 60 div def
classend def
% Simple skyrockets animation, explosion more of a fizzle
/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
% Run several animations together
/Tandomator Object [ /Canvas /Animators ] classbegin
% NB: abstract class
/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 {
% Animators { /paint exch send } forall % the "right" way
/paint Animators 0 get send % the hack way
} def
/monitor_drag {
true Animators { /monitor_drag exch send and } forall
} def
classend def
% What it sez...
/PoetryAndBouncer Tandomator [] classbegin
/new {
[ PoetryThing WorldBouncer ] /new super send
} def
classend def
% Likewise...
/WorldAndStars Tandomator [] classbegin
/new {
[ StarField WorldBouncer ] /new super send
} def
classend def
% A list of interesting animations to be used by the "Randomator"
% and "Circulator." These can be modified in "CreateAnimationObject."
/Animations [
PoetryThing % historical interest (sentimental artifact?)
WorldNeWSBouncer PoetryAndBouncer WorldAndStars SkyRockets
XBusters % propoganda alert!
% WorldBouncer StarField % boring but servicable
% ClockThing BounceClockThing % just plain boring
] def
% Select from among Animations using menu
/Selectomator Tandomator [ /Nanimators /Current /N /SelectionMenu ] classbegin
/new { % canvas -> obj
Animations /new super send begin
/Nanimators Animators length def
/N 0 def
/SelectionMenu [
Animators { /ClassName exch send 50 string cvs } forall
] [ {
currentindex {
false animate
/N exch def
true animate
} Animation send
} ] /new DefaultMenu send {
% Make the menu a child of the "blanket" canvas so that it
% can never end up "behind" it. Easy, right? Wrong!
% This is all I should need to do:
/ParentCanvas BlanketCanvas def
% but I need these hacks too :-(
% 1) because LiteMenu slopily uses "framebuffer" in some places
% where it should use "ParentCanvas":
/framebuffer BlanketCanvas def
% 2) Because LiteMenu depends on obnoxious behavior of
% "newcanvas" (in particular, that children of "framebuffer"
% have different default attributes than all others):
/showat { % instance method ;-)
MenuCanvas null eq {
/MenuCanvas ParentCanvas newcanvas def
MenuCanvas /Retained RetainCanvas? put
MenuCanvas /Transparent false put
MenuCanvas /EventsConsumed /AllEvents put
MenuWidth null eq { layout } if
reshape
} if
% instance method "super send" hack:
/showat ParentDict supersend
} def
} 1 index send def
{ % fork
createevent
dup /Name MenuButton put
dup /Action /DownTransition put
dup /Canvas Canvas put
expressinterest
{
awaitevent
/IgnoreClick? true store
/showat SelectionMenu send
} loop
} fork pop
currentdict
end
} def
/animate {
Current null ne {
false /animate Current send
/Current null def
} if
{
/Current Animators N get def
true /animate Current send
} if
} def
/paint {
Current null ne { /paint Current send } if
} def
/monitor_drag false def
classend def
% Cyclicly choose from among the animations above
/Circulator Selectomator [] classbegin
/animate {
dup /animate super send
{ /N N 1 add def N Nanimators ge { /N 0 def } if } if
} def
classend def
% Randomly choose from among the animations above
/Randomator Circulator [] classbegin
/new { /new super send dup begin Randomize end } def
/Randomize {
/N Nanimators random mul cvi dup Nanimators ge { pop 0 } if def
} def
/animate { dup /animate super send { Randomize } if } def
classend def
/Animation BlanketCanvas CreateAnimationObject def
% It would probably be better to subclass the following from some form of
% Item. However, to prevent sneaky code inserted in LiteItem from stealing
% passwords, we write it from scratch. This is turning out to be a real
% Robinson Crusoe (Gilligan's Island?) adventure.
/MessageCanvas Object dictbegin
/Canvas null def
/Message () def
/EventProc null def
dictend classbegin
/Width 350 def /Height 85 def /CornerRadius 10 def
/FillColor 1 def /TextColor 0 def
/Font /Times-Roman findfont 18 scalefont def
/new { /new super send begin % canvas -> obj
/Canvas gsave exch dup setcanvas newcanvas dup begin
/Transparent false def
/Retained false def
/Mapped false def
end def
grestore
currentdict
end } def
/MessagePath { CornerRadius 5 1 roll rrectpath } def
/reshape { % x y w h -> -
gsave Canvas /Parent get setcanvas
4 2 roll translate 0 0 4 2 roll MessagePath Canvas reshapecanvas
grestore
} def
/ExpressInterests {
% Damage Repair
createevent
dup /Name 1 dict dup begin
/Damaged {
{ GSave damagepath clipcanvas
Paint
newpath clipcanvas grestore
} self 0 pop send
} def
end put
dup /Canvas Canvas put
expressinterest
} def
/StartEventProc {
/EventProc { % fork
ExpressInterests
{ awaitevent pop } loop
} fork def
} def
/setmessage { /Message exch def paint } def
/map-it { % bool -> -
dup { EventProc null eq { StartEventProc } if } if
Canvas /Mapped 3 -1 roll put
} def
/Paint { % - -> -
gsave FillColor fillcanvas grestore
Width Message stringwidth pop sub .5 mul
Height currentfont fontascent sub .5 mul moveto
Message show
} def
/GSave { gsave Canvas setcanvas Font setfont TextColor setshade } def
/paint { GSave Paint grestore } def
classend def
% Error message canvas:
/RaspberryMessage BlanketCanvas /new MessageCanvas send {
clippath pathbbox 4 2 roll pop pop
exch Width sub 2 idiv exch Height sub 2 idiv Width Height reshape
} 1 index send def
% Password query canvas:
/QueryMessage BlanketCanvas /new MessageCanvas send {
/Paint {
gsave FillColor fillcanvas grestore
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 Message show
} def
clippath pathbbox 4 2 roll pop pop
exch Width sub 2 idiv exch Height sub 2 idiv Width Height reshape
} 1 index send def
/ButtonCanvas MessageCanvas dictbegin
/Inside? false def
dictend classbegin
/UpColor 1 def
/DownColor .5 def
/FillColor { Inside? DownColor UpColor ifelse } def
/Notify nullproc def
/ButtonDown {
null blockinputqueue { % fork
createevent
dup /Action 1 dict dup begin
/UpTransition {
dup /Name get PointButton eq {
Inside? { Notify } if
} if
exit
} def
end put
expressinterest
createevent
dup /Name 2 dict dup begin
/EnterEvent { /Inside? true store paint } def
/ExitEvent { /Inside? false store paint } def
end put
dup /Canvas Canvas put
expressinterest
unblockinputqueue
/Inside? true store paint
{ awaitevent pop } loop
} fork
} def
/ExpressInterests {
/ExpressInterests super send
% Left Mouse click:
createevent
dup /Name 1 dict dup begin
PointButton { /ButtonDown self 0 pop send } def
end put
dup /Canvas Canvas put
dup /Action /DownTransition put
expressinterest
} def
classend def
/ExitButton null BlankscreenExitButton { pop
BlanketCanvas /new ButtonCanvas send {
/Message (Exit NeWS) def
/Notify {exitcleanly} def
GSave
/Height currentfont fontheight 20 add def
/Width Message stringwidth pop 20 add def
grestore
{ Canvas getcanvaslocation } QueryMessage send exch 400 add exch
Width Height reshape
} 1 index send
} if def
/nouse /nouse_m BlanketCanvas setstandardcursor
/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
/Conditions [
dictbegin % Invisible monitoring:
/Condition { State /Monitor eq } def
/Enter {
MonitorClicks expressinterest
MonitorMouseDrag expressinterest
} def
/Leave {
MonitorClicks revokeinterest
MonitorMouseDrag revokeinterest
} def
dictend
dictbegin % Screen is blanked:
/Condition {
State { /Blank /Lock /Query /Check /Raspberry } Member?
} def
/Enter {
true /animate Animation send pause
BlanketCanvas canvastotop
BlanketCanvas /Mapped true put
} def
/Leave {
BlanketCanvas /Mapped false put
false /animate Animation send
} def
/Remain { BlanketCanvas canvastotop } def
dictend
dictbegin % Keyboard and mouse monitoring when blanked:
/Condition { State { /Blank /Lock /Raspberry } Member? } def
/Enter {
MonitorClicks expressinterest
/monitor_drag Animation send {
MonitorMouseDrag expressinterest
} if
} def
/Leave {
MonitorClicks revokeinterest
MonitorMouseDrag /IsInterest get {
MonitorMouseDrag revokeinterest
} if
} def
dictend
dictbegin % Querying:
/Condition { State /Query eq } def
/Enter {
ClearPW
(Enter Password.) /setmessage QueryMessage send
QueryInterests /expressinterest load forall
} def
/Leave { QueryInterests /revokeinterest load forall } def
dictend
dictbegin % Checking:
/Condition { State /Check eq } def
/Enter {
(Checking Password.) /setmessage QueryMessage send
CheckInterest expressinterest
} def
/Leave { CheckInterest revokeinterest } store
dictend
dictbegin % Querying or checking:
/Condition { State { /Query /Check } Member? } def
/Enter {
true /map-it QueryMessage send
ExitButton null ne { true /map-it ExitButton send } if
/ptr /ptr_m BlanketCanvas setstandardcursor
} def
/Leave {
false /map-it QueryMessage send
ExitButton null ne { false /map-it ExitButton send } if
/nouse /nouse_m BlanketCanvas setstandardcursor
} def
dictend
dictbegin % Error Message
/Condition { State /Raspberry eq } def
/Enter { true /map-it RaspberryMessage send } def
/Leave { false /map-it RaspberryMessage send } 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 % evaluate 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
/SBInitialize {
% Express interests, etc.
% Must be done in the forked event, so it must be part of a proc.
% Still, it'll only be executed once, so after it is executed, we
% free up some server memory by having it delete itself!
% 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
/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
/IgnoreClick? false def
/MonitorClicks createevent dup begin
/Priority 20 def
/Exclusivity true def
/Action 1 dict dup begin
/DownTransition {
/IgnoreClick? false def
dup redistributeevent pause pause
IgnoreClick? not {
Secure? /Query /Sleep ifelse newState
} if
} def
end def
end def
/MonitorMouseDrag createevent dup begin
/Priority 5 def
/Exclusivity true def
/Name 1 dict dup begin
/MouseDragged {
dup redistributeevent pause
Secure? {
/Query newState
} {
/Sleep newState
} ifelse
} def
end def
end def
% Canvas damage interest
createevent dup begin
/Name 1 dict dup begin
/Damaged {
gsave BlanketCanvas setcanvas damagepath clipcanvas
/paint Animation send
newpath clipcanvas grestore
} def
end def
/Canvas BlanketCanvas def
end expressinterest
% 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
/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 /paint QueryMessage send
} if
dup 8 eq 1 index 127 eq or { % BS or DEL
DelPW /paint QueryMessage send
} if
dup 24 eq 1 index 21 eq or { % ^X or ^U
ClearPW /paint QueryMessage send
} 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 % reverse engineering at its worst...
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 & mouse clicks
% priority below shift processing
/Priority 18 def
/Exclusivity true def
/Action 1 dict dup begin
/DownTransition {
dup /Name get type /integertype ne {
% let mouse clicks fall through
dup redistributeevent
} if
} def
end def
end
] def
/CheckInterest createevent dup begin
/Name 1 dict dup begin
/PWresult {
dup /Action get dup null eq { % OK
pop /Sleep
} {
/setmessage RaspberryMessage send
/Raspberry
} ifelse newState
} def
end def
/Canvas /Canvas QueryMessage send def % avoid fraud!
end def
/Sleep newState
currentdict /SBInitialize undef % poof!
} def
/ScreenBlank {
SBInitialize % express interests, etc.
{ % 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
% bind specified F-keys
/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 grestore % do it this way to fool formatters!