1 REM >Calendar3 10 REM Program Calendar 20 REM Version B1.0 30 REM Author Barry Thorpe 40 REM BEEBUG December 1988 50 REM Program subject to copyright 51 REM Modified by Douglas Ambrose March 1996 to give two 52 REM weeks beginning on Sunday per A4 page and including the 53 REM phases of the moon. Printing stops at the end of each 54 REM sheet until a fresh sheet has been inserted and a key 55 REM pressed. The original numbering is preserved and the 56 REM lines introducing the modifications do not end in zero. 57 REM Phases of the moon are calculated and stored in a file 58 REM PMOON. It is assumed that the file DATES exists. 59 REM Entries in DATES must be of the form day/month/detail, 60 REM each on a new line, and there must be an entry (dummy 61 REM if necessary) for January and for a fictitious date 62 REM following 31 December. 70 : 100 MODE7:PROCinit:ON ERROR GOTO210 110 REMREPEAT 120 RESTORE 190 130 opt%=FNmenu("CALENDAR PRINTER",nitems%,maxlen%) 140 IF opt%=1 THEN PROCdeskcal 150 IF opt%=2 THEN PROCcheckfile 160 REMUNTIL opt%=3 170 REMMODE7:*FX4 175 CLOSE#0:VDU14 180 END 190 DATA Desk calendar,Check date file,Quit 200 : 210 CLOSE#0:VDU1,27,64,3:CLS:*FX15 215 REM *FX15,0 flushes all buffers, *FX15,1 flushes current input buffer. 220 REMIF ERR=17 THEN GOTO110 ELSE REPORT:PRINT" in line ";ERL:END 221 ON ERROR OFF:VDU3:VDU14:REPORT:PRINT" in line ";ERL:END 230 : 999 DEF FNN="DIARY" 1000 DEF PROCinit 1010 dy$=" ":mn$=dy$:rec$=STRING$(100," "):line$=rec$:rec$="":line$="" 1020 DIM month$(12),daysinmonth%(12),day$(6),mstart%(12),daynum%(12) 1030 pagelen%=66:width%=132:margin%=6 1040 REMS$=" ":U$=S$+STRING$(70,"_"):dot$=S$+STRING$(70,".") 1045 S$=" ":U$=S$+STRING$(70,"_"):dot$=S$+STRING$(70,"=") 1050 DIM insert$(10),errmess$(5),dayabbr$(31) 1060 errmess$(1)="day out of range":errmess$(2)="month out of range":errmess$(3)="year out of range":errmess$(4)="printer not connected":errmess$(5)="File not found" 1070 RESTORE 1130 1080 FOR N%=1 TO 12 1090 READ month$(N%),daysinmonth%(N%) 1100 daynum%(N%)=daynum%(N%-1)+daysinmonth%(N%) 1110 NEXT 1120 FOR N%=0TO 6:READ day$(N%):NEXT 1130 DATA JANUARY,31,FEBRUARY,28,MARCH,31,APRIL,30,MAY,31,JUNE,30 1140 DATA JULY,31,AUGUST,31,SEPTEMBER,30,OCTOBER,31,NOVEMBER,30,DECEMBER,31 1150 DATA Saturday,Sunday,Monday,Tuesday,Wednesday,Thursday,Friday 1160 filechecked=FALSE:nitems%=3:maxlen%=20 1170 ENDPROC 1180 : 1190 DEF FNzeller(D%,M%,Y%) 1200 K%=(60+(100/M%))DIV100:X%=365 1210 F%=X%*Y%+D%+31*(M%-1)-INT(.4*M%+2.3)*(1-K%) 1220 F%=F%+(Y%-K%)DIV4-INT(.75*(Y%-K%)DIV100+1)+700 1230 =F%MOD 7 1240 : 1250 DEF FNleap(y%) 1260 IF y% MOD 400=0 THEN =TRUE 1270 IF y% MOD 4=0 AND y% MOD 100<>0 THEN =TRUE 1280 =FALSE 1290 : 1300 DEF FNyday(m%,d%) 1310 IF m%=1 THEN =d% 1320 LOCAL C%:tdays%=0 1330 FOR C%=1 TO m%-1 1340 tdays%=tdays%+daysinmonth%(C%) 1350 NEXT 1360 =tdays%+d% 1370 : 1380 DEF PROCtestbuffer 1390 REMREPEAT:*FX21,3 1400 probe1%=ADVAL(-4):VDU2,1,0,1,0,3:probe2%=ADVAL(-4) 1410 printerconnected=probe1%=probe2% 1413 CLS:VDU14 1414 PRINT"PRINTER ON?":C$=GET$ 1415 GOTO 1445 1420 IF NOT printerconnected THEN CLS:PRINT TAB(8,10)CHR$129 CHR$136"Please connect printer"''TAB(8)"Press Return to go on":REPEAT UNTIL GET=13 1430 REMUNTIL printerconnected 1440 REMVDU2,1,27,1,64,3 1445 IF C$="Y" VDU2,1,27,1,64,3,15 1450 ENDPROC 1460 : 1470 DEF PROCcentre(S$) 1480 PRINTTAB((39-LENS$)DIV2)S$ 1490 ENDPROC 1500 : 1510 DEF FNmenu(T$,N%,L%) 1520 LOCAL Y%,B$,S%:S%=3:VDU23,1,0;0;0;0;:VDU26:CLS 1530 FOR Y%=0 TO 1:PROCcentre(CHR$134+CHR$157+CHR$132+CHR$141+T$+" "+CHR$156):NEXT:PRINT 1540 FOR Y%=1 TO N%:PRINTTAB(0,S%*Y%+1) 1550 READ B$:PROCcentre(CHR$156+CHR$156+CHR$134+LEFT$(B$+STRING$(L%," "),L%)+CHR$156):NEXT 1560 PRINTTAB(0,24)CHR$132CHR$157CHR$135"Use up/down cursors: then Return"SPC2CHR$156;:*FX4 1 1570 Y%=1:L%=(34-L%)/2:PRINTTAB(L%,S%*Y%+2)CHR$129CHR$157 1580 REPEAT:REPEAT UNTIL GET:PRINTTAB(L%,S%*Y%+2)CHR$156CHR$156:Y%=(Y%-INKEY-42+INKEY-58+N%-1)MODN%+1:PRINTTAB(L%,S%*Y%+2)CHR$129CHR$157:UNTIL INKEY-74:*FX4 1590 VDU23,1,1;0;0;0;:=Y% 1600 : 1610 DEF PROCerror(n%) 1620 L%=LEN(errmess$(n%)) 1630 PRINT'TAB((39-L%)DIV2)CHR$129CHR$136;errmess$(n%) 1640 TIME=0:REPEAT UNTIL TIME>200 1650 PRINTTAB((39-L%)DIV2,VPOS-1)SPC(L%+2) 1660 mistake=TRUE 1670 ENDPROC 1680 : 1690 DEF PROCrepeat 1700 CLS:PRINTTAB(5,10)CHR$135CHR$157CHR$129"Repeat this routine Y/N "CHR$156; 1710 REPEAT:A$=GET$ 1720 UNTIL INSTR("YNyn",A$)>0 1730 norepeat=(INSTR("Nn",A$)>0) 1740 ENDPROC 1750 : 1760 DEF PROCdeskcal 1770 PROCtestbuffer 1780 REMREPEAT 1790 CLS:FORY%=0TO1:PROCcentre(CHR$134+CHR$157+CHR$132+CHR$141+"DESK CALENDAR "+CHR$156):NEXT 1800 VDU28,0,24,39,3 1810 PRINT''CHR$134;"Enter year required: "; 1820 REPEAT:mistake=FALSE 1830 INPUTTAB(22,2)SPC6;TAB(22,2) year% 1840 IF year%<1752 OR year%>4000 THEN PROCerror(3) 1850 UNTIL NOT mistake 1860 PRINT''CHR$131;"Enter number of first month: "; 1870 REPEAT:mistake=FALSE 1880 INPUTTAB(30,5)" "TAB(30,5) startmonth% 1890 IF startmonth%<1 OR startmonth%>12 THEN PROCerror(2) 1900 UNTIL NOT mistake 1910 PRINT''CHR$134;"Enter number of months: "; 1920 REPEAT:mistake=FALSE 1930 INPUTTAB(25,8)" "TAB(25,8) nm% 1940 IF nm%>12 THEN PROCerror(2) 1950 UNTIL NOT mistake 1955 startmonth%=startmonth%-1:IF startmonth%=0 startmonth%=12 1960 month%=startmonth%:IF FNleap(year%) THEN daysinmonth%(2)=29 1965 IF startmonth%=12 year%=year%-1 1970 day%=FNzeller(1,startmonth%,year%) 1980 REMPROConepersheet 1985 CLS:PROCmoon:PROConepersheet 1990 REMVDU26,12:PROCrepeat 1995 VDU26,12 2000 daysinmonth%(2)=28 2010 REMUNTIL norepeat 2020 ENDPROC 2030 : 2040 DEF PROConepersheet 2042 REM rday%, rmonth% - date for entry from file DATES 2044 REM month%=startmonth%; nm%=number of months 2046 REM day%=day of week, 0 (Saturday) to 6 (Friday); dy%=day of month 2048 REM bhd%=date of bankholiday; bhm%=month of bank holiday 2050 PROCcalc_hols(year%) 2055 PRINT"Calculating holidays":GOTO 2095 2060 PRINT''CHR$131;"Is the text file DATES available?"; 2070 REPEAT:A$=GET$:UNTIL INSTR("YyNn",A$):inserts=INSTR("Yy",A$)>0 2080 IF inserts AND NOT filechecked THEN PRINT'CHR$129 "File not checked: OK? ";:REPEAT:A$=GET$:UNTIL INSTR("YNyn",A$):IF INSTR("Nn",A$) THEN ENDPROC 2090 IF inserts THEN X=OPENUP"DATES":REPEAT PROCgetdaterec:UNTIL rmonth%>=month% 2095 inserts=TRUE:X=OPENUP"DATES":REPEAT PROCgetdaterec:UNTIL rmonth%>=month% 2096 file%=OPENUP"PMOON":REPEAT PROCreadmoon:UNTIL mmonth%=month% 2100 IF month%=1 THEN I%=0 ELSE PROCfindstartofhols 2105 REM I% is the number, 1 to 9 of bankholiday 2110 PROCnextbankholiday 2112 PROCdiscard 2115 IF startmonth%=12 REPEAT PROCgetdaterec:UNTIL rmonth%=month% 2116 PROCcalc_hols(year%):IF month%=1 THEN I%=0 ELSE PROCfindstartofhols 2118 PROCnextbankholiday 2119 REPEAT:PROCreadmoon:UNTIL mmonth%=month% 2120 REMVDU2,1,27,1,69 2130 FOR m%=1 TO nm% 2140 REMT%=39-LEN(month$(month%))DIV2:PRINT SPC(T%);month$(month%)" ";year%' 2145 PROCprintmonth 2150 FOR dy%=1 TO daysinmonth%(month%) 2160 PRINT SPC(margin%);LEFT$(day$(day%),3);SPC(2+(dy%>9));dy%;SPC(2); 2170 IF bhd%=dy% AND bhm%=month% THEN PRINT bh$;:PROCnextbankholiday 2180 IF inserts THEN PROCinsertrec ELSE PRINT 2182 PROCinsertmoon 2185 PRINT:B%=B%+1 2190 REMPRINT U$ 2195 IF day%=1 PRINT dot$ ELSE PRINT U$ 2200 day%=day%+1:IF day%=7 THEN day%=0 2207 IF B%=14 A=GET:B%=0:PROCprintmonth 2210 NEXT dy% 2220 REML1%=pagelen%-(daysinmonth%(month%)*2+2) 2230 REMFOR K%=1 TO L1%:PRINT:NEXT 2240 month%=month%+1:IF month%=13 THEN month%=1:year%=year%+1:PROCcalc_hols(year%):I%=0:PROCnextbankholiday 2250 NEXT m% 2255 PROCgather 2260 REMIF inserts THEN CLOSE#X 2265 CLOSE#X:VDU 1,27,1,64,3 2270 daysinmonth%(2)=28 2280 ENDPROC 2290 : 2300 DEF PROCgetdaterec 2310 rec$="":A%=BGET#X:IF A%=ASC"|" THEN CLOSE#X:inserts=FALSE:ENDPROC 2320 REPEAT 2330 rec$=rec$+CHR$(A%):A%=BGET#X 2340 UNTIL A%=13 2350 line$=rec$ 2360 slash%=INSTR(rec$,"/"):IF slash%=0 THEN rec$="":ENDPROC 2370 rday%=VAL(LEFT$(rec$,slash%-1)):ms%=slash%+1:slash%=INSTR(rec$,"/",ms%):IF slash%=0 THEN rec$="":ENDPROC 2380 rmonth%=VAL(MID$(rec$,ms%,slash%-ms%)):rec$=MID$(rec$,slash%+1) 2390 ENDPROC 2400 : 2401 DEF PROCprintmonth 2402 T%=39-LEN(month$(month%))DIV2:PRINT SPC(T%);month$(month%)" ";year% 2403 ENDPROC 2404 2410 DEF PROCinsertrec 2420 IF dy%=rday% AND month%=rmonth% THEN VDU1,27,1,70,1,15:PRINT " ";LEFT$(rec$,70):VDU1,18,1,27,1,69:PROCgetdaterec:ENDPROC 2430 PRINT 2440 ENDPROC 2450 : 2460 DEF PROCfindeasterin(X) 2470 A=X-19*INT(X/19):B=INT(X/100) 2480 C=X-100*B:D=INT(B/4) 2490 E=B-4*D:G=INT((8*B+13)/25) 2500 F=19*A+B-D-G+15:Z1=INT(F/30) 2510 H=F-30*Z1:M=INT((A+11*H)/319) 2520 I=INT(C/4):K=C-4*I 2530 Q=2*E+2*I-K-H+M+32 2540 Z2=INT(Q/7):L=Q-7*Z2 2550 R=H-M+L+90:M%=R/25 2560 Z3=INT((H-M+L+M%+19)/32) 2570 D%=H-M+L+M%+19-32*Z3 2580 ENDPROC 2590 : 2600 DEF PROCcalc_hols(Y%) 2610 daysinmonth%(2)=28-FNleap(Y%) 2620 LOCAL m%,M%,d%,D% 2630 d%=FNzeller(1,1,Y%) 2640 IF d%>1 THEN dy$="1" ELSE dy$=STR$(3-d%) 2650 insert$(1)="0"+dy$+"01Bank Holiday" 2660 PROCfindeasterin(Y%) 2670 insert$(3)=RIGHT$("0"+STR$(D%),2)+"0"+STR$(M%)+"Easter Day" 2680 m%=M%:d%=D%-2:IF d%<1 THEN d%=d%+31:m%=M%-1 2690 insert$(2)=RIGHT$("0"+STR$(d%),2)+"0"+STR$(m%)+"Good Friday - b.h." 2700 m%=M%:d%=D%+1:IF d%>31 THEN d%=1:m%=m%+1 2710 insert$(4)=RIGHT$("0"+STR$(d%),2)+"0"+STR$(m%)+"Bank Holiday" 2720 d%=FNzeller(1,5,Y%):C%=1 2730 IF d%<>2 THEN REPEAT:d%=d%+1:C%=C%+1:d%=ABS(d%<7)*d%:UNTIL d%=2 2740 insert$(5)="0"+STR$(C%)+"05Bank Holiday" 2750 d%=FNzeller(31,5,Y%):C%=31 2760 IF d%<>2 THEN REPEAT:d%=d%-1:C%=C%-1:d%=ABS(d%<0)*7+d%:UNTIL d%=2 2770 insert$(6)=STR$(C%)+"05Bank Holiday" 2780 d%=FNzeller(31,8,Y%):C%=31 2790 IF d%<>2 THEN REPEAT:d%=d%-1:C%=C%-1:d%=ABS(d%<0)*7+d%:UNTIL d%=2 2800 insert$(7)=STR$(C%)+"08Bank Holiday" 2810 d%=FNzeller(25,12,Y%):C%=1 2820 insert$(8)="2512Christmas Day" 2830 d%=FNzeller(26,12,Y%) 2840 IF d%>2 THEN insert$(9)="2612Bank Holiday" ELSE insert$(9)=STR$(26+2-d%)+"12Bank Holiday" 2850 ENDPROC 2860 : 2870 DEF PROCnextbankholiday 2880 I%=I%+1 2890 bhd%=VAL(LEFT$(insert$(I%),2)) 2900 bhm%=VAL(MID$(insert$(I%),3,2)) 2910 bh$=" "+MID$(insert$(I%),5) 2920 ENDPROC 2930 : 2940 DEF PROCfindstartofhols 2950 I%=0:REPEAT:I%=I%+1:UNTIL VAL(MID$(insert$(I%),3,2))>=month% 2960 I%=I%-1 2970 ENDPROC 2980 : 2990 DEF PROCcheckfile 3000 CLS:inserts=TRUE:pyd%=0 3010 errcount%=0:numentries%=0 3020 X=OPENUP"DATES" 3030 IF X=0 THEN PROCerror(5):ENDPROC 3040 PRINT"ERRORS IN DATES"' 3050 PROCgetdaterec 3060 REPEAT 3070 numentries%=numentries%+1 3080 IF rec$="" THEN errcount%=errcount%+1:PRINT;numentries% SPC(3) line$ ELSE PROCchecksequence 3090 IF error THEN errcount%=errcount%+1:PRINT;numentries% SPC(3) line$ " >> out of sequence" 3100 pyd%=yd% 3110 PROCgetdaterec 3120 UNTIL NOT inserts 3130 PRINT';errcount%;" errors detected" 3135 filechecked=(errcount%=0) 3150 ENDPROC 3160 : 3170 DEF PROCchecksequence 3180 error=FALSE 3190 IF rmonth%<1 OR rmonth%>12 THEN error=TRUE:ENDPROC 3200 IF rday%<1 OR rday%>daysinmonth%(rmonth%) THEN error=TRUE:ENDPROC 3210 yd%=FNyday(rmonth%,rday%) 3220 IF yd%<=pyd% THEN error=TRUE 3230 REM unless, of course, the calendar crosses the new year 3240 ENDPROC 3250 3260 DEF PROCdiscard 3270 B%=0:PRINT"Discarding preceding month" 3280 FOR dy%=1 TO daysinmonth%(month%) 3290 PRINT SPC(margin%);LEFT$(day$(day%),3);SPC(2+(dy%>9));dy%;SPC(2); 3300 IF bhd%=dy% AND bhm%=month% THEN PRINT bh$;:PROCnextbankholiday 3310 IF inserts THEN PROCinsertrec ELSE PRINT 3315 PROCinsertmoon 3320 PRINT::B%=B%+1 3330 IF day%=1 OR day%=6 PRINT dot$ ELSE PRINT U$ 3340 day%=day%+1:IF day%=7 THEN day%=0 3350 D%=daysinmonth%(month%) 3360 REMIF D%-dy%<=14 AND day%=1 AND B%>8 PRINT "Now we start":B%=0:A=GET 3370 IF D%-dy%<=6 AND day%=1 PRINT "Now we start: insert paper":B%=0:A=GET 3380 IF C$="Y" AND B%=0 VDU2,1,27,1,69 3390 IF dy%9));dy%;SPC(2); 3490 IF bhd%=dy% AND bhm%=month%-1 THEN PRINT bh$;:PROCnextbankholiday 3500 IF inserts THEN PROCinsertrec ELSE PRINT 3505 PROCinsertmoon 3510 PRINT 3520 IF day%=1 OR day%=6 PRINT dot$ ELSE PRINT U$ 3530 day%=day%+1:IF day%=7 day%=0 3540 IF day%=1 A=GET:ENDPROC 3550 NEXT dy% 3560 ENDPROC 3570 4000 DEF PROCmoon 4005 PRINT"Calculating phases of the moon" 4010 DIM phase$(4) 4020 phase$(1)="new moon":phase$(2)="first quarter" 4030 phase$(3)="full moon":phase$(4)="last quarter" 4040 file%=OPENOUT"PMOON" 4050 tzone=0 4060 IM%=startmonth%:ID%=1:IY%=year% 4070 timzon=-tzone/24 4080 N%=INT(12.37*(IY%-1900+(IM%-.5)/12)) 4090 nphase%=2 4100 PROCjulday(IM%,ID%,IY%) 4110 J1%=JD% 4120 PROCflmoon(N%,nphase%) 4130 N%=INT(N%+(J1%-JD%)/28) 4140 FOR J%=1 TO 7*(nm%+1) 4150 PROCflmoon(N%,nphase%) 4160 ifrac%=INT((24*(frac+timzon))+.5) 4170 IF ifrac%<0 JD%=JD%-1:ifrac%=ifrac%+24 4180 IF ifrac%>=12 JD%=JD%+1:ifrac%=ifrac%-12 ELSE ifrac%=ifrac%+12 4190 PROCcaldat(JD%) 4200 REM PRINT OD%,OM%,ifrac%,phase$(nphase%+1) 4210 PRINT#file%, OD%,OM%,ifrac%,phase$(nphase%+1) 4220 IF nphase%=3 nphase%=0:N%=N%+1 ELSE nphase%=nphase%+1 4230 NEXT J% 4240 CLOSE#file% 4250 ENDPROC 4260 4270 DEF PROCflmoon(N%,nphase%) 4280 C=N%+nphase%/4 4290 T=C/1236.85 4300 T2=T^2 4310 AQ=359.2242+29.105366*C 4320 AM=306.0253+385.816918*C+.01073*T2 4330 JD%=2415020+28*N%+7*nphase% 4340 xtra=.75933+1.53058868*C+(.0001178-1.55E-7*T)*T2 4350 IF nphase%=0 OR nphase%=2 xtra=xtra+(.1734-.000393*T)*SIN(RAD(AQ))-.4068*SIN(RAD(AM)) 4360 IF nphase%=1 OR nphase%=3 xtra=xtra+(.1721-.0004*T)*SIN(RAD(AQ))-.628*SIN(RAD(AM)) 4370 IF xtra>=0 I%=INT(xtra) ELSE I%=INT(xtra-1) 4380 JD%=JD%+I% 4390 frac=xtra-I% 4400 ENDPROC 4410 4420 DEF PROCjulday(MM%,ID%,IY%) 4430 igreg%=588829 4440 IF IY%<0 IY%=IY%+1 4450 IF MM%>2 JY%=IY%:JM%=MM%+1:ELSE JY%=IY%-1:JM%=MM%+13 4460 JD%=INT(365.25*JY%)+INT(30.6001*JM%)+ID%+1720995 4470 IF ID%+31*(MM%+12*IY%)>=igreg% JA%=INT(.01*JY%):JD%=JD%+2-JA%+INT(.25*JA%) 4480 ENDPROC 4490 4500 DEF PROCcaldat(JD%) 4510 igreg%=2299161 4520 IF JD%>=igreg% jalpha%=INT(((JD%-1867216)-.25)/36524.25): JA%=JD%+1+jalpha%-INT(.25*jalpha%) ELSE JA%=JD% 4530 JB%=JA%+1524 4540 JC%=INT(6680+((JB%-2439870)-122.1)/365.25) 4550 JD%=365*JC%+INT(.25*JC%) 4560 JE%=INT((JB%-JD%)/30.6001) 4570 OD%=JB%-JD%-INT(30.6001*JE%) 4580 OM%=JE%-1 4590 IF OM%>12 OM%=OM%-12 4600 OY%=JC%-4715 4610 IF OM%>2 OY%=OY%-1 4620 IF OY%<=0 OY%=OY%-1 4630 ENDPROC 4640 4650 DEF PROCreadmoon 4660 INPUT#file%,mday%,mmonth%,ifrac%,phase$ 4670 ENDPROC 4680 4690 DEF PROCinsertmoon 4700 IF dy%=mday% AND month%=mmonth% THEN VDU1,27,1,70,1,15:PRINT phase$:VDU1,18,1,27,1,69:PROCreadmoon:ENDPROC 4710 PRINT:ENDPROC