(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED " 2-Apr-87 00:37:46" {ERIS}LYRIC>CROCK.;2 17791 previous date%: "11-Jan-86 19:46:27" {PHYLUM}LYRIC>CROCK.;1) (* " Copyright (c) 1984, 1985, 1986, 1987 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 '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) (CROCK.STYLE.MENU) (CROCK.ALARMS) (CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) [CROCK.TUNE '((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 'CROCK.PROCESS) (ADD.PROCESS '(CROCK.PROCESS) 'RESTARTABLE T]) (CROCK.BUTTONEVENTFN [LAMBDA (WINDOW) (* edited%: "24-AUG-82 17:15") (COND ((LASTMOUSESTATE MIDDLE) (CROCK.CHANGE.STYLE WINDOW)) ((LASTMOUSESTATE (NOT UP)) (WAKE.PROCESS 'CROCK.PROCESS '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 _ '(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 '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 'HANDS T)) (NO.HANDS (LISTPUT STYLE 'HANDS NIL)) (TIMES (LISTPUT STYLE 'TIMES T)) (NO.TIMES (LISTPUT STYLE 'TIMES NIL)) (RINGS (LISTPUT STYLE 'RINGS T)) (NO.RINGS (LISTPUT STYLE 'RINGS NIL)) (NUMBERS (LISTPUT STYLE 'NUMBERS T)) (POINTS (LISTPUT STYLE 'NUMBERS 'POINTS)) (NO.NUMBERS (LISTPUT STYLE '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 'NUMBERS) "yes") (T "no")) "; Rings: " (COND ((LISTGET STYLE 'RINGS) "yes") (T "no")) "; Hands: " (COND ((LISTGET STYLE 'HANDS) "yes") (T "no")) "; Times: " (COND ((LISTGET STYLE 'TIMES) "yes") (T "no"))) (SETQ NO.CHANGE T)) (SHOULDNT)) (COND (NO.CHANGE) (T (WINDOWPROP WINDOW 'STYLE STYLE) (WAKE.PROCESS 'CROCK.PROCESS 'CHANGE.STYLE]) (CROCK.CLOSEFN [LAMBDA (WINDOW) (* edited%: "24-AUG-82 17:17") (WAKE.PROCESS 'CROCK.PROCESS 'CLOSING]) (CROCK.PROCESS [LAMBDA NIL (DECLARE (GLOBALVARS CROCKWINDOW)) (* ; "Edited 1-Apr-00 by Briggs & Dixon") (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 1APR OLDHOURS) (CROCK.INIT CROCKWINDOW) (SETQ STRPTR (DATE CROCK.DATEFORMAT)) (SETQ DS (WINDOWPROP CROCKWINDOW '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 0.9 HALFSIZE))) (SETQ INSIDERADIUS (IDIFFERENCE RADIUS 10)) (SETQ HOURHANDSIZE (FTIMES 0.5 INSIDERADIUS)) (SETQ MINUTEHANDSIZE (FTIMES 0.8 INSIDERADIUS)) (SETQ OUTLINE (BITMAPCREATE WIDTH HEIGHT)) (SETQ OUTLINEDSP (DSPCREATE)) (DSPDESTINATION OUTLINE OUTLINEDSP) (DSPFONT [SETQ FONT (COND ((ILESSP RADIUS 50) (FONTCREATE 'GACHA 8)) (T (FONTCREATE 'HELVETICA 10 'BOLD] OUTLINEDSP) (DSPFONT FONT DS) (SETQ STYLE (WINDOWPROP CROCKWINDOW 'STYLE)) (SETQ 1APR 1) [until DONE do (COND (CHANGE.STYLE (SETQ CHANGE.STYLE (SETQ OLDMINUTES (SETQ OLDHOURS NIL))) (DSPFILL NIL WHITESHADE 'REPLACE OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER RADIUS 4 NIL OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER 2 4 NIL OUTLINEDSP) (COND ((LISTGET STYLE 'RINGS) (DRAWCIRCLE XCENTER YCENTER HOURHANDSIZE 2 NIL OUTLINEDSP) (DRAWCIRCLE XCENTER YCENTER MINUTEHANDSIZE 2 NIL OUTLINEDSP))) (SELECTQ (LISTGET STYLE '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 1APR 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 'INPUT 'REPLACE) (SETQ HOURANGLE (FPLUS (FTIMES 1APR 30.0 HOURS) (FTIMES 1APR 0.5 MINUTES))) (SETQ MINUTEANGLE (FTIMES 1APR 6.0 MINUTES)) (COND ((LISTGET STYLE 'HANDS) (DRAWLINE XCENTER YCENTER [PLUS XCENTER (FIXR (FTIMES HOURHANDSIZE (SIN HOURANGLE] [PLUS YCENTER (FIXR (FTIMES HOURHANDSIZE (COS HOURANGLE] 5 'PAINT DS) (DRAWLINE XCENTER YCENTER [PLUS XCENTER (FIXR (FTIMES MINUTEHANDSIZE (SIN MINUTEANGLE] [PLUS YCENTER (FIXR (FTIMES MINUTEHANDSIZE (COS MINUTEANGLE] 3 'PAINT DS))) (COND ((LISTGET STYLE '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))) (COND ((NEQ HOURS OLDHOURS) (COND ((NEQ 1APR (SETQ 1APR (if (AND (EQ (CADR UDATE) 3) (EQ (CADDR UDATE) 1) (ILESSP (CADDDR UDATE) 12)) then -1 else 1))) (SETQ CHANGE.STYLE T] (SETQ OLDHOURS HOURS) (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) '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 'CROCK.PROCESS '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 'BUTTONEVENTFN 'CROCK.BUTTONEVENTFN) (WINDOWPROP WINDOW 'RESHAPEFN 'CROCK.RESHAPEFN) (WINDOWPROP WINDOW 'CLOSEFN 'CROCK.CLOSEFN) (COND ((NULL (WINDOWPROP WINDOW 'STYLE)) (WINDOWPROP WINDOW 'STYLE (COPY CROCK.DEFAULT.STYLE]) ) (RPAQ? CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) (RPAQ? CROCK.STYLE.MENU ) (RPAQ? CROCK.ALARMS ) (RPAQ? CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) (RPAQ? CROCK.TUNE '((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 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1940 16814 (CROCK 1950 . 2520) (CROCK.BUTTONEVENTFN 2522 . 2811) (CROCK.CHANGE.STYLE 2813 . 5626) (CROCK.CLOSEFN 5628 . 5790) (CROCK.PROCESS 5792 . 14290) (CROCK.RESHAPEFN 14292 . 14451) (CROCK.ALARM 14453 . 15681) (CROCK.RING.ALARM 15683 . 16424) (CROCK.INIT 16426 . 16812))))) STOP