(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