home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / lambda / soundpot / f / holidays.lbr / EASTER.BZS / EASTER.BAS
Encoding:
BASIC Source File  |  1993-10-26  |  9.3 KB  |  232 lines
  1. 10 '    ****************************************************
  2.  
  3.     ****    Major Holidays of the Christian Year    ****
  4.  
  5.     ****                        ****
  6. 20 '    ****       for the KAYPRO 10 ---  5/26/89    ****
  7.  
  8.     ****        by Richard Altman        ****
  9.  
  10.     ****                        ****
  11. 30 '    ****    Copyright (c) 1989 by Richard Altman    ****
  12.  
  13.     ****        All Rights Reserved        ****
  14.  
  15.     ****************************************************
  16.  
  17. 50 '
  18. 51 '     USER SUPPORTED
  19. 52 '
  20. 53 '     This program is user-supported software.  It is copyrighted and cannot
  21. 54 ' be sold for profit (without the author's express written permission),  but
  22. 55 ' it may be copied and distributed for free.
  23. 56 '
  24. 57 '     The  SHAREWARE  concept is a  distribution method  that dispenses with
  25. 58 ' heavy  marketing/advertising costs and gives the user the  opportunity  to
  26. 59 ' try a software program before buying.   Its continued existence depends on
  27. 60 ' each user paying for what he does, in fact, use.
  28. 61 '
  29. 62 '     If you find this program [EASTER.BAS] useful,  please send the $15 (or
  30. 63 ' more) registration fee directly to the author:
  31. 64 '
  32. 65 '        Richard S. Altman -- P.O. Box 4388 -- Clearlake, CA 95422
  33. 66 '
  34. 67 '      Upon registration,  you will receive a floppy diskette containing the
  35. 68 ' latest version of this program,  as well as a printed manual detailing its
  36. 69 ' uses and specifications.   You will also receive a FREE  calendar printing
  37. 70 ' program and other programs by the same author.
  38. 71 '
  39. 72 '      WHEN ORDERING,  please be sure to indicate  single or double  density
  40. 73 ' disk drive,  and the name of the program  [EASTER.BAS].   Comments on pro-
  41. 74 ' grams are also most welcome!
  42. 75 '
  43. 76 '     Due to  possible unforeseen circumstances,  the above offer is subject
  44. 77 ' to change without notice.
  45. 78 '
  46. 80 GOTO 7000
  47. 90 RT=RZ:RZ=RY:RY=RX:RETURN
  48. 95 RT=RL-INT(RL):RT=INT((RT*H)+.5):IF RT=0 THEN RL=RL-1:GOSUB 5400
  49. 96 GOTO 3200
  50. 100 '    Input Year
  51. 105 K0=241303.22#:K1=10281807.26#:K2=15042312.01#:K3=20092717.06#
  52. 110 R0=K0:R1=K1:R2=K2:R3=K3
  53. 115 L$=FNF(3,17)+"  ***  C H R I S T I A N   C A L E N D A R  ***  "
  54. 120 PRINT DE:GOSUB 5065:PRINT:PRINT DE
  55. 125 IF Z1=99 THEN 165
  56. 126 'R9=1980:GOTO 165
  57. 130 PRINT FNF(8,12)"This program will display the major CHRISTIAN HOLIDAYS"
  58. 135 PRINT FNF(9,29)"that occur during the year." DSCR
  59. 140 IF C89="C89" THEN 145 ELSE 150 
  60. 145 C89="":PRINT FNF(23,14)"(c) 1989 by Richard Altman -- All Rights Reserved."
  61. 150 PRINT FNF(13,12)"Please input the desired year (";
  62. 155 L$="between 1900 and 2100":GOSUB 5050:PRINT DCLEAR;
  63. 160 PRINT")  "C7;:INPUT R9:IF R9<1900 OR R9>2100 THEN 150
  64. 165 GOSUB 1000:GOSUB 5200:PRINT F(8) DSCR
  65. 170 R9=R9-1:GOSUB 1500:R9=R9+1:GOSUB 2000:GOTO 3000
  66. 175 '
  67. 1000 '    Easter
  68. 1005 R10=365.25:R4=INT(R9*R10)+143
  69. 1010 R=R9 MOD 19:R=(R+1)/5:R=R*10:R6=R/10
  70. 1015 R=R6-INT(R6):RX=0:R=INT((R*10)+.5)/10
  71. 1020 IF R= 0 THEN RX=8:GOTO 1040
  72. 1025 IF R=.2 THEN RX=6:GOTO 1040
  73. 1030 IF R=.4 THEN RX=4:GOTO 1040
  74. 1035 IF R=.6 THEN RX=2:GOTO 1040
  75. 1040 RX=10#^RX:RX=1/RX:GOSUB 90
  76. 1045 IF INT(R6)=0 THEN KX=K0:GOTO 1065
  77. 1050 IF INT(R6)=1 THEN KX=K1:GOTO 1065
  78. 1055 IF INT(R6)=2 THEN KX=K2:GOTO 1065
  79. 1060 IF INT(R6)=3 THEN KX=K3
  80. 1065 R5=KX:IF RY=1 THEN 1075
  81. 1070 RX=KX:R=RX*RY:RX=R:RY=RZ:RX=RX-INT(RX):GOTO 1080
  82. 1075 K=INT((KX*H)+.5)/H:K=K-INT(K):RX=INT(K*H)/H:RX=RX*RY
  83. 1080 RX=INT(RX*H):R4=R4+RX:RY=RX:RX=R4
  84. 1085 RX=RX+5:R=INT(RX/7):RX=RX-(R*7)
  85. 1090 RX=INT(RX+.5):RX=RX-7:R4=R4-RX
  86. 1095 GOSUB 90:RX=R4:RX=RX-122.1
  87. 1100 RX=INT(RX/R10):R9=RX:RX=INT(RX*R10)
  88. 1105 GOSUB 90:RX=RY-R4:RY=RZ:RX=-RX:R6=RX
  89. 1110 R11=30.6001:RX=INT(RX/R11):R7=RX
  90. 1115 GOSUB 90:RX=R6:SWAP RX,RY:GOSUB 90:RX=R11
  91. 1120 RX=INT(RX*RY):RY=RZ:RX=RY-RX:RZ=RT:RY=RZ
  92. 1125 R8=RX:RT=R8:RZ=R7:RY=1:RX=R8
  93. 1130 RX=RY-(RX/(RY*H)):RX=RZ-RX:RZ=R8:RY=RX
  94. 1135 RX=INT(R7/14):R9=R9+RX:RX=RX*12
  95. 1140 RX=RY-RX:RY=RZ:R8=RX:RL=RX:V=7:GOSUB 3200
  96. 1145 RESTORE 6500:FOR X=1 TO 12:READ D(X):NEXT:RETURN
  97. 1500 '    Christmas
  98. 1510 RY=8-RZ:RL=12.25:V=1:GOSUB 3200:IF RY=7 THEN RY=0
  99. 1520 GOSUB 2800:DA(1)=" ("+DA+")":RETURN
  100. 2000 '    Epiphany Sunday
  101. 2010 IF RZ=6 THEN RX=1.06:GOTO 2070
  102. 2020 IF RZ=5 THEN RX=1.12:GOTO 2070
  103. 2030 IF RZ=4 THEN RX=1.11:GOTO 2070
  104. 2040 IF RZ=3 THEN RX=1.1 :GOTO 2070
  105. 2050 IF RZ=2 THEN RX=1.09:GOTO 2070
  106. 2060 IF RZ=1 THEN RX=1.08:GOTO 2070 ELSE RX=1.07
  107. 2070 RL=RX:V=2:GOSUB 3200
  108. 2100 '    Ash Wednesday and 1st Sunday in Lent
  109. 2110 RX=R8-INT(R8):RL=INT(R8)-1:RX=RX*H
  110. 2120 GOSUB 5400:RX=RX+28:RL=RL-.28:RT=RL-INT(RL)
  111. 2130 IF (42-RX)/H>RT THEN RX=RX+RT*H:RL=RL-1:GOSUB 5400
  112. 2140 R=42-RX:RL=RL-R/H:IF RL<=INT(RL)+.01 THEN RL=RL-1:GOSUB 5400
  113. 2150 V=4:GOSUB 95:RT=RL-INT(RL)
  114. 2160 IF RT>4/H THEN RL=RL-4/H:GOTO 2190
  115. 2170 IF RT=4/H THEN RL=RL-1:GOSUB 5400:GOTO 2190
  116. 2180 RX=4-RT*H:RL=RL-1:GOSUB 5400:RL=RL-RX/H
  117. 2190 V=3:GOSUB 95
  118. 2200 '    Good Friday and Palm Sunday
  119. 2210 RL=R8:RT=RL-INT(RL)
  120. 2220 IF RT>2/H THEN RL=RL-2/H:GOTO 2250
  121. 2230 IF RT=2/H THEN RL=RL-1:GOSUB 5400:GOTO 2250
  122. 2240 RX=2-RT*H:RL=RL-1:GOSUB 5400:RL=RL-RX/H
  123. 2250 V=6:GOSUB 95:RL=R8:RT=RL-INT(RL)
  124. 2260 IF RT>7/H THEN RL=RL-7/H:GOTO 2290
  125. 2270 IF RT=7/H THEN RL=RL-1:GOSUB 5400:GOTO 2290
  126. 2280 RX=7-RT*H:RL=RL-1:GOSUB 5400:RL=RL-RX/H
  127. 2290 V=5:GOSUB 95
  128. 2300 '    Ascension Sunday
  129. 2310 RL=R8:RT=RL-INT(RL):RM=INT(RL)
  130. 2320 RL=RM+1:GOSUB 5400:IF RM=3 THEN RX=11+RT*H ELSE RX=12+RT*H
  131. 2330 IF INT(RL)=4 THEN RX=RX-29 ELSE RX=RX-31
  132. 2340 RL=RL+RX/H:IF RL-INT(RL)>.31 THEN RL=RL+1:RL=RL-.31
  133. 2350 V=8:GOSUB 95
  134. 2400 '    Pentecost Sunday
  135. 2410 RL=RL+7/H:RT=RL-INT(RL):RM=INT(RL)
  136. 2420 IF RM=6 THEN 2440
  137. 2430 IF RT>.31 THEN RL=RL+1:RL=RL-.31
  138. 2440 V=9:GOSUB 95
  139. 2500 '    Kingdomtide
  140. 2510 RT=RL-INT(RL):RM=INT(RL)
  141. 2520 IF RM=5 THEN RX=92-RT*H ELSE RX=61-RT*H
  142. 2530 RL=8.21:RX=RX+21:RY=RX MOD 7:RL=RL-RY/H
  143. 2540 IF RL+7/H<=8.31 THEN RL=RL+7/H
  144. 2550 IF RL+7/H<=8.31 THEN RL=RL+7/H
  145. 2560 V=10:GOSUB 95
  146. 2600 '    Advent
  147. 2610 RT=RL-INT(RL):RM=8:RX=147-RT*H
  148. 2620 RY=RX MOD 7:RX=RX-RY:RL=12.25-RY/H:RC=RL:RYY=RY
  149. 2630 RL=RL-.14:RT=RL-INT(RL):RM=INT(RL)
  150. 2640 IF RY=0 THEN RL=RL-7/H:RT=RL-INT(RL)
  151. 2650 IF RT>7/H THEN RL=RL-7/H:GOTO 2680
  152. 2660 IF RT=7/H THEN RL=RL-1:GOSUB 5400:GOTO 2680
  153. 2670 RX=7-RT*H:RL=RL-1:GOSUB 5400:RL=RL-RX/H
  154. 2680 V=11:GOSUB 95
  155. 2700 '    Christmas
  156. 2710 RL=12.25:RY=RYY:GOSUB 2800
  157. 2720 V=12:GOSUB 95:DA(12)=" ("+DA+")":RETURN
  158. 2800 IF RY=0 THEN DA="Sunday":RETURN
  159. 2810 IF RY=1 THEN DA="Monday":RETURN
  160. 2820 IF RY=2 THEN DA="Tuesday":RETURN
  161. 2830 IF RY=3 THEN DA="Wednesday":RETURN
  162. 2840 IF RY=4 THEN DA="Thursday":RETURN
  163. 2850 IF RY=5 THEN DA="Friday":RETURN
  164. 2860 IF RY=6 THEN DA="Saturday":RETURN
  165. 2870 '
  166. 3000 '    Display Dates and End Program
  167. 3010 PRINT F(10):FOR X=1 TO 12:L=LEN(DA(X))+LEN(D(X))+LEN(DATE(X))
  168. 3020 PRINT FNF(X+6,19) D(X);DA(X)" "STRING$(43-L,46)" "DATE(X):NEXT:PRINT C7
  169. 3030 PRINT F(21)DD;" Press (1) for DIFFERENT year,  (2) PREVIOUS year,  (3) ";
  170. 3040 PRINT"NEXT year,  (Q) to QUIT ";
  171. 3050 GOSUB 6000:IF I="Q" OR I="q" THEN PRINT F(21)DD;DSCR;F(20):END:GOTO 3030
  172. 3060 ZZ=99:Z1=0
  173. 3070 IF I="1" OR I=CHR$(13) THEN PRINT CLS:GOTO 100 ELSE Z1=99
  174. 3080 IF I="2" THEN  R9=R9-1:PRINT CLS:GOTO 100
  175. 3090 IF I="3" THEN  R9=R9+1:PRINT CLS:GOTO 100 ELSE 3050
  176. 3200 '    Get Date
  177. 3205 RX=INT(RL):RD=RL-INT(RL):RD=INT((RD*H)+.5)
  178. 3210 IF RX=1  THEN MO$="January"
  179. 3215 IF RX=2  THEN MO$="February"
  180. 3220 IF RX=3  THEN MO$="March"
  181. 3225 IF RX=4  THEN MO$="April"
  182. 3230 IF RX=5  THEN MO$="May"
  183. 3235 IF RX=6  THEN MO$="June"
  184. 3240 IF RX=7  THEN MO$="July"
  185. 3245 IF RX=8  THEN MO$="August"
  186. 3250 IF RX=9  THEN MO$="September"
  187. 3255 IF RX=10 THEN MO$="October"
  188. 3260 IF RX=11 THEN MO$="November"
  189. 3265 IF RX=12 THEN MO$="December"
  190. 3270 DATE(V)=MO$+STR$(RD)+","+STR$(R9):RETURN
  191. 3275 '
  192. 5000 '    *****     Misc. Subroutines
  193. 5005 '
  194. 5010 PRINT ESC "B0";:RETURN:'    Inverse Video ON/OFF
  195. 5015 PRINT ESC "C0";:RETURN
  196. 5020 PRINT ESC "B4";:RETURN:'    Cursor ON/OFF
  197. 5025 PRINT ESC "C4";:RETURN
  198. 5030 PRINT ESC "B1";:RETURN:'    Reduced Intensity ON/OFF
  199. 5035 PRINT ESC "C1";:RETURN
  200. 5040 PRINT ESC "B3";:RETURN:'    Underline ON/OFF
  201. 5045 PRINT ESC "C3";:RETURN
  202. 5050 GOSUB 5040:PRINT L$;:GOTO 5045:'    Underline L$
  203. 5055 '
  204. 5060 GOSUB 5010:GOSUB 5030:PRINT L$;:GOSUB 5015:GOTO 5035:'    Revrs. Video L$
  205. 5065 GOSUB 5010:PRINT L$;:GOTO 5015:'                BRIGHT Video L$
  206. 5070 '
  207. 5200 '    Determine DOW for Jan. 1
  208. 5210 RM=INT(R8):RD=(R8-INT(R8))*H:LP=0:IF R9/4=R9\4 THEN LP=1
  209. 5220 RDOW=59:IF LP=1 THEN RDOW=60
  210. 5230 RDOW=RDOW+RD:IF RM=4 THEN RDOW=RDOW+31
  211. 5240 RZ=RDOW MOD 7:IF RZ=0 THEN RZ=7
  212. 5250 RETURN
  213. 5400 '    Convert to Last Day of Month
  214. 5410 RL=INT(RL):RF=28:IF R9/4=R9\4 THEN RF=29
  215. 5420 IF RL=2 THEN RL=2+RF/H:RETURN
  216. 5430 IF RL=4 OR RL=6 OR RL=9 OR RL=11 THEN RL=RL+.3:RETURN
  217. 5440 RL=RL+.31:RETURN
  218. 5450 '
  219. 6000 '    *****     INKEY$ Subroutines
  220. 6010 K$=INKEY$:I=""
  221. 6020 I=INKEY$:IF I="" THEN 6020 ELSE RETURN
  222. 6050 KN$=INKEY$:IN=""
  223. 6060 IN=INKEY$:IF IN<>CHR$(13) THEN 6060 ELSE RETURN
  224. 6070 '
  225. 6500 DATA CHRISTMAS,EPIPHANY SUNDAY,ASH WEDNESDAY,"LENT, 1st Sunday"
  226. 6510 DATA PALM SUNDAY,GOOD FRIDAY,EASTER,ASCENSION SUNDAY,PENTECOST SUNDAY
  227. 6520 DATA KINGDOMTIDE,ADVENT,CHRISTMAS
  228. 6530 '
  229. 7000 '    *****    Set Up Variables
  230. 7005 '
  231. 7010 '    String:  A$-F$, I$    Integer:  G-H, T-Z
  232.  
  233. 7011 '    Single Precision: J-S    Double Precision: K
  234. 7015 '
  235. 7020 DEFSTR A-F,I:DEFINT G-H,T-Z:DEFDBL K:DIM D(12),DA(12),DATE(12),F(24)
  236. 7025 CLS=CHR$(26):DCLEAR=CHR$(24):DSCR=CHR$(23):ESC=CHR$(27):C7=CHR$(7)
  237. 7030 FE=ESC+"=":H=100:PRINT CLS:GOSUB 5020:WIDTH 255:C89="C89"
  238. 7035 FOR X=1 TO 24:F(X)=FE+CHR$(X+31)+CHR$(32):NEXT:DE=STRING$(79,61)
  239. 7040 DEF FNF(X,Y)=FE+CHR$(X+31)+CHR$(Y+31):DD=STRING$(79,45):GOTO 100
  240.  24:F(X)=FE+CHR$(X+31)+CHR$(32):NEXT