(FILECREATED "11-Jan-86 19:46:27" {ERIS}<LISPUSERS>KOTO>CROCK.;2 13564
changes to: (FNS CROCK.PROCESS)
previous date: "25-Feb-85 17:03:39" {ERIS}<LISPUSERS>KOTO>CROCK.;1)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT CROCKCOMS)
(RPAQQ CROCKCOMS ((* CROCK -- By Kelly Roach *)
(FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS
CROCK.RESHAPEFN CROCK.ALARM CROCK.RING.ALARM CROCK.INIT)
(INITVARS (CROCK.DEFAULT.STYLE (QUOTE (HANDS T TIMES NIL RINGS NIL NUMBERS T)))
(CROCK.STYLE.MENU)
(CROCK.ALARMS)
(CROCK.DATEFORMAT (QUOTE (DATEFORMAT NO.SECONDS)))
(CROCK.TUNE (QUOTE ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000)
(2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000))))
(CROCKWINDOW))))
(* CROCK -- By Kelly Roach *)
(DEFINEQ
(CROCK
(LAMBDA (REGION)
(DECLARE (GLOBALVARS CROCKWINDOW)) (* lmm "22-Feb-84 17:07")
(PROG NIL
(COND
((NOT (WINDOWP CROCKWINDOW))
(COND
((NULL REGION)
(PROMPTPRINT "Please indicate a region for the clock")
(SETQ REGION (GETREGION))))
(SETQ CROCKWINDOW (CREATEW REGION)))
(REGION (SHAPEW CROCKWINDOW REGION)))
(DEL.PROCESS (QUOTE CROCK.PROCESS))
(ADD.PROCESS (QUOTE (CROCK.PROCESS))
(QUOTE RESTARTABLE)
T))))
(CROCK.BUTTONEVENTFN
(LAMBDA (WINDOW) (* edited: "24-AUG-82 17:15")
(COND
((LASTMOUSESTATE MIDDLE)
(CROCK.CHANGE.STYLE WINDOW))
((LASTMOUSESTATE (NOT UP))
(WAKE.PROCESS (QUOTE CROCK.PROCESS)
(QUOTE REPAINT))))))
(CROCK.CHANGE.STYLE
(LAMBDA (WINDOW) (* bvm: "22-APR-83 17:13")
(PROG (MENU COMMAND STYLE NO.CHANGE)
(SETQ MENU (OR CROCK.STYLE.MENU
(SETQ CROCK.STYLE.MENU
(create MENU
ITEMS ← (QUOTE (NUMBERS POINTS NO.NUMBERS RINGS NO.RINGS HANDS
NO.HANDS TIMES NO.TIMES (" " NIL)
SHOW.STYLE SET.TO.DEFAULT CHANGE.DEFAULT
(" " NIL)
SETTIME))))))
(SETQ COMMAND (MENU MENU))
(SETQ STYLE (WINDOWPROP WINDOW (QUOTE STYLE)))
(SELECTQ COMMAND
(NIL (SETQ NO.CHANGE T))
(SETTIME (RESETFORM (TTY.PROCESS (THIS.PROCESS))
(SETTIME)))
(SET.TO.DEFAULT (SETQ STYLE (COPY CROCK.DEFAULT.STYLE)))
(HANDS (LISTPUT STYLE (QUOTE HANDS)
T))
(NO.HANDS (LISTPUT STYLE (QUOTE HANDS)
NIL))
(TIMES (LISTPUT STYLE (QUOTE TIMES)
T))
(NO.TIMES (LISTPUT STYLE (QUOTE TIMES)
NIL))
(RINGS (LISTPUT STYLE (QUOTE RINGS)
T))
(NO.RINGS (LISTPUT STYLE (QUOTE RINGS)
NIL))
(NUMBERS (LISTPUT STYLE (QUOTE NUMBERS)
T))
(POINTS (LISTPUT STYLE (QUOTE NUMBERS)
(QUOTE POINTS)))
(NO.NUMBERS (LISTPUT STYLE (QUOTE NUMBERS)
NIL))
(CHANGE.DEFAULT (SETQ CROCK.DEFAULT.STYLE (COPY STYLE))
(SETQ NO.CHANGE T))
(SHOW.STYLE (printout PROMPTWINDOW T "CROCK style: " T 3 "Numbers: "
(COND
((LISTGET STYLE (QUOTE NUMBERS))
"yes")
(T "no"))
"; Rings: "
(COND
((LISTGET STYLE (QUOTE RINGS))
"yes")
(T "no"))
"; Hands: "
(COND
((LISTGET STYLE (QUOTE HANDS))
"yes")
(T "no"))
"; Times: "
(COND
((LISTGET STYLE (QUOTE TIMES))
"yes")
(T "no")))
(SETQ NO.CHANGE T))
(SHOULDNT))
(COND
(NO.CHANGE)
(T (WINDOWPROP WINDOW (QUOTE STYLE)
STYLE)
(WAKE.PROCESS (QUOTE CROCK.PROCESS)
(QUOTE CHANGE.STYLE)))))))
(CROCK.CLOSEFN
(LAMBDA (WINDOW) (* edited: "24-AUG-82 17:17")
(WAKE.PROCESS (QUOTE CROCK.PROCESS)
(QUOTE CLOSING))))
(CROCK.PROCESS
(LAMBDA NIL
(DECLARE (GLOBALVARS CROCKWINDOW)) (* kbr: "11-Jan-86 19:43")
(PROG (SIZE HALFSIZE XCENTER YCENTER RADIUS INSIDERADIUS MINUTEHANDSIZE HOURHANDSIZE DS STYLE
CLIPPINGREGION OUTLINE OUTLINEDSP DONE IDATE UDATE DATE HOURS MINUTES SECONDS
OLDMINUTES WIDTH HEIGHT HOURANGLE MINUTEANGLE NUM FONTHALFHEIGHT CHANGE.STYLE FONT
STRPTR)
(CROCK.INIT CROCKWINDOW)
(SETQ STRPTR (DATE CROCK.DATEFORMAT))
(SETQ DS (WINDOWPROP CROCKWINDOW (QUOTE DSP)))
RESTART
(SETQ CHANGE.STYLE T)
(SETQ CLIPPINGREGION (DSPCLIPPINGREGION NIL DS))
(SETQ XCENTER (IQUOTIENT (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION))
2))
(SETQ YCENTER (IQUOTIENT (SETQ HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT)
of CLIPPINGREGION)
10))
2)) (* Allow 10 points at top for digital form)
(SETQ SIZE (IMIN HEIGHT WIDTH))
(SETQ HALFSIZE (IQUOTIENT SIZE 2))
(SETQ RADIUS (FIXR (FTIMES .9 HALFSIZE)))
(SETQ INSIDERADIUS (IDIFFERENCE RADIUS 10))
(SETQ HOURHANDSIZE (FTIMES .5 INSIDERADIUS))
(SETQ MINUTEHANDSIZE (FTIMES .8 INSIDERADIUS))
(SETQ OUTLINE (BITMAPCREATE WIDTH HEIGHT))
(SETQ OUTLINEDSP (DSPCREATE))
(DSPDESTINATION OUTLINE OUTLINEDSP)
(DSPFONT (SETQ FONT (COND
((ILESSP RADIUS 50)
(FONTCREATE (QUOTE GACHA)
8))
(T (FONTCREATE (QUOTE HELVETICA)
10
(QUOTE BOLD)))))
OUTLINEDSP)
(DSPFONT FONT DS)
(SETQ STYLE (WINDOWPROP CROCKWINDOW (QUOTE STYLE)))
(until DONE
do (COND
(CHANGE.STYLE (SETQ CHANGE.STYLE (SETQ OLDMINUTES NIL))
(DSPFILL NIL WHITESHADE (QUOTE REPLACE)
OUTLINEDSP)
(DRAWCIRCLE XCENTER YCENTER RADIUS 4 NIL OUTLINEDSP)
(DRAWCIRCLE XCENTER YCENTER 2 4 NIL OUTLINEDSP)
(COND
((LISTGET STYLE (QUOTE RINGS))
(DRAWCIRCLE XCENTER YCENTER HOURHANDSIZE 2 NIL OUTLINEDSP)
(DRAWCIRCLE XCENTER YCENTER MINUTEHANDSIZE 2 NIL OUTLINEDSP)
))
(SELECTQ
(LISTGET STYLE (QUOTE NUMBERS))
(T (SETQ FONTHALFHEIGHT (IDIFFERENCE (IQUOTIENT
(FONTHEIGHT FONT)
2)
(FONTDESCENT FONT)))
(for I from 1 to 12
do (SETQ NUM (MKSTRING I))
(SETQ MINUTEANGLE (FTIMES 30 I))
(MOVETO (FDIFFERENCE (FPLUS
XCENTER
(FTIMES INSIDERADIUS
(SIN
MINUTEANGLE)))
(IQUOTIENT (STRINGWIDTH
NUM
OUTLINEDSP)
2))
(FDIFFERENCE (FPLUS
YCENTER
(FTIMES INSIDERADIUS
(COS
MINUTEANGLE)))
FONTHALFHEIGHT)
OUTLINEDSP)
(PRIN1 NUM OUTLINEDSP)))
(POINTS (for I from 1 to 12
bind (RAD ← (FPLUS INSIDERADIUS 5))
do (SETQ MINUTEANGLE (FTIMES 30 I))
(DRAWCIRCLE (FPLUS XCENTER
(FTIMES RAD
(SIN
MINUTEANGLE)))
(FPLUS YCENTER
(FTIMES RAD
(COS
MINUTEANGLE)))
1 2 NIL OUTLINEDSP)))
NIL)))
(SETQ IDATE (IDATE))
(SETQ UDATE (\UNPACKDATE IDATE))
(SETQ DATE (\OUTDATE UDATE CROCK.DATEFORMAT STRPTR))
(SETQ MINUTES (CAR (NTH UDATE 5)))
(SETQ SECONDS (CAR (NTH UDATE 6)))
(COND
((NEQ MINUTES OLDMINUTES)
(SETQ HOURS (CAR (NTH UDATE 4)))
(BITBLT OUTLINE 0 0 DS 0 0 WIDTH HEIGHT (QUOTE INPUT)
(QUOTE REPLACE))
(SETQ HOURANGLE (FPLUS (FTIMES 30.0 HOURS)
(FTIMES .5 MINUTES)))
(SETQ MINUTEANGLE (FTIMES 6.0 MINUTES))
(COND
((LISTGET STYLE (QUOTE HANDS))
(DRAWLINE XCENTER YCENTER (PLUS XCENTER (FIXR (FTIMES
HOURHANDSIZE
(SIN HOURANGLE))))
(PLUS YCENTER (FIXR (FTIMES HOURHANDSIZE (COS
HOURANGLE))))
5
(QUOTE PAINT)
DS)
(DRAWLINE XCENTER YCENTER (PLUS XCENTER (FIXR (FTIMES
MINUTEHANDSIZE
(SIN MINUTEANGLE))
))
(PLUS YCENTER (FIXR (FTIMES MINUTEHANDSIZE
(COS MINUTEANGLE))))
3
(QUOTE PAINT)
DS)))
(COND
((LISTGET STYLE (QUOTE TIMES))
(MOVETO (FPLUS XCENTER -5 (FTIMES HOURHANDSIZE (SIN HOURANGLE)))
(FPLUS YCENTER -5 (FTIMES HOURHANDSIZE (COS HOURANGLE)))
DS)
(PRIN1 (COND
((IGREATERP HOURS 12)
(IDIFFERENCE HOURS 12))
(T HOURS))
DS)
(MOVETO (FPLUS XCENTER -5 (FTIMES MINUTEHANDSIZE (SIN MINUTEANGLE)
))
(FPLUS YCENTER -5 (FTIMES MINUTEHANDSIZE (COS MINUTEANGLE)
))
DS)
(PRIN1 MINUTES DS)))))
(SETQ OLDMINUTES MINUTES)
(MOVETOUPPERLEFT CROCKWINDOW CLIPPINGREGION)
(PRIN3 DATE CROCKWINDOW)
(while (AND CROCK.ALARMS (GEQ IDATE (CAR (CAR CROCK.ALARMS))))
do (CROCK.RING.ALARM))
(SELECTQ (BLOCK (ITIMES 1000 (IDIFFERENCE 60 SECONDS)))
(CHANGE.STYLE (SETQ CHANGE.STYLE T))
(SHAPE (GO RESTART))
(CLOSING (SETQ DONE T))
NIL)
(COND
((AND (EQ MINUTES 0)
(EQ (IREMAINDER HOURS 6)
0)
(EQ (MACHINETYPE)
(QUOTE DANDELION)))
(* \NET.SETTIME every six hours if possible because Xerox computers can't keep time right. SETTIME would make
non-network users enter time manually--we don't want this. *)
(\NET.SETTIME))))
(PROCESS.RETURN))))
(CROCK.RESHAPEFN
(LAMBDA (WINDOW REGION) (* bvm: "27-AUG-82 16:26")
(WAKE.PROCESS (QUOTE CROCK.PROCESS)
(QUOTE SHAPE))))
(CROCK.ALARM
(LAMBDA (DATESTRING MESSAGE FORM) (* kbr: "29-Mar-84 14:57")
(* Add (IDATE . MESSAGE) to CROCK.ALARMS *)
(PROG (IDATE)
(SETQ IDATE (IDATE DATESTRING))
(COND
((ILESSP IDATE (IDATE))
(printout T "CROCK: Can't set alarm to " DATESTRING " in the past!" T)
(RINGBELLS))
(T (SETQ CROCK.ALARMS (NCONC (for BUCKET in CROCK.ALARMS when (ILEQ (CAR BUCKET)
IDATE)
collect BUCKET)
(LIST (LIST IDATE (GDATE IDATE)
MESSAGE FORM))
(for BUCKET in CROCK.ALARMS when (IGREATERP (CAR BUCKET)
IDATE)
collect BUCKET)))
(printout T "CROCK: Alarm set at " (GDATE IDATE)
"." T))))))
(CROCK.RING.ALARM
(LAMBDA NIL (* kbr: "29-Mar-84 14:59")
(PROG (BUCKET IDATE MESSAGE FORM)
(SETQ BUCKET (pop CROCK.ALARMS))
(SETQ IDATE (CAR BUCKET))
(SETQ MESSAGE (CADDR BUCKET))
(SETQ FORM (CADDDR BUCKET))
(SELECTQ (MACHINETYPE)
(DANDELION (COND
(CROCK.TUNE (PLAYTUNE CROCK.TUNE))
(T (RINGBELLS 3))))
(RINGBELLS 3))
(printout PROMPTWINDOW "CROCK: It is now " (GDATE IDATE)
"." T)
(COND
(MESSAGE (printout PROMPTWINDOW MESSAGE T)))
(EVAL FORM)
(INVERTW CROCKWINDOW))))
(CROCK.INIT
(LAMBDA (WINDOW) (* kbr: "21-JUN-83 09:44")
(WINDOWPROP WINDOW (QUOTE BUTTONEVENTFN)
(QUOTE CROCK.BUTTONEVENTFN))
(WINDOWPROP WINDOW (QUOTE RESHAPEFN)
(QUOTE CROCK.RESHAPEFN))
(WINDOWPROP WINDOW (QUOTE CLOSEFN)
(QUOTE CROCK.CLOSEFN))
(COND
((NULL (WINDOWPROP WINDOW (QUOTE STYLE)))
(WINDOWPROP WINDOW (QUOTE STYLE)
(COPY CROCK.DEFAULT.STYLE))))))
)
(RPAQ? CROCK.DEFAULT.STYLE (QUOTE (HANDS T TIMES NIL RINGS NIL NUMBERS T)))
(RPAQ? CROCK.STYLE.MENU )
(RPAQ? CROCK.ALARMS )
(RPAQ? CROCK.DATEFORMAT (QUOTE (DATEFORMAT NO.SECONDS)))
(RPAQ? CROCK.TUNE (QUOTE ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000)
(2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000))))
(RPAQ? CROCKWINDOW )
(PUTPROPS CROCK COPYRIGHT ("Xerox Corporation" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1212 12819 (CROCK 1222 . 1759) (CROCK.BUTTONEVENTFN 1761 . 2054) (CROCK.CHANGE.STYLE
2056 . 4106) (CROCK.CLOSEFN 4108 . 4284) (CROCK.PROCESS 4286 . 10693) (CROCK.RESHAPEFN 10695 . 10868)
(CROCK.ALARM 10870 . 11707) (CROCK.RING.ALARM 11709 . 12370) (CROCK.INIT 12372 . 12817)))))
STOP