(FILECREATED "28-Feb-86 21:54:50" {ERIS}<LISPUSERS>KOTO>BICLOCK.;3 18022
changes to: (FNS BICLOCK)
previous date: "19-Dec-85 01:24:40" {ERIS}<LISPUSERS>KOTO>BICLOCK.;2)
(* Copyright (c) 1984, 1985, 1986 by Bernt Nilsson @ University of Linkoeping. All rights reserved.)
(PRETTYCOMPRINT BICLOCKCOMS)
(RPAQQ BICLOCKCOMS ((FNS BICLOCK BICLOCKBEFN BICLOCKCFN BICLOCKNRFN BICLOCKPROCESS BICLOCKRPFN
BICLOCKRSFN BICLOCKSETALARM BICLOCKSETALARM1 BICLOCKSETALARM2)
(RECORDS BICLOCKPARMS UPTIMEREC)
(INITVARS (BICLOCKINITIALREGION (CREATEREGION (SUB1 (IDIFFERENCE SCREENWIDTH
119))
(SUB1 (IDIFFERENCE SCREENHEIGHT 119))
119 119))
(BICLOCKINITIALNOSECONDS NIL)
(BICLOCKINITIALCOLOR NIL))
(VARS (BICLOCKWINDOW (if (REGIONP BICLOCKINITIALREGION)
then
(BICLOCK BICLOCKINITIALREGION
BICLOCKINITIALNOSECONDS BICLOCKINITIALCOLOR))
))
(COMS (* Idling stuff)
(FNS IDLE.BOUNCING.BICLOCK IDLE.BICLOCK.KILLER)
(INITVARS (IDLE.BICLOCKWIDTH 200))
(ADDVARS (IDLE.FUNCTIONS ("Bouncing BiClock" (QUOTE
IDLE.BOUNCING.BICLOCK
)))
(IDLE.SUSPEND.PROCESS.NAMES BICLOCKPROCESS)))))
(DEFINEQ
(BICLOCK
(LAMBDA (REG NOSECONDSFLG COLOR) (* lmm
"28-Feb-86 20:43")
(PROG ((W (CREATEW (OR REG (GETREGION 20 20 NIL (QUOTE BICLOCKNRFN)))
NIL 0))
(PARMS (create BICLOCKPARMS
SECONDSMODE ←(NOT NOSECONDSFLG)
COLORMODE ←(OR COLOR (QUOTE WHITE))
ADJUSTEVENT ←(CREATE.EVENT)))
P)
(SETQ P (ADD.PROCESS (LIST (FUNCTION BICLOCKPROCESS)
(KWOTE W)
(KWOTE PARMS))
(QUOTE RESTARTABLE)
T))
(WINDOWPROP W (QUOTE PROCESS)
P)
(WINDOWPROP W (QUOTE NEWREGIONFN)
(FUNCTION BICLOCKNRFN))
(WINDOWPROP W (QUOTE RESHAPEFN)
(FUNCTION BICLOCKRSFN))
(WINDOWPROP W (QUOTE REPAINTFN)
(FUNCTION BICLOCKRPFN))
(WINDOWPROP W (QUOTE CLOSEFN)
(FUNCTION BICLOCKCFN))
(WINDOWPROP W (QUOTE AFTERMOVEFN)
(FUNCTION BICLOCKRPFN))
(WINDOWPROP W (QUOTE PARMS)
PARMS)
(WINDOWPROP W (QUOTE WINDOWENTRYFN)
(FUNCTION BICLOCKBEFN))
(WINDOWPROP W (QUOTE BUTTONEVENTFN)
(FUNCTION BICLOCKBEFN))
(RETURN W))))
(BICLOCKBEFN
[LAMBDA (W) (* BKN "11-Dec-85 14:49")
(if (KEYDOWNP 'LSHIFT)
then (BKSYSBUF (DATE))
(UNTILMOUSESTATE (NOT (OR LEFT MIDDLE)))
else (with BICLOCKPARMS (WINDOWPROP W 'PARMS)
(if (MOUSESTATE LEFT)
then (if ALARMTIME
then (PROMPTPRINT (DATE)
" ALARM AT "
(GDATE ALARMTIME))
else (PROMPTPRINT (DATE)
" NO ALARM SET"))
elseif (MOUSESTATE MIDDLE)
then (SELECTQ [MENU (create MENU
ITEMS ←(BQUOTE (("Seconds On" 'SON)
("Seconds Off" 'SOFF)
("White" 'WHITE)
("Black" 'BLACK)
("Set Alarm" 'ALARM)
("Alarm Off" 'AOFF]
(SON (SETQ SECONDSMODE T))
(SOFF (SETQ SECONDSMODE NIL))
(WHITE (SETQ COLORMODE 'WHITE))
(BLACK (SETQ COLORMODE 'BLACK))
(ALARM (BICLOCKSETALARM W))
(AOFF (SETQ ALARMTIME NIL))
NIL)
(WAKE.PROCESS (WINDOWPROP W 'PROCESS])
(BICLOCKCFN
[LAMBDA (W)
(DEL.PROCESS (WINDOWPROP W 'PROCESS])
(BICLOCKNRFN
[LAMBDA (FP MP) (* BN "17-Sep-84 10:40")
(COND
[MP (with POSITION MP (PROG [(DX (IDIFFERENCE XCOORD (fetch (POSITION XCOORD) of FP)))
(DY (IDIFFERENCE YCOORD (fetch (POSITION YCOORD) of FP]
[COND
[(IGREATERP (IABS DX)
(IABS DY))
(SETQ YCOORD (IPLUS (fetch (POSITION YCOORD) of FP)
(ITIMES DX (COND
((MINUSP (ITIMES DX DY))
-1)
(T 1]
(T (SETQ XCOORD (IPLUS (fetch (POSITION XCOORD) of FP)
(ITIMES DY (COND
((MINUSP (ITIMES DX DY))
-1)
(T 1]
(RETURN MP]
(T FP])
(BICLOCKPROCESS
[LAMBDA (W PARMS) (* BKN "11-Dec-85 14:34")
(CENTERPRINTINREGION "Wait" NIL W)
(with BICLOCKPARMS PARMS
(PROG [(WIDTH (WINDOWPROP W 'WIDTH))
(HEIGHT (WINDOWPROP W 'HEIGHT]
(while T bind S (BM ←(BITMAPCREATE WIDTH HEIGHT))
(BG ←(BITMAPCREATE WIDTH HEIGHT))
(BM1 ←(BITMAPCREATE WIDTH HEIGHT))
(SHADOW ←(BITMAPCREATE WIDTH HEIGHT))
(XC ←(IQUOTIENT WIDTH 2))
(YC ←(IQUOTIENT HEIGHT 2))
(SX ←(ARRAY 60 'FIXP 0 0))
(SY ←(ARRAY 60 'FIXP 0 0))
MX MY HX HY MP HP R MARKUR MARKLR MARK1LR DOTR SECR MINR HOURR CIRCW
MARKW MARK1W SECW MINW HOURW NOW SECS (SLOWMODE ← T)
(SMODE ← T)
(MEAN ← 50)
(LIMIT ← 1000)
CL0 REF NOSEC INVERTFLG
first (* First set up some relations)
(BLOCK)
(SETQ R (IDIFFERENCE (IMIN XC YC)
3))
(SETQ MARKUR (FIX (FTIMES R 1.0)))
(SETQ MARKLR (FIX (FTIMES R .9)))
(SETQ MARK1LR (FIX (FTIMES R .98)))
(SETQ DOTR (FIX (FTIMES R .05)))
(SETQ SECR (FIX (FTIMES R 1.0)))
(SETQ MINR (FIX (FTIMES R .9)))
(BLOCK)
(SETQ HOURR (FIX (FTIMES R .6)))
(SETQ CIRCW (FIX (FTIMES R .03)))
(SETQ MARKW (FIX (FTIMES R .05)))
(SETQ MARK1W (FIX (FTIMES R .013)))
(SETQ SECW (IMAX 1 (FTIMES R .01)))
(SETQ MINW (IMAX 2 (FTIMES R .037)))
(SETQ HOURW (IMAX 3 (FTIMES R .07)))
(SETQ S (DSPCREATE BM))
(DSPXOFFSET XC S)
(DSPYOFFSET YC S) (* Generate background Minute Marks)
(for V from 0 to 330 by 30
do (BLOCK)
(DRAWLINE (FTIMES (SIN V)
MARKUR)
(FTIMES (COS V)
MARKUR)
(FTIMES (SIN V)
MARKLR)
(FTIMES (COS V)
MARKLR)
MARKW
'REPLACE S)) (* Generate background Second Marks)
(for V from 0 to 354 by 6 as I from 0
do (BLOCK)
(DRAWLINE (SETA SX I (FIX (FTIMES (SIN V)
SECR)))
(SETA SY I (FIX (FTIMES (COS V)
SECR)))
(FTIMES (SIN V)
MARK1LR)
(FTIMES (COS V)
MARK1LR)
MARK1W
'REPLACE S))
(BLOCK)
(FILLCIRCLE 0 0 DOTR BLACKSHADE S)
(* Let this be the Background to be used in the loop)
(BITBLT BM NIL NIL BG) (* Determine a reference point for millisecond clock,
that is half a second ahead...)
(while (IEQP (DAYTIME)
T1)
bind (T1 ←(DAYTIME)) do (BLOCK) finally (SETQ REF (IPLUS (CLOCK 0)
500)))
do (BITBLT BG NIL NIL BM) (* Compute Number of seconds since midnigth)
(SETQ NOW (DAYTIME))
(SETQ SECS (with UPTIMEREC (\UNPACKDATE (if ADJUSTALARM
then ALARMTIME
else NOW))
(IPLUS (ITIMES HOUR 3600)
(ITIMES MINUTE 60)
SECOND)))
(if SLOWMODE
then (BLOCK)) (* Draw Hour Arm)
(COND
((EQP HP (IQUOTIENT SECS 120))
(DRAWLINE 0 0 HX HY HOURW 'REPLACE S))
(T (DRAWLINE 0 0 (SETQ HX (FIX (FTIMES (SIN (SETQ HP (IQUOTIENT SECS 120)))
HOURR)))
(SETQ HY (FIX (FTIMES (COS HP)
HOURR)))
HOURW
'REPLACE S)))
(if SLOWMODE
then (BLOCK)) (* Draw Minute Arm)
(COND
((EQP MP (IQUOTIENT SECS 10))
(DRAWLINE 0 0 MX MY MINW 'REPLACE S))
(T (DRAWLINE 0 0 (SETQ MX (FIX (FTIMES (SIN (SETQ MP (IQUOTIENT SECS 10)))
MINR)))
(SETQ MY (FIX (FTIMES (COS MP)
MINR)))
MINW
'REPLACE S)))
(if SLOWMODE
then (BLOCK)) (* Draw Seconds Arm)
(COND
((NOT NOSEC)
(DRAWLINE 0 0 (ELT SX (IMOD SECS 60))
(ELT SY (IMOD SECS 60))
SECW
'REPLACE S))) (* Now, Generate The Shadow)
(if SLOWMODE
then (BLOCK))
(BITBLT BM NIL NIL SHADOW)
[for DX from -1 to 1
do (for DY from -1 to 1
do (if SLOWMODE
then (BLOCK))
(BITBLT SHADOW NIL NIL SHADOW DX DY NIL NIL 'INPUT 'PAINT)
when (NOT (ZEROP (IPLUS (IABS DX)
(IABS DY]
(if SLOWMODE
then (BLOCK)) (* Find the Real background)
(TOTOPW W)
(BITBLT (WINDOWPROP W 'IMAGECOVERED)
NIL NIL BM1)
(BITBLT SHADOW NIL NIL BM1 NIL NIL NIL NIL 'INPUT (SELECTQ COLORMODE
(WHITE 'PAINT)
(BLACK 'ERASE)
NIL))
(if SLOWMODE
then (BLOCK))
(BITBLT BM NIL NIL BM1 NIL NIL NIL NIL 'INPUT (SELECTQ COLORMODE
(WHITE 'ERASE)
(BLACK 'PAINT)
NIL))
(* Now, at last, Output it)
(BITBLT BM1 NIL NIL W NIL NIL NIL NIL (if INVERTFLG
then 'INVERT
else 'INPUT)
'REPLACE)
[if SLOWMODE
then (for N from 1 to (COND
(SMODE 10)
(T 1))
bind (DEL ←(COND
((OR SMODE (AND ALARMTIME (ILEQ ALARMTIME NOW)))
1000)
(T 60000)))
until (OR ADJUSTALARM (AND ALARMTIME (ILEQ ALARMTIME NOW)))
repeatwhile (AND NOSEC (IGREATERP MEAN LIMIT))
do (BLOCK (IDIFFERENCE DEL (IMOD (IDIFFERENCE (CLOCK 0)
REF)
DEL)))
(SETQ CL0 (CLOCK 0))
(BLOCK)
(SETQ MEAN (IQUOTIENT (IPLUS (ITIMES MEAN 8)
(ITIMES (IMIN (IDIFFERENCE
(CLOCK 0)
CL0)
500)
2))
10]
(SETQ SLOWMODE (NOT ADJUSTALARM))
(SETQ SMODE SECONDSMODE)
(SETQ NOSEC (AND (OR (NOT SMODE)
(IGREATERP MEAN LIMIT))
(NOT ADJUSTALARM)))
(SETQ INVERTFLG (if (AND ALARMTIME (ILEQ ALARMTIME NOW))
then (BEEPON (if INVERTFLG
then 440
else 880))
(BLOCK 50)
(BEEPOFF)
(NOT INVERTFLG)
elseif ADJUSTALARM
then (AWAIT.EVENT ADJUSTEVENT)
NIL))
(SETQ LIMIT (IMIN (IPLUS (IMIN LIMIT (IQUOTIENT (ITIMES MEAN 10)
9))
1)
50])
(BICLOCKRPFN
[LAMBDA (W)
(WAKE.PROCESS (WINDOWPROP W 'PROCESS])
(BICLOCKRSFN
[LAMBDA (W)
(RESTART.PROCESS (WINDOWPROP W 'PROCESS])
(BICLOCKSETALARM
[LAMBDA (W) (* BKN "11-Dec-85 14:57")
(LET [(M (OR (WINDOWPROP W 'ADJUSTMENUW)
(MENUWINDOW
(create MENU
ITEMS ←(BQUOTE
(("<Hr>")
("<Min>")
("<Sec>")
,@[for I1 in '(24 12 3 1 -1 -3 -12 -24) as I2
in '(30 15 5 1 -1 -5 -15 -30)
join (for QQQ in '(T NIL NIL) as SCALE
in (CONSTANT (LIST (TIMES 60 60)
60 1))
as HELP in '(
"Will Increment/Decrement Hours by that Amount"
"Will Increment/Decrement Minutes by that Amount"
"Will Increment/Decrement Seconds by that Amount")
collect (LET ((I (if QQQ
then I1
else I2)))
(LIST I (LIST (FUNCTION BICLOCKSETALARM1)
(KWOTE W)
(KWOTE (TIMES I SCALE)))
HELP]
("OK!" (BICLOCKSETALARM2 , (KWOTE W))
"Will Exit Adjust Mode")
("←0" (BICLOCKSETALARM1 , (KWOTE W)
,
(CONSTANT (TIMES 60 60))
T)
"Will Reset Alarm Time to Hr:00:00")
("←0" (BICLOCKSETALARM1 , (KWOTE W)
60 T)
"Will Reset Alarm Time to Hr:Min:00")))
TITLE ← "Adjust Alarm"
CENTERFLG ← T
MENUCOLUMNS ← 3]
(WINDOWPROP W 'ADJUSTMENUW M)
(ATTACHWINDOW M W 'BOTTOM 'JUSTIFY)
(with BICLOCKPARMS (WINDOWPROP W 'PARMS)
(SETQ ALARMTIME (OR ALARMTIME (PLUS (DAYTIME)
60)))
(SETQ ADJUSTALARM T)
(NOTIFY.EVENT ADJUSTEVENT)
(PROMPTPRINT (GDATE ALARMTIME])
(BICLOCKSETALARM1
[LAMBDA (W DSEC MODULOFLG) (* BKN "11-Dec-85 14:56")
(with BICLOCKPARMS (WINDOWPROP W 'PARMS)
[LET [(OLDTIME (OR ALARMTIME (PLUS (DAYTIME)
60]
(SETQ ALARMTIME (if MODULOFLG
then (DIFFERENCE OLDTIME (IMOD (with UPTIMEREC (\UNPACKDATE ALARMTIME)
(IPLUS (ITIMES HOUR 3600)
(ITIMES MINUTE 60)
SECOND))
DSEC))
else (IPLUS OLDTIME DSEC]
(NOTIFY.EVENT ADJUSTEVENT)
(PROMPTPRINT (GDATE ALARMTIME])
(BICLOCKSETALARM2
[LAMBDA (W) (* BKN "12-Nov-85 19:34")
(with BICLOCKPARMS (WINDOWPROP W 'PARMS)
(SETQ ADJUSTALARM NIL)
(NOTIFY.EVENT ADJUSTEVENT)
(DETACHWINDOW (WINDOWPROP W 'ADJUSTMENUW))
(CLOSEW (WINDOWPROP W 'ADJUSTMENUW])
)
[DECLARE: EVAL@COMPILE
(DATATYPE BICLOCKPARMS (SECONDSMODE COLORMODE ALARMTIME ADJUSTALARM ADJUSTEVENT))
(RECORD UPTIMEREC (YEAR MONTH DAY HOUR MINUTE SECOND QQQ))
]
(/DECLAREDATATYPE (QUOTE BICLOCKPARMS)
(QUOTE (POINTER POINTER POINTER POINTER POINTER))
(QUOTE ((BICLOCKPARMS 0 POINTER)
(BICLOCKPARMS 2 POINTER)
(BICLOCKPARMS 4 POINTER)
(BICLOCKPARMS 6 POINTER)
(BICLOCKPARMS 8 POINTER)))
(QUOTE 10))
(RPAQ? BICLOCKINITIALREGION (CREATEREGION (SUB1 (IDIFFERENCE SCREENWIDTH 119))
(SUB1 (IDIFFERENCE SCREENHEIGHT 119))
119 119))
(RPAQ? BICLOCKINITIALNOSECONDS NIL)
(RPAQ? BICLOCKINITIALCOLOR NIL)
(RPAQ BICLOCKWINDOW (if (REGIONP BICLOCKINITIALREGION)
then
(BICLOCK BICLOCKINITIALREGION BICLOCKINITIALNOSECONDS BICLOCKINITIALCOLOR
)))
(* Idling stuff)
(DEFINEQ
(IDLE.BOUNCING.BICLOCK
(LAMBDA (screenWindow) (* LeL, "18-Dec-85 02:39")
(DECLARE (GLOBALVARS IDLE.BICLOCKWIDTH))
(while T
bind (biclockW ←(BICLOCK (LIST 0 0 IDLE.BICLOCKWIDTH IDLE.BICLOCKWIDTH)
NIL
'BLACK))
(maxX ←(IDIFFERENCE SCREENWIDTH IDLE.BICLOCKWIDTH))
(maxY ←(IDIFFERENCE SCREENHEIGHT IDLE.BICLOCKWIDTH))
first (ADD.PROCESS (BQUOTE (IDLE.BICLOCK.KILLER (\, biclockW))))
do (TOTOPW screenWindow)
(MOVEW biclockW (RAND 0 maxX)
(RAND 0 maxY))
(BLOCK (RAND 2000 5000)))))
(IDLE.BICLOCK.KILLER
(LAMBDA (biclock) (* LeL, "18-Dec-85 02:23")
(DECLARE (GLOBALVARS \IDLING))
(while \IDLING do (BLOCK))
(CLOSEW biclock)))
)
(RPAQ? IDLE.BICLOCKWIDTH 200)
(ADDTOVAR IDLE.FUNCTIONS ("Bouncing BiClock" (QUOTE IDLE.BOUNCING.BICLOCK)))
(ADDTOVAR IDLE.SUSPEND.PROCESS.NAMES BICLOCKPROCESS)
(PUTPROPS BICLOCK COPYRIGHT ("Bernt Nilsson @ University of Linkoeping" 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1961 15778 (BICLOCK 1971 . 3469) (BICLOCKBEFN 3471 . 4591) (BICLOCKCFN 4593 . 4672) (
BICLOCKNRFN 4674 . 5506) (BICLOCKPROCESS 5508 . 12877) (BICLOCKRPFN 12879 . 12960) (BICLOCKRSFN 12962
. 13046) (BICLOCKSETALARM 13048 . 14818) (BICLOCKSETALARM1 14820 . 15443) (BICLOCKSETALARM2 15445 .
15776)) (16820 17736 (IDLE.BOUNCING.BICLOCK 16830 . 17503) (IDLE.BICLOCK.KILLER 17505 . 17734)))))
STOP