(FILECREATED "24-Aug-84 23:09:35" {ERIS}<LISPUSERS>LCROCK.;1 12335
changes to: (VARS LCROCKCOMS)
(FNS START.LCROCK JRandomCrock WAKEUP.LCROCK)
previous date: "24-Aug-84 21:51:24" {ERIS}<LISPUSERS>LCROCK.;1)
(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LCROCKCOMS)
(RPAQQ LCROCKCOMS ((FNS START.LCROCK JRandomCrock WAKEUP.LCROCK)
(* "Update rate initialized to every five minutes")
(INITVARS (CROCKUPDATERATE.MS (ITIMES 5 60 1000))
(LOGOW NIL))
(VARS (LCROCK.NEWPOSITION NIL))
(GLOBALVARS LOGOW MAKESYSDATE SCREENWIDTH SCREENHEIGHT CROCKUPDATERATE.MS
DARKBITSHADE LCROCK.NEWPOSITION)))
(DEFINEQ
(START.LCROCK
(LAMBDA (LOGO POSITION) (* JonL "24-Aug-84 23:06")
(PROG ((LSTRING (if (NULL LOGO)
then "Interlisp-D"
elseif (OR (STRINGP LOGO)
(LITATOM LOGO))
then LOGO
else (MKSTRING LOGO)))
(REG (if (WINDOWP LOGOW)
then (CLOSEW LOGOW)
(WINDOWPROP LOGOW (QUOTE REGION))))
(DEFAULTLOGOWIDTH (CONSTANT (STRINGWIDTH "Interlisp-D" (QUOTE (TIMESROMAND 36)))))
STRWIDTH)
(SETQ STRWIDTH (STRINGWIDTH LSTRING (QUOTE (TIMESROMAND 36))))
(if (ILESSP STRWIDTH DEFAULTLOGOWIDTH)
then (SETQ LSTRING
(CONCAT LSTRING
(CONCATCODES
(to (IQUOTIENT (IPLUS (IDIFFERENCE DEFAULTLOGOWIDTH STRWIDTH)
(CONSTANT (SUB1 (STRINGWIDTH
" "
(QUOTE (TIMESROMAND 36))))))
(CONSTANT (STRINGWIDTH " " (QUOTE (TIMESROMAND 36)))))
collect (CHARCODE SPACE))))))
(SETQ POSITION (if (POSITIONP POSITION)
elseif REG
then (create POSITION
XCOORD ←(fetch LEFT of REG)
YCOORD ←(fetch BOTTOM of REG))))
(SETQ LOGOW (LOGOW LSTRING POSITION))
(SETQ REG (WINDOWPROP LOGOW (QUOTE REGION)))
(if (OR (ILEQ SCREENWIDTH (fetch PRIGHT of REG))
(ILEQ SCREENHEIGHT (fetch PTOP of REG)))
then (* Foo, he positioned it so that it wasn't all visible)
(CLOSEW LOGOW)
(SETQ LOGOW (LOGOW LSTRING (CONSTANT (create POSITION
XCOORD ← 0
YCOORD ← 0))))
(SETQ LCROCK.NEWPOSITION POSITION))
(WINDOWPROP LOGOW (QUOTE CLOSEFN)
(FUNCTION (LAMBDA (X)
(DEL.PROCESS (QUOTE JRandomCrock)))))
(WINDOWPROP LOGOW (QUOTE OPENFN)
(FUNCTION (LAMBDA (X)
(OR (FIND.PROCESS (QUOTE JRandomCrock))
(ADD.PROCESS (QUOTE (JRandomCrock))
(QUOTE RESTARTABLE)
T)))))
(WINDOWPROP LOGOW (QUOTE TOTOPFN)
(FUNCTION WAKEUP.LCROCK))
(WINDOWPROP LOGOW (QUOTE BUTTONEVENTFN)
(FUNCTION (LAMBDA (WIN)
(TOTOPW WIN T)
(WAKEUP.LCROCK))))
(WINDOWPROP LOGOW (QUOTE RESHAPEFN)
(QUOTE DON'T))
(DEL.PROCESS (QUOTE JRandomCrock))
(ADD.PROCESS (QUOTE (JRandomCrock))
(QUOTE RESTARTABLE)
T))))
(JRandomCrock
(LAMBDA NIL (* JonL "24-Aug-84 23:09")
(PROG ((SNAILWIDTH 170)
(LOGOWDS (WINDOWPROP LOGOW (QUOTE DSP)))
(LOGOREGION (WINDOWPROP LOGOW (QUOTE REGION)))
(CLIPPINGREGION (DSPCLIPPINGREGION NIL LOGOW))
(WIDTH 75)
(HEIGHT 80)
(SEMIMAJORLENGTH 83)
(SEMIMINORLENGTH 63)
(RADIUS 45.0)
(FONT (FONTCREATE (QUOTE HELVETICA)
10
(QUOTE BOLD)))
(CLOCKFACEDS (DSPCREATE))
CLOCKFACECENTERX CLOCKFACECENTERY DIALCENTERX DIALCENTERY CLOCKBMXOFFSET CLOCKBMYOFFSET
DTSCENTERX DTSCENTERY DTSX DTSY DTSYBASE DTSREGIONWIDTH DTSREGIONHEIGHT INSIDERADIUS
MINUTEHANDSIZE HOURHANDSIZE IDATE DATE HOUR MINUTE SECONDS OLDHOUR OLDMINUTE HOURI MINUTEI
S&C MSIN MCOS HSIN HCOS HALFSTRWIDTH HOURHANDDELTAS MINUTEHANDDELTAS HAND.DELTAS HAND.DX
HAND.DY)
(PROGN (* Setup some clock features)
(SETQ INSIDERADIUS (IDIFFERENCE RADIUS 10))
(SETQ HOURHANDSIZE (FTIMES .5 INSIDERADIUS))
(SETQ MINUTEHANDSIZE (FTIMES .8 INSIDERADIUS))
(SETQ CLOCKFACECENTERX (IPLUS SNAILWIDTH (QUOTIENT (IDIFFERENCE (IDIFFERENCE
(fetch WIDTH
of LOGOREGION)
(TIMES 2 WBorder))
SNAILWIDTH)
2)))
(SETQ CLOCKFACECENTERY (IDIFFERENCE (IDIFFERENCE (fetch HEIGHT of LOGOREGION)
(IPLUS (TIMES 2 WBorder)
(FONTHEIGHT
WindowTitleDisplayStream)))
(IPLUS 2 SEMIMINORLENGTH)))
(SETQ DIALCENTERX CLOCKFACECENTERX)
(SETQ DIALCENTERY (IDIFFERENCE CLOCKFACECENTERY (IPLUS 2 (FONTHEIGHT FONT))))
(* DIALCENTERX and DIALCENTERY are center of circular
clock face, in LOGOW's coordinates)
(SETQ CLOCKBMXOFFSET (DIFFERENCE DIALCENTERX (QUOTIENT WIDTH 2)))
(SETQ CLOCKBMYOFFSET (DIFFERENCE DIALCENTERY (QUOTIENT HEIGHT 2)))
(* Lower-left corner of clockface bitmap, in LOGOW's
coordinates)
(DSPDESTINATION (BITMAPCREATE WIDTH HEIGHT)
CLOCKFACEDS) (* Setup the clock face as a bitmap)
(DSPFONT FONT CLOCKFACEDS)
(bind NUMSTR NUMWIDTH MINUTEANGLE (FONTHALFHEIGHT ←(IDIFFERENCE (IQUOTIENT
(FONTHEIGHT FONT)
2)
(FONTDESCENT FONT)))
(XCENTER ←(IQUOTIENT WIDTH 2))
(YCENTER ←(IDIFFERENCE DIALCENTERY CLOCKBMYOFFSET)) for I from 1 to 12
do (SETQ NUMWIDTH (STRINGWIDTH (SETQ NUMSTR (MKSTRING I))
CLOCKFACEDS))
(SETQ MINUTEANGLE (FTIMES 30 I))
(MOVETO (FDIFFERENCE (FPLUS XCENTER (FTIMES INSIDERADIUS (SIN MINUTEANGLE)))
(IQUOTIENT NUMWIDTH 2))
(FDIFFERENCE (FPLUS YCENTER (FTIMES INSIDERADIUS (COS MINUTEANGLE)))
FONTHALFHEIGHT)
CLOCKFACEDS)
(PRIN3 NUMSTR CLOCKFACEDS)))
(PROGN (* Region for printing the Date/Time string.)
(SETQ DTSREGIONHEIGHT (FONTHEIGHT FONT))
(SETQ DTSREGIONWIDTH (IDIFFERENCE (STRINGWIDTH (GDATE)
FONT)
(STRINGWIDTH ":11" FONT)))
(* Remember that the seconds digits are knocked off
before printing.)
(SETQ DTSCENTERX DIALCENTERX)
(SETQ DTSX (IDIFFERENCE DTSCENTERX (QUOTIENT DTSREGIONWIDTH 2)))
(SETQ DTSYBASE (IPLUS CLOCKBMYOFFSET HEIGHT 4))
(SETQ DTSY (IPLUS DTSYBASE (FONTDESCENT FONT))))
(PROGN (* Put boundary ellipse in LOGOW and set DSP parameters
for printing date/time string into it)
(DSPOPERATION (QUOTE REPLACE)
LOGOWDS)
(DRAWELLIPSE CLOCKFACECENTERX CLOCKFACECENTERY SEMIMINORLENGTH SEMIMAJORLENGTH 0
(QUOTE (HORIZONTAL 3))
NIL LOGOWDS)
(DSPFONT FONT LOGOWDS)
(DSPOPERATION (QUOTE ERASE)
LOGOWDS))
(PROGN (* Cache up the various position that the hands will
draw to)
(SETQ HOURHANDDELTAS (ARRAY 15 (QUOTE POINTER)
NIL 0))
(for I from 0 to 14 do (SETA HOURHANDDELTAS I
(LIST (FIXR (FTIMES HOURHANDSIZE
(SIN (TIMES I 6.0))))
(FIXR (FTIMES HOURHANDSIZE
(COS (TIMES I 6.0)))))))
(* Do one quarter of the clockface, remembering that a
"minute" notch is 6 degrees)
(SETQ MINUTEHANDDELTAS (ARRAY 15 (QUOTE POINTER)
NIL 0))
(for I from 0 to 14 do (SETA MINUTEHANDDELTAS I
(LIST (FIXR (FTIMES MINUTEHANDSIZE
(SIN (TIMES I 6.0))))
(FIXR (FTIMES MINUTEHANDSIZE
(COS (TIMES I 6.0)))))))
(* Do one quarter of the clockface, remembering that a
"minute" notch is 6 degrees)
)
(PROGN
(* If the crock had to be drawn at position (0 0) in order to fit on the screen, then move it now to it's real
home)
(if (POSITIONP LCROCK.NEWPOSITION)
then (MOVEW LOGOW LCROCK.NEWPOSITION))
(SETQ LCROCK.NEWPOSITION))
LOOPFOREVER
(SETQ IDATE (IDATE))
(SETQ DATE (GDATE NIL NIL DATE))
(SETQ SECONDS (SUBATOM DATE -2 -1))
(SETQ DATE (SUBSTRING DATE 1 -4 DATE))
(SETQ MINUTE (SUBATOM DATE -2 -1))
(SETQ HOUR (SUBATOM DATE -5 -4))
(if (OR (NEQ MINUTE OLDMINUTE)
(NEQ HOUR OLDHOUR))
then (if (NEQ HOUR OLDHOUR)
then (* Update the cached stringlength)
(SETQ HALFSTRWIDTH (QUOTIENT (STRINGWIDTH DATE FONT)
2)))
(BITBLT CLOCKFACEDS 0 0 LOGOWDS CLOCKBMXOFFSET CLOCKBMYOFFSET WIDTH HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE)) (* This gives us a clean clock face)
(SETQ MINUTEI MINUTE)
(SETQ HOURI (IPLUS (ITIMES 5 (IREMAINDER HOUR 12))
(IQUOTIENT MINUTE 12)))
(* These are indices in the 60-slot clockface)
(PROGN
(* cached values of (FIXR (FTIMES HOURHANDSIZE (SIN (TIMES I 6.0)))) and (FIXR (FTIMES HOURHANDSIZE
(COS (TIMES I 6.0)))))
(SETQ HAND.DELTAS (ELT HOURHANDDELTAS (IREMAINDER HOURI 15)))
(SELECTC (IQUOTIENT HOURI 15)
(0 (SETQ HAND.DX (CAR HAND.DELTAS))
(SETQ HAND.DY (CADR HAND.DELTAS)))
(1 (SETQ HAND.DX (CADR HAND.DELTAS))
(SETQ HAND.DY (IMINUS (CAR HAND.DELTAS))))
(2 (SETQ HAND.DX (IMINUS (CAR HAND.DELTAS)))
(SETQ HAND.DY (IMINUS (CADR HAND.DELTAS))))
(3 (SETQ HAND.DX (IMINUS (CADR HAND.DELTAS)))
(SETQ HAND.DY (CAR HAND.DELTAS)))
(SHOULDNT)))
(DRAWLINE DIALCENTERX DIALCENTERY (PLUS DIALCENTERX HAND.DX)
(PLUS DIALCENTERY HAND.DY)
5
(QUOTE PAINT)
LOGOWDS)
(PROGN
(* cached values of (FIXR (FTIMES MINUTEHANDSIZE (SIN (TIMES I 6.0)))) and (FIXR (FTIMES MINUTEHANDSIZE
(COS (TIMES I 6.0)))))
(SETQ HAND.DELTAS (ELT MINUTEHANDDELTAS (IREMAINDER MINUTEI 15)))
(SELECTC (IQUOTIENT MINUTEI 15)
(0 (SETQ HAND.DX (CAR HAND.DELTAS))
(SETQ HAND.DY (CADR HAND.DELTAS)))
(1 (SETQ HAND.DX (CADR HAND.DELTAS))
(SETQ HAND.DY (IMINUS (CAR HAND.DELTAS))))
(2 (SETQ HAND.DX (IMINUS (CAR HAND.DELTAS)))
(SETQ HAND.DY (IMINUS (CADR HAND.DELTAS))))
(3 (SETQ HAND.DX (IMINUS (CADR HAND.DELTAS)))
(SETQ HAND.DY (CAR HAND.DELTAS)))
(SHOULDNT)))
(DRAWLINE DIALCENTERX DIALCENTERY (PLUS DIALCENTERX HAND.DX)
(PLUS DIALCENTERY HAND.DY)
3
(QUOTE PAINT)
LOGOWDS)
(BITBLT NIL 0 0 LOGOWDS DTSX DTSYBASE DTSREGIONWIDTH DTSREGIONHEIGHT (QUOTE
TEXTURE)
(QUOTE REPLACE)
DARKBITSHADE)
(MOVETO (IDIFFERENCE DTSCENTERX HALFSTRWIDTH)
DTSY LOGOWDS)
(PRIN3 DATE LOGOWDS))
(SETQ OLDMINUTE MINUTE)
(SETQ OLDHOUR HOUR) (* Forcibly show the CROCK at least onece every 5
minutes.)
(SELECTQ (BLOCK CROCKUPDATERATE.MS)
(UPDATE (* Will cause an instant update)
(SETQ OLDHOUR))
NIL)
(GO LOOPFOREVER))))
(WAKEUP.LCROCK
(LAMBDA NIL (* JonL "24-Aug-84 21:44")
(WAKE.PROCESS (QUOTE JRandomCrock)
(QUOTE UPDATE))))
)
(* "Update rate initialized to every five minutes")
(RPAQ? CROCKUPDATERATE.MS (ITIMES 5 60 1000))
(RPAQ? LOGOW NIL)
(RPAQQ LCROCK.NEWPOSITION NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS LOGOW MAKESYSDATE SCREENWIDTH SCREENHEIGHT CROCKUPDATERATE.MS DARKBITSHADE
LCROCK.NEWPOSITION)
)
(PUTPROPS LCROCK COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (695 11931 (START.LCROCK 705 . 3138) (JRandomCrock 3140 . 11756) (WAKEUP.LCROCK 11758 .
11929)))))
STOP