(FILECREATED "10-Oct-86 13:07:26" {DSK}<LISPFILES>DATEFNS.;1 20771 changes to: (FNS MAKE.DATE) previous date: " 4-May-84 18:46:07" {DANTE}<LISPNEW>LISPUSERS>DATEFNS.;1) (* Copyright (c) 1984, 1986 by Xerox Corporation. All rights reserved.) (PRETTYCOMPRINT DATEFNSCOMS) (RPAQQ DATEFNSCOMS ((FNS BUILDCALENDAR CALRBUTTONFN CENTERBLTINREGION DATEMENU DAY DAYOFWEEK DAYSIN DRAWCALENDAR FOLLOWING.MONTH LEAPYEARP MAKE.DATE PREVIOUS.MONTH XYTODATE \CALBOXITEM \CALINVERTITEM) (VARS LISTOFDAYS MONTH.LIST) (VARS (CALBORDER 3) (CALGRIDBORDER 1)) [VARS (MONTHNAMEFONT (FONTCREATE (QUOTE GACHA) 12)) (OTHERMONTHFONT (FONTCREATE (QUOTE GACHA) 8)) (DAYNAMEFONT (FONTCREATE (QUOTE GACHA) 10)) (DAYNUMBERFONT (FONTCREATE (QUOTE GACHA) 12 (QUOTE BOLD] (DECLARE: DONTCOPY (RECORDS CALENDARINFO)))) (DEFINEQ (BUILDCALENDAR [LAMBDA (MON YEAR CALENDARW) (* rrb " 3-May-84 12:41") (PROG ([YEAR (OR YEAR (MKATOM (SUBSTRING (DATE) 8 9] (MON (OR MON (SUBSTRING (DATE) 4 6))) DAYSIN FIRSTDAY WEEKROWS CALWIDTH CALHEIGHT CALWWIDTH CALWHEIGHT DAYWIDTH DAYHEIGHT OTHERMONWIDTH OTHERMONHEIGHT) (SETQ MON (MKATOM (U-CASE MON))) MONLP (COND ((MEMB MON MONTH.LIST)) ((IGREATERP (NCHARS MON) 3) (SETQ MON (MKATOM (SUBSTRING MON 1 3))) (GO MONLP)) (T (ERROR MON "not recognized as a month. Should be 3 letter abbrev."))) (SETQ DAYSIN (DAYSIN MON YEAR)) [SETQ FIRSTDAY (DAYOFWEEK (IDATE (CONCAT "01-" MON "-" YEAR " 12:00:00"] (SETQ WEEKROWS (COND ((IGREATERP (IPLUS DAYSIN FIRSTDAY) 35) 6) ((IGREATERP (IPLUS DAYSIN FIRSTDAY) 28) 5) (T 4))) [SETQ CALWIDTH (IPLUS (IMAX (ITIMES (IPLUS (ITIMES 2 (IPLUS CALGRIDBORDER 1)) (IMAX (STRINGWIDTH "Su" DAYNAMEFONT) (STRINGWIDTH "28" DAYNUMBERFONT))) 7) (IPLUS [ITIMES 2 (SETQ OTHERMONWIDTH (IPLUS 4 (STRINGWIDTH "MAY" OTHERMONTHFONT] (STRINGWIDTH " MAR 84 " MONTHNAMEFONT] (SETQ CALWWIDTH (WIDTHIFWINDOW CALWIDTH CALBORDER)) (SETQ CALHEIGHT (IPLUS (IPLUS 2 (IMAX (SETQ OTHERMONHEIGHT (IPLUS 2 (FONTHEIGHT OTHERMONTHFONT))) (FONTHEIGHT MONTHNAMEFONT))) (IPLUS 2 (FONTHEIGHT DAYNAMEFONT)) (ITIMES (SETQ DAYHEIGHT (IPLUS CALGRIDBORDER 2 (FONTHEIGHT DAYNUMBERFONT))) WEEKROWS))) (SETQ CALWHEIGHT (HEIGHTIFWINDOW CALHEIGHT NIL CALBORDER)) [COND [(WINDOWP CALENDARW) (PROG [(CURRENTREG (WINDOWPROP CALENDARW (QUOTE REGION] (CLEARW CALENDARW) (WINDOWPROP CALENDARW (QUOTE RESHAPEFN) NIL) (COND ((NEQ (fetch (REGION HEIGHT) of CURRENTREG) CALWHEIGHT) (* do reshape so that upper part of window remains fixed.) (WINDOWPROP CALENDARW (QUOTE REGION) (CREATEREGION (fetch (REGION LEFT) of CURRENTREG) (IDIFFERENCE (fetch (REGION BOTTOM) of CURRENTREG) (IDIFFERENCE CALWHEIGHT (fetch (REGION HEIGHT) of CURRENTREG))) CALWWIDTH CALWHEIGHT] (T (SETQ CALENDARW (CREATEW (MAKEWITHINREGION (CREATEREGION LASTMOUSEX LASTMOUSEY CALWWIDTH CALWHEIGHT)) NIL CALBORDER NIL] (WINDOWPROP CALENDARW (QUOTE BUTTONEVENTFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE CURSORINFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE CURSORMOVEDFN) (FUNCTION CALRBUTTONFN)) (WINDOWPROP CALENDARW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP CALENDARW (QUOTE CALENDARINFO) (create CALENDARINFO MONTH ← MON YEAR ← YEAR #DAYS ← DAYSIN DAYOFFIRST ← FIRSTDAY WEEKROWS ← WEEKROWS) DAYSIN) (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC) (create REGION LEFT ←(IQUOTIENT [IDIFFERENCE CALWIDTH (ITIMES 7 (SETQ DAYWIDTH (IQUOTIENT CALWIDTH 7] 2) BOTTOM ← 0 WIDTH ← DAYWIDTH HEIGHT ← DAYHEIGHT)) (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS) (LIST (create REGION LEFT ← 0 BOTTOM ←(IDIFFERENCE CALHEIGHT OTHERMONHEIGHT) WIDTH ← OTHERMONWIDTH HEIGHT ← OTHERMONHEIGHT) (create REGION LEFT ←(IDIFFERENCE CALWIDTH OTHERMONWIDTH) BOTTOM ←(IDIFFERENCE CALHEIGHT OTHERMONHEIGHT) WIDTH ← OTHERMONWIDTH HEIGHT ← OTHERMONHEIGHT))) (DRAWCALENDAR CALENDARW) (RETURN CALENDARW]) (CALRBUTTONFN [LAMBDA (CALENDARW) (* rrb " 2-May-84 19:51") (* buttoneventfn for calendar menus) (PROG ((CALINFO (WINDOWPROP CALENDARW (QUOTE CALENDARINFO))) (OTHERMONTHREGIONS (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS))) (MGRIDSPEC (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC))) (LASTBUTTONSTATE LASTMOUSEBUTTONS) (MAXXBOX 7) OLDBOXX OLDBOXY BOXX BOXY DSPX DSPY MAXYBOX MOUSEDOWN ITEM YEAR MONTH) (SETQ MONTH (fetch (CALENDARINFO MONTH) of CALINFO)) (SETQ YEAR (fetch (CALENDARINFO YEAR) of CALINFO)) (SETQ MAXYBOX (fetch (CALENDARINFO WEEKROWS) of CALINFO)) [RETURN (until (COND (MOUSEDOWN (* if mouse has been down, process it) (MOUSESTATE UP)) ((MOUSESTATE (NOT UP)) (* mouse hasn't been down but just went down.) [COND ((LASTMOUSESTATE RIGHT) (DOWINDOWCOM CALENDARW) (SETQ MOUSEDOWN NIL)) (T (SETQ MOUSEDOWN T) (COND (OLDBOXX (* switch between boxing to flipping items.) (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW) (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW] NIL)) do [COND [[OR (AND (STRICTLY/BETWEEN (SETQ BOXY (GRIDYCOORD (LASTMOUSEY CALENDARW) MGRIDSPEC)) -1 MAXYBOX) (STRICTLY/BETWEEN (SETQ BOXX (GRIDXCOORD (LASTMOUSEX CALENDARW) MGRIDSPEC)) -1 MAXXBOX)) (SETQ BOXX (for REG in OTHERMONTHREGIONS when (INSIDE? REG (LASTMOUSEX CALENDARW) (LASTMOUSEY CALENDARW)) do (RETURN REG] (* BOXX and BOXY hold the number of the box pointed at.) (COND ((OR (NEQ BOXX OLDBOXX) (NEQ BOXY OLDBOXY)) (* selected item has changed.) (* uninvert old item if there was one.) [COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW] (* invert new item) (COND (MOUSEDOWN (\CALINVERTITEM BOXX BOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM BOXX BOXY MGRIDSPEC CALENDARW))) (SETQ OLDBOXX BOXX) (SETQ OLDBOXY BOXY] (T (* cursor moved outside of the menu.) (COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW))) (* OLDBOXX denotes item inverted.) (SETQ OLDBOXX))) (COND ((INSIDEP (WINDOWPROP CALENDARW (QUOTE REGION)) LASTMOUSEX LASTMOUSEY) (* cursor is still inside the window, keep control.) NIL) (T (RETURN] finally (* turn off inverse image. and call whenunheldfn is necessary.) (COND (OLDBOXX (COND (MOUSEDOWN (\CALINVERTITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW)) (T (\CALBOXITEM OLDBOXX OLDBOXY MGRIDSPEC CALENDARW))) (* something was selected, take down the window.) (CLOSEW CALENDARW))) (* return selected date or bring up new calendar) (RETURN (COND ((REGIONP OLDBOXX) (* selected a month) [COND [(EQ OLDBOXX (CAR OTHERMONTHREGIONS)) (COND ((EQ (SETQ MONTH (PREVIOUS.MONTH MONTH)) (QUOTE DEC)) (SETQ YEAR (SUB1 YEAR] (T (COND ((EQ (SETQ MONTH (FOLLOWING.MONTH MONTH)) (QUOTE JAN)) (SETQ YEAR (ADD1 YEAR] (BUILDCALENDAR MONTH YEAR CALENDARW)) (OLDBOXX (WINDOWPROP CALENDARW (QUOTE VALUE) (MAKE.DATE (XYTODATE CALENDARW OLDBOXX OLDBOXY) MONTH YEAR] (* return selected date or bring up new calendar) ]) (CENTERBLTINREGION [LAMBDA (BITMAP REGION STRM) (* rrb " 1-May-84 14:18") (* puts a bitmap centered in a region of a stream) (BITBLT BITMAP 0 0 STRM (IPLUS (fetch (REGION LEFT) of REGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION WIDTH) of REGION) (BITMAPWIDTH BITMAP)) 2)) (IPLUS (fetch (REGION BOTTOM) of REGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION HEIGHT) of REGION) (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) 2)) NIL NIL (QUOTE INPUT) NIL NIL REGION]) (DATEMENU [LAMBDA (MON YEAR) (* rrb " 2-May-84 19:53") (* puts up a calendar menu and reads a date from the user) (PROG ((CALMENUW (BUILDCALENDAR MON YEAR))) (until (WINDOWPROP CALMENUW (QUOTE VALUE)) do (TOTOPW CALMENUW) (DISMISS 500)) (RETURN (WINDOWPROP CALMENUW (QUOTE VALUE) NIL]) (DAY [LAMBDA (STRDATE) (* rrb " 1-May-84 14:30") (SELECTQ (DAYOFWEEK (IDATE STRDATE)) (1 "MONDAY") (2 "TUESDAY") (3 "WEDNESDAY") (4 "THURSDAY") (5 "FRIDAY") (6 "SATURDAY") (0 "SUNDAY") (SHOULDNT]) (DAYOFWEEK [LAMBDA (INTERNALDATE) (* gbn "11-MAY-83 10:47") (* Returns a number between 0 (Sunday) and 6 (Saturday) representing the day of the week which the given IDATE was/is/willbe) (PROG ((UNITSSINCEBASE (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE INTERNALDATE) 1) 30))) (* UNITSSINCEBASE represents the number of minutes since Jan 1,1901 GMT) (* now, adjust for the time zone. Since this may make UNITSSINCEBASE go negative , add in one week of hours) (SETQ UNITSSINCEBASE (IDIFFERENCE (IPLUS (IQUOTIENT UNITSSINCEBASE 60) (ITIMES 24 7)) \TimeZoneComp)) (* UNITSSINCEBASE now represents the number of hours since Genesis) (RETURN (IREMAINDER (IPLUS 2 (IQUOTIENT UNITSSINCEBASE 24)) 7]) (DAYSIN [LAMBDA (MONTH YEAR) (* rrb " 2-May-84 19:38") (SELECTQ (MKATOM MONTH) (FEB (COND ((LEAPYEARP YEAR) 29) (T 28))) ((APR JUN SEP NOV) 30) 31]) (DRAWCALENDAR [LAMBDA (CALENDARW) (* rrb " 2-May-84 18:47") (* Adds the grid numbering and messages to calendar) (PROG ((CALENDARINFO (WINDOWPROP CALENDARW (QUOTE CALENDARINFO))) (CALGRIDSPEC (WINDOWPROP CALENDARW (QUOTE CALGRIDSPEC))) ROWS GRIDWIDTH GRIDHEIGHT BOTTOM MONTH) (CLEARW CALENDARW) (* prepares the grid for the calendar) (GRID CALGRIDSPEC 7 (SETQ ROWS (fetch (CALENDARINFO WEEKROWS) of CALENDARINFO)) CALGRIDBORDER CALENDARW) (SETQ GRIDWIDTH (fetch WIDTH of CALGRIDSPEC)) (SETQ GRIDHEIGHT (fetch HEIGHT of CALGRIDSPEC)) (DSPFONT DAYNUMBERFONT CALENDARW) (* print in the numbers for the days.) (for #DAYOFWEEK from (fetch (CALENDARINFO DAYOFFIRST) of CALENDARINFO) as DATE from 1 to (fetch (CALENDARINFO #DAYS) of CALENDARINFO) do (CENTERPRINTINREGION DATE (create REGION BOTTOM ←(BOTTOMOFGRIDCOORD (SUB1 (IDIFFERENCE ROWS (IQUOTIENT #DAYOFWEEK 7))) CALGRIDSPEC) LEFT ←(LEFTOFGRIDCOORD (IREMAINDER #DAYOFWEEK 7) CALGRIDSPEC) WIDTH ← GRIDWIDTH HEIGHT ← GRIDHEIGHT) CALENDARW)) (* Now print the day headings in the top row of the calendar) (DSPFONT DAYNAMEFONT CALENDARW) (for CHAR in LISTOFDAYS as #DAYOFWEEK from 0 do (CENTERPRINTINREGION CHAR (create REGION BOTTOM ←( BOTTOMOFGRIDCOORD ROWS CALGRIDSPEC) LEFT ←( LEFTOFGRIDCOORD #DAYOFWEEK CALGRIDSPEC) WIDTH ← GRIDWIDTH HEIGHT ← GRIDHEIGHT) CALENDARW)) (* put up the scroll bars for moving to previous and following months.) (DSPFONT OTHERMONTHFONT CALENDARW) (SETQ MONTH (fetch (CALENDARINFO MONTH) of CALENDARINFO)) (for REGION in (WINDOWPROP CALENDARW (QUOTE OTHERMONTHREGIONS)) as NEARMONTH in (LIST (PREVIOUS.MONTH MONTH) (FOLLOWING.MONTH MONTH)) do (DRAWAREABOX (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 1 NIL CALENDARW) (CENTERPRINTINREGION NEARMONTH REGION CALENDARW)) (* put up month and year.) (DSPFONT MONTHNAMEFONT CALENDARW) (CENTERPRINTINREGION (CONCAT MONTH " " (fetch (CALENDARINFO YEAR) of CALENDARINFO)) (create REGION LEFT ←(LEFTOFGRIDCOORD 0 CALGRIDSPEC) BOTTOM ←(SETQ BOTTOM (BOTTOMOFGRIDCOORD (ADD1 ROWS) CALGRIDSPEC)) WIDTH ←(ITIMES 7 GRIDWIDTH) HEIGHT ←(IDIFFERENCE (WINDOWPROP CALENDARW (QUOTE HEIGHT)) BOTTOM)) CALENDARW]) (FOLLOWING.MONTH [LAMBDA (MONTH) (* rrb " 2-May-84 17:55") (* returns the following months) (for TAIL on MONTH.LIST when (EQ MONTH (CAR TAIL)) do (RETURN (COND ((CADR TAIL)) (T (CAR MONTH.LIST]) (LEAPYEARP [LAMBDA (YEAR) (* rrb " 2-May-84 19:38") (* determines if YEAR is a leap year. Uses current year if YEAR is NIL) (* assumes year is two digit number.) (AND (ZEROP (REMAINDER [SETQ YEAR (COND ((NUMBERP YEAR)) ((NULL YEAR) (MKATOM (SUBSTRING (DATE) 8 9))) (T (\ILLEGAL.ARG YEAR] 4)) (NOT (ZEROP YEAR]) (MAKE.DATE [LAMBDA (DAY MONTH YEAR) (* Newman "10-Oct-86 12:58") (* returns a date string.) [COND [(ILESSP DAY 1) (* day from previous month) (SETQ MONTH (PREVIOUS.MONTH MONTH)) [COND ((EQ MONTH (QUOTE DEC)) (SETQ YEAR (SUB1 YEAR] (SETQ DAY (IPLUS (ADD1 DAY) (DAYSIN MONTH YEAR] ((IGREATERP DAY (DAYSIN MONTH YEAR)) (* day in next month) (SETQ DAY (IDIFFERENCE DAY (DAYSIN MONTH YEAR))) (SETQ MONTH (FOLLOWING.MONTH MONTH)) (COND ((EQ MONTH (QUOTE JAN)) (SETQ YEAR (ADD1 YEAR] (CONCAT (COND ((IGEQ DAY 10) DAY) (T (CONCAT "0" DAY))) "-" MONTH "-" YEAR " 00:00:00"]) (PREVIOUS.MONTH [LAMBDA (MONTH) (* rrb " 2-May-84 17:53") (* returns the previous months) (COND ((EQ MONTH (CAR MONTH.LIST)) (CAR (LAST MONTH.LIST))) (T (for TAIL on MONTH.LIST when (EQ MONTH (CADR TAIL)) do (RETURN (CAR TAIL]) (XYTODATE [LAMBDA (WINDOW X Y) (* rrb " 2-May-84 15:33") (* Takes an x y position in grid coordinates and returns the date which corresponds to it) (PROG [(CALINFO (WINDOWPROP WINDOW (QUOTE CALENDARINFO] (RETURN (IPLUS 1 X (MINUS (fetch (CALENDARINFO DAYOFFIRST) of CALINFO)) (ITIMES (IPLUS -1 (fetch (CALENDARINFO WEEKROWS) of CALINFO) (MINUS Y)) 7]) (\CALBOXITEM [LAMBDA (COLUMN ROW GRID DSP) (* rrb " 2-May-84 20:00") (* inverts an item in a calendar displayed in DSP.) (PROG (LFT BTM WID HGHT) [COND ((REGIONP COLUMN) (* either the previous or next months.) (SETQ LFT (fetch (REGION LEFT) of COLUMN)) (SETQ BTM (fetch (REGION BOTTOM) of COLUMN)) (SETQ WID (fetch (REGION WIDTH) of COLUMN)) (SETQ HGHT (fetch (REGION HEIGHT) of COLUMN))) (T (* must be part of calendar.) (SETQ LFT (LEFTOFGRIDCOORD COLUMN GRID)) (SETQ BTM (BOTTOMOFGRIDCOORD ROW GRID)) (SETQ WID (fetch (REGION WIDTH) of GRID)) (SETQ HGHT (fetch (REGION HEIGHT) of GRID] (BITBLT NIL NIL NIL DSP (ADD1 LFT) (ADD1 BTM) (IDIFFERENCE WID 2) (IDIFFERENCE HGHT 2) (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE) (BITBLT NIL NIL NIL DSP (IPLUS LFT 2) (IPLUS BTM 2) (IDIFFERENCE WID 4) (IDIFFERENCE HGHT 4) (QUOTE TEXTURE) (QUOTE INVERT) BLACKSHADE]) (\CALINVERTITEM [LAMBDA (COLUMN ROW GRID DSP) (* rrb " 2-May-84 18:37") (* inverts an item in a calendar displayed in DSP.) (COND ((REGIONP COLUMN) (* either the previous or next months.) (DSPFILL COLUMN BLACKSHADE (QUOTE INVERT) DSP)) (T (* must be part of calendar.) (SHADEGRIDBOX COLUMN ROW BLACKSHADE (QUOTE INVERT) GRID CALGRIDBORDER DSP]) ) (RPAQQ LISTOFDAYS ("Su" "M" "Tu" "W" "Th" "F" "Sa")) (RPAQQ MONTH.LIST (JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC)) (RPAQQ CALBORDER 3) (RPAQQ CALGRIDBORDER 1) (RPAQ MONTHNAMEFONT (FONTCREATE (QUOTE GACHA) 12)) (RPAQ OTHERMONTHFONT (FONTCREATE (QUOTE GACHA) 8)) (RPAQ DAYNAMEFONT (FONTCREATE (QUOTE GACHA) 10)) (RPAQ DAYNUMBERFONT (FONTCREATE (QUOTE GACHA) 12 (QUOTE BOLD))) (DECLARE: DONTCOPY [DECLARE: EVAL@COMPILE (RECORD CALENDARINFO (MONTH YEAR #DAYS DAYOFFIRST WEEKROWS)) ] ) (PUTPROPS DATEFNS COPYRIGHT ("Xerox Corporation" 1984 1986)) (DECLARE: DONTCOPY (FILEMAP (NIL (896 20124 (BUILDCALENDAR 906 . 4810) (CALRBUTTONFN 4812 . 9418) (CENTERBLTINREGION 9420 . 10087) (DATEMENU 10089 . 10559) (DAY 10561 . 10864) (DAYOFWEEK 10866 . 11981) (DAYSIN 11983 . 12233 ) (DRAWCALENDAR 12235 . 15548) (FOLLOWING.MONTH 15550 . 15906) (LEAPYEARP 15908 . 16475) (MAKE.DATE 16477 . 17393) (PREVIOUS.MONTH 17395 . 17773) (XYTODATE 17775 . 18299) (\CALBOXITEM 18301 . 19544) ( \CALINVERTITEM 19546 . 20122))))) STOP