0010 ! CALNDR - a calendar program
0020 ! Version 1.1  27 December 1986
0030 ! Dennis R. Kolpanen [346]
0040 !
0050 ! outputs calendar for a year on ThinkJet printer
0060 ! RPT$ from STRINGLX is used - can be replaced with a loop if not availabl
0070 !
0080 ! Note: This routine is by no means elegant.  It works and it's only
0090 ! really needed once a year.
0100 !
0110 CALL CALNDR @ SUB CALNDR
0120 ! dimension what is needed
0130 DIM F$[16] ! saved system flags
0140 DIM W$[2] ! saved printer width
0150 ! save system flags and printer width - change a few things
0160 F$=PEEK$("2F6D9",16) @ W$=PEEK$("2F958",2)
0170 OPTION BASE 1 @ PWIDTH INF @ STD
0180 DIM C(24,21) ! array for dates - 3 months across by 4 months down
0190 ! 3 * 7 days/week = 21 columns
0200 ! 4 * 6 (maximim rows/month) = 24 rows
0210 DIM D(12) ! days per month
0220 DIM O$[80] ! output buffer
0230 DIM L(21) ! location of columns on calendar
0240 DIM H$[20] ! column headings - days of week
0250 DIM M$(12)[9] ! names of months
0260 DIM Y$[4] ! the year as a string
0270 REAL Y ! year for the calendar
0280 REAL P ! pointer for day of week
0290 REAL K9 ! number of copies
0300 REAL I1 ! row pointer
0310 REAL I2 ! column pointer
0320 REAL K8 ! pointer to number of current copy
0330 REAL K ! month pointer
0340 REAL J1 ! row pointer for next day
0350 REAL J2 ! column pointer for next day
0360 REAL I3 ! loop counter for filling month
0370 REAL N ! pointer to first month in row & output pointer in O$
0380 REAL T ! value of current day
0390 !
0400 INPUT " CALNDR: Calendar Year? ",STR$(IP(DATE/1000+1900));Y
0410 INPUT " Number of copies? ","1";K9
0420 !
0430 FOR I=1 TO 12 @ READ D(I) @ NEXT I
0440 DATA 31,28,31,30,31,30,31,31,30,31,30,31
0450 IF MOD(Y,4)=0 THEN D(2)=29 ! check for leap years
0460 IF MOD(Y,400)=0 THEN D(2)=28
0470 FOR I=1 TO 21 @ READ L(I) @ NEXT I
0480 DATA 5,8,11,14,17,20,23,31,34,37,40,43,46,49,57,60,63,66,69,72,75
0490 H$="Su Mo Tu We Th Fr Sa"
0500 FOR I=1 TO 12 @ READ M$(I) @ NEXT I
0510 DATA January,February,March
0520 DATA April,May,June
0530 DATA July,August,September
0540 DATA October,November,December
0550 !
0560 CALL SDOW(Y,P) ! DOW for Jan 1
0570 K=1
0580 ! fill in the months one row at a time
0590 FOR I1=1 TO 19 STEP 6
0600 FOR I2=1 TO 15 STEP 7
0610 GOSUB 'FILL'
0620 NEXT I2
0630 NEXT I1
0640 !
0650 FOR K8=1 TO K9 @ GOSUB 'PRNT' @ NEXT K8
0660 ! restore everything to the way it was
0670 POKE "2F6D9",F$ @ POKE "2F958",W$ @ END
0680 !
0690 'FILL': ! places dates for month into C
0700 J1=I1 @ J2=I2+P
0710 FOR I3=1 TO D(K)
0720 IF J2<=I2+6 THEN 740
0730 J2=I2 @ J1=J1+1 @ P=0
0740 C(J1,J2)=I3
0750 P=P+1 @ J2=J2+1
0760 NEXT I3
0770 K=K+1 @ IF P>6 THEN P=0
0780 RETURN
0790 !
0800 'NAMES': ! prints month names
0810 DEF FNT(A$)=(20-LEN(A$))/2 ! offset to center month name
0820 PRINT
0830 PRINT CHR$(14) ! bold
0840 N=IP(I1/6)*3+1
0850 PRINT TAB(L(1)+FNT(M$(N)));M$(N);
0860 PRINT TAB(L(8)+FNT(M$(N+1)));M$(N+1);
0870 PRINT TAB(L(15)+FNT(M$(N+2)));M$(N+2);CHR$(15) ! and back to normal
0880 RETURN
0890 !
0900 'PRNT': ! prints the calendar
0910 Y$=STR$(Y)
0920 FOR I=1 TO 8 @ PRINT @ NEXT I
0930 ! print the year centered,bold,expanded and then return to normal
0940 PRINT TAB(37);CHR$(27)&"&k1S";CHR$(14);Y$;CHR$(15);CHR$(27)&"&k0S"
0950 FOR I1=1 TO 24
0960 IF MOD(I1,6)#1 THEN 990 ! start of a new month row?
0970 GOSUB 'NAMES'
0980 PRINT TAB(L(1));H$;TAB(L(8));H$;TAB(L(15));H$
0990 O$=RPT$(" ",80)
1000 FOR I2=1 TO 21
1010 N=L(I2)
1020 T=C(I1,I2) ! remember it's zero if empty
1030 IF T>0 AND T<10 THEN O$[N+1]=STR$(T)
1040 IF T>9 THEN O$[N,N+1]=STR$(T)
1050 NEXT I2
1060 PRINT O$
1070 NEXT I1
1080 PRINT CHR$(12); ! a form feed
1090 RETURN
1100 !
1110 ! SDOW returnes the starting day of week
1120 ! It's a slight rewrite of DOW from the HP Utilities book
1130 SUB SDOW(Y,P)
1140 CALL JULIAN(Y*10000+101,J)
1150 P=RMD(RMD(J,7)+1,7)
1160 END SUB
1170 !
1180 SUB JULIAN(D,J) ! also from Utilities book
1190 B=D<0
1200 M=MOD(ABS(D),10000) DIV 100
1210 Y=D DIV 10000+B
1220 IF M<3 THEN M=M+12 @ Y=Y-1
1230 D0=RMD(ABS(D),100)
1240 J=IP(365.25*Y-B*.75)+IP(30.6001*(M+1))+D0+1720995
1250 IF D>15821004 THEN J=J-Y DIV 100+Y DIV 400+2
1260 END SUB