home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol147 / calendr5.bas < prev    next >
Encoding:
BASIC Source File  |  1984-04-29  |  5.6 KB  |  157 lines
  1. 10 PRINT
  2. 20 PRINT "****************************"
  3. 30 PRINT "*  THE GREGORIAN CALENDR1  *"
  4. 40 PRINT "*                          *"
  5. 50 PRINT "****************************"
  6. 60 REM
  7. 70  REM      Original program obtained from CP/Mug.
  8. 80  REM   Program adapted to read the TP-100 TimEPROMmer card
  9. 90  REM   from Optronics Technology, 2990 Atlantic Avenue,
  10. 100 REM   Penfield, NY 14526, and to compute astronomical "Julian 
  11. 110 REM   Date," by D. Mc Lanahan, Box 17, Marlow, NH 03456.
  12. 120 REM   Program computes day-of-week and ignores TP-100 d-o-w.
  13. 130 REM
  14. 140 DIM M$(12),D$(6),TIME(6)
  15. 150 P=40 :  REM: P is the base location of the TimEPROMmer card.
  16. 160 P1=P+1
  17. 170 DATA January,February,March,April,May,June,July,August
  18. 180 DATA September,October,November,December
  19. 190 FOR A=1 TO 12:READ M$(A):NEXT A
  20. 200 DATA Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday
  21. 210 FOR A=0 TO 6:READ D$(A):NEXT A
  22. 220 DEF FND(V)=INT(7*(V/7-INT(V/7))+.05)
  23. 230 PRINT:PRINT
  24. 240 PRINT "The Routines:":PRINT
  25. 250 PRINT "     1.   Print a calendar"
  26. 260 PRINT "     2.   Day of the week"
  27. 270 PRINT "     3.   Days between dates"
  28. 280 PRINT "     4.   Date before or after"
  29. 290 PRINT "     5.   Astronomical Julian date"
  30. 300 PRINT "     6.   Return to Basic"
  31. 310 PRINT "     7.   Return to System" : PRINT
  32. 320 INPUT "Enter Routine Number";R
  33. 330 PRINT CHR$(12)
  34. 340 ON R GOTO 370,660,750,860,1000,1560,1550
  35. 350 GOTO 320
  36. 360 REM
  37. 370 PRINT "This routine will print a calendar for each month"
  38. 380 PRINT "starting with the month and year entered and"
  39. 390 PRINT "continuing for the number of months specified."
  40. 400 REM  PRINT "CALENDARS WILL BE PRINTED ON LINE PRINTER"
  41. 410 REM  PRINT "IF SENSE SWITCH 'A15' IS RAISED."
  42. 420 GOSUB 1290:DM=1:C=0
  43. 430 PRINT:INPUT "Number of months";N:IF (INP(255) AND INP(128))<>0 GOTO 530
  44. 440 IF C=N THEN PRINT CHR$(12):GOTO 240
  45. 450 PRINT CHR$(12);"******** ";M$(MY);TAB(20);YR;"********"
  46. 460 PRINT " SUN  MON  TUE  WED  THU  FRI  SAT"
  47. 470 PRINT "***********************************"
  48. 480 GOSUB 1220
  49. 490 DW=FND(X)
  50. 500 PRINT TAB(5*DW);DM;:IF DM=6 THEN PRINT
  51. 510 X=X+1:GOSUB 1160:IF DM=1 THEN C=C+1:GOTO 440
  52. 520 GOTO 490
  53. 530 IF C=N THEN PRINT:PRINT CHR$(12):GOTO 240
  54. 540 PRINT:PRINT:PRINT
  55. 550 PRINT "******** "M$(MY);TAB(20);YR;"********"
  56. 560 PRINT " SUN  MON  TUE  WED  THU  FRI  SAT"
  57. 570 FOR I=1 TO 34:PRINT "*";:NEXT I:PRINT
  58. 580 GOSUB 1220
  59. 590 DW=FND(X)
  60. 600 PRINT TAB(5*DW);DM;:IF DW=6 THEN PRINT
  61. 610 X=X+1:GOSUB 1160:IF DM=1 THEN C=C+1:GOTO 530
  62. 620 GOTO 590
  63. 630 REM
  64. 640 REM ***DAY OF WEEK***
  65. 650 REM
  66. 660 PRINT "This routine will determine the day of the week"
  67. 670 PRINT "For any Gregorian date after December 31, 1582."
  68. 680 GOSUB 1130
  69. 690 DW=FND(X)
  70. 700 PRINT:PRINT M$(MY);" ";STR$(DM);",";YR;" is a ";D$(DW)
  71. 710 GOTO 230
  72. 720 REM
  73. 730 REM ***NUMBER OF DAYS***
  74. 740 REM
  75. 750 PRINT "This routine will determine the number of days"
  76. 760 PRINT "between two Gregorian dates after December 31, 1582."
  77. 770 GOSUB 1130:D2=D1:M2=M1:Y2=Y1:X2=X:GOSUB 1130
  78. 780 PRINT M$(M2);" ";STR$(D2);",";Y2;"is";ABS(X2-X);"day";
  79. 790 IF ABS(X2-X<>1) THEN PRINT "s";
  80. 800 IF X2>X THEN PRINT " after ":GOTO 820
  81. 810 PRINT " before "
  82. 820 PRINT M$(MY);" ";STR$(DM);","YR:GOTO 230
  83. 830 REM
  84. 840 REM ***DATE***
  85. 850 REM
  86. 860 PRINT "This routine will determine the Gregorian date for a"
  87. 870 PRINT "given number of days before (-) or after a specified date."
  88. 880 GOSUB 1130:INPUT "Number of days before (-) or after date";Z
  89. 890 X=X+Z:IF X>139753! GOTO 920
  90. 900 PRINT:PRINT "The date is prior to the adoption of the Gregorian Calendar."
  91. 910 GOTO 880
  92. 920 GOSUB 1160:PRINT:PRINT ABS(Z);"day";:IF ABS(Z)<>1 THEN PRINT "s"
  93. 930 IF Z<0 THEN PRINT " before ";:GOTO 950
  94. 940 PRINT " after ";
  95. 950 PRINT M$(M1);" ";STR$(D1);",";Y1
  96. 960 PRINT " is ";M$(MY);" ";STR$(DM);",";YR:GOTO 230
  97. 970 REM
  98. 980 REM ***JULIAN DATE***
  99. 990 REM
  100. 1000 PRINT "This routine will determine the Julian Date"
  101. 1010 PRINT "for a Gregorian date after 31 December 1582"
  102. 1020 GOSUB 1030
  103. 1030 GOSUB 1130
  104. 1040 OFFSET#=2159407.5#
  105. 1050 PRINT M$(MY);" ";STR$(DM);",";YR;"is Julian Day  ";
  106. 1060 PRINT USING "########,.#";(X+OFFSET#)
  107. 1070 PRINT "Before noon UT (GMT), ignore the decimal."
  108. 1080 PRINT "After noon UT, add 0.5.":GOTO 230
  109. 1090 STOP
  110. 1100 REM
  111. 1110 REM ***SUBROUTINES***
  112. 1120 REM
  113. 1130 GOSUB 1260:GOSUB 1220:D1=DM:M1=MY:Y1=YR:GOSUB 1160:REM***TEST DATE***
  114. 1140 IF D1<>DM OR M1<>MY OR Y1<>YR THEN PRINT:PRINT "INVALID DATE":GOTO 1130
  115. 1150 RETURN
  116. 1160 Y=INT((X+60)/365.25):REM ***NUMBER TO DATE***
  117. 1170 I=X-INT(Y*365.25)+120+INT(Y/100)-INT(Y/400)
  118. 1180 M=INT((I-.1)/30.6):IF M<4 THEN M=M+12:Y=Y-1:GOTO 1170
  119. 1190 I=I-INT(M*30.6):IF M>13 THEN M=M-12:Y=Y+1
  120. 1200 YR=Y+1200:MY=M-1:DM=I
  121. 1210 RETURN
  122. 1220 D=DM:M=MY:Y=YR-1200:REM ***DATE TO NUMBER***
  123. 1230 M=M+1:IF M<=3 THEN Y=Y-1:M=M+12
  124. 1240 X=INT(365.25*Y)+INT(30.6*M)+D-120-INT(Y/100)+INT(Y/400)
  125. 1250 RETURN
  126. 1260 PRINT : PRINT "Day of the month-"
  127. 1270 INPUT "(for today, enter 0)",DM:IF DM=0 GOTO 1350 : REM***ENTER DATE***
  128. 1280 GOTO 1320
  129. 1290 PRINT : PRINT "Starting Month (1-12)---?";
  130. 1300 PRINT:INPUT "(for this month, enter 0)",MY:IF MY=0 GOTO 1350 : IF MY<1 OR MY>12 GOTO 1290
  131. 1310 GOTO 1330
  132. 1320 PRINT : INPUT "Enter month";MY:IF MY<1 OR MY>12 GOTO 1320
  133. 1330 PRINT:INPUT "YEAR (>1582)";YR:IF YR<1583 GOTO 1330
  134. 1340 PRINT:RETURN
  135. 1350 REM
  136. 1360 REM ****** READ TP-100 (CALENDAR BOARD) DATA ****** 
  137. 1370 REM
  138. 1380 REM ....OUTPUT HOLD BIT
  139. 1390 OUT P,16
  140. 1400 REM ....OUTPUT HOLD + READ BITS
  141. 1410 OUT P,48
  142. 1420 REM ....OUTPUT ADDRESS AND INPUT DATA FOR RANGE
  143. 1430 FOR X=1 TO 6
  144. 1440 OUT P,61-X
  145. 1450 TIME(X)=(INP(P1) AND 15): NEXT X
  146. 1460 REM ....REMOVE HOLD RESUME CLOCK FUNCTIONS
  147. 1470 OUT P,0
  148. 1480 REM
  149. 1490 REM ****** FORMAT DATA ******
  150. 1500 REM
  151. 1510 YR=(TIME(1)*10+TIME(2)+1900)
  152. 1520 MY=(TIME(3) AND 1)*10+TIME(4)
  153. 1530 DM=(TIME(5) AND 3)*10+TIME(6)
  154. 1540 RETURN
  155. 1550 SYSTEM
  156. 1560 END
  157.