home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / simtel / cpmug / cpmug054.ark / WEKDAY.BAS < prev    next >
Encoding:
BASIC Source File  |  1984-04-29  |  3.1 KB  |  132 lines
  1. 10 ?:?
  2. 20 ? "THIS PROGRAM DEMONSTRATES XITAN DISK BASIC AND ALSO GIVES"
  3. 30 ? "FACTS ABOUT A DATE OF INTEREST TO YOU."
  4. 120 ?
  5. 124 LET Y1=1970
  6. 130 PRINT " ENTER TODAYS DATE IN THIS FORM: MONTH,DAY,YEAR";
  7. 140 INPUT M1,D1,Y1
  8. 150 IF Y1>100 THEN 170
  9. 160 LET Y1=Y1+1900
  10. 170 DEF FNA(A)=INT(A/4)
  11. 180 DIM T(12)
  12. 190 DEF FNB(A)=INT(A/7)
  13. 210 FOR I=1 TO 12
  14. 220 READ T(I)
  15. 230 NEXT I
  16. 240 ?
  17. 244 ?
  18. 245 PRINT " ENTER DATE OF BIRTH IN THIS FORM: MO,DAY,YEAR";
  19. 250 INPUT M,D,Y
  20. 260 ?
  21. 270 IF Y>100 THEN 280
  22. 275 LET Y=Y+1900
  23. 280 LET I1=INT((Y-1500)/100)
  24. 290 IF Y-1582<0 THEN 1300
  25. 300 LET A=I1*5+(I1+3)/4
  26. 310 LET I2=INT(A-FNB(A)*7)
  27. 320 LET Y2=INT(Y/100)
  28. 330 LET Y3=INT(Y-Y2*100)
  29. 340 LET A=Y3/4+Y3+D+T(M)+I2
  30. 350 LET B=INT(A-FNB(A)*7)+1
  31. 360 IF M>2 THEN 470
  32. 370 IF Y3=0 THEN 440
  33. 380 LET T1=INT(Y-FNA(Y)*4)
  34. 390 IF T1<>0 THEN 470
  35. 400 IF B<>0 THEN 420
  36. 410 LET B=6
  37. 420 LET B=B-1
  38. 430 GOTO 470
  39. 440 LET A=I1-1
  40. 450 LET T1=INT(A-FNA(A)*4)
  41. 460 IF T1=0 THEN 400
  42. 470 IF B<>0 THEN 490
  43. 480 LET B=7
  44. 490 IF (Y1*12+M1)*31+D1<(Y*12+M)*31+D THEN 550
  45. 500 IF (Y1*12+M1)*31+D1=(Y*12+M)*31+D THEN 530
  46. 510 PRINT M;"/";D;"/";Y;" WAS A ";
  47. 520 GOTO 560
  48. 530 PRINT M;"/";D;"/";Y;" IS A ";
  49. 540 GOTO 560
  50. 550 PRINT M;"/";D;"/";Y;" WILL BE A ";
  51. 560 ON B GOTO 570,580,590,600,610,1250,630
  52. 570 ? "SUNDAY":GOTO 710
  53. 580 ? "MONDAY":GOTO 710
  54. 590 ? "TUESDAY":GOTO 710
  55. 600 ? "WEDNESDAY":GOTO 710
  56. 610 ? "THURSDAY":GOTO 710
  57. 630 ? "SATURDAY":GOTO 710
  58. 710 IF (Y1*12+M1)*31+D1=(Y*12+M)*31+D THEN 1120
  59. 720 LET I5=Y1-Y
  60. 730 ?
  61. 740 LET I6=M1-M
  62. 750 LET I7=D1-D
  63. 760 IF I7>=0 THEN 790
  64. 770 LET I6=I6-1
  65. 780 LET I7=I7+30
  66. 790 IF I6>=0 THEN 820
  67. 800 LET I5=I5-1
  68. 810 LET I6=I6+12
  69. 820 IF I5<0 THEN 1310
  70. 830 IF I7<>0 THEN 850
  71. 835 IF I6<>0 THEN 850
  72. 840 PRINT "**** HAPPY BIRTHDAY ****"
  73. 850 PRINT ,,"YEARS","MONTHS","DAYS"
  74. 860 PRINT "YOUR AGE              ",I5,I6,I7
  75. 870 LET A8=(I5*365)+(I6*30)+I7+INT(I6/2)
  76. 880 LET K5=I5
  77. 890 LET K6=I6
  78. 900 LET K7=I7
  79. 920 LET E=Y+65
  80. 940 LET F=.35
  81. 950 PRINT "YOU HAVE SLEPT ",
  82. 960 GOSUB 1370
  83. 970 LET F=.17
  84. 980 PRINT "YOU HAVE EATEN ",
  85. 990 GOSUB 1370
  86. 1000 LET F=.23
  87. 1010 IF K5>3 THEN 1040
  88. 1020 PRINT "YOU HAVE PLAYED ",
  89. 1030 GOTO 1080
  90. 1040 IF K5>9 THEN 1070
  91. 1050 PRINT "YOU HAVE PLAYED/STUDIED",
  92. 1060 GOTO 1080
  93. 1070 PRINT "YOU HAVE WORKED/STUDIED",
  94. 1080 GOSUB 1370
  95. 1090 PRINT "YOU HAVE RELAXED ",K5,K6,K7
  96. 1100 ?
  97. 1110 PRINT ,"*** YOU MAY RETIRE IN";E;"***"
  98. 1120 PRINT
  99. 1140 ?:?:?
  100. 1240 GOTO 240
  101. 1250 IF D=13 THEN 1280
  102. 1260 ? "FRIDAY "
  103. 1270 GOTO 710
  104. 1280 PRINT "FRIDAY THE THIRTEENTH---BEWARE!!!!!!"
  105. 1290 GOTO 710
  106. 1300 ? "NOT PREPARED TO GIVE DAY OF WEEK PRIOR TO 1582"
  107. 1305 ? "    THE CURRENT CALENDAR DID NOT EXIST BEFORE THAT YEAR."
  108. 1310 GOTO 1140
  109. 1330 DATA 0,3,3,6,1,4,6,2,5,0,3,5
  110. 1370 LET K1=INT(F*A8)
  111. 1380 LET I5=INT(K1/365)
  112. 1390 LET K1=K1-(I5*365)
  113. 1400 LET I6=INT(K1/30)
  114. 1410 LET I7=K1-(I6*30)
  115. 1420 LET K5=K5-I5
  116. 1430 LET K6=K6-I6
  117. 1440 LET K7=K7-I7
  118. 1450 IF K7>=0 THEN 1480
  119. 1460 LET K7=K7+30
  120. 1470 LET K6=K6-1
  121. 1480 IF K6>0 THEN 1510
  122. 1490 LET K6=K6+12
  123. 1500 LET K5=K5-1
  124. 1510 PRINT I5,I6,I7
  125. 1520 RETURN
  126. 1530 IF K6=12 THEN 1550
  127. 1540 GOTO 1090
  128. 1550 LET K5=K5+1
  129. 1560 LET K6=0
  130. 1570 GOTO 1090
  131. 1580 END
  132.