'=========================================================================== ' Subject: PERPETUAL CALENDAR Date: 11-02-97 (04:12) ' Author: Andrew S. Gibson Code: QB, QBasic, PDS ' Origin: zapf_dingbat@juno.com Packet: DATETIME.ABC '=========================================================================== 'This perpetual calendar program was taken out of an old issue 'of TRS-80 MicroComputer News. I typed it in and adjusted it to 'work properly with PCs (text formatting problems..) 'I believe all major basic languages can use this code. 'Despite its size Auto Calendar *is* accurate even in leap years ! 'Also it 'sports' moving holidays ! 'Remeber if you have an Internet Connection or E-mail you can contact 'me at Zapf_DinBat@JUNO.COM. My real name is Andrew Gibson, Although 'I didn't write the code you'll probably find a working 'true Perpetual Calendar very useful every day. ' MM represents a month (numbers 1-12) ' DD represents a day (numbers 1-31) ' YY represents the year (only the last two digits i.e. 1/98) ' YYYY the full year, i.e. 1/1998 ' Typing in a specific day such as 1/25/98 (or 1/25/1998) with ' cause the program to calculate the julian date. ' The only valid separation character is the foward slash (/). 10 DEFSNG A-Z: '<-Don't change ! / Auto Calendar Version 1.6 20 'WIDTH 40, 25: 'uncomment this so you can strain your eyes :} 30 CY$ = RIGHT$(DATE$, 4) ' EXTRACT CURRENT YEAR FROM SYSTEM CLOCK 40 YR$ = CY$ 50 DIM HOL$(31) 60 ED = 99: LM = 31 70 PRINT : 'NEVER ALTER LINES 71-110 71 MH$ = "0414040303230411033104180408032804160405032504130402032204100330041704070327" 80 DY$ = "000031059090120151181212243273304334" 90 MN$ = "JANUARY FEBRUARY MARCH APRIL MAY JUNE JULY AUGUST SEPTEMBEROCTOBER NOVEMBER DECEMBER" 100 AD$ = "SUNDAY MONDAY TUESDAY WEDNESDAY THURSDAY FRIDAY SATURDAY" 110 DZ$ = " SUN MON TUE WED THU FRI SAT " 120 CLS 130 PRINT : PRINT : PRINT 140 PRINT TAB(11); "PERPETUAL CALENDAR" 150 PRINT TAB(14); "VERSION 1.6": PRINT 160 PRINT TAB(5); " ENTER A DATE (YEARS 1753- )" 170 PRINT TAB(6); "(FORMATS: MM/DD, MM/DD/YYYY," 180 PRINT TAB(6); " MM/DD/YY, MM/YYY, OR JUST MM)" 190 PRINT 200 PRINT TAB(10); "ENTER DATE OR END"; : INPUT DT$ 210 LL = LEN(DT$) 220 IF UCASE$(DT$) = "END" THEN WIDTH 80, 25: END 230 IF LL = 0 THEN 120 240 P1 = INSTR(1, DT$, "/"): P2 = INSTR(P1 + 1, DT$, "/") 250 IF P1 = 0 THEN MO = VAL(DT$): DA = 1: GOTO 320 260 MO = VAL(LEFT$(DT$, P1 - 1)) 270 IF P2 = 0 THEN 310 280 DA = VAL(MID$(DT$, P1 + 1, (P2 - 1) - P1)) 290 IF LL - P2 > 3 THEN YR$ = RIGHT$(DT$, 4) ELSE YR$ = STR$(VAL("19" + RIGHT$(DT$, 2))) 300 GOTO 320 310 IF LL - P1 > 3 THEN YR$ = RIGHT$(DT$, 4): DA = 1 ELSE YR$ = CY$: DA = VAL(RIGHT$(DT$, LL - P1)) 320 YR = VAL(YR$) 330 IF LL < 5 AND YR$ = CY$ AND MO < 1 THEN YR = YR + 1: YR$ = LTRIM$(STR$(YR)) 340 IF YR < 1753 AND SW = 0 THEN GOSUB 1200 350 IF MO > 12 OR MO < 1 THEN DA = 1: GOTO 1140 360 IF DA < 1 THEN 1140 370 LP = 0 380 IF (YR / 100 - INT(YR / 100)) = 0 THEN I = INT(YR / 400) * 400 ELSE I = INT(YR / 4) * 4 390 IF I = YR THEN LP = 1 400 LD = 365 + LP 410 IF MO = 2 THEN 450 420 IF MO = 4 OR MO = 6 OR MO = 9 OR MO = 11 THEN 480 430 IF DA > 31 THEN YR$ = STR$(VAL("19" + STR$(DA))) 440 LM = 31: GOTO 500 450 LM = 28 + LP 460 IF DA > LM THEN 1140 470 GOTO 500 480 LM = 30 490 IF DA > LM THEN 1140 500 IF MO < 3 THEN LP = 0 510 N = MO * 3 520 JUL = VAL(MID$(DY$, N - 2, 3)) 530 JUL = JUL + DA + LP 540 N = MO * 9 550 PM$ = MID$(MN$, N - 8, 9) 560 DT = YR + INT((YR - 1) / 4) - INT((YR - 1701) / 100) + INT((YR - 1601) / 400) + JUL 570 IF P1 = 0 OR (P2 = 0 AND LL > 5) THEN 710 580 IF DA > 31 THEN 710 590 DW = (DT / 7): WKDY = INT((DW - INT(DW)) * 7 + .5) 600 O1 = WKDY * 10 + 1 610 WKDY$ = MID$(AD$, O1, 10) 620 CLS : PRINT : PRINT : PRINT 630 PRINT TAB(6); "THE DATE "; DT$; " = "; WKDY$ 640 IF LL > 5 THEN 650 650 PRINT : JD$ = LTRIM$(YR$) + "." + LTRIM$(STR$(JUL)) 660 PRINT TAB(6); " THE JULIAN DATE = "; JD$ 670 PRINT : PRINT : PRINT TAB(6); "WOULD YOU LIKE TO SEE" 680 PRINT TAB(6); "THE WHOLE MONTH? (Y OR N) "; : INPUT R$ 690 IF UCASE$(R$) = "Y" THEN 710 700 IF UCASE$(R$) = "N" THEN 120 ELSE DT$ = R$: GOTO 210 710 DD = 0: HS = 0 720 MS = (DT - (DA - 1)) / 7 730 D1 = INT((MS - INT(MS)) * 7 + .5) 740 CLS 750 PRINT TAB(8); PM$; TAB(18); LTRIM$(YR$) 760 PRINT 770 PRINT DZ$ 780 GOSUB 1010 790 PL$ = "" 800 FOR WK = 1 TO 7 810 IF DD = D1 THEN DP = 1 820 IF DP < 10 THEN DP$ = " " + STR$(DP) ELSE DP$ = " " + STR$(DP) 830 IF DP = 0 THEN DP$ = " " 840 HS = 1: IF HOL$(DP) <> "" THEN DP$ = " **" 850 IF HOL$(DP) <> "" THEN DP$ = " " + DP$ 860 PL$ = PL$ + DP$ 870 DD = DD + 1 880 IF DP <> 0 THEN DP = DP + 1 890 IF DP > LM THEN DP = 0: DP$ = "" 900 NEXT WK 910 PRINT PL$ 920 IF DP = 0 THEN 940 930 GOTO 790 940 PRINT 950 GOTO 1280 970 DT$ = R$: GOTO 210 980 IF HOL$(DP) <> "" THEN HOL$(DP) = "EASTER SUNDAY" + CHR$(13) + " & " + HOL$(DP) ELSE HOL$(DP) = "EASTER SUNDAY" 990 ED = 99 1000 RETURN 1010 'SET MONTHS HOLIDAYS 1020 GOSUB 1880 1030 GOSUB 1480 1040 RESTORE 1050 READ HDT$, HOL$ 1060 IF HDT$ = "END" THEN RETURN 1070 MT = VAL(LEFT$(HDT$, 2)) 1080 IF LEN(HDT$) > 5 AND YR <> VAL(RIGHT$(HDT$, 4)) THEN 1050 1090 IF MT <> MO THEN 1050 1100 HDT$ = LEFT$(HDT$, 5) 1110 DX = VAL(RIGHT$(HDT$, 2)) 1120 IF HOL$(DX) = "" THEN HOL$(DX) = HOL$ ELSE HOL$(DX) = HOL$(DX) + CHR$(13) + " & " + HOL$ 1130 GOTO 1050 1140 CLS : LOCATE 10, 14: PRINT "INVALID DATE" 1150 IF DA > LM THEN PRINT TAB(8); "FORMATS ARE:MM/YYYY OR MM/DD ": PRINT TAB(13); " - NOT MM/YY!" 1160 S9 = 1 1170 Period! = 2: GOSUB 1921 1180 IF DA > LM AND S9 < 2 THEN S9 = S9 + 1: GOTO 1170 1190 GOTO 120 1200 'TOO OLD 1210 CLS : LOCATE 2, 12: PRINT "*** CAUTION ***" 1220 PRINT : PRINT : PRINT ; "OUR PRESENT CALENDAR WAS ADOPTED IN 1753- ACCURACY FOR DATES EARLIER THAN 1753" 1230 PRINT "MAY REQUIRE CONVERSION." 1240 PRINT : PRINT TAB(1); "*(MOST DATES IN AMERICAN HISTORY HAVE ALREADY BEEN CONVERTED)" 1250 PRINT : PRINT : PRINT TAB(3); "PRESS TO CONTINUE "; : INPUT R$ 1260 SW = 1 1270 RETURN 1280 ' PRINT HOLIDAYS 1290 IF HS = 0 THEN 1460 1300 PRINT " IMPORTANT DATE(S) IN "; PM$ 1310 PRINT STRING$(30, "*") 1320 FOR H = 1 TO LM 1330 IF HOL$(H) = "" THEN 1350 1340 PRINT H; TAB(5); HOL$(H) 1350 NEXT H 1360 PRINT ""; 1370 R$ = "": PRINT : PRINT "ENTER DATE OR FOR NEXT MONTH "; : PRINT 1380 PRINT "NEXT DATE OR END "; : INPUT R$ 1390 X = 3 1400 FOR I = 1 TO X: PRINT : NEXT 1410 IF R$ = "" THEN DT$ = STR$(VAL(DT$) + 1): MO = MO + 1 1420 IF MO = 13 THEN MO = 1 1430 IF VAL(DT$) = 13 THEN DT$ = STR$(1): YR$ = STR$((VAL(YR$) + 1)) 1440 IF R$ = "" THEN GOTO 210 1450 DT$ = R$: GOTO 210 1460 PRINT " NO HOLIDAYS, BIRTHDAYS, OR ANYTHING AT ALL IN"; PM$ 1470 GOTO 1360 1480 'MOVABLE HOLIDAYS 1490 ON MO GOSUB 1500, 1510, 1780, 1780, 1540, 1630, 1500, 1500, 1670, 1750, 1700, 1500 1500 RETURN 1510 IF D1 < 2 THEN HX = 16 - D1 ELSE HX = 23 - D1 1520 HOL$(HX) = "WASHINGTON'S BIRTHDAY" 1530 RETURN 1540 HX = 15 - D1 1550 IF D1 = 0 THEN HX = 8 1560 HOL$(HX) = "MOTHER'S DAY" 1570 HX = 30 - D1 1580 IF D1 = 6 THEN HX = 31 1590 HOL$(HX) = "MEMORIAL DAY **" 1600 HX = 21 - D1 1610 HOL$(HX) = "ARMED FORCES DAY" 1620 RETURN 1630 HX = 22 - D1 1640 IF D1 = 0 THEN HX = 15 1650 HOL$(HX) = "FATHER'S DAY" 1660 RETURN 1670 IF D1 < 2 THEN HX = 2 - D1 ELSE HX = 9 - D1 1680 HOL$(HX) = "LABOR DAY **" 1690 RETURN 1700 IF D1 < 2 THEN HX = 3 - D1 ELSE HX = 10 - D1 1710 HOL$(HX) = "ELECTION DAY" 1720 IF D1 > 4 THEN HX = 33 - D1 ELSE HX = 26 - D1 1730 HOL$(HX) = "THANKSGIVING DAY **" 1740 RETURN 1750 IF D1 < 2 THEN HX = 9 - D1 ELSE HX = 16 - D1 1760 HOL$(HX) = "COLUMBUS DAY" 1770 RETURN 1780 'EASTER SUNDAY 1790 FM = YR / 19 1800 PFM = INT((FM - INT(FM)) * 19 + .5) 1810 PX = PFM * 4 + 1 1820 PFM$ = MID$(MH$, PX, 4) 1830 EM = VAL(LEFT$(PFM$, 2)): EH = VAL(RIGHT$(PFM$, 2)) 1840 IF EM = MO THEN ED = EH ELSE ED = 99 1850 D2 = D1: IF D2 = 0 THEN D2 = 7 1860 IF EM = 3 AND M0 = 4 AND EH > 31 - D1 THEN ED = 0 1870 RETURN 1880 ' CLEAR HOLIDAYS 1890 FOR IX = 1 TO 31 1900 HOL$(IX) = "" 1910 NEXT 1920 RETURN 1921 BEGIN! = TIMER 'Delay 1922 DO UNTIL (TIMER - BEGIN! > Period!) OR (TIMER - BEGIN! < 0) 1923 LOOP 1924 RETURN 1930 'add any fixed day holidays here. 1940 DATA 01/01, NEW YEARS DAY ** 1941 DATA 02/12, LINCOLN'S BIRTHDAY 1942 DATA 02/14, VALENTINE'S DAY 1943 DATA 03/17, ST. PATRICK'S DAY 1944 DATA 03/20, FIRST DAY OF SPRING 1950 DATA 04/15, INCOME TAXES DUE !!! 1951 DATA 06/14, FLAG DAY 1952 DATA 06/21, FIRST DAY OF SUMMER 1960 DATA 07/04, INDEPENDENCE DAY 1961 DATA 09/22, FIRST DAY OF AUTUMN 2020 DATA 10/31, HALLOWEEN 2030 DATA 11/11, VETERAN'S DAY 2070 DATA 12/07, PEARL HABOR DAY 2080 DATA 12/21, FIRST DAY OF WINTER 2081 DATA 12/25, CHRISTMAS DAY ** ' DON'T change then following line at all ! 2090 DATA END, ***