(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Dec-87 12:52:29" {DSK}<LISPFILES>CALENDAR.;3 142057
changes to%: (FNS CALLOADFILE)
(VARS CALENDARCOMS)
previous date%: "11-Dec-87 10:33:39" {ICE}<DENBER>LISP>CALENDAR.;145)
(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT CALENDARCOMS)
(RPAQQ CALENDARCOMS
((VARS (CALCIRCLEDAY)
(CALCIRCLEMONTH)
(CALCURDAY)
(CALENDARVERSION "Calendar Version 2.04")
(CALMAINMENU)
CALOPTIONSDESC CALOPTIONSDESCLYRIC)
(INITVARS (CALALERTFLG T)
(CALDAYBROWSERS)
(CALDAYDEFAULTREGION '(32 200 350 100))
(CALDAYSTART 900)
(CALDEFAULTALERTDELTA 0)
(CALDEFAULTHOST&DIR)
(CALDIRTYREMLST NIL)
(CALFILELST)
(CALFLASHTIMES 0)
(CALFLASHTYPE 'None)
(CALFONT)
(CALHARDCOPYPOMFLG T)
(CALHASH (HARRAY 200))
(CALHILITETODAY 'CIRCLE)
(CALKEEPEXPIREDREMSFLG)
(CALMONLOCK)
(CALMONTHDEFAULTREGION '(32 32 868 700))
(CALMONTHICON)
(CALMONTHLST)
(CALNEEDSUPDATE)
(CALREMDISPLAYREGION '(200 400 300 400))
(CALREMINDERS)
(CALREMSLOADED)
(CALTEDITWINDOW)
[CALTUNE '((750 . 20000)
(650 . 20000]
(CALUPDATEONSHRINKFLG 'Never)
(CALYEARICON)
(PBIGFONT)
(PCALFONT)
(PLITTLEFONT))
(DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
TABLEBROWSER))
(FNS CALADDEVENT CALCREATEREM CALDELETEREM CALDISPEVENT CALDOOPTIONS CALENDAR CALENDARWATCHER
CALEXTENDSEL CALLOADFILE CALMAKEKEY CALMONTHBEF CALMONTHICONFN CALMONTHRBF CALOPTIONMENU
CALPRINTREM CALREMDEF CALTBCLOSEFN CALTBNULLFN CALTEDITEXIT CALTEDITSTRING CALUPDATEFILE
CALUPDATEINIT CALYEARICONFN CALYEARINRANGE CIRCLETODAY CLEARDAY CLOSEMONTH DAYABBR
DAYNAME DAYOF DAYPLUS DAYSIN DERIVENEWDATE DOREMINDER FMNWAYITEM GETREMDEF INVERTGROUP
LISPDATEDAY LISPDATEMONTH LISPDATEYEAR MDMENUITEMREGION MENUITEM MENUREGIONITEM
MONTHABBR MONTHNAME MONTHNUM MONTHOFDAYPLUS MONTHPLUS MONTHYEARPLUS NEWPARSETIME
NEXTMDISPLAYREGION PACKDATE PARSETIME PICKFONTSIZE POM POMDAYS PRINTMONTH REMINDERSOF
REMINDERTIME REMINDERTIMELT REMSINMONTH REPAINTMONTH REPAINTYEAR SAMEDAYAS SAMEMONTHAS
SCALEBITMAP SHOWDAY SHOWMONTH SHOWMONTHSMALL SHOWMOON SHOWREMSINDAY SHOWREMSINMONTH
SHOWYEAR SHRINKMONTH SHRINKYEAR TIMEDREMP TPLUS YNCONVERT)
(BITMAPS CALDAYICON CALMONTHICONMAP CALYEARICONMAP FQMAP FMMAP LQMAP NMMAP)
(FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
FREEMENU TABLEBROWSER)))
(RPAQQ CALCIRCLEDAY NIL)
(RPAQQ CALCIRCLEMONTH NIL)
(RPAQQ CALCURDAY NIL)
(RPAQ CALENDARVERSION "Calendar Version 2.04")
(RPAQQ CALMAINMENU NIL)
(RPAQQ CALOPTIONSDESC (((TYPE TITLE LABEL Alert%: FONT (HELVETICA 10 BOLD))
(TYPE NWAY ID CALALERTFLG LABEL Yes MESSAGE
"Reminders will alert you when they fire.")
(TYPE NWAY ID CALALERTFLG LABEL No MESSAGE
"Reminders will not alert you when they fire."))
((TYPE TITLE LABEL "Keep expired rems.:" FONT (HELVETICA 10 BOLD))
(TYPE NWAY ID CALKEEPEXPIREDREMSFLG LABEL Yes MESSAGE
"Expired reminders will not be deleted.")
(TYPE NWAY ID CALKEEPEXPIREDREMSFLG LABEL No MESSAGE
"Reminders are deleted automatically when they fire."))
((TYPE TITLE LABEL "Auto. file update:" FONT (HELVETICA 10 BOLD))
(TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Always MESSAGE
"Update after each reminder is created.")
(TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Shrink MESSAGE
"Update only when you shrink a month window.")
(TYPE NWAY ID CALUPDATEONSHRINKFLG LABEL Never MESSAGE
"No automatic updates - use Update in day browser menu."))
((TYPE EDITSTART LABEL "Alert delta:" ITEMS (CALDEFAULTALERTDELTA)
FONT
(HELVETICA 10 BOLD)
MESSAGE
"Default alert time offset in minutes: - for before, + for after.")
(TYPE EDIT ID CALDEFAULTALERTDELTA LABEL 0))
((TYPE EDITSTART LABEL "Host & dir.:" ITEMS (CALDEFAULTHOST&DIR)
FONT
(HELVETICA 10 BOLD))
(TYPE EDIT ID CALDEFAULTHOST&DIR LABEL ""))
((TYPE MOMENTARY LABEL Apply! FONT (HELVETICA 10 BOLD)
SELECTEDFN CALDOOPTIONS MESSAGE
"Puts the selected options into effect and closes this window."))
(WINDOWPROPS TITLE "Calendar Options")))
(RPAQQ CALOPTIONSDESCLYRIC ([(GROUP (PROPS ID ALERTGROUP)
((TYPE DISPLAY LABEL "Alert:" FONT (HELVETICA 10 BOLD))
(TYPE NWAY COLLECTION CALALERTFLG LABEL Yes MESSAGE
"Reminders will alert you when they fire.")
(TYPE NWAY COLLECTION CALALERTFLG LABEL No MESSAGE
"Reminders will not alert you when they fire."]
[(GROUP (PROPS ID XGROUP)
((TYPE DISPLAY LABEL "Keep expired rems.:" FONT (HELVETICA 10
BOLD))
(TYPE NWAY COLLECTION CALKEEPEXPIREDREMSFLG LABEL Yes MESSAGE
"Expired reminders will not be deleted.")
(TYPE NWAY COLLECTION CALKEEPEXPIREDREMSFLG LABEL No MESSAGE
"Reminders are deleted automatically when they fire."]
[(GROUP (PROPS ID UPGROUP)
((TYPE DISPLAY LABEL "Auto. file update:" FONT (HELVETICA 10 BOLD
))
(TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Always MESSAGE
"Update after each reminder is created.")
(TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Shrink MESSAGE
"Update only when you shrink a month window.")
(TYPE NWAY COLLECTION CALUPDATEONSHRINKFLG LABEL Never MESSAGE
"No automatic updates - use Update in day browser menu."]
((TYPE EDITSTART LABEL "Alert delta:" ITEMS (CALDEFAULTALERTDELTA)
FONT
(HELVETICA 10 BOLD)
MESSAGE
"Default alert time offset in minutes: - for before, + for after."
)
(TYPE EDIT ID CALDEFAULTALERTDELTA LABEL 0))
((TYPE EDITSTART LABEL "Host & dir.:" ITEMS (CALDEFAULTHOST&DIR)
FONT
(HELVETICA 10 BOLD))
(TYPE EDIT ID CALDEFAULTHOST&DIR LABEL ""))
((TYPE MOMENTARY LABEL Apply! FONT (HELVETICA 10 BOLD)
SELECTEDFN CALDOOPTIONS MESSAGE
"Puts the selected options into effect and closes this window."))))
(RPAQ? CALALERTFLG T)
(RPAQ? CALDAYBROWSERS )
(RPAQ? CALDAYDEFAULTREGION '(32 200 350 100))
(RPAQ? CALDAYSTART 900)
(RPAQ? CALDEFAULTALERTDELTA 0)
(RPAQ? CALDEFAULTHOST&DIR )
(RPAQ? CALDIRTYREMLST NIL)
(RPAQ? CALFILELST )
(RPAQ? CALFLASHTIMES 0)
(RPAQ? CALFLASHTYPE 'None)
(RPAQ? CALFONT )
(RPAQ? CALHARDCOPYPOMFLG T)
(RPAQ? CALHASH (HARRAY 200))
(RPAQ? CALHILITETODAY 'CIRCLE)
(RPAQ? CALKEEPEXPIREDREMSFLG )
(RPAQ? CALMONLOCK )
(RPAQ? CALMONTHDEFAULTREGION '(32 32 868 700))
(RPAQ? CALMONTHICON )
(RPAQ? CALMONTHLST )
(RPAQ? CALNEEDSUPDATE )
(RPAQ? CALREMDISPLAYREGION '(200 400 300 400))
(RPAQ? CALREMINDERS )
(RPAQ? CALREMSLOADED )
(RPAQ? CALTEDITWINDOW )
(RPAQ? CALTUNE '((750 . 20000)
(650 . 20000)))
(RPAQ? CALUPDATEONSHRINKFLG 'Never)
(RPAQ? CALYEARICON )
(RPAQ? PBIGFONT )
(RPAQ? PCALFONT )
(RPAQ? PLITTLEFONT )
(DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
TABLEBROWSER)
)
(DEFINEQ
(CALADDEVENT
[LAMBDA (M D YR W BROWSER INITMSG) (* MJD " 1-Dec-87 17:38")
(* MJD " 2-Jul-86 14:10")
(PROG (ANS MSGTITLE REMDATE REMTIME ALERTFLG ALERTTIME PARSEDALERTTIME PARSEDREMTIME
AMBIGUOUSTIMEFLG HOUR PMFLG MSGSTREAM ASTARTPOS TSTARTPOS)
(OBTAIN.MONITORLOCK CALMONLOCK)
(WITH.MONITOR CALMONLOCK (SETQ MSGSTREAM (CALTEDITSTRING INITMSG)))
(if (NOT MSGSTREAM)
then (printout PROMPTWINDOW T "Reminder aborted")
(RELEASE.MONITORLOCK CALMONLOCK)
(RETURN NIL))
(SETQ ANS (COERCETEXTOBJ MSGSTREAM 'STRINGP))
(if (NOT (STRPOS (CONCAT (CHARACTER 13)
"Event time: ")
ANS))
then (printout PROMPTWINDOW T "Error parsing event time: reminder aborted")
(RELEASE.MONITORLOCK CALMONLOCK)
(RETURN NIL))
(SETQ TSTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 13)
"Event time: ")
ANS)
13))
[SETQ REMTIME (SUBSTRING ANS TSTARTPOS (SUB1 (STRPOS (CHARACTER 13)
ANS TSTARTPOS]
(if (STRING-EQUAL REMTIME ">>Time<<")
then (SETQ REMTIME NIL))
(SETQ REMDATE (PACKDATE (SETQ PARSEDREMTIME (NEWPARSETIME REMTIME))
M D YR))
(if (NOT (STRPOS (CONCAT (CHARACTER 13)
"Alert time: ")
ANS))
then (printout PROMPTWINDOW T "Error parsing alert time: reminder aborted")
(RELEASE.MONITORLOCK CALMONLOCK)
(RETURN NIL))
(SETQ ASTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 13)
"Alert time: ")
ANS)
13))
[SETQ ALERTTIME (SUBSTRING ANS ASTARTPOS (SUB1 (STRPOS (CHARACTER 9)
ANS ASTARTPOS]
(* ; "Alert time field ends with a TAB")
(if (STRING-EQUAL ALERTTIME ">>Time<<")
then (SETQ ALERTTIME NIL))
(SETQ PARSEDALERTTIME (NEWPARSETIME ALERTTIME))
(if (NULL PARSEDREMTIME)
then (printout PROMPTWINDOW T "Sorry - I couldn't parse that time.")
(CALADDEVENT M D YR W BROWSER ANS)
(RETURN T)
elseif (IGREATERP PARSEDREMTIME 2359)
then (SHOULDNT "Illegal time: must be <= 23:59")
elseif (AND REMTIME (ILEQ (IDATE REMDATE)
(IDATE)))
then (printout PROMPTWINDOW T
"Warning: you have added a reminder with a time in the past."))
(* ;
"If user gave an alert time w/o an event time, assume event time = alert time.")
(if (AND (EQ PARSEDREMTIME 0)
(NEQ PARSEDALERTTIME 0))
then (SETQ PARSEDREMTIME PARSEDALERTTIME))
(* ;; "If user didn't give an alert time, but has a default delta, then derive an alert time from that plus the event time.")
(if (AND (NEQ CALDEFAULTALERTDELTA 0)
(EQ PARSEDALERTTIME 0))
then (SETQ PARSEDALERTTIME (TPLUS PARSEDREMTIME CALDEFAULTALERTDELTA)))
(if (NOT (STRPOS (CONCAT (CHARACTER 9)
"Alert: ")
ANS))
then (printout PROMPTWINDOW T "Error parsing alert option: reminder aborted")
(RELEASE.MONITORLOCK CALMONLOCK)
(RETURN NIL))
(SETQ ASTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 9)
"Alert: ")
ANS)
8))
[SETQ ALERTFLG (SUBSTRING ANS ASTARTPOS (SUB1 (STRPOS (CHARACTER 13)
ANS ASTARTPOS]
(SETQ ALERTFLG (COND
((STRING-EQUAL ALERTFLG "Yes")
T)
((STRING-EQUAL ALERTFLG "No")
NIL)
(T CALALERTFLG)))
(if (AND (IGREATERP (HARRAYPROP CALHASH 'NUMKEYS)
0)
(NOT CALNEEDSUPDATE))
then (SETQ CALREMSLOADED T))
(if AMBIGUOUSTIMEFLG
then (SETQ HOUR (QUOTIENT PARSEDREMTIME 100))
[if (IGEQ HOUR 12)
then (SETQ PMFLG T)
(if (IGEQ HOUR 12)
then (SETQ HOUR (IDIFFERENCE HOUR 12]
(printout PROMPTWINDOW "Assuming " HOUR ":" |.I2.10.0| (IMOD PARSEDREMTIME 100)
(if PMFLG
then " p.m."
else " a.m.")
T)) (* ; " tell user translated time")
(RELEASE.MONITORLOCK CALMONLOCK)
[SETQ MSGTITLE (SUBSTRING ANS 8 (SUB1 (STRPOS (CHARACTER 13)
ANS] (* ; "This needs fixing for groups")
(if (EQ (WINDOWPROP W 'GROUPEND)
'% )
then (WINDOWPROP W 'GROUPEND NIL))
(for RDAY from D to (OR (WINDOWPROP W 'GROUPEND)
D) do (CALCREATEREM (LIST MSGTITLE MSGSTREAM)
PARSEDREMTIME PARSEDALERTTIME ALERTFLG M RDAY YR
BROWSER)
(SHOWREMSINDAY W M RDAY YR))
(SETQ CALNEEDSUPDATE T)
(if (NOT CALUPDATEONSHRINKFLG)
then (CALUPDATEINIT])
(CALCREATEREM
[LAMBDA (MSG REMTIME ALERTTIME ALERTFLG M D YR BROWSER) (* MJD " 1-Dec-87 17:42")
(* ;;
"MSG is a list of the form (title-string TEdit-stream), REMTIME is a number representing the time")
(* ;; "Timed reminders are stored on the list CALREMINDERS as (timer-object date-string TB-pointer) The message itself is stored in the data field of the browser item.")
(* ;; "BROWSER is always supplied, unless the user clicked Middle in the month window to go startight to CALADDEVENT w/o calling Add from a browser menu.")
(PROG (R REMDATE ITEM)
(SETQ REMDATE (PACKDATE REMTIME M D YR))
(SETQ ITEM (create TABLEITEM))
(SETQ R (LIST (COND
((NEQ ALERTTIME 0)
(SETUPTIMER.DATE (PACKDATE ALERTTIME M D YR)))
((NEQ REMTIME 0)
(SETUPTIMER.DATE REMDATE))
(T NIL))
REMDATE ITEM))
(replace TIDATA of ITEM with (APPEND R MSG))
(if BROWSER
then (TB.INSERT.ITEM BROWSER ITEM)
(if (ILESSP (TB.NUMBER.OF.ITEMS BROWSER 'SELECTED)
1)
then (TB.SELECT.ITEM BROWSER ITEM)))
[if (AND (NEQ REMTIME 0)
ALERTFLG
(IGREATERP (IDATE REMDATE)
(IDATE)))
then
(* ;; "It's a timed reminder. If he wants an alert AND this rem. is not in the past (we now allow this for historical purposes), then put it on CALREMINDERS.")
(if CALREMINDERS
then (MERGE (LIST R)
CALREMINDERS T)
else (SETQ CALREMINDERS (LIST R]
(pushnew CALDIRTYREMLST ITEM)
(PUTHASH (CALMAKEKEY M D YR)
(SORT (NCONC1 (GETHASH (CALMAKEKEY M D YR)
CALHASH)
ITEM)
'REMINDERTIMELT)
CALHASH])
(CALDELETEREM
[LAMBDA (BROWSER ITEM) (* MJD "10-Dec-87 15:44")
(* ;; "ITEM can be either a timed list-form reminder (timer-obj date-str TI-pointer) from CALREMINDERS if this is being called by DOREMINDER, or a TABLEITEM if this is being called by the user via the browser menu.")
(PROG (M D YR R RTIMESTR DAYBROWSER ITEMKEY)
(if BROWSER
then (TB.DELETE.ITEM BROWSER ITEM))
(SETQ CALDIRTYREMLST (REMOVE ITEM CALDIRTYREMLST))
(SETQ R (if (EQ (TYPENAME ITEM)
'TABLEITEM)
then (if (EQ (TYPENAME (fetch TIDATA of ITEM))
'TABLEITEM)
then (fetch TIDATA of (fetch TIDATA of ITEM))
else (fetch TIDATA of ITEM))
else ITEM))
(SETQ RTIMESTR (CADR R))
(SETQ M (LISPDATEMONTH RTIMESTR))
(SETQ D (LISPDATEDAY RTIMESTR))
(SETQ YR (LISPDATEYEAR RTIMESTR))
(* ;; "See if this rem. has a browser open so it can be marked as deleted. However, if it has an alert time earlier than its event time, leave it be (looks bad to have a rem. crossed out before the event time.)")
[if (AND (NOT BROWSER)
(LESSP (IDATE RTIMESTR)
(IDATE)))
then (SETQ DAYBROWSER (for B in CALDAYBROWSERS
thereis (AND (EQ D (CADR (TB.USERDATA B)))
(EQ M (CAR (TB.USERDATA B)))
(EQ YR (CADDR (TB.USERDATA B]
[if DAYBROWSER
then (TB.DELETE.ITEM DAYBROWSER (CAR (LAST ITEM]
(* ;; "If this is a timed rem and it hasn't expired yet, remove it form CALREMINDERS.")
(if (AND (TIMEDREMP R)
(IGREATERP (IDATE RTIMESTR)
(IDATE)))
then (SETQ CALREMINDERS (REMOVE [for REM in CALREMINDERS
thereis (EQ ITEM (CAR (NTH REM 3]
CALREMINDERS)))
(* ;; "If this reminder is periodic, its hash key is stored in its 6th slot. If nothing is found there, compute the key the usual way.")
(SETQ ITEMKEY (OR (CAR (NTH R 6))
(CALMAKEKEY M D YR))) (* ;
"Now that we have the key, we can remove it from the list of rems. in that day.")
(PUTHASH ITEMKEY (REMOVE (CADDR R)
(GETHASH ITEMKEY CALHASH))
CALHASH])
(CALDISPEVENT
[LAMBDA (ITEM MNAME BUTTON) (* MJD "11-Dec-87 10:28")
(* ;
"Handles browser menu item selections --- Add, Display, Delete, Update, SendMail, Period")
(PROG (M D YR DLIST W BROWSER CHOICE ITEMKEY RECIPIENTS)
(SETQ BROWSER (GETMENUPROP MNAME 'BROWSER))
(SETQ DLIST (TB.USERDATA BROWSER))
(SETQ W (CADDDR DLIST))
(SETQ M (CAR DLIST))
(SETQ D (CADR DLIST))
(SETQ YR (CADDR DLIST))
[COND
[(EQ (CADR ITEM)
'CALADD)
(CALADDEVENT M D YR W (GETMENUPROP MNAME 'BROWSER]
((EQ (CADR ITEM)
'CALDISPLAY)
(TB.MAP.SELECTED.ITEMS BROWSER '[LAMBDA (B I)
(TEDIT (CAR (NTH (GETREMDEF I)
5))
(CREATEW '(200 400 300 400)
"Reminder Display Window")
NIL
'(QUITFN T LEAVETTY T] 'CALTBNULLFN))
((EQ (CADR ITEM)
'CALUPDATE)
(CALUPDATEINIT)
(TB.MAP.DELETED.ITEMS BROWSER '[LAMBDA (B I)
(TB.REMOVE.ITEM B I] 'NILL))
((EQ (CADR ITEM)
'CALMAIL)
(if (EQ (TB.NUMBER.OF.ITEMS BROWSER)
0)
then (CALTBNULLFN BROWSER)
else (SETQ RECIPIENTS (PROMPTFORWORD (PROGN (TERPRI PROMPTWINDOW)
"Send message to: ")
NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL)))
(TB.MAP.SELECTED.ITEMS
BROWSER
'[LAMBDA (B I)
(change (CAR (NTH (GETREMDEF I)
5))
(LIST 'LAFITE.SENDMESSAGE (CONCAT "Subject: A CALENDAR Message"
(CHARACTER 13)
"To: " RECIPIENTS (CHARACTER 13)
(CHARACTER 13)
(COERCETEXTOBJ
(CAR (NTH (GETREMDEF I)
5))
'STRINGP]
'CALTBNULLFN)
(PRINTOUT PROMPTWINDOW T "The message will be mailed when its time arrives.")))
((EQ (CADR ITEM)
'CALDELETE)
(if (EQ (TB.NUMBER.OF.ITEMS BROWSER)
0)
then (CALTBNULLFN BROWSER)
else (SETCURSOR WAITINGCURSOR)
(TB.MAP.SELECTED.ITEMS BROWSER 'CALDELETEREM 'CALTBNULLFN)
(SHOWREMSINDAY W M D YR)
(SETQ CALNEEDSUPDATE T)
(CURSOR T)))
((EQ (CADR ITEM)
'CALPERIOD)
(if (EQ (TB.NUMBER.OF.ITEMS BROWSER)
0)
then (CALTBNULLFN BROWSER)
else (SETQ CHOICE (MENU (create MENU
ITEMS ← '(Daily Weekly Monthly)
TITLE ← "Period:")))
(if (NOT CHOICE)
then (PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER)
1)
T "No period set.")
(RETURN NIL))
(TB.MAP.SELECTED.ITEMS BROWSER
'[LAMBDA (B I)
(PROG (DSTR D M YR)
(SETQ DSTR (CADR (GETREMDEF I)))
(SETQ D (LISPDATEDAY DSTR))
(SETQ M (LISPDATEMONTH DSTR))
(SETQ YR (LISPDATEYEAR DSTR))
(* ;
"First, remove the item from its original slot...")
(PUTHASH (CALMAKEKEY M D YR)
(REMOVE I (GETHASH (CALMAKEKEY M D YR)
CALHASH))
CALHASH) (* ;
"Hash key period codes: 0 = daily; 1-31 = monthly; 32-38 = weekly (32 + day no.)")
(SETQ ITEMKEY (COND
((EQ CHOICE 'Daily)
0)
((EQ CHOICE 'Weekly)
(IPLUS (DAYOF M D YR)
32))
((EQ CHOICE 'Monthly)
D))) (* ;
"...and move it to the appropriate periodic slot:")
(REPLACE TIDATA OF I WITH (NCONC1 (GETREMDEF I)
ITEMKEY))
(* ;; "Note that we save the access key to this item in the rem. itself so that 1. we'll be able to find it if we need to delete it, and 2. when it fires we can tell it's periodic, figure out its next firing time and put it back on CALREMINDERS.")
(PUTHASH ITEMKEY (SORT (NCONC1 (GETHASH ITEMKEY CALHASH)
I)
'REMINDERTIMELT)
CALHASH]
'CALTBNULLFN)
(PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER)
1)
T "OK"]
(TOTOPW (TB.WINDOW BROWSER])
(CALDOOPTIONS
[LAMBDA (ITEM WINDOW BUTTON) (* MJD " 9-Dec-87 10:24")
(* ;; " The conversion to Lyric has turned this routine into a disgusting mess, in particular that whole TYPEP clause.")
(PROG [VALLIST (OPTLIST (if (EQ MAKESYSNAME 'KOTO)
then (FM.READSTATE WINDOW)
else (FM.GETSTATE WINDOW]
(SETQ VALLIST (CDR OPTLIST))
[for ITEM in OPTLIST by (CDDR OPTLIST) as VAL in VALLIST by (CDDR VALLIST)
when (NEQ VAL T) do (SET ITEM (COND
((EQ VAL 'Yes)
T)
((EQ VAL 'No)
NIL)
[(AND (NEQ MAKESYSNAME 'KOTO)
(TYPEP VAL 'FREEMENUITEM))
(if (AND (EQ (FM.ITEMPROP VAL 'TYPE)
'NWAY)
(NEQ (FM.ITEMPROP VAL 'LABEL)
'Yes)
(NEQ (FM.ITEMPROP VAL 'LABEL)
'No))
then (FM.ITEMPROP VAL 'LABEL)
else (FM.ITEMPROP VAL 'STATE]
(T (MKATOM VAL]
(CLOSEW WINDOW)
(PRINTOUT PROMPTWINDOW T "OK"])
(CALENDAR
[LAMBDA (M D YR) (* MJD " 9-Dec-87 10:21")
(* ;
"Top-level entry to the program, and public programming interface.")
(* ;;; "If you use any part of Calendar code in your own programs, I would appreciate it if you would include credit to the original author. Thanks.")
(pushnew BACKGROUNDFNS 'CALENDARWATCHER)
[OR (EQ (TYPENAME CALMONLOCK)
'MONITORLOCK)
(SETQ CALMONLOCK (CREATE.MONITORLOCK 'CALLOCKNAME]
[if (NOT CALDEFAULTHOST&DIR)
then (SETQ CALDEFAULTHOST&DIR (PROMPTFORWORD
"Please enter a default host & directory for reminder files:"
NIL NIL PROMPTWINDOW NIL NIL (CHARCODE EOL]
(COND
((type? MENU CALMAINMENU)
(DELETEMENU CALMAINMENU)))
(SETQ CALMAINMENU (create MENU
ITEMS ← [APPEND (for YR from (IDIFFERENCE (LISPDATEYEAR (DATE))
1) to (IPLUS (LISPDATEYEAR (DATE))
3)
collect (LIST YR YR
"Will make a calendar for this year."))
(LIST '(Other 'OTHER "Lets you choose another year"]
TITLE ← "Year"
CENTERFLG ← T
CHANGEOFFSETFLG ← T
WHENSELECTEDFN ← 'SHOWYEAR))
(COND
((NOT CALFONT)
(if (AND (NOT M)
(NOT D)
(NOT YR))
then (printout PROMPTWINDOW T "Looking for font TimesRoman 36 - one moment please ...")
(SETCURSOR WAITINGCURSOR))
(SETQ CALFONT (FONTCREATE 'TIMESROMAN 36))
(CURSOR T)))
(COND
((AND (NOT M)
(NOT D)
(NOT YR))
(printout T CALENDARVERSION T)
(printout T "See the Prompt Window for Calendar messages." T)
(printout PROMPTWINDOW T "Select a year for calendar.")
(MENU CALMAINMENU))
[(EQ M 'TODAY)
(SHOWDAY (LIST (LISPDATEDAY (DATE))
(LISPDATEMONTH (DATE))
(LISPDATEYEAR (DATE]
[(EQ M 'THISMONTH)
(SHOWMONTH (LIST NIL (LISPDATEMONTH (DATE))
(LISPDATEYEAR (DATE]
[(EQ M 'THISYEAR)
(SHOWYEAR (LIST (LISPDATEYEAR (DATE]
((AND (NUMBERP M)
(NUMBERP D)
(NUMBERP YR))
(SHOWDAY (LIST D M YR)))
((AND (NOT M)
(NUMBERP YR))
(SHOWYEAR (LIST YR)))
[(NUMBERP M)
(SHOWMONTH (LIST NIL M (OR YR (LISPDATEYEAR (DATE]
(T NIL])
(CALENDARWATCHER
[LAMBDA NIL (* MJD "23-Jun-87 15:53")
(if (AND CALREMINDERS (TIMEREXPIRED? (CAAR CALREMINDERS)
'SECONDS))
then (DOREMINDER (CAR CALREMINDERS])
(CALEXTENDSEL
[LAMBDA (CALMONTHWINDOW) (* MJD " 9-Dec-87 10:54")
(* ;
"Changes the length of a day group selection.")
(PROG [DEND NEWEND [CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
(CALCURMONTH (WINDOWPROP CALMONTHWINDOW 'MONTH#))
(CALCURYEAR (WINDOWPROP CALMONTHWINDOW 'YEAR#]
(while (MOUSESTATE (ONLY RIGHT))
do (SETQ DEND (CAR (MENUREGIONITEM CALMONTHWINDOW CALMONTHMENU)))
(if (EQ DEND '% )
then (* ; " He clicked Right in a blank box.")
(RETURN (TOTOPW CALMONTHWINDOW)))
(OR DEND (SETQ DEND CALCURDAY))
(INVERTGROUP CALCURMONTH CALCURDAY CALCURYEAR CALCURMONTH DEND CALCURYEAR BLACKSHADE
CALMONTHMENU)
(SETQ NEWEND (CAR (MENUREGIONITEM CALMONTHWINDOW CALMONTHMENU)))
(* ;; " At this point we have to check NEWEND for two possibilities: user wandered into a blank box (which makes it a blank), or out of the menu entirely (which makes it NIL). Either way, skip it.")
(if (AND NEWEND (NEQ NEWEND '% )
(ILESSP NEWEND DEND))
then (INVERTGROUP CALCURMONTH NEWEND CALCURYEAR CALCURMONTH DEND CALCURYEAR
WHITESHADE CALMONTHMENU)
(SETQ DEND NEWEND)))
(WINDOWPROP CALMONTHWINDOW 'GROUPEND DEND])
(CALLOADFILE
[LAMBDA (F) (* ; "Edited 14-Dec-87 12:52 by ")
(* ;; "Each reminder on the file has the format:")
(* ;; " (timer-value date-string hash-key title-string) TEdit-text <CR> *start*")
(PROG (FILE FSTREAM RSTREAM M D YR R ITEM TIMER REMDATE TITLE ITEMKEY FILEKEY (R# 0))
(SETCURSOR WAITINGCURSOR)
[SETQ FILE (OR F (PROMPTFORWORD "File to load:" NIL NIL PROMPTWINDOW NIL NIL (CHARCODE
EOL]
(* ;; " First see if he typed in a full file name. If not, make it one, using the value of CALDEFAULTHOST&DIR:")
(if (NOT (MEMBER 'HOST (UNPACKFILENAME FILE)))
then (SETQ FILE (PACKFILENAME 'NAME FILE 'DIRECTORY CALDEFAULTHOST&DIR)))
(* ;; "Now that we have a complete name, see if it's out there:")
(if (NOT (INFILEP FILE))
then (PRINTOUT PROMPTWINDOW T FILE " not found. No reminders loaded.")
(CURSOR T)
(RETURN NIL))
(if (AND (INFILEP FILE)
(GETHASH (STRINGHASHBITS (MKSTRING FILE))
CALHASH))
then (if (NOT (MOUSECONFIRM (CONCAT FILE
" is already loaded. Reloading it will create local copies of any undeleted "
"reminders from it. "
"Are you sure you want to do this?")))
then (PRINTOUT PROMPTWINDOW T "OK. No reminders loaded.")
(CURSOR T)
(RETURN NIL)))
(SETQ FSTREAM (OPENSTREAM FILE 'INPUT 'OLD))
(if (NEQ (CAR (READ FSTREAM))
'$$CALREMINDERS)
then (PRINTOUT PROMPTWINDOW T FILE
" is not a valid reminders file. No reminders loaded.")
(CLOSEF FILE)
(CURSOR T)
(RETURN NIL))
(PRINTOUT PROMPTWINDOW T "Loading " FILE "...")
(SETQ FILEKEY (STRINGHASHBITS (MKSTRING FILE)))
(PUTHASH FILEKEY (LIST 'FILEINDEX)
CALHASH)
(pushnew CALFILELST (MKATOM FILE))
(until (EQ (SETQ R (READ FSTREAM))
'STOP)
do (SETQ TIMER (CAR R)) (* ; " eg. -1558614616")
(SETQ REMDATE (CADR R)) (* ; " eg. %"12-Oct-87%"")
(SETQ ITEMKEY (CADDR R)) (* ; "eg. 29271")
(SETQ TITLE (CADDDR R)) (* ; "eg. %"FOO%"")
(SETQ ITEM (create TABLEITEM))
(SETQ RSTREAM (OPENTEXTSTREAM))
(TEDIT.INCLUDE (TEXTOBJ RSTREAM)
FSTREAM
(GETFILEPTR FSTREAM)
(FILEPOS (CONCAT (CHARACTER 13)
"*start*")
FSTREAM))
(SETFILEPTR FSTREAM (IPLUS (GETFILEPTR FSTREAM)
8))
(if (AND (ILEQ ITEMKEY 38)
(TIMEREXPIRED? TIMER 'SECONDS))
then
(* ;; " It's a periodic rem. with an expired timer, so we need to find the next future time it will come up so we can add it to CALREMINDERS.")
(SETQ REMDATE (DERIVENEWDATE REMDATE ITEMKEY))
(SETQ TIMER (SETUPTIMER.DATE REMDATE)))
(replace TIDATA of ITEM with (LIST TIMER REMDATE ITEM TITLE RSTREAM ITEMKEY))
[if [AND TIMER (NOT (TIMEREXPIRED? TIMER 'SECONDS]
then
(* ;; "It's a timed reminder. Note that we don't put already expired timers on the list, as might happen when an old file containing timed-keep's is reloaded.")
(if CALREMINDERS
then (MERGE (LIST (LIST TIMER REMDATE ITEM ITEMKEY))
CALREMINDERS T)
else (SETQ CALREMINDERS (LIST (LIST TIMER REMDATE ITEM ITEMKEY]
(SETQ M (LISPDATEMONTH REMDATE))
(SETQ D (LISPDATEDAY REMDATE))
(SETQ YR (LISPDATEYEAR REMDATE))
(* ;; " Stuff it into the hash array:")
(PUTHASH ITEMKEY (SORT (NCONC1 (GETHASH ITEMKEY CALHASH)
ITEM)
'REMINDERTIMELT)
CALHASH)
(* ;; " Also, make a hash bin for all the reminders in this file.:")
(PUTHASH FILEKEY (NCONC1 (GETHASH FILEKEY CALHASH)
ITEM)
CALHASH)
(add R# 1)
(if (EQ (REMAINDER R# 5)
0)
then (PRINTOUT PROMPTWINDOW R# ",")))
(CLOSEF FSTREAM)
(SETQ CALREMSLOADED T)
(OR (EQ (REMAINDER R# 5)
0)
(printout PROMPTWINDOW R# ","))
(PRINTOUT PROMPTWINDOW " done.")
(CURSOR T)
(RETURN T])
(CALMAKEKEY
[LAMBDA (M D YR) (* MJD "20-Nov-86 15:48")
(BLOCK)
(LOGOR (LLSH M 12)
(LLSH D 7)
(IDIFFERENCE YR 1900])
(CALMONTHBEF
[LAMBDA (CALMONTHWINDOW) (* MJD " 2-Dec-87 12:27")
(PROG (CALMONTHSTREAM FILE)
(SETQ CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP))
(if [AND (MOUSESTATE MIDDLE)
(NOT (INSIDEP (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH)
(WINDOWPROP CALMONTHWINDOW 'HEIGHT))
(LASTMOUSEX CALMONTHSTREAM)
(LASTMOUSEY CALMONTHSTREAM]
then (SETQ FILE (MENU (create MENU
ITEMS ← (APPEND CALFILELST (LIST 'Other))
TITLE ← "Load file:")))
(if (EQ FILE 'Other)
then (SETQ FILE (PROMPTFORWORD "File name:" NIL NIL PROMPTWINDOW)))
(if FILE
then (CALLOADFILE FILE)
else (PRINTOUT PROMPTWINDOW T "No file given."))
else (MENUBUTTONFN CALMONTHWINDOW])
(CALMONTHICONFN
[LAMBDA (W ICON) (* MJD "17-Jun-87 15:47")
(if ICON
then [ICONW.TITLE ICON (MONTHNAME (WINDOWPROP W 'MONTH#]
ICON
else [SETQ CALMONTHICON (create TITLEDICON
ICON ← CALMONTHICONMAP
TITLEREG ← '(3 51 56 9]
(TITLEDICONW CALMONTHICON (MONTHNAME (WINDOWPROP W 'MONTH#))
LITTLEFONT])
(CALMONTHRBF
[LAMBDA (CALMONTHWINDOW) (* MJD "17-Nov-87 16:53")
(* ;; "User clicked in a month window. If inside menu area with left, pass on to menu. If inside menu area with right, extend a selection. If outside menu area, do standard window menu.")
(PROG [(CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP]
(if (INSIDEP [MENUREGION (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
(LASTMOUSEX CALMONTHSTREAM)
(LASTMOUSEY CALMONTHSTREAM))
then (if (MOUSESTATE LEFT)
then (MENUBUTTONFN CALMONTHWINDOW)
else (CALEXTENDSEL CALMONTHWINDOW))
else (DOWINDOWCOM CALMONTHWINDOW])
(CALOPTIONMENU
[LAMBDA NIL (* ; "Edited 5-Nov-87 16:58 by MJD")
(if (EQ MAKESYSNAME 'KOTO)
then (SETQ CALOPTIONWINDOW (FM.FORMATMENU CALOPTIONSDESC))
(FM.CHANGELABEL (FM.ITEMFROMID CALOPTIONWINDOW 'CALDEFAULTHOST&DIR)
CALOPTIONWINDOW CALDEFAULTHOST&DIR)
(FM.CHANGELABEL (FM.ITEMFROMID CALOPTIONWINDOW 'CALDEFAULTALERTDELTA)
CALOPTIONWINDOW CALDEFAULTALERTDELTA)
(FM.CHANGESTATE (FMNWAYITEM CALOPTIONWINDOW 'CALALERTFLG (YNCONVERT CALALERTFLG))
CALOPTIONWINDOW)
(FM.CHANGESTATE (FMNWAYITEM CALOPTIONWINDOW 'CALKEEPEXPIREDREMSFLG (YNCONVERT
CALKEEPEXPIREDREMSFLG
))
CALOPTIONWINDOW)
(FM.CHANGESTATE (FM.ITEMFROMID CALOPTIONWINDOW CALUPDATEONSHRINKFLG)
CALOPTIONWINDOW)
(MOVEW CALOPTIONWINDOW LASTMOUSEX LASTMOUSEY)
(OPENW CALOPTIONWINDOW)
else (SETQ CALOPTIONWINDOW (FREEMENU CALOPTIONSDESCLYRIC "Calendar Options"))
(FM.CHANGELABEL (FM.GETITEM 'CALDEFAULTHOST&DIR NIL CALOPTIONWINDOW)
CALDEFAULTHOST&DIR CALOPTIONWINDOW)
(FM.CHANGELABEL (FM.GETITEM 'CALDEFAULTALERTDELTA NIL CALOPTIONWINDOW)
CALDEFAULTALERTDELTA CALOPTIONWINDOW)
(FM.CHANGESTATE 'CALALERTFLG (FM.GETITEM (YNCONVERT CALALERTFLG)
'ALERTGROUP CALOPTIONWINDOW)
CALOPTIONWINDOW)
(FM.CHANGESTATE 'CALKEEPEXPIREDREMSFLG (FM.GETITEM (YNCONVERT CALKEEPEXPIREDREMSFLG)
'XGROUP CALOPTIONWINDOW)
CALOPTIONWINDOW)
(FM.CHANGESTATE 'CALUPDATEONSHRINKFLG (FM.GETITEM CALUPDATEONSHRINKFLG 'UPGROUP
CALOPTIONWINDOW)
CALOPTIONWINDOW)
(MOVEW CALOPTIONWINDOW LASTMOUSEX LASTMOUSEY)
(OPENW CALOPTIONWINDOW])
(CALPRINTREM
[LAMBDA (B ITEM STREAM) (* MJD " 7-Oct-87 13:52")
(* ;
"Prints reminder in day box of month window. Caller must set x,y position in STREAM first.")
(PROG (REMINDER (XOFFSET 0))
(SETQ REMINDER (fetch TIDATA of ITEM))
(if (EQ (TYPENAME REMINDER)
'TABLEITEM)
then (SETQ REMINDER (fetch TIDATA of REMINDER)))
(if (TIMEDREMP REMINDER)
then (PRIN1 (REMINDERTIME REMINDER)
STREAM)
(SPACES 1 STREAM)
(if (NEQ (IMAGESTREAMTYPE STREAM)
'DISPLAY)
then (SETQ XOFFSET -10)))
(* ;; "This kludge is required because IP streams currently do not support clipping regions (SHOWREMSINMONTH sets the clipping region that limits the line length automatically):")
(PRIN1 (if (EQ (IMAGESTREAMTYPE STREAM)
'DISPLAY)
then (CALREMDEF REMINDER)
else (OR (SUBSTRING (CALREMDEF REMINDER)
1
(IPLUS 26 XOFFSET))
(CALREMDEF REMINDER)))
STREAM) (* ;
" The OR above hinges on the fact that SUBSTRING returns NIL if its arg is too big.")
(TERPRI STREAM])
(CALREMDEF
[LAMBDA (REMINDER) (* MJD " 5-Jun-87 12:48")
(* Return reminder message title text.)
(CAR (NTH REMINDER 4])
(CALTBCLOSEFN
[LAMBDA (BROWSER W TYPE) (* MJD "16-Nov-87 12:50")
(* ;
"Before closing a day browser, remove it from the list of active browsers.")
(if (EQ TYPE 'CLOSE)
then (SETQ CALDAYBROWSERS (REMOVE BROWSER CALDAYBROWSERS)))
NIL])
(CALTBNULLFN
[LAMBDA (BROWSER) (* MJD "22-Jun-87 14:49")
(PRINTOUT (GETPROMPTWINDOW (TB.WINDOW BROWSER)
1)
T "No reminders selected."])
(CALTEDITEXIT
[LAMBDA (ITEM MNAME BUTTON) (* MJD "17-Jun-87 12:38")
(COND
((EQ ITEM 'Save)
(TEDIT.QUIT (TEXTSTREAM CALTEDITWINDOW)))
((EQ ITEM 'Abort)
(TEDIT.QUIT (TEXTSTREAM CALTEDITWINDOW)
'Abort])
(CALTEDITSTRING
[LAMBDA (STRING) (* MJD " 8-Dec-87 13:00")
(* T.Bigham "12-Nov-84 11:03")
(* ;; "this may not be needed in Carol. In harmony, this makes tedit put the value into the item editor without the confirmation that always pops up when changes have been made without saving the file.")
(PROG (STREAM)
(if (NOT (WINDOWP CALTEDITWINDOW))
then (SETQ CALTEDITWINDOW (CREATEW '(400 400 400 300) "Calendar message editor" NIL T))
(ATTACHMENU (create MENU
ITEMS ← '(Save Abort)
ITEMWIDTH ← 199
CENTERFLG ← T
MENUROWS ← 1
MENUFONT ← (FONTCREATE 'HELVETICA 12 'BOLD)
MENUBORDERSIZE ← 1
WHENSELECTEDFN ← 'CALTEDITEXIT)
CALTEDITWINDOW
'TOP
'LEFT))
(RETURN (EVAL.IN.TTY.PROCESS `(PROGN [SETQ STREAM (OPENTEXTSTREAM
(OR %, STRING (CONCAT
"Title: >>One line<<"
(CHARACTER 13)
"Event time: >>Time<<"
(CHARACTER 13)
"Alert time: >>Time<<"
(CHARACTER 9)
"Alert: >>Yes No<<"
(CHARACTER 13)
"Duration: >>hh:mm<<"
(CHARACTER 13)
"Message: >>Any text<<"
))
NIL NIL NIL '(QUITFN T]
(TEDIT.SETSEL STREAM 8 12 NIL T)
(SPAWN.MOUSE)
[SETQ RESULT (TEDIT STREAM CALTEDITWINDOW T
'(QUITFN T]
(IF (EQ RESULT 'Abort)
THEN NIL
ELSE STREAM)) T])
(CALUPDATEFILE
[LAMBDA (FILE) (* MJD "19-Nov-87 13:10")
(* ;; "Each reminder on the file has the form:")
(* ;; " (timer-value date-string hash-key title-string) TEdit-stream <CR> *start*.")
(* ;; " File updates work like this: The file to be updated will contain all still valid reminders that were on it when it was loaded (this info. was cached in the hash array under the file name when it was loaded), plus any new reminders that have not yet been saved (this comes from CALDIRTYREMLST).")
(PROG (FSTREAM RDATA REMLIST (R# 0))
(OBTAIN.MONITORLOCK CALMONLOCK)
(WITH.MONITOR
CALMONLOCK
[OUTPUT (SETQ FSTREAM (OPENSTREAM FILE 'OUTPUT 'OLD/NEW]
(printout PROMPTWINDOW T "Updating reminder file " FILE "...")
(* ;; " A list of all the reminders that were in this file when it was loaded (or NIL if this is a new file to be written):")
(SETQ REMLIST (GETHASH (STRINGHASHBITS (MKSTRING FILE))
CALHASH))
(PRINT (LIST '$$CALREMINDERS CALENDARVERSION)
FSTREAM)
(* ;; "The hash array contains both lists of items and items in files.")
[MAPHASH
CALHASH
(FUNCTION (LAMBDA (VLIST KEY)
(* ;; " This is ugly, but we need the key of each item being written - it's the only way to tell if it's periodic. We sweep through the entire hash array, skipping the one entry that contains REMLIST, looking for items that are on REMLIST. This test isn't done when creating a new file from scratch. In this case, there are no previously loaded rems., and so REMLIST is NIL.")
(if (NEQ (CAR VLIST)
'FILEKEY)
then
(for VAL in VLIST when (OR (MEMBER VAL REMLIST)
(MEMBER VAL CALDIRTYREMLST))
do (SETQ RDATA (fetch TIDATA of VAL))
(* ;;
" Now put out the timer (CAR), the date-string (CADR), the hash key (KEY), and the title (CADDDR):")
(PRINT (LIST (CAR RDATA)
(CADR RDATA)
KEY
(CADDDR RDATA))
FSTREAM)
(* ;; "Finally, write the reminder text:")
(if [STREAMP (CAR (LAST (fetch TIDATA of VAL]
then (COPYCHARS (OPENSTREAM (COERCETEXTOBJ
(CAR (LAST (fetch TIDATA
of VAL)))
'FILE)
'INPUT)
FSTREAM))
(TERPRI FSTREAM)
(PRINT '*start* FSTREAM)
(add R# 1)
(if (EQ (REMAINDER R# 5)
0)
then (PRINTOUT PROMPTWINDOW R# ","]
(PRINT 'STOP FSTREAM)
(CLOSEF FSTREAM)
(SETQ CALDIRTYREMLST NIL)
(SETQ CALREMSLOADED T)
(OR (EQ (REMAINDER R# 5)
0)
(printout PROMPTWINDOW R# ","))
(printout PROMPTWINDOW " done."))
(RELEASE.MONITORLOCK CALMONLOCK])
(CALUPDATEINIT
[LAMBDA NIL (* MJD " 3-Dec-87 17:01")
(PROG (FILE)
(SETQ FILE (MENU (create MENU
ITEMS ← (APPEND CALFILELST (LIST 'Other 'Abort))
TITLE ← "File to update:")))
(if (EQ FILE 'Abort)
then (PRINTOUT PROMPTWINDOW T "Update aborted.")
(RETURN NIL))
[if (EQ FILE 'Other)
then (SETQ FILE (PROMPTFORWORD "File name:" NIL NIL PROMPTWINDOW))
(if (NOT FILE)
then (PRINTOUT PROMPTWINDOW T "No file given - update aborted.")
(RETURN NIL))
(* ;; " Now see if he typed in a full file name. If not, make it one, using the value of CALDEFAULTHOST&DIR:")
(if (NOT (MEMBER 'HOST (UNPACKFILENAME FILE)))
then (SETQ FILE (PACKFILENAME 'NAME FILE 'DIRECTORY
(OR CALDEFAULTHOST&DIR
(SETQ CALDEFAULTHOST&DIR
(PROMPTFORWORD
"Please enter a host & directory for the reminders file:"
NIL NIL PROMPTWINDOW NIL NIL (CHARCODE
EOL]
(pushnew CALFILELST FILE)
(if (AND (NOT (GETHASH (STRINGHASHBITS (MKSTRING FILE))
CALHASH))
(INFILEP FILE))
then (if (MOUSECONFIRM (CONCAT FILE
" already exists but hasn't been loaded into this Caslendar yet."
" Should I overwrite it?"))
then (CALUPDATEFILE FILE)
else (PRINTOUT PROMPTWINDOW T "File not updated.")
(RETURN NIL))
else (CALUPDATEFILE FILE])
(CALYEARICONFN
[LAMBDA (W ICON) (* MJD "22-Jun-87 14:40")
(if ICON
then [ICONW.TITLE ICON (MONTHNAME (WINDOWPROP W 'YEAR#]
ICON
else [SETQ CALYEARICON (create TITLEDICON
ICON ← CALYEARICONMAP
TITLEREG ← '(6 26 50 9]
(TITLEDICONW CALYEARICON (WINDOWPROP W 'YEAR#)
LITTLEFONT])
(CALYEARINRANGE
[LAMBDA (YR) (* MJD " 7-Jan-86 12:33"
"Actual range is 3/1/1700 - 2/28/2100")
(AND YR (ILESSP YR 2100)
(IGREATERP YR 1700])
(CIRCLETODAY
[LAMBDA (CALMONTHWINDOW) (* MJD "18-Nov-87 14:03")
(* ;; "Put a circle around today. Only do this if: 1: the current month is this month, 2: the current year is this year (don't want circle around 3/12/87 if it's 3/12/86), and 3: today is different from the day already circled.")
(PROG ([CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
(CENTERFACTOR 0.62)
RADIUS DAYREGION)
(OR CALHILITETODAY (RETURN NIL)) (* ; " Don't if not wanted.")
(COND
([AND (NEQ CALCIRCLEDAY (LISPDATEDAY (DATE)))
(EQ (WINDOWPROP CALMONTHWINDOW 'MONTH#)
(LISPDATEMONTH (DATE)))
(EQ (WINDOWPROP CALMONTHWINDOW 'YEAR#)
(LISPDATEYEAR (DATE]
(TOTOPW CALMONTHWINDOW T)
(SETQ DAYREGION (MDMENUITEMREGION CALCIRCLEDAY CALMONTHMENU))
(DSPOPERATION 'INVERT CALMONTHWINDOW) (* ; "Erase the old circle, if any")
[AND CALCIRCLEDAY (EQ CALCIRCLEMONTH (LISPDATEMONTH (DATE)))
(SETQ RADIUS (TIMES (MAXMENUITEMWIDTH CALMONTHMENU)
CENTERFACTOR))
(COND
((EQ CALHILITETODAY 'CIRCLE)
(DRAWCIRCLE (IPLUS (CAR DAYREGION)
RADIUS)
(IPLUS (CADR DAYREGION)
RADIUS)
RADIUS 1 NIL CALMONTHWINDOW))
((EQ CALHILITETODAY 'BOX)
(BITBLT NIL 0 0 CALMONTHWINDOW (CAR DAYREGION)
(CADR DAYREGION)
(MAXMENUITEMWIDTH CALMONTHMENU)
(MAXMENUITEMHEIGHT CALMONTHMENU)
'TEXTURE NIL 32800]
(* ;; "Then reset the circle to today, and draw a new circle:")
(SETQ CALCIRCLEDAY (LISPDATEDAY (DATE)))
(SETQ RADIUS (TIMES (MAXMENUITEMWIDTH CALMONTHMENU)
CENTERFACTOR)) (* ; " Figure out the new location:")
(SETQ DAYREGION (MDMENUITEMREGION CALCIRCLEDAY CALMONTHMENU))
(COND
((EQ CALHILITETODAY 'CIRCLE)
(DRAWCIRCLE (IPLUS (CAR DAYREGION)
RADIUS)
(IPLUS (CADR DAYREGION)
RADIUS)
RADIUS 1 NIL CALMONTHWINDOW))
((EQ CALHILITETODAY 'BOX)
(BITBLT NIL 0 0 CALMONTHWINDOW (CAR DAYREGION)
(CADR DAYREGION)
(PLUS (MAXMENUITEMWIDTH CALMONTHMENU)
4)
(PLUS (MAXMENUITEMHEIGHT CALMONTHMENU)
4)
'TEXTURE NIL 32800)))
(DSPOPERATION 'REPLACE CALMONTHWINDOW)
(SETQ CALCIRCLEMONTH (LISPDATEMONTH (DATE])
(CLEARDAY
[LAMBDA (D CALMONTHWINDOW CALMONTHMENU) (* MJD "19-Nov-87 16:10")
(* ;
"Erase the contents of this day box so it can be rewritten.")
(PROG ((DAYREGION (MDMENUITEMREGION D CALMONTHMENU)))
(* ;; "Fool CIRCLETODAY into erasing the circle before clearing the box. Then we'll be OK when we redraw the circle. We have to do this since the circle overlaps into the text area and its top part would get lopped off otherwise.")
(if (EQ D CALCIRCLEDAY)
then (SETQ CALCIRCLEDAY NIL)
(CIRCLETODAY CALMONTHWINDOW))
(BITBLT NIL NIL NIL CALMONTHWINDOW (CAR DAYREGION)
(IPLUS (CADR DAYREGION)
(TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
0.053))
(CADDR DAYREGION)
(TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
0.08714)
'TEXTURE
'ERASE BLACKSHADE)
(if (EQ D CALCIRCLEDAY)
then (SETQ CALCIRCLEDAY NIL)
(CIRCLETODAY CALMONTHWINDOW])
(CLOSEMONTH
[LAMBDA (W) (* MJD " 1-Dec-87 17:29")
(PROG [(M (WINDOWPROP W 'MONTH#))
(YR (WINDOWPROP W 'YEAR#]
[AND (NEQ CALUPDATEONSHRINKFLG 'Never)
CALNEEDSUPDATE
(ADD.PROCESS '(CALUPDATEINIT]
(SETQ CALMONTHLST (REMOVE W CALMONTHLST))
(for B in CALDAYBROWSERS when [AND (EQ M (CAR (TB.USERDATA B)))
(EQ YR (CADDR (TB.USERDATA B]
do (CLOSEW (TB.WINDOW B])
(DAYABBR
[LAMBDA (D SCALE) (* MJD " 7-Aug-87 14:15")
(if (GEQ SCALE 0.2)
then (CAR (NTH '(Sun Mon Tue Wed Thu Fri Sat % ) (ADD1 D)))
else (CAR (NTH '(S M T W T F S % ) (ADD1 D])
(DAYNAME
[LAMBDA (D) (* MD " 2-Feb-84 17:15")
(CAR (NTH '(Sunday Monday Tuesday Wednesday Thursday Friday Saturday % ) (ADD1 D])
(DAYOF
[LAMBDA (M D Y) (* MD " 2-Feb-84 15:39")
(PROG (N)
(SETQ N (FQUOTIENT (IDIFFERENCE (IPLUS [FIX (FTIMES 365.25 (COND
((IGREATERP M 2)
Y)
(T (SUB1 Y]
[FIX (FTIMES 30.6 (COND
((IGREATERP M 2)
(ADD1 M))
(T (IPLUS M 13]
D)
621049)
7))
(RETURN (FIX (FPLUS (FTIMES (FDIFFERENCE N (FIX N))
7)
0.5])
(DAYPLUS
[LAMBDA (M D YR N) (* MJD "23-Jun-87 16:28")
(if (ILEQ (IPLUS D N)
(DAYSIN M))
then (IPLUS D N)
else (IDIFFERENCE N (IDIFFERENCE (DAYSIN M)
D])
(DAYSIN
[LAMBDA (M Y) (* MD " 2-Feb-84 17:03")
(COND
((EQ M 2)
(COND
((EQ (IREMAINDER Y 4)
0)
29)
(T 28)))
(T (CAR (NTH '(31 NIL 31 30 31 30 31 31 30 31 30 31) M])
(DERIVENEWDATE
[LAMBDA (DSTRING ITEMKEY) (* MJD " 9-Oct-87 12:03")
(* ;; " Takea a date string for some expired periodic reminder nad returns a new date representing the next scheduled firing time for the reminder. ITEMKEY is the rem's. hash key. This is used to tell what kind of periodic rem. it is.")
(PROG (M D YR DNEW NEWDATESTR)
(SETQ M (LISPDATEMONTH DSTRING))
(SETQ D (LISPDATEDAY DSTRING))
(SETQ YR (LISPDATEYEAR DSTRING))
(* ;; "Start incrementing the day, month, or year, as appropriate until we create some date in the future from now:")
(repeatwhile (LESSP (IDATE NEWDATESTR)
(IDATE (DATE))) do (COND
((EQ ITEMKEY 0)
(SETQ D (DAYPLUS M D YR 1)))
((ILESSP ITEMKEY 32)
(SETQ M (MONTHPLUS M 1)))
((GEQ ITEMKEY 32)
(SETQ DNEW (DAYPLUS M D YR 7))
(SETQ M (MONTHOFDAYPLUS M D YR 7))
(SETQ D DNEW)))
(SETQ NEWDATESTR (PACKDATE (GDATE (IDATE DSTRING)
(DATEFORMAT
NO.DATE))
M D YR)))
(RETURN NEWDATESTR])
(DOREMINDER
[LAMBDA (REM) (* MJD " 9-Dec-87 10:38")
(PROG (RSTREAM RDATESTR MSG MSTARTPOS MSGTEXT ITEM ITEMKEY DNEW R NEWTIMER REMDATE)
(* ;; "Sometimes a machine boots with no time set, which makes the time be '31-Dec-00' causing all pending reminders to fire at once. This prevents that.")
(if (LESSP (IDATE)
(IDATE "31-Dec-86 00:00"))
then (RETURN NIL))
(pop CALREMINDERS) (* ;
"Get rid of it before CALENDARWATCHER sees it again")
(* ;; "REM is an instance of what goes on CALREMINDERS, ie. (timer-integer date-string tableitem-obj). The tableitem-obj has the form (timer-integer date-string tableitem-obj title-string text-stream hashkey). Hashkey is present only if this is a periodic reminder (we need it to figure out when the next firing time will be).")
(SETQ RSTREAM (CAR (NTH (GETREMDEF (CAR (NTH REM 3)))
5)))
(SETQ RDATESTR (CADR REM))
[if (LISTP RSTREAM)
then (EVAL RSTREAM)
else (SETQ MSG (COERCETEXTOBJ RSTREAM 'STRINGP))
(SETQ MSTARTPOS (IPLUS (STRPOS (CONCAT (CHARACTER 13)
"Message: ")
MSG)
9))
(SETFILEPTR RSTREAM MSTARTPOS)
(SETQ MSGTEXT (READ RSTREAM))
(if (LISTP MSGTEXT)
then (EVAL MSGTEXT)
else (PLAYTUNE CALTUNE)
(if (EQ CALFLASHTYPE 'SCREEN)
then (FLASHWINDOW NIL CALFLASHTIMES))
(TEDIT RSTREAM (PROG1 (CREATEW CALREMDISPLAYREGION "Reminder Display Window")
(if (EQ CALFLASHTYPE 'WINDOW)
then (FLASHWINDOW RSTREAM CALFLASHTIMES)))
NIL
'(QUITFN T LEAVETTY T] (* ;
"Let's see if this one is periodic:")
(SETQ ITEM (CAR (NTH REM 3)))
(SETQ ITEMKEY (CAR (NTH (GETREMDEF (CAR (NTH REM 3)))
6)))
[if (AND ITEMKEY (ILEQ ITEMKEY 38))
then (* ;
"Yup, so figure out its next scheduled firing time and put it back on CALREMINDERS")
(SETQ REMDATE (DERIVENEWDATE RDATESTR ITEMKEY))
(SETQ NEWTIMER (SETUPTIMER.DATE REMDATE))
(SETQ R (LIST NEWTIMER REMDATE ITEM))
(if CALREMINDERS
then (MERGE (LIST R)
CALREMINDERS T)
else (SETQ CALREMINDERS (LIST R]
(if (NOT CALKEEPEXPIREDREMSFLG)
then (CALDELETEREM NIL REM])
(FMNWAYITEM
[LAMBDA (W ID LABEL) (* MJD "22-Jul-87 12:01")
(for I in (WINDOWPROP W 'FM.ITEMS) thereis (AND (EQ (FM.ITEMPROP I 'ID)
ID)
(EQ (FM.ITEMPROP I 'LABEL)
LABEL])
(GETREMDEF
[LAMBDA (ITEM) (* MJD "21-May-87 16:49")
(if (EQ (TYPENAME (fetch TIDATA of ITEM))
'TABLEITEM)
then (fetch TIDATA of (fetch TIDATA of ITEM))
else (fetch TIDATA of ITEM])
(INVERTGROUP
[LAMBDA (M1 D1 YR1 M2 D2 YR2 SHADE CALMONTHMENU) (* MJD " 9-Dec-87 10:54")
(AND D2 (for D from D1 to D2 do (SHADEITEM (MENUITEM D CALMONTHMENU)
CALMONTHMENU SHADE])
(LISPDATEDAY
[LAMBDA (LD) (* MJD "10-Jul-86 12:54")
(SUBATOM LD (COND
((STREQUAL (SUBSTRING LD 1 1)
" ")
2)
(T 1))
2])
(LISPDATEMONTH
[LAMBDA (LD) (* MD "14-Feb-84 15:56")
(MONTHNUM (SUBATOM LD 4 6])
(LISPDATEYEAR
[LAMBDA (LD) (* MJD "24-Jun-87 10:55")
(* Returns the year of a date in Lisp date format.
eg.%: "26-Nov-86 15:30:00")
(if (EQ (SUBATOM LD 10 10)
'% )
then (IPLUS 1900 (SUBATOM LD 8 9))
else (SUBATOM LD 8 11])
(MDMENUITEMREGION
[LAMBDA (ITEM MNAME SCALE) (* MJD "12-Feb-86 16:00")
(for I in (fetch ITEMS of MNAME) until (EQ ITEM (CAR I)) do NIL
finally (RETURN (if SCALE
then (for J in (MENUITEMREGION I MNAME) collect (TIMES J SCALE))
else (MENUITEMREGION I MNAME])
(MENUITEM
[LAMBDA (ITEM MNAME) (* MJD "25-Jun-86 12:03")
(for I in (fetch ITEMS of MNAME) thereis (EQ ITEM (CAR I])
(MENUREGIONITEM
[LAMBDA (W MNAME) (* MJD "22-May-87 13:44")
(GETMOUSESTATE)
(for I in (fetch ITEMS of MNAME) thereis (INSIDEP (MENUITEMREGION I MNAME)
(LASTMOUSEX W)
(LASTMOUSEY W])
(MONTHABBR
[LAMBDA (M) (* MD "15-Feb-84 12:19")
(CAR (NTH '(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) M])
(MONTHNAME
[LAMBDA (M) (* MJD "13-Nov-87 12:52")
(CAR (NTH '(% January February | March| | April| | May| | June| | July| | August|
September % October November December) M])
(MONTHNUM
[LAMBDA (MNAME) (* MD "14-Feb-84 16:01")
(LISTGET '(Jan 1 Feb 2 Mar 3 Apr 4 May 5 Jun 6 Jul 7 Aug 8 Sep 9 Oct 10 Nov 11 Dec 12) MNAME])
(MONTHOFDAYPLUS
[LAMBDA (M D YR N) (* MJD "23-Jun-87 16:27")
(if (ILEQ (DAYPLUS M D YR N)
D)
then (MONTHPLUS M 1)
else M])
(MONTHPLUS
[LAMBDA (M N) (* MD "19-Oct-84 13:57")
(COND
((ILEQ (IPLUS M N)
0)
(IPLUS M N 12))
((AND (EQ M 12)
(IGREATERP N 0))
1)
(T (IREMAINDER (IPLUS M N)
13])
(MONTHYEARPLUS
[LAMBDA (M YR N) (* MD " 5-Nov-84 14:48")
(IPLUS YR (IQUOTIENT (IPLUS M N)
13)
(if (ILEQ (IPLUS M N)
0)
then -1
else 0])
(NEWPARSETIME
[LAMBDA (TSTRING) (* MJD " 9-Dec-87 11:07")
(* ;;; " This function converts the string TSTRING into an atom doing all the error checking to insure the time is valid. An a.m. or p.m. specifier is allowed as well as time in the 12 or 24 hour format. If the 12 hour format is allowed then the routine tries to deduce what the user meant. The global variable CALDAYSTART is an atom which represents the time that the user's day starts. Typically CALDAYSTART might be set to 900. The user's day when goes from 9:00 am to 8:59 pm. If TSTRING is 1:00 then this means 1:00 p.m. or 13:00. If TSTRING is 9:00 this translates to 9;00 am. If TSTRING is 8:00 this translates to 8:00 pm or 20:00")
(LET* ([TempCleanedString (PACK (LDIFFERENCE (UNPACK TSTRING)
'(%. %: - % A P M a p m]
(CleanedString (if (AND (NOT (STRPOS "." TSTRING 1))
(NOT (STRPOS ":" TSTRING 1))
(NOT (STRPOS "-" TSTRING 1))
(NUMBERP TempCleanedString)
(IGEQ TempCleanedString 0)
(ILEQ TempCleanedString 23))
then
(* ;; "handle the cases where the user says n meaning n:00")
(TIMES TempCleanedString 100)
else TempCleanedString))
(TwelveHours 1200)
(TwentyFourHours (TIMES 2 TwelveHours))
Start End Time NewTime AMBIGUOUSTIMEFLG)
(if (NULL TSTRING)
then 0
elseif (NOT (NUMBERP CleanedString))
then NIL
else (if (OR (STRPOS "A" TSTRING 1)
(STRPOS "a" TSTRING 1))
then
(* ;; "am specified")
(if (AND (IGEQ CleanedString 0)
(ILEQ CleanedString 1200))
then CleanedString
else (printout PROMPTWINDOW
" - time greater than 12:00 plus am doesn't make sense")
NIL)
elseif (OR (STRPOS "P" TSTRING 1)
(STRPOS "p" TSTRING 1))
then
(* ;; "pm specified")
(if (AND (IGEQ CleanedString 0)
(ILEQ CleanedString 1200))
then (IPLUS CleanedString 1200)
elseif (AND (IGREATERP CleanedString 1200)
(ILEQ CleanedString 2400))
then CleanedString
else (printout PROMPTWINDOW
" - time greater than 23:59 doesn't make sense")
NIL)
elseif (AND (IGREATERP CleanedString 1259)
(ILEQ CleanedString 2359))
then
(* ;; "In 24 hour mode between 12:59 and 23:59")
CleanedString
elseif (IGEQ CleanedString 2400)
then
(* ;; " time greater than 23:59")
(printout PROMPTWINDOW " - time greater than 23:59 doesn't make sense")
NIL
else (* ambiguous time)
(SETQ AMBIGUOUSTIMEFLG T)
(if (OR (NOT (SMALLP CALDAYSTART))
(ILESSP CALDAYSTART 0)
(IGREATERP CALDAYSTART 2359))
then (printout PROMPTWINDOW "- invalid variable CALDAYSTART " CALDAYSTART
T)
NIL
else (SETQ Time CleanedString)
(SETQ Start CALDAYSTART)
(if (EQ Start TwelveHours)
then (* Special case when we are starting
at 12%:00)
(SETQ End TwentyFourHours)
else (SETQ End (IMOD (IPLUS Start TwelveHours)
TwentyFourHours)))
(SETQ NewTime (IMOD (IPLUS Time TwelveHours)
TwentyFourHours))
(if (GREATERP Start TwelveHours)
then (if (OR (IGEQ NewTime Start)
(ILESSP NewTime End))
then (* the time is the new time)
else (SETQ NewTime Time))
else (if (AND (IGEQ NewTime Start)
(ILESSP NewTime End))
then (* the time is the new time)
else (SETQ NewTime Time)))
NewTime])
(NEXTMDISPLAYREGION
[LAMBDA (W H) (* MJD " 2-Dec-87 10:34")
(* ; " Handles tiling of month windows given the locaiton of the previous one (in CALMONTHLST) if any. Otherwise use defaults.")
(PROG (REG WWIDTH WHEIGHT WXLOC WYLOC)
(SETQ REG (if CALMONTHLST
then (WINDOWPROP (CAR CALMONTHLST)
'REGION)
else CALMONTHDEFAULTREGION))
(* ;; " If the month we're keying off is shrunken, find the position of the window itself, not the icon. If this isn't the case, we've got the xloc in REG:")
(SETQ WXLOC (if (AND CALMONTHLST (WINDOWPROP (CAR CALMONTHLST)
'ICONFOR))
then (CAR (WINDOWPROP (WINDOWPROP (CAR CALMONTHLST)
'ICONFOR)
'REGION))
else (CAR REG)))
(SETQ WYLOC (if (AND CALMONTHLST (WINDOWPROP (CAR CALMONTHLST)
'ICONFOR))
then (CADR (WINDOWPROP (WINDOWPROP (CAR CALMONTHLST)
'ICONFOR)
'REGION))
else (CADR REG)))
(SETQ WWIDTH (CADDR REG))
(SETQ WHEIGHT (CADDDR REG))
(RETURN (LIST (if (AND CALMONTHLST (IGREATERP (IPLUS WXLOC WWIDTH W)
SCREENWIDTH))
then (CAR CALMONTHDEFAULTREGION)
else (if (AND CALMONTHLST (ILEQ (IPLUS WXLOC WWIDTH W)
SCREENWIDTH))
then (IPLUS WXLOC WWIDTH 1)
else (CAR CALMONTHDEFAULTREGION)))
(if (IGREATERP (IPLUS WXLOC WWIDTH W)
SCREENWIDTH)
then (if (IGREATERP (IPLUS WYLOC WHEIGHT H)
SCREENHEIGHT)
then (CADR CALMONTHDEFAULTREGION)
else (IPLUS WYLOC WHEIGHT 1))
else WYLOC)
W H])
(PACKDATE
[LAMBDA (MTIME M D YR) (* MJD "15-May-87 09:38")
(* Takes a time, M, D, and YR, and packs them into a formatted date which is
returned.)
(* If MTIME = 0, then this is an untimed rem., so store NIL in the time field.)
(CONCAT (if (IGEQ D 10)
then D
else (CONCAT " " D))
"-"
(MONTHABBR M)
"-"
(if (IGREATERP YR 1999)
then YR
else (IDIFFERENCE YR 1900))
" "
(if (EQ MTIME 0)
then NIL
else MTIME])
(PARSETIME
[LAMBDA (TSTRING) (* MJD "22-Oct-85 12:06")
(COND
([AND TSTRING
(NOT (NUMBERP (PACK (LDIFFERENCE (UNPACK TSTRING)
'(%. %: - % A P M a p m]
NIL)
[TSTRING (IPLUS (ITIMES [PACK (LDIFFERENCE (UNPACK TSTRING)
'(%. %: - % A P M a p m]
(COND
([OR (AND (NUMBERP (MKATOM TSTRING))
(ILEQ (MKATOM TSTRING)
24))
(AND (NOT (NUMBERP (MKATOM TSTRING)))
(NOT (MEMBER '%: (UNPACK TSTRING]
100)
(T 1)))
(COND
((STRPOS "P" TSTRING 1)
1200)
((STRPOS "p" TSTRING 1)
1200)
(T 0]
(T 0])
(PICKFONTSIZE
[LAMBDA (W H) (* MJD "18-Nov-87 13:21")
(PROG ((KEYSIZE (MIN W H)))
(RETURN (COND
((LEQ KEYSIZE 40)
8)
((LEQ KEYSIZE 50)
10)
((LEQ KEYSIZE 60)
12)
((LEQ KEYSIZE 70)
14)
((LEQ KEYSIZE 80)
18)
((LEQ KEYSIZE 90)
24)
((LEQ KEYSIZE 100)
30)
(T 36])
(POM
[LAMBDA (M D YR) (* MD " 4-Apr-84 13:38")
(PROG [GOLDEN CENTURY GREGCORRECTION CLAVCORRECTION EXTRADAYS EPACT SECSFROMNEWTHISYEAR
SECSTHISMOON DAYINYEAR (SECSPERMIN 60)
SECSPERHR SECSPERDAY SECSPERMOON
(MONTHTABLE '(0 31 60 91 121 152 182 213 244 274 305 335 366]
(SETQ SECSPERHR (ITIMES SECSPERMIN 60))
(SETQ SECSPERDAY (ITIMES SECSPERHR 24))
(SETQ SECSPERMOON (IPLUS (ITIMES SECSPERDAY 29)
(ITIMES SECSPERHR 12)
(ITIMES SECSPERMIN 44)
3))
(SETQ GOLDEN (ADD1 (IREMAINDER YR 19)))
(SETQ CENTURY (ADD1 (IQUOTIENT YR 100)))
(SETQ GREGCORRECTION (IDIFFERENCE (IQUOTIENT (ITIMES 3 CENTURY)
4)
12))
(SETQ CLAVCORRECTION (IQUOTIENT (IDIFFERENCE (IDIFFERENCE CENTURY 16)
(IQUOTIENT (IDIFFERENCE CENTURY 18)
25))
3))
(SETQ EXTRADAYS (IDIFFERENCE (IDIFFERENCE (IQUOTIENT (ITIMES 5 YR)
4)
GREGCORRECTION)
10))
(SETQ EPACT (ADD1 (IREMAINDER (IPLUS (ITIMES 11 GOLDEN)
19 CLAVCORRECTION (IMINUS GREGCORRECTION))
30)))
(COND
((OR (AND (EQ EPACT 25)
(IGREATERP GOLDEN 11))
(EQ EPACT 24))
(add EPACT 1)))
(SETQ DAYINYEAR (IPLUS (CAR (NTH MONTHTABLE M))
D))
[COND
((IGREATERP M 2)
(COND
((EQ (IREMAINDER YR 4)
0)
(COND
[(NEQ (IREMAINDER YR 100)
0)
(COND
((EQ (IREMAINDER YR 400)
0)
(add DAYINYEAR 1]
(T (add DAYINYEAR 1]
(SETQ SECSFROMNEWTHISYEAR (IPLUS (ITIMES DAYINYEAR SECSPERDAY)
(ITIMES EPACT SECSPERDAY)))
(SETQ SECSTHISMOON (IREMAINDER SECSFROMNEWTHISYEAR SECSPERMOON))
(RETURN (IQUOTIENT SECSTHISMOON (IQUOTIENT SECSPERMOON 8])
(POMDAYS
[LAMBDA (M YR) (* MJD "13-Mar-86 15:47")
(* PLIST is list of phase of each day. Then return list of first days of phases
NM, FQ, Full, LQ in that order.)
(* The COND is complicated because the first phase may be split between the
beginning and end of the month. Since we want the first day of the phase
(which might not be the first time it appears on the list) we have to check for
this.)
(PROG (PLIST)
(SETQ PLIST (for D from 1 to (DAYSIN M YR) collect (POM M D YR)))
(RETURN (for D in '(0 2 4 6)
collect (COND
((EQ D (CAR PLIST))
(if (EQ D (CAR (LAST PLIST)))
then [ADD1 (IDIFFERENCE (DAYSIN M YR)
(COUNT (MEMBER (CAR PLIST)
(NLEFT PLIST 15]
else 1))
(T (ADD1 (IDIFFERENCE (DAYSIN M YR)
(COUNT (MEMBER D PLIST])
(PRINTMONTH
[LAMBDA (W STREAM) (* MJD " 8-Dec-87 13:11")
(PROG [(CALPSCALE 190)
(M (WINDOWPROP W 'MONTH#))
(YR (WINDOWPROP W 'YEAR#]
(IF (NOT (EQ MAKESYSNAME 'KOTO))
THEN (HARDCOPYW W)
(RETURN NIL))
(SETCURSOR WAITINGCURSOR)
(PRINTOUT PROMPTWINDOW T "Formatting for print...")(* ; "SETQ STREAM NIL")
[SETQ CALPRINTSTREAM (OPENIMAGESTREAM (PACKFILENAME 'VERSION NIL 'BODY (FULLNAME STREAM))
'INTERPRESS
'(LANDSCAPE T]
(SETQ STREAM NIL)
[OR PBIGFONT (SETQ PBIGFONT (FONTCREATE 'HELVETICA 14 NIL 0 'INTERPRESS]
[OR PCALFONT (SETQ PCALFONT (FONTCREATE 'TIMESROMAN 24 NIL 0 'INTERPRESS]
[OR PLITTLEFONT (SETQ PLITTLEFONT (FONTCREATE 'HELVETICA 8 NIL 0 'INTERPRESS]
(DSPFONT PCALFONT CALPRINTSTREAM)
[PROG (X Y CT)
(SETQ CT 0)
(DSPRESET CALPRINTSTREAM)
(MOVETO 9500 20400 CALPRINTSTREAM)
(PRIN1 (MONTHNAME M)
CALPRINTSTREAM)
(PRIN1 " " CALPRINTSTREAM) (* ;
"Leaves room for 3-ring binder hole")
(PRIN1 YR CALPRINTSTREAM)
(SETQ X 550)
(SETQ Y 16700)
(for I in (APPEND (for N from 1 to (DAYOF M 1 YR) collect '% )
(for N from 1 to (DAYSIN M YR) collect N))
do (MOVETO X Y CALPRINTSTREAM)
(PRIN1 I CALPRINTSTREAM)
(add X 3750)
(add CT 1)
(COND
((EQ (IREMAINDER CT 7)
0)
(SETQ X 600)
(add Y -3166]
(for X from 300 to 26800 by 3750 do (DRAWLINE X 600 X 19600 40 'PAINT CALPRINTSTREAM))
(* ; "Print vertical lines")
(DSPFONT PBIGFONT CALPRINTSTREAM)
(for X from 800 to 25600 by 3750 as D from 0 to 6 do (MOVETO X 19800 CALPRINTSTREAM)
(PRIN1 (DAYNAME D)
CALPRINTSTREAM))
(* ; "Print day names")
(for Y from 600 to 19600 by 3166 do (DRAWLINE 300 Y 26550 Y 40 'PAINT CALPRINTSTREAM))
(* ; "Print horizontal lines")
(if CALHARDCOPYPOMFLG
then (SHOWMOON M YR 32.0 (CAR (WINDOWPROP W 'MENU))
CALPRINTSTREAM))
(DSPFONT PLITTLEFONT CALPRINTSTREAM)
(SHOWMONTHSMALL (MONTHPLUS M -1)
(MONTHYEARPLUS M YR -1)
19300 950 28.0 CALPRINTSTREAM)
(SHOWMONTHSMALL (MONTHPLUS M 1)
(MONTHYEARPLUS M YR 1)
23100 950 28.0 CALPRINTSTREAM)
(SHOWREMSINMONTH M YR 32.0 W (CAR (WINDOWPROP W 'MENU))
CALPRINTSTREAM)
(CLOSEF CALPRINTSTREAM)
(PRINTOUT PROMPTWINDOW "done." T)
(CURSOR T])
(REMINDERSOF
[LAMBDA (M D YR) (* MJD "23-Jun-87 15:47")
(* This day's reminders are the union of one shot rems.
explicitly stored on this day; weeklies (in the |32-38| range);
monthlies, keyed by D; and dailies, keyed by 0
(always applies))
(APPEND (GETHASH (CALMAKEKEY M D YR)
CALHASH)
(GETHASH (IPLUS (DAYOF M D YR)
32)
CALHASH)
(GETHASH D CALHASH)
(GETHASH 0 CALHASH])
(REMINDERTIME
[LAMBDA (R) (* MJD "15-May-87 11:16")
(if (CAR R)
then (MKATOM (GDATE (IDATE (CADR R))
(DATEFORMAT NO.DATE NO.SECONDS])
(REMINDERTIMELT
[LAMBDA (R1 R2) (* MJD "20-May-87 10:48")
(ILESSP (PARSETIME (REMINDERTIME (fetch TIDATA of R1)))
(PARSETIME (REMINDERTIME (fetch TIDATA of R2])
(REMSINMONTH
[LAMBDA (M YR) (* MJD "16-May-86 11:57")
(for D to (DAYSIN M YR) collect (REMINDERSOF M D YR])
(REPAINTMONTH
[LAMBDA (W REG) (* MJD " 7-Aug-87 13:44")
(DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP W 'WIDTH)
(WINDOWPROP W 'HEIGHT))
(WINDOWPROP W 'DSP))
(SHOWMONTH (LIST W (WINDOWPROP W 'MONTH#)
(WINDOWPROP W 'YEAR#])
(REPAINTYEAR
[LAMBDA (W REG) (* MJD "22-May-87 13:24")
(DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP W 'WIDTH)
(WINDOWPROP W 'HEIGHT))
(WINDOWPROP W 'DSP))
(SHOWYEAR (LIST (WINDOWPROP W 'YEAR#))
NIL NIL W])
(SAMEDAYAS
[LAMBDA (LD M D YR) (* MD "12-Oct-84 14:23")
(COND
((AND (EQ (LISPDATEDAY LD)
D)
(EQ (LISPDATEMONTH LD)
M)
(OR (EQ (LISPDATEYEAR LD)
YR)
(EQ (LISPDATEYEAR LD)
2034)))
T)
(T NIL])
(SAMEMONTHAS
[LAMBDA (LD M YR) (* MD "10-May-85 10:50")
(AND (EQ (LISPDATEMONTH LD)
M)
(OR (EQ (LISPDATEYEAR LD)
YR)
(EQ (LISPDATEYEAR LD)
2034])
(SCALEBITMAP
[LAMBDA (BITMAP FACTOR) (* PmT "18-Mar-85 14:34")
(* SCALES BITMAPS BY AN ARBITRARY AMOUNT OF 2 DECIMAL PLACES.
FACTOR CAN BE OF THE FOLLOWING FORMS%: I
(AN INTEGER REPRESENTING A PERCENTAGE AMOUNT;
E.G. I=67 MEANS REDUCE THE X AND Y AXIS TO 67% OF THEIR ORIGINAL);
R (A REAL; E.G. R=1.3 MEANS INCREASE THE X AND Y AXIS BY A FACTOR OF 1.3);
(IX . IY) (A DOTTED PAIR OF INTEGERS; E.G.
(75 . 125) MEANS REDUCE THE X AXIS TO 75% OF ORIGINAL;
INCREASE Y TO 125% OF ORIGINAL); (RX . RY)
(A DOTTED PAIR OF REALS; E.G. (2.3 . 0.81) MEANS 2.3 TIMES ORIGINAL X AXIS,
0.81 TIMES ORIGINAL Y))
(PROG (XFACTOR YFACTOR DELTAX DELTAY XROUND YROUND BITMAPWIDTH BITMAPHEIGHT HEIGHT-1 RASTERWIDTH
BITMAPBASE NEWBITMAP NEWHEIGHT-1 NEWBITMAPBASE NEWRASTERWIDTH ORIGBASE NEWBASE
ORIGWORD NEWWORD XSTART YSTART ENDX ENDY ONLINE)
(OR (type? BITMAP BITMAP)
(\ILLEGAL.ARG BITMAP))
(SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP))
(SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
(COND
((NUMBERP FACTOR)
(SETQ XFACTOR FACTOR)
(SETQ YFACTOR FACTOR))
((POSITIONP FACTOR)
(SETQ XFACTOR (CAR FACTOR))
(SETQ YFACTOR (CDR FACTOR)))
(T (\ILLEGAL.ARG FACTOR)))
[AND (FLOATP XFACTOR)
(SETQ XFACTOR (FIX (FTIMES XFACTOR 100]
[AND (FLOATP YFACTOR)
(SETQ YFACTOR (FIX (FTIMES YFACTOR 100]
(SETQ XFACTOR (IMIN SCREENWIDTH XFACTOR))
(SETQ YFACTOR (IMIN SCREENHEIGHT YFACTOR))
(COND
((ILESSP XFACTOR 101)
(SETQ DELTAX 100)
(SETQ XROUND (IQUOTIENT XFACTOR 2)))
(T (SETQ DELTAX XFACTOR)
(SETQ XROUND 50)))
(COND
((ILESSP YFACTOR 101)
(SETQ DELTAY 100)
(SETQ YROUND (IQUOTIENT YFACTOR 2)))
(T (SETQ DELTAY YFACTOR)
(SETQ YROUND 50)))
(SETQ NEWBITMAP (BITMAPCREATE (IQUOTIENT (IPLUS XROUND DELTAX (ITIMES (SUB1 BITMAPWIDTH)
XFACTOR))
100)
(IQUOTIENT (IPLUS YROUND DELTAY (ITIMES (SUB1 BITMAPHEIGHT)
YFACTOR))
100)
1)) (* MAKE ALL VALUES QUICKLY AVAILABLE)
(SETQ HEIGHT-1 (SUB1 BITMAPHEIGHT))
(SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
(SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of BITMAP))
(* AND THE NEW BITMAP VALUES)
(SETQ NEWHEIGHT-1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of NEWBITMAP)))
(SETQ NEWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of NEWBITMAP))
(SETQ NEWBITMAPBASE (fetch (BITMAP BITMAPBASE) of NEWBITMAP))
(* OK, CRANK IT OUT)
(* ORIGWORD AND NEWWORD ARE SORTA
CACHED FOR SPEED PURPOSES)
[for Y from 0 to HEIGHT-1
do [SETQ ORIGBASE (\ADDBASE BITMAPBASE (ITIMES RASTERWIDTH (IDIFFERENCE HEIGHT-1 Y]
(SETQ ONLINE NIL)
[for X from 0 to (SUB1 BITMAPWIDTH)
do [AND (ZEROP (IMOD X 16))
(SETQ ORIGWORD (\GETBASE ORIGBASE (LRSH X 4]
(* LOOK FOR STRINGS OF "ON" BITS; THEN TREAT AS A LINE FOR TRANSLATIONAL
PURPOSES)
(COND
[(BITTEST ORIGWORD (\WORDELT BITMASKARRAY (IMOD X 16)))
(OR ONLINE (AND (SETQ ONLINE T)
(SETQ XSTART X)
(SETQ YSTART Y]
((NULL ONLINE) (* JUST SKIP OVER BLANKS)
)
(T
(* SPELL THIS ALL OUT SO I CAN SEE WHAT'S GOIN' ON HERE)
(SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR))
100))
(SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR)
YROUND DELTAY)
100))
(SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR))
100))
(SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 X)
XFACTOR))
100))
(for NY from YSTART to (SUB1 ENDY)
do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE
(\ADDBASE NEWBITMAPBASE
(ITIMES NEWRASTERWIDTH
(IDIFFERENCE NEWHEIGHT-1 NY]
(LRSH XSTART 4)))
(for NX from XSTART to ENDX
do [AND (ZEROP (IMOD NX 16))
(SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4]
[SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY
(IMOD NX 16]
(AND (ZEROP (IMOD (ADD1 NX)
16))
(\PUTBASE NEWBASE (LRSH NX 4)
NEWWORD)))
(\PUTBASE NEWBASE (LRSH ENDX 4)
NEWWORD))
(SETQ ONLINE NIL]
(COND
(ONLINE (* GOTTA CLEANUP AFTER THE LAST CASE)
(* THIS IN CASE WORKING ON A LINE THAT GOES TO END OF BITMAP)
(* GAWD! WHAT A WASTE O SPACE THIS IS. FIX LATER)
(SETQ XSTART (IQUOTIENT (IPLUS XROUND (ITIMES XSTART XFACTOR))
100))
(SETQ ENDY (IQUOTIENT (IPLUS (ITIMES YSTART YFACTOR)
YROUND DELTAY)
100))
(SETQ YSTART (IQUOTIENT (IPLUS YROUND (ITIMES YSTART YFACTOR))
100))
(SETQ ENDX (IQUOTIENT (IPLUS XROUND (ITIMES (SUB1 BITMAPWIDTH)
XFACTOR))
100))
(for NY from YSTART to (SUB1 ENDY)
do (SETQ NEWWORD (\GETBASE [SETQ NEWBASE (\ADDBASE NEWBITMAPBASE
(ITIMES NEWRASTERWIDTH
(IDIFFERENCE
NEWHEIGHT-1 NY]
(LRSH XSTART 4)))
(for NX from XSTART to ENDX
do [AND (ZEROP (IMOD NX 16))
(SETQ NEWWORD (\GETBASE NEWBASE (LRSH NX 4]
[SETQ NEWWORD (LOGOR NEWWORD (\WORDELT BITMASKARRAY
(IMOD NX 16]
(AND (ZEROP (IMOD (ADD1 NX)
16))
(\PUTBASE NEWBASE (LRSH NX 4)
NEWWORD)))
(\PUTBASE NEWBASE (LRSH ENDX 4)
NEWWORD]
(RETURN NEWBITMAP])
(SHOWDAY
[LAMBDA (ITEM MENUNAME BUTTON) (* MJD " 9-Dec-87 11:02")
(PROG ((D (CAR ITEM))
(M (CADR ITEM))
(YR (CADDR ITEM))
[CALMONTHWINDOW (OR (WINDOWP (CAR (LAST ITEM)))
(WFROMMENU (OR MENUNAME (CAAR (LAST ITEM]
(DFHEIGHT (FONTPROP DEFAULTFONT 'HEIGHT))
DAYBROWSER CALTBITEMS CALDISPMENU CALMONTHMENU CALMONTHSTREAM CALCURMONTH
(CALDAYDEFAULTXLOC (CAR CALDAYDEFAULTREGION))
(CALDAYDEFAULTYLOC (CADR CALDAYDEFAULTREGION)))
[SETQ CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
[SETQ CALMONTHSTREAM (CAR (WINDOWPROP CALMONTHWINDOW 'STREAM]
[SETQ CALCURMONTH (CAR (WINDOWPROP CALMONTHWINDOW 'MONTH#]
(COND
((NOT M)
(printout PROMPTWINDOW T
"Selecting a day in this month with Left will give you a Day Window.")
(RETURN NIL))
((NOT (CALYEARINRANGE YR))
(RETURN NIL))
((AND (EQ BUTTON 'MIDDLE)
(NEQ D '% )) (* ;
"Middle gets you Add, but only if on a numbered day.")
(CALADDEVENT M D YR CALMONTHWINDOW))
((EQ BUTTON 'RIGHT)
(GETMOUSESTATE)
(if (INSIDEP (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH)
(WINDOWPROP CALMONTHWINDOW 'HEIGHT))
(LASTMOUSEX CALMONTHSTREAM)
(LASTMOUSEY CALMONTHSTREAM))
then (CALEXTENDSEL CALMONTHWINDOW)
else (DOWINDOWCOM CALMONTHWINDOW))
(RETURN NIL))
((EQ (CAR (LAST ITEM))
'OPTIONS)
(CALOPTIONMENU)
(RETURN NIL))
((EQ (CAR (LAST ITEM))
'PREV)
(SHOWMONTH (LIST (if (EQ BUTTON 'LEFT)
then CALMONTHWINDOW)
(MONTHPLUS M -1)
(MONTHYEARPLUS M YR -1)))
(RETURN NIL))
((EQ (CAR (LAST ITEM))
'NEXT)
(SHOWMONTH (LIST (if (EQ BUTTON 'LEFT)
then CALMONTHWINDOW)
(MONTHPLUS M 1)
(MONTHYEARPLUS M YR 1)))
(RETURN NIL)))
(if [AND BUTTON (NUMBERP (WINDOWPROP CALMONTHWINDOW 'GROUPEND]
then (INVERTGROUP M CALCURDAY YR M (WINDOWPROP CALMONTHWINDOW 'GROUPEND)
YR WHITESHADE CALMONTHMENU)
(WINDOWPROP CALMONTHWINDOW 'GROUPEND NIL))
(if [AND CALMONTHWINDOW (EQ M (WINDOWPROP CALMONTHWINDOW 'MONTH#]
then (SHOWREMSINDAY CALMONTHWINDOW M D YR)) (* ;
"Only write in month window if it exists, and is month of this day")
(* ;
"You need default locs in case SHOWDAY is called programmatically w/o there being a Month window")
[SETQ DAYBROWSER (for B in CALDAYBROWSERS thereis (AND (EQ D (CADR (TB.USERDATA B)))
(EQ M (CAR (TB.USERDATA B)))
(EQ YR (CADDR (TB.USERDATA B]
(if (NOT DAYBROWSER)
then [SETQ DAYBROWSER (TB.MAKE.BROWSER NIL
(LIST (if CALMONTHMENU
then (IDIFFERENCE (CAR (MDMENUITEMREGION D
CALMONTHMENU))
(ITIMES (DAYOF M D YR)
DFHEIGHT))
else CALDAYDEFAULTXLOC)
(IPLUS (if CALMONTHMENU
then (CADR (MDMENUITEMREGION D
CALMONTHMENU))
else CALDAYDEFAULTYLOC)
180)
(CADDR CALDAYDEFAULTREGION)
(CADDDR CALDAYDEFAULTREGION))
(LIST 'PRINTFN (FUNCTION CALPRINTREM)
'CLOSEFN
(FUNCTION CALTBCLOSEFN)
'USERDATA
(LIST M D YR CALMONTHWINDOW)
'TITLE
(CONCAT "Day browser for " (MKSTRING (MONTHNAME
M))
" " D ", " (MKSTRING YR]
(push CALDAYBROWSERS DAYBROWSER)
(SETQ CALTBITEMS (REMINDERSOF M D YR))
(for ITEM in CALTBITEMS do (TB.INSERT.ITEM DAYBROWSER ITEM))
(SETQ CALDISPMENU (create MENU
ITEMS ← '((Add CALADD "Add a new message in this day.")
(Display CALDISPLAY
"Displays the contents of the selected reminder."
)
(Delete CALDELETE
"The selected messages will be deleted immediately."
)
(Update CALUPDATE
"Write out all reminder changes to disk file."
)
(SendMail CALMAIL
"The selected messages will be mailed to the recipients of your choice."
)
(Period CALPERIOD
"Makes the selected messages periodic.")
)
MENUROWS ← 1
CENTERFLG ← T
WHENSELECTEDFN ← 'CALDISPEVENT))
(PUTMENUPROP CALDISPMENU 'BROWSER DAYBROWSER)
(ATTACHMENU CALDISPMENU (TB.WINDOW DAYBROWSER)
'TOP
'LEFT))
(OR (TB.WINDOW DAYBROWSER)
(SHOULDNT "Browser window is NIL: please inform author"))
(TB.REDISPLAY.ITEMS DAYBROWSER)
(AND CALTBITEMS (TB.SELECT.ITEM DAYBROWSER (CAR CALTBITEMS)))
(TOTOPW (TB.WINDOW DAYBROWSER))
(RETURN (SETQ CALCURDAY D])
(SHOWMONTH
[LAMBDA (ITEM) (* MJD " 9-Dec-87 10:17")
(* ;
"Both displays new and redisplays existing month windows.")
(PROG ((CALLTYPE (CAR ITEM))
(M (CADR ITEM))
(YR (CAR (LAST ITEM)))
MLOC CALMONTHWINDOW CALMONTHSTREAM CALMONTHMENU TOFFSETX TOFFSETY NMOFFSETX LMOFFSETX
LMOFFSETY OOFFSETX OOFFSETY DHEIGHT DOFFSET MOFFSET MWIDTH MHEIGHT (WWIDTH (CADDR
CALMONTHDEFAULTREGION
))
(WHEIGHT (CADDDR CALMONTHDEFAULTREGION)))
(if (NOT (CALYEARINRANGE YR))
then (RETURN NIL)) (* ; "Can it be done?")
(SETCURSOR WAITINGCURSOR)
[if (NOT CALMONTHWINDOW)
then (SETQ MWIDTH (FIX (FQUOTIENT WWIDTH 7.15)))
(SETQ MHEIGHT (IQUOTIENT WHEIGHT 7))
(SETQ MOFFSET (IQUOTIENT WHEIGHT 60))
(SETQ DHEIGHT (FIX (FQUOTIENT WHEIGHT 1.096)))
(SETQ DOFFSET (FIX (FQUOTIENT WWIDTH 36.1667)))
(SETQ OOFFSETX (FIX (FQUOTIENT WWIDTH 1.66)))
(SETQ OOFFSETY (FIX (FQUOTIENT WHEIGHT 12.069)))
(SETQ LMOFFSETX (FIX (FQUOTIENT WWIDTH 1.39)))
(SETQ LMOFFSETY (FIX (FQUOTIENT WHEIGHT 23.0)))
(SETQ NMOFFSETX (FIX (FQUOTIENT WWIDTH 1.165)))
(SETQ TOFFSETX (FIX (FQUOTIENT WWIDTH 3.472)))
(SETQ TOFFSETY (FIX (FQUOTIENT WHEIGHT 1.045]
(SETQ CALMONTHWINDOW (WINDOWP CALLTYPE))
(* ;; "Do we want to redo an existing month window?")
(if CALMONTHWINDOW
then
(* ;; "Yes, so save the menu and delete it from the window (has the effect of clearing the window. Then the ADDMENU below will redraw the menu items for us.)")
[SETQ CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
(DELETEMENU CALMONTHMENU NIL CALMONTHWINDOW)
(* ;; " If this call is due to a window reshape, we'll have to remake the menu.")
(if (OR (NEQ (WINDOWPROP CALMONTHWINDOW 'WIDTH)
868)
(NEQ (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
700))
then (SETQ CALMONTHMENU NIL))
(* ;; "If this call is from a Next or Prev, the window passed in ITEM is there only to tell us to reuse this window --- it's month# and menu must be changed.")
(if (NEQ (WINDOWPROP CALMONTHWINDOW 'MONTH#)
M)
then (WINDOWPROP CALMONTHWINDOW 'MONTH# M)
(WINDOWPROP CALMONTHWINDOW 'YEAR# YR)
(SETQ CALMONTHMENU NIL))
(SETQ WWIDTH (WINDOWPROP CALMONTHWINDOW 'WIDTH))
(SETQ WHEIGHT (WINDOWPROP CALMONTHWINDOW 'HEIGHT))
(SETQ MWIDTH (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
7.15)))
(SETQ MHEIGHT (IQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
7))
(SETQ MOFFSET (IQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
60))
(SETQ DHEIGHT (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
1.096)))
(SETQ DOFFSET (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
36.1667)))
(SETQ OOFFSETX (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
1.66)))
(SETQ OOFFSETY (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
12.069)))
(SETQ LMOFFSETX (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
1.39)))
(SETQ LMOFFSETY (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
23.0)))
(SETQ NMOFFSETX (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
1.165)))
(SETQ TOFFSETX (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
3.472)))
(SETQ TOFFSETY (FIX (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
1.045)))
else (SETQ CALMONTHWINDOW (CREATEW (NEXTMDISPLAYREGION (WIDTHIFWINDOW WWIDTH)
(HEIGHTIFWINDOW WHEIGHT T))
(CONCAT CALENDARVERSION " " (MKSTRING (MONTHNAME M))
" "
(MKSTRING YR))
NIL T))
(WINDOWPROP CALMONTHWINDOW 'HARDCOPYFN 'PRINTMONTH)
(WINDOWPROP CALMONTHWINDOW 'CLOSEFN 'CLOSEMONTH)
(WINDOWPROP CALMONTHWINDOW 'SHRINKFN 'SHRINKMONTH)
(WINDOWPROP CALMONTHWINDOW 'ICONFN 'CALMONTHICONFN)
(WINDOWPROP CALMONTHWINDOW 'TOTOPFN 'CIRCLETODAY)
(WINDOWPROP CALMONTHWINDOW 'RIGHTBUTTONFN 'CALMONTHRBF)
(WINDOWPROP CALMONTHWINDOW 'PROCESS (FIND.PROCESS 'BACKGROUND))
(WINDOWPROP CALMONTHWINDOW 'MINSIZE '(125 . 110))
(WINDOWPROP CALMONTHWINDOW 'MONTH# M)
(WINDOWPROP CALMONTHWINDOW 'YEAR# YR))
[SETQ CALMONTHSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM CALMONTHWINDOW NIL
(CONCAT CALENDARVERSION " " (MKSTRING (MONTHNAME M))
" "
(MKSTRING YR]
(WINDOWPROP CALMONTHWINDOW 'GROUPEND NIL)
[OR CALMONTHMENU (SETQ CALMONTHMENU
(create MENU
ITEMS ← [APPEND (for I from 1 to (DAYOF M 1 YR)
collect (LIST '% ))
(for I from 1 to (DAYSIN M YR)
collect (LIST I M YR))
(for I from 1
to (IDIFFERENCE 39 (IPLUS (DAYOF M 1 YR)
(DAYSIN M YR)))
collect (LIST '% ))
(LIST (LIST '% M YR 'OPTIONS))
(LIST (LIST '% M YR 'PREV))
(LIST (LIST '% M YR 'NEXT]
MENUCOLUMNS ← 7
MENUFONT ← (if (GEQ MWIDTH 100)
then CALFONT
else (FONTCREATE 'TIMESROMAN (PICKFONTSIZE MWIDTH
MHEIGHT)))
ITEMHEIGHT ← MHEIGHT
ITEMWIDTH ← MWIDTH
MENUBORDERSIZE ← 1
WHENSELECTEDFN ← 'SHOWDAY]
(ADDMENU CALMONTHMENU CALMONTHWINDOW (CONS MOFFSET MOFFSET))
(WINDOWPROP CALMONTHWINDOW 'RESHAPEFN 'REPAINTMONTH)
(WINDOWPROP CALMONTHWINDOW 'REPAINTFN 'REPAINTMONTH)
(WINDOWPROP CALMONTHWINDOW 'BUTTONEVENTFN 'CALMONTHBEF)
(* ;
"WINDOWPROP CALMONTHWINDOW (QUOTE BUTTONEVENTFN) (QUOTE CALMONTHBEF)")
(* ; "Day names across the top")
(DSPFONT (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
700)
0.6)
then BIGFONT
else (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
700)
0.4)
then DEFAULTFONT
else LITTLEFONT))
CALMONTHWINDOW)
(for X from MOFFSET to WWIDTH by MWIDTH as D from 0 to 6
do (MOVETO (IPLUS X DOFFSET)
DHEIGHT CALMONTHSTREAM)
(PRIN1 (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
868)
0.7)
then (DAYNAME D)
else (DAYABBR D (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
868)))
CALMONTHSTREAM))
(if (GEQ (WINDOWPROP CALMONTHWINDOW 'WIDTH)
175)
then (SHOWMOON M YR 1 CALMONTHMENU CALMONTHWINDOW))
(* ; "Phases of moon")
(DSPFONT (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
700)
0.6)
then DEFAULTFONT
else LITTLEFONT)
CALMONTHWINDOW)
(MOVETO OOFFSETX OOFFSETY CALMONTHSTREAM)
(PRINTOUT CALMONTHSTREAM (if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'WIDTH)
868)
0.6)
then "Options"
else "Opt"))
(DSPFONT LITTLEFONT CALMONTHWINDOW)
(if (GEQ (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
150)
then (SHOWREMSINMONTH M YR 1 CALMONTHWINDOW CALMONTHMENU CALMONTHSTREAM))
(* ; "Little last month")
[if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
700)
0.9)
then (SHOWMONTHSMALL (MONTHPLUS M -1)
(MONTHYEARPLUS M YR -1)
LMOFFSETX LMOFFSETY 1 CALMONTHWINDOW)
else (MOVETO LMOFFSETX LMOFFSETY CALMONTHSTREAM)
(PRINTOUT CALMONTHSTREAM (MONTHNAME (MONTHPLUS M -1]
[if (GEQ (FQUOTIENT (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
700)
0.9)
then (SHOWMONTHSMALL (MONTHPLUS M 1)
(MONTHYEARPLUS M YR 1)
NMOFFSETX LMOFFSETY 1 CALMONTHWINDOW)
else (MOVETO NMOFFSETX LMOFFSETY CALMONTHSTREAM)
(PRINTOUT CALMONTHSTREAM (MONTHNAME (MONTHPLUS M 1]
(* ; "Little next month")
(DSPFONT (if (GEQ MWIDTH 100)
then CALFONT
else (FONTCREATE 'TIMESROMAN (PICKFONTSIZE MWIDTH MHEIGHT)))
CALMONTHWINDOW)
(MOVETO TOFFSETX TOFFSETY CALMONTHSTREAM)
(* ;; " Trailing blanks help erase previous name if this mo. is a display in an existing window (but this causes wrap-around problems with small month window sizes):")
(PRINTOUT CALMONTHSTREAM (MONTHNAME M)
" " YR " ")
(SETQ CALCIRCLEDAY NIL)
(CIRCLETODAY CALMONTHWINDOW)
(pushnew CALMONTHLST CALMONTHWINDOW)
(CURSOR T)
(RETURN M])
(SHOWMONTHSMALL
[LAMBDA (M YR XLOC YLOC SCALE WINDOW) (* MJD "18-Nov-87 16:52")
(PROG [(CT 0)
(X XLOC)
(Y (IPLUS YLOC (TIMES 48 SCALE]
(MOVETO (IPLUS X (TIMES SCALE 24))
(IPLUS Y (TIMES SCALE 12))
WINDOW)
(PRIN1 (if (GEQ (FQUOTIENT (WINDOWPROP WINDOW 'WIDTH)
700)
0.4)
then (MONTHNAME M)
else (MONTHABBR M))
WINDOW)
(for I in (APPEND (for N from 1 to (DAYOF M 1 YR) collect '% )
(for N from 1 to (DAYSIN M YR) collect N))
do (MOVETO X Y WINDOW)
(PRIN1 I WINDOW)
(add X (TIMES SCALE 16))
(add CT 1)
(COND
((EQ (IREMAINDER CT 7)
0)
(SETQ X XLOC)
(add Y (TIMES SCALE -10])
(SHOWMOON
[LAMBDA (M YR SCALE CALMONTHMENU STREAM) (* MJD "19-Nov-87 16:00")
(* ; " SCALE here is 1 for screen res. or ~ 35 for printer res. Scaling for different window sizes is handled inline.")
(for P in (POMDAYS M YR) as PMAP in (if (AND (EQ (IMAGESTREAMTYPE STREAM)
'DISPLAY)
(VIDEOCOLOR))
then '(NMMAP FQMAP FMMAP LQMAP)
else '(FMMAP LQMAP NMMAP FQMAP))
do (if (EQ (IMAGESTREAMTYPE STREAM)
'INTERPRESS)
then (\MOVETO.IP STREAM (IPLUS (CAR (MDMENUITEMREGION P CALMONTHMENU SCALE))
(FQUOTIENT (CADDR (DSPCLIPPINGREGION NIL STREAM))
16.6))
(IPLUS (CADR (MDMENUITEMREGION P CALMONTHMENU SCALE))
(FQUOTIENT (CADDDR (DSPCLIPPINGREGION NIL STREAM))
125.0)))
(SHOWBITMAP.IP STREAM (EVAL PMAP)
NIL 0.5) (* ; "Thanks, Dinh!")
else (BITBLT (if (GEQ (WINDOWPROP STREAM 'WIDTH)
600)
then (EVAL PMAP)
else (SCALEBITMAP (EVAL PMAP)
(FQUOTIENT (MIN (WINDOWPROP STREAM 'WIDTH)
(WINDOWPROP STREAM 'HEIGHT))
900)))
NIL NIL STREAM (IPLUS (CAR (MDMENUITEMREGION P CALMONTHMENU SCALE))
(TIMES (FQUOTIENT (WINDOWPROP STREAM 'WIDTH)
16.6)
SCALE))
(IPLUS (CADR (MDMENUITEMREGION P CALMONTHMENU SCALE))
(TIMES (FQUOTIENT (WINDOWPROP STREAM 'HEIGHT)
350.0)
SCALE))
34 34 'INPUT 'INVERT])
(SHOWREMSINDAY
[LAMBDA (CALMONTHWINDOW M D YR) (* MJD "10-Aug-87 13:35")
(* ;; "This code is similar to SHOWREMSINMONTH except that it is optimized for picking out the reminders for only one particular day, rather than all reminders in a month. Changes here may need to be done to SHOWREMSINMONTH also.")
(PROG [(CALMONTHSTREAM (WINDOWPROP CALMONTHWINDOW 'DSP))
[CALMONTHMENU (CAR (WINDOWPROP CALMONTHWINDOW 'MENU]
(NREMS (FIX (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
0.01]
(CLEARDAY D CALMONTHWINDOW CALMONTHMENU)
(DSPFONT LITTLEFONT CALMONTHWINDOW)
(MOVETOUPPERLEFT CALMONTHSTREAM (MDMENUITEMREGION D CALMONTHMENU))
(DSPYPOSITION (IDIFFERENCE (DSPYPOSITION NIL CALMONTHSTREAM)
2)
CALMONTHSTREAM)
(SETQ DAYREGION (MDMENUITEMREGION D CALMONTHMENU))
(DSPCLIPPINGREGION DAYREGION CALMONTHSTREAM)
(for REMINDER in (REMINDERSOF M D YR) as I to NREMS
do (DSPXPOSITION (CAR (MDMENUITEMREGION D CALMONTHMENU))
CALMONTHSTREAM)
(CALPRINTREM NIL REMINDER CALMONTHSTREAM))
(DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH)
(WINDOWPROP CALMONTHWINDOW 'HEIGHT))
CALMONTHSTREAM])
(SHOWREMSINMONTH
[LAMBDA (M YR SCALE CALMONTHWINDOW CALMONTHMENU STREAM) (* MJD "19-Nov-87 15:57")
(* ;; "Handles printing of all reminders in a month both for screen and on paper. Changes here may need to be done to SHOWREMSINDAY also.")
(PROG [D REMLIST DAYREGION (NREMS (FIX (TIMES (WINDOWPROP CALMONTHWINDOW 'HEIGHT)
0.01]
(SETQ REMLIST (REMSINMONTH M YR))
(for REMINDER in REMLIST as D to (DAYSIN M YR) when REMINDER
do (SETQ DAYREGION (MDMENUITEMREGION D CALMONTHMENU SCALE))
(MOVETOUPPERLEFT STREAM DAYREGION)
(DSPYPOSITION (IDIFFERENCE (DSPYPOSITION NIL STREAM)
(TIMES 2 SCALE))
STREAM)
(DSPCLIPPINGREGION DAYREGION STREAM)
(for R in REMINDER as I to NREMS do (DSPXPOSITION (CAR (MDMENUITEMREGION D
CALMONTHMENU SCALE))
STREAM)
(CALPRINTREM NIL R STREAM)))
(if (EQ (IMAGESTREAMTYPE STREAM)
'DISPLAY)
then (DSPCLIPPINGREGION (CREATEREGION 0 0 (WINDOWPROP CALMONTHWINDOW 'WIDTH)
(WINDOWPROP CALMONTHWINDOW 'HEIGHT))
STREAM])
(SHOWYEAR
[LAMBDA (ITEM MNAME BUTTON CALYEARWINDOW) (* MJD "10-Aug-87 12:59")
(PROG ((YR (CAR ITEM))
(CALLTYPE (LENGTH ITEM))
MLOC CALYEARSTREAM CALYEARMENU)
[if (EQ YR 'Other)
then (TERPRI PROMPTWINDOW)
(SETQ YR (MKATOM (PROMPTFORWORD "Year: " NIL NIL PROMPTWINDOW NIL NIL (CHARCODE
EOL]
(COND
[(CALYEARINRANGE YR)
(if CALYEARWINDOW
then (CLEARW CALYEARWINDOW)
else [SETQ CALYEARWINDOW
(CREATEW (if (NEQ CALLTYPE 1)
then (PROGN (SETQ MLOC (GETBOXPOSITION 364 324 NIL NIL NIL
"Please position the Year Window."))
(create REGION
LEFT ← (CAR MLOC)
BOTTOM ← (CDR MLOC)
WIDTH ← 364
HEIGHT ← 324))
else '(32 400 364 324))
(CONCAT CALENDARVERSION " " (MKSTRING YR]
[SETQ CALYEARSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM CALYEARWINDOW NIL
(CONCAT CALENDARVERSION " " (MKSTRING YR]
(WINDOWPROP CALYEARWINDOW 'ICON CALYEARICON)
(WINDOWPROP CALYEARWINDOW 'ICONFN 'CALYEARICONFN)
(WINDOWPROP CALYEARWINDOW 'YEAR# YR)
(ATTACHMENU CALMAINMENU CALYEARWINDOW 'RIGHT 'TOP))
(SETQ CALYEARMENU (create MENU
ITEMS ← (for I from 1 to 12 collect (LIST '% I YR))
MENUCOLUMNS ← 3
ITEMHEIGHT ← 70
ITEMWIDTH ← 118
WHENSELECTEDFN ← 'SHOWMONTH))
(ADDMENU CALYEARMENU CALYEARWINDOW '(0 . 0))
(WINDOWPROP CALYEARWINDOW 'RESHAPEFN 'DON'T)
(WINDOWPROP CALYEARWINDOW 'REPAINTFN 'REPAINTYEAR)
(WINDOWPROP CALYEARWINDOW 'SCROLLFN NIL)
(DSPFONT DEFAULTFONT CALYEARWINDOW)
(MOVETO 157 294 CALYEARSTREAM)
(PRIN1 YR CALYEARSTREAM)
(DSPFONT LITTLEFONT CALYEARWINDOW)
(for Y from 0 to 3 do (for X from 0 to 2 do (SHOWMONTHSMALL (IPLUS (ADD1 X)
(ITIMES Y 3))
YR
(IPLUS (ITIMES X 120)
4)
(ITIMES (IDIFFERENCE 3 Y)
70)
1 CALYEARWINDOW]
(T (printout PROMPTWINDOW T "Sorry - I can only handle years between 1700 and 2100."])
(SHRINKMONTH
[LAMBDA (X) (* MJD "20-Jul-87 14:10")
[AND (EQ CALUPDATEONSHRINKFLG 'Shrink)
CALNEEDSUPDATE
(ADD.PROCESS '(CALUPDATEINIT]
(OR CALMONTHICON (SETQ CALMONTHICON (create TITLEDICON
ICON ← CALMONTHICONMAP
TITLEREG ← '(3 51 56 9])
(SHRINKYEAR
[LAMBDA (X) (* MJD "19-Jun-87 12:09")
[OR (WINDOWPROP CALYEARWINDOW 'ICONPOSITION)
(WINDOWPROP CALYEARWINDOW 'ICONPOSITION (GETBOXPOSITION (BITMAPWIDTH CALYEARICON)
(BITMAPHEIGHT CALYEARICON]
(OR CALYEARICON (SETQ CALYEARICON (create TITLEDICON
ICON ← CALYEARICONMAP
TITLEREG ← '(6 26 50 9])
(TIMEDREMP
[LAMBDA (REM) (* MJD "30-Jun-87 16:15")
(CAR REM])
(TPLUS
[LAMBDA (TIME MINS) (* MJD "21-Jul-87 11:32")
(GDATE (PLUS (IDATE (PACKDATE TIME 7 1 1987))
(TIMES MINS 60))
(DATEFORMAT NO.DATE])
(YNCONVERT
[LAMBDA (X) (* MJD "22-Jul-87 12:07")
(if X
then 'Yes
else 'No])
)
(RPAQQ CALDAYICON #*(64 64)OOOOOOOOOOOOOOOOOANOGLCGFAOGHOOONOMGGMOCGFNKKGOONOKKGLGCGFMMKGOONOHCGMOEGFLAHOOONOKKGMOEGFMMJGOOOAKK@LCFFAMMKGOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AHOOOOOOOOOOO@@@AHOOOOOOOOOOOH@@AHOOOOOOOOOOOL@@AHOOOOOOOOOOON@@AHMOOOOOOOOOOO@@AHMOOOOOOOOOOOH@AHMGOOOOOOOOOOL@AHMD@@@@@@@@@@L@AHMD@AL@@@CH@@D@AHMD@CN@@@GL@@D@AHMD@CN@@@GL@@D@AHMD@CN@@@GL@@D@AHMD@AL@@@CH@@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@D@AHMD@@@@B@AH@CD@AHMEOL@@G@AL@CD@AHMEON@@MH@L@FD@AHMDFG@AHL@F@FD@AHMDFCHC@F@F@LD@AHMDFAHB@F@CAHD@AHMDFAHF@C@CAHD@AHMDFAHL@CHAK@D@AHMDFAHL@AH@O@D@AHMDFAHL@AH@N@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFAHOOOH@F@D@AHMDFAHOOOH@F@D@AHMDFAHOOOH@F@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFAHL@AH@F@D@AHMDFCHL@AH@F@D@AHMEOO@L@AH@F@D@AHMEOL@L@AH@F@D@AHMD@@@@@@@@@@D@AHMD@@@@@@@@@@F@AHMD@@@@@@@@@@B@AHMD@@@@@@@@@@C@AHMD@@@@@@@@@@AHAHMD@@@@@@@@@@@LAHMB@@@@@@@@@@@FAHMA@@@@@@@@@@@LAHMA@@@@@@@@@@AHAHM@H@@@@@@@@@C@AHM@L@@@@@@@@ON@AHE@GOOOOOOOO@D@AHG@@@@@@@@@@@D@AHC@@@@@@@@@@@D@AHAOOOOOOOOOOOL@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOO
)
(RPAQQ CALMONTHICONMAP #*(64 64)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@AHG@HHOHDDCN@O@NAHD@MHB@ED@H@H@HAHG@JHB@ED@H@N@NAHA@JHB@CH@H@H@BAHG@HHB@BH@H@H@NAH@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AH@D@B@AB@KHELBJAH@D@B@AB@HHDDBJAH@D@B@AB@IHELBOAH@D@B@AB@J@DDBBAH@D@B@AB@KHELBBAH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AKHELBNAG@KHEGBJAJ@E@BBAE@JHEEBJAKHELBBAG@KHEEBJAHHEDBBAE@HHEEBJAKHELBBAG@HHEGBJAH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AJNEGBJIELJNEGBKIJBEABJIE@JHEABJIJNEGBKMELJNEABKIJHEABHIDDJJEABJIJNEGBHIELJNEABKIH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AJNEKJNIFLKGEJJMMJJDJJBIBDIADJJEAJNEJJNIFLKGEKJMMJBEBJHIDHJAE@JHEJBEKJNIFLKGEHJMMH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOOH@D@B@A@@H@D@B@AKGEKJMMFNKGD@B@AIDDHJEMBNIED@B@AJGE@JIEDBIED@B@AKGEHJMMFBKGD@B@AH@D@B@A@@H@D@B@AOOOOOOOOOOOOOOOO
)
(RPAQQ CALYEARICONMAP #*(64 64)OOOOOOOOOOOOOOOOOANOGLCGFAOGHOHANOMGGMOCGFNKKGMENOKKGLGCGFMMKGMENOHCGMOEGFLAHOOMNOKKGMOEGFMMJGLAOAKK@LCFFAMMKGMMOOOOOOOOOOOOOOLAH@@@@H@@@@D@@@GOHCOOHHGOO@D@GN@AH@@@@H@@@@D@@@@AHEEEDH@BJHD@@EDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHED@@HJJ@@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AH@OL@H@GH@D@CN@AH@@@@H@@@@D@@@@AHEEEDH@JJHD@@ADAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHE@@@HJJH@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AH@GL@HAON@DCOOHAH@@@@H@@@@D@@@@AHEEEDH@BJHD@@@DAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHED@@HJJJ@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOOH@@@@H@@@@D@@@@AHCOO@HGOO@DCOOHAH@@@@H@@@@D@@@@AHAEEDH@@JHD@@@DAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAH@@@@H@@@@D@@@@AHEEEDHJJJHDEEEDAJ@@@@H@@@@D@@@@AKEEEDHJJJHDEEEDAJ@@@@H@@@@D@@@@AHEE@@HJJJ@DEEEDAH@@@@H@@@@D@@@@AOOOOOOOOOOOOOOOO
)
(RPAQQ FQMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OLGOL@@@@@@AN@GON@@@@@@GH@GOOH@@@@@O@@GOOL@@@@@L@@GOOL@@@@AL@@GOON@@@@CH@@GOOO@@@@C@@@GOOO@@@@G@@@GOOOH@@@F@@@GOOOH@@@F@@@GOOOH@@@N@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@L@@@GOOOL@@@N@@@GOOOL@@@F@@@GOOOH@@@F@@@GOOOH@@@G@@@GOOOH@@@C@@@GOOO@@@@CH@@GOOO@@@@AL@@GOON@@@@@L@@GOOL@@@@@O@@GOOL@@@@@GH@GOOH@@@@@AN@GON@@@@@@@OLGOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@
)
(RPAQQ FMMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OOOOL@@@@@@AOOOON@@@@@@GOOOOOH@@@@@OOOOOOL@@@@@OOOOOOL@@@@AOOOOOON@@@@COOOOOOO@@@@COOOOOOO@@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOOH@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@OOOOOOOOL@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOOH@@@GOOOOOOO@@@@COOOOOOO@@@@AOOOOOON@@@@@OOOOOOL@@@@@OOOOOOL@@@@@GOOOOOH@@@@@AOOOON@@@@@@@OOOOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@
)
(RPAQQ LQMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OOHOL@@@@@@AOOHAN@@@@@@GOOH@GH@@@@@OOOH@CL@@@@@OOOH@@L@@@@AOOOH@@N@@@@COOOH@@G@@@@COOOH@@C@@@@GOOOH@@CH@@@GOOOH@@AH@@@GOOOH@@AH@@@OOOOH@@AL@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@@L@@@OOOOH@@AL@@@GOOOH@@AH@@@GOOOH@@AH@@@GOOOH@@CH@@@COOOH@@C@@@@COOOH@@G@@@@AOOOH@@N@@@@@OOOH@@L@@@@@OOOH@CL@@@@@GOOH@GH@@@@@AOOHAN@@@@@@@OOHOL@@@@@@@COOO@@@@@@@@@GOH@@@@@@
)
(RPAQQ NMMAP #*(34 34)@@@GOH@@@@@@@@COOO@@@@@@@@OL@OL@@@@@@AN@@AN@@@@@@GH@@@GH@@@@@O@@@@CL@@@@@L@@@@@L@@@@AL@@@@@N@@@@CH@@@@@G@@@@C@@@@@@C@@@@G@@@@@@CH@@@F@@@@@@AH@@@F@@@@@@AH@@@N@@@@@@AL@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@L@@@@@@@L@@@N@@@@@@AL@@@F@@@@@@AH@@@F@@@@@@AH@@@G@@@@@@CH@@@C@@@@@@C@@@@CH@@@@@G@@@@AL@@@@@N@@@@@L@@@@@L@@@@@O@@@@CL@@@@@GH@@@GH@@@@@AN@@AN@@@@@@@OL@OL@@@@@@@COOO@@@@@@@@@GOH@@@@@@
)
(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
FREEMENU TABLEBROWSER)
(PUTPROPS CALENDAR COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (9598 136953 (CALADDEVENT 9608 . 16055) (CALCREATEREM 16057 . 18316) (CALDELETEREM 18318
. 21228) (CALDISPEVENT 21230 . 28061) (CALDOOPTIONS 28063 . 29846) (CALENDAR 29848 . 32922) (
CALENDARWATCHER 32924 . 33201) (CALEXTENDSEL 33203 . 34907) (CALLOADFILE 34909 . 40466) (CALMAKEKEY
40468 . 40669) (CALMONTHBEF 40671 . 41764) (CALMONTHICONFN 41766 . 42273) (CALMONTHRBF 42275 . 43067)
(CALOPTIONMENU 43069 . 45324) (CALPRINTREM 45326 . 46944) (CALREMDEF 46946 . 47187) (CALTBCLOSEFN
47189 . 47591) (CALTBNULLFN 47593 . 47819) (CALTEDITEXIT 47821 . 48114) (CALTEDITSTRING 48116 . 51593)
(CALUPDATEFILE 51595 . 55543) (CALUPDATEINIT 55545 . 57725) (CALYEARICONFN 57727 . 58210) (
CALYEARINRANGE 58212 . 58486) (CIRCLETODAY 58488 . 61695) (CLEARDAY 61697 . 62980) (CLOSEMONTH 62982
. 63551) (DAYABBR 63553 . 63815) (DAYNAME 63817 . 64010) (DAYOF 64012 . 65044) (DAYPLUS 65046 . 65337
) (DAYSIN 65339 . 65637) (DERIVENEWDATE 65639 . 67489) (DOREMINDER 67491 . 70753) (FMNWAYITEM 70755 .
71156) (GETREMDEF 71158 . 71470) (INVERTGROUP 71472 . 71740) (LISPDATEDAY 71742 . 72020) (
LISPDATEMONTH 72022 . 72170) (LISPDATEYEAR 72172 . 72536) (MDMENUITEMREGION 72538 . 72955) (MENUITEM
72957 . 73148) (MENUREGIONITEM 73150 . 73518) (MONTHABBR 73520 . 73697) (MONTHNAME 73699 . 73970) (
MONTHNUM 73972 . 74178) (MONTHOFDAYPLUS 74180 . 74408) (MONTHPLUS 74410 . 74715) (MONTHYEARPLUS 74717
. 75005) (NEWPARSETIME 75007 . 80658) (NEXTMDISPLAYREGION 80660 . 83231) (PACKDATE 83233 . 83948) (
PARSETIME 83950 . 85077) (PICKFONTSIZE 85079 . 85731) (POM 85733 . 88387) (POMDAYS 88389 . 89730) (
PRINTMONTH 89732 . 93341) (REMINDERSOF 93343 . 93947) (REMINDERTIME 93949 . 94191) (REMINDERTIMELT
94193 . 94457) (REMSINMONTH 94459 . 94648) (REPAINTMONTH 94650 . 95005) (REPAINTYEAR 95007 . 95337) (
SAMEDAYAS 95339 . 95742) (SAMEMONTHAS 95744 . 96029) (SCALEBITMAP 96031 . 105083) (SHOWDAY 105085 .
112795) (SHOWMONTH 112797 . 125424) (SHOWMONTHSMALL 125426 . 126507) (SHOWMOON 126509 . 128944) (
SHOWREMSINDAY 128946 . 130436) (SHOWREMSINMONTH 130438 . 131998) (SHOWYEAR 132000 . 135470) (
SHRINKMONTH 135472 . 135898) (SHRINKYEAR 135900 . 136429) (TIMEDREMP 136431 . 136555) (TPLUS 136557 .
136783) (YNCONVERT 136785 . 136951)))))
STOP