Mona Eyes for OW 3.x
Pat Lashley
This group desperately needs an injection of levity, so here's a
quick port of the TNT 1.0 `monaeyes' demo. I did it in a somewhat
unique 3.0.1 environment, but I'm pretty sure it will run in a
standard 3.0 system.
-Pat
PMLashley plas...@Sun.COM SunSoft:NeWS/TNT
"Those who do not understand NeWS are doomed to recreate it - badly"
=====================================================================
#!/bin/sh
psh "$@" << '%EOF'
%
% This file is a product of Sun Microsystems, Inc. and is provided for
% unrestricted use provided that this legend is included on all tape
% media and as a part of the software program in whole or part. Users
% may copy or modify this file without charge, but are not authorized to
% license or distribute it to anyone else except as part of a product
% or program developed by the user.
%
% THIS FILE IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
% WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
% PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
%
% This file is provided with no support and without any obligation on the
% part of Sun Microsystems, Inc. to assist in its use, correction,
% modification or enhancement.
%
% SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
% INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY THIS FILE
% OR ANY PART THEREOF.
%
% In no event will Sun Microsystems, Inc. be liable for any lost revenue
% or profits or other special, indirect and consequential damages, even
% if Sun has been advised of the possibility of such damages.
%
% Sun Microsystems, Inc.
% 2550 Garcia Avenue
% Mountain View, California 94043
%
%
% @(#)monaeyes 23.3 90/06/19
%
% Copyright (c) 1989,1993 by Sun Microsystems, Inc.
%
[ /NeWS /TNT /TNTCore ] {
dup 3 0 knownpackage not {
dup 3 0 findpackage beginpackage
} if
pop
} forall
% ---------------------------------------------------------------------------
% ClassPupil
% The canvas that moves to follow the mouse
%
/ClassPupil ClassCanvas nulldict
classbegin
%-% Class Variables
% By making the canvas retained, we eliminate the flicker when
% the mouse moves.
%
/Retained true def
%-% Methods
% override
% Initialize the object
%
% - => -
/NewInit { % - => -
true /setdamageable self send
} def
% override
% This canvas is round.
%
% x y w h => =
/path { % x y w h => =
pop 0 360 arc
} def
% override
% We're a round canvas, so all we need to do is to paint our
% background blue, then put a round black iris in the center.
% Unfortunately this really demonstrates the broken circles
% in NeWS. (Caused by attempting to share NeWS and X rendering
% paths.) It could be fixed by using something out of the
% circlefont, but it's too much trouble.
%
% - => -
/Paint { % - => -
.1 .6 .9 rgbcolor /FillCanvas self send
newpath
0 0 /size self send pop 4 div 0 360 arc
0 setgray fill
} def
classend def %% ClassPupil
% ---------------------------------------------------------------------------
% Eyeball
% The canvas that provides the `white' of the eye and a clip for the
% pupil canvas.
%
/Eyeball ClassBag
dictbegin
% Instance Variables
/X 0 def % X location of eyeball
/Y 0 def % Y location of eyeball
/Xtracked 0 def % last X location tracked
/Ytracked 0 def % last Y location tracked
/Z 0 def % inverse distance from face
/Radius 0 def
dictend
classbegin
% Class Methods
% override
% - => -
/NewInit { % - => -
/NewInit super send
true /setdamageable self send
% Create a separate canvas to be the pupil of the eye.
/Pupil self /new ClassPupil send /addclient self send
% When we are activate, we are interested in all MouseDragged
% events. Other possible modes are /None, /Local, and /Crossings.
/All /setwatchmotion self send
% We want to be almost-white.
.93 dup dup rgbcolor
dup /setcolors self send
} def
/move { % x y => -
2 copy
Y sub Ytracked exch sub /Ytracked exch def
X sub Xtracked exch sub /Xtracked exch def
/Y exch def
/X exch def
} def
% override
% What shape is this canvas?
%
% x y width height => -
/path { % x y width height => -
matrix currentmatrix 5 1 roll % mat x y w h
scale translate % mat
0 0 1 0 360 arc % mat
setmatrix % -
} def
% override
%
% x y w h => -
/reshape { % x y w h => -
/Radius exch promote
pop
/Y exch promote
/X exch promote
X Y Radius dup dup add exch /reshape super send
gsave %++%
X Y Radius dup /reshape /Pupil /client self send pop send
grestore %--%
Xtracked Ytracked /look self send
} def
/setdepth { % Z => -
/Z exch def
} def
/look { % relx rely => -
2 copy
/Ytracked exch def
/Xtracked exch def
Z mul exch
Z mul exch
2 copy
dup mul exch dup mul add sqrt % relx rely dist
0.0000001 max % avoid divide by 0
Radius exch div 1 min % relx rely sf
dup 3 1 roll mul % sf relx sfy
3 1 roll mul exch % sfx sfy
/Pupil /client self send pop setcanvas
2 div % keep y coord in the half height orbs.
movecanvas
} def
% override
% Handle a MouseDragged event from anywhere on the screen, whether
% a mouse button is down or not.
%
% event => -
/HandleMotion { % event => -
self setcanvas
begin
XLocation YLocation
end
/look self send
} def
classend def % Eyeball class
% ---------------------------------------------------------------------------
% MonaCanvas
% The main canvas, holding the clipped section of the picture.
%
/MonaCanvas ClassBag nulldict
classbegin
/NewInit {
/NewInit super send
/theimage %++%
(OPENWINHOME) getenv (/share/images/raster/monasmile.im8) append
readcanvas
promote %--%
/left self /new Eyeball send /addclient self send
/right self /new Eyeball send /addclient self send
} def
% override
%
% - => -
/Layout { % - => -
gsave %++%
self setcanvas
/size self send scale
gsave
.20 .86 .08 .04 /reshape /left /client self send pop send
grestore
.65 .88 .08 .04 /reshape /right /client self send pop send
.05 /setdepth /left /client self send pop send
.05 /setdepth /right /client self send pop send
grestore %--%
} def
% override
%
% - => -
/Paint {
/size self send scale
theimage imagecanvas
} def
/minsize { % - => w h
/minsize super send
50 40 xymax
} def
/preferredsize { % - => w h
/preferredsize super send
250 200 xymax
} def
classend def % MonaCanvas %
% ---------------------------------------------------------------------------
% Setup code
%
/mona framebuffer /new MonaCanvas send def
/win mona framebuffer /new ClassBaseWindow send def
{
/paint eq {
gsave %++%
/size self send scale
theimage imagecanvas
grestore %--%
} {
% If it isn't a /paint, assume that it must be /size
64 64
} ifelse
} /seticonimage win send
null /seticonlabel win send
(Mona Eyes) /setlabel win send
/new ClassEventMgr send /activate win send
/place win send
/map win send
newprocessgroup
currentfile closefile
% Tell GNU emacs to use PostScript mode on this file.
%Local Variables:
%mode: PostScript
%End:
%EOF