home *** CD-ROM | disk | FTP | other *** search
/ The CIA World Factbook 1992 / k3bimage.iso / sel / 12 / 0156 / calendar.bas < prev    next >
Encoding:
BASIC Source File  |  1983-06-24  |  9.0 KB  |  231 lines
  1. 5 DEFINT A-Z
  2. 10 'Program Name: CALENDAR.BAS - Last Updated: 01/07/82 IJK for IBN-PC
  3. 12 '
  4. 14 'Downloaded from MBBS Atlanta, Georgia - 404-872-3430
  5. 16 '
  6. 17 'Download time: 5 Minutes and 2 seconds.
  7. 18 '
  8. 20 CLEAR 4000:RESTORE
  9. 22 KEY OFF
  10. 25 '
  11. 30 DEF FNP%(X%,Y%)=X%*64+Y%
  12. 33 DEF FNROW%(PRINT.POS%) = (PRINT.POS% \ 64) + 1
  13. 36 DEF FNCOLUMN%(PRINT.POS%) = (PRINT.POS% - (PRINT.POS% \ 64) * 64) + 1 + 8
  14. 38 DEF FNCLEARLINE$ = STRING$(79-POS(0),32) + STRING$(79-POS(0),29)
  15. 40 DIM N$(31),N%(37),A%(37),ND%(12),MN$(12)
  16. 45 '
  17. 50 'N$  = STR$(1..31), N% = INT((DAY-1)/7)+1 (LINE # ON SCREEN)
  18. 60 'A% = PRINT @ FOR DAY #'S, ND%(1..12) = # DAYS IN MONTH 
  19. 70 'MN$= Month Name 
  20. 75 '
  21. 100 FOR I%=1 TO 10 : KEY I%,"" : NEXT I%
  22. 110 'FUNCTION TO COMPUTE DAY OF WEEK
  23. 115 '
  24. 120 DEF FND%(X)=X+(FIX(-X/7)*7) 
  25. 125 '
  26. 130 ' 0-6 = SAT-FRI 
  27. 135 '
  28. 140 DEF FNE%(X%)=VAL(MID$("6012345",X%+1,1))
  29. 145 '
  30. 150 'FUNCTION TO GET NAME OF DAY OF WEEK
  31. 160 ' 
  32. 170 DEF FNN$(DW%)=MID$("SATSUNMONTUEWEDTHUFRI",(DW%+1)*3-2,3) 
  33. 180 ' 
  34. 182 '* Initialize Special Ascii Codes *
  35. 184 COMMAND$="Press "+CHR$(24)+", "+CHR$(25)+", "+CHR$(26)+", "+CHR$(27)+", "
  36. 185 COMMAND$=COMMAND$+"<ENTER>, ? for help, or <ESC> to Quit" : GOSUB 5000
  37. 188 ' 
  38. 195 LEFT.ARROW% = 75 : RIGHT.ARROW% = 77 : UP.ARROW% = 72 : DOWN.ARROW% = 80
  39. 200 '
  40. 205 DEF SEG=0 : POKE 1047, (PEEK(1047) OR 32) - 32 ' NUM LOCK off
  41. 210 GOSUB 2000  ' Instructions!
  42. 215 '
  43. 220 'SET UP ARRAY (# Days in Month)
  44. 230 '
  45. 240 FOR I%=1 TO 12 : READ ND%(I%) : NEXT I% 
  46. 250 FOR I%=1 TO 12 : READ MN$(I%) : NEXT I% 
  47. 260 ' 
  48. 270 ' 
  49. 280 '* Initialize Arrays with Print @ positions, etc. *
  50. 290 ' 
  51. 300 FOR I%=1 TO 37
  52. 310     IF I%<=31 THEN N$(I%)=STR$(I%)
  53. 320     N%(I%)=INT((I%-1)/7)
  54. 330     A%(I%)=(N%(I%)+2)*128+(I%-N%(I%)*7)*7+4 
  55. 340 NEXT I% 
  56. 350 ' 
  57. 420 'Clear Screen... 
  58. 430 ' 
  59. 440 CLS : LOCATE ,,0
  60. 450 ' 
  61. 460 M%=1 ' January
  62. 470 Y%=1983 ' Starting Year 
  63. 480 GOSUB 1060 ' Month Name at top of Screen 
  64. 490 ' 
  65. 500 GOSUB 840 ' Calculate Month Data 
  66. 510 '
  67. 520 GOSUB 920 ' Display Month on Screen
  68. 530 ' 
  69. 540 MC%=0:YC%=0
  70. 545 IN$=INKEY$ : IF LEN(IN$)<1 THEN POKE 1047, (PEEK(1047) OR 32) - 32:GOTO 545
  71. 550 IF LEN(IN$)>1 THEN 570
  72. 555 IF IN$=CHR$(27) THEN CLS : GOSUB 12000 : END ' End stuff
  73. 560 IF IN$=CHR$(13) THEN GOSUB 970 : GOTO 640 '* Specify Month/Year *
  74. 562 IF IN$="/" OR IN$="?" THEN IN%=(0=0) : RESTORE : GOSUB 2003 : GOSUB 1050 : GOSUB 1060 : GOTO 520
  75. 565 BEEP : GOTO 545
  76. 570 CODE.ENTERED%=ASC(RIGHT$(IN$,1))
  77. 580 IF CODE.ENTERED%=UP.ARROW%    THEN MC%=-1
  78. 585 IF CODE.ENTERED%=DOWN.ARROW%  THEN MC%=+1
  79. 590 IF CODE.ENTERED%=LEFT.ARROW%  THEN YC%=-1
  80. 600 IF CODE.ENTERED%=RIGHT.ARROW% THEN YC%=+1
  81. 610 IF YC%=0 AND MC%=0 THEN BEEP : GOTO 545
  82. 620 M%=M%+MC%:Y%=Y%+YC%+(M%<1)-(M%>12) 
  83. 630 M%=-(M%<1)*12-(M%>12)-M%*(M%>0 AND M%<13) 
  84. 640 IN$=INKEY$ : IF IN$="" THEN CLS : GOTO 480 ELSE 550
  85. 650 IF M%<3 THEN 680
  86. 660 F=365*Y%+31*(M%-1)+D%-FIX(.4*M%+2.3)+FIX(Y%/4)-FIX(.75*(INT(Y%/100)+1)) 
  87. 670 GOTO 690
  88. 680 F=365*Y%+(M%-1)*31+D%+FIX((Y%-1)/4)-FIX((3/4)*(FIX(((Y%-1)/100)+1)))
  89. 690 RETURN
  90. 700 ' 
  91. 710 '* Calculate Date of First Day of Month # M% * 
  92. 720 '* (Year # Y%, Day # D% - Value returned is  * 
  93. 730 '* 0-6 (Sat.-Fri.).......................... *
  94. 740 ' 
  95. 750 D%=1:GOSUB 650 
  96. 760 FD%=FND%(F) 
  97. 770 RETURN
  98. 780 ' 
  99. 790 '* Routine to Calculate Next Month Number * 
  100. 800 ' 
  101. 810 M%=M%+1 
  102. 820 Y%=-(M%>12)+Y%
  103. 830 M%=-(M%>12)-(M%<=12)*M% 
  104. 840 MD%=ND%(M%)-(M%=2 AND Y%=FIX(Y%/100)*100 AND Y%=FIX(Y%/400)*400)-(M%=2 AND Y%<>FIX(Y%/100)*100 AND Y%=FIX(Y%/4)*4)
  105. 850 D%=1:GOSUB 650:GOSUB 760
  106. 860 RETURN
  107. 870 ' 
  108. 880 '* Routine to Display Current Month      *
  109. 890 '* FD% = Day of Week of Day #1 in Month! * 
  110. 900 '* M%  = Month Number, Y% = Year         *
  111. 910 ' 
  112. 920 ST%=FNE%(FD%)+1  ' Starting Subscript in Array A%
  113. 930 FOR I%=ST% TO ST%+MD%-1     ' MD% days on screen
  114. 935     PRINT.POSITION%=A%(I%)-LEN(N$(I%-ST%+1))
  115. 940     LOCATE FNROW%(PRINT.POSITION%),FNCOLUMN%(PRINT.POSITION%)
  116. 945     PRINT N$(I%-ST%+1);
  117. 950 NEXT I% 
  118. 955 M$=COMMAND$
  119. 957 GOSUB 5000
  120. 960 RETURN
  121. 970 LOCATE 22,1 : PRINT FNCLEARLINE$;"Enter Desired Month (1-12) : ";:V$="01234567890":GOSUB 15120: M$=FL$
  122. 980 IF M$="" THEN 1030
  123. 990 IF VAL(M$)<1 OR VAL(M$)>12 THEN M$="Enter 1-12 ONLY!":GOSUB 1040:GOTO 970 
  124. 1000 M%=VAL(M$) 
  125. 1010 LOCATE 23,1 : PRINT "Enter Desired Year (4 char.) : "; : V$="0123456789" : GOSUB 15120
  126. 1015 IF FL$="" THEN RETURN ELSE Y$=FL$
  127. 1020 Y%=VAL(Y$):IF Y%<999 THEN Y%=Y%+1900
  128. 1030 LOCATE 22,1 : FOR I%=1 TO 2 : PRINT FNCLEARLINE$ : NEXT I% : RETURN
  129. 1040 GOSUB 5000
  130. 1045 BEEP
  131. 1050 FOR K%=1 TO 2000:NEXT K%:RETURN
  132. 1060 ST$="* "+MN$(M%)+","+STR$(Y%)+" *" 
  133. 1070 LOCATE 1,1 : PRINT FNCLEARLINE$;TAB(40-LEN(ST$)/2);ST$;
  134. 1080 LOCATE 3,18 : PRINT  "SUN    MON   TUES    WED   THURS   FRI    SAT";
  135. 1090 LOCATE 4,18 : PRINT  "---------------------------------------------";FNCLEARLINE$;
  136. 1140 RETURN
  137. 2000 GOSUB 6000:IN%=(IN$="Y"):
  138. 2003 CLS
  139. 2005 DATA "CALENDAR.BAS - IBM-PC Version"
  140. 2010 DATA "-----------------------------"
  141. 2013 '
  142. 2016 'Now, if y'all don't want to see my name on this program,
  143. 2017 'feel free to substitute whatever you deem appropriate...
  144. 2018 '
  145. 2020 DATA "Written by Irvan J. Krantzler"
  146. 2025 DATA $2
  147. 2030 DATA "     This program will display the calendar of virtually any"
  148. 2040 DATA "month that you  desire.   It will start up  with the default"
  149. 2050 DATA "month and year already set.                                 "
  150. 2070 DATA "$2"
  151. 2080 DATA "   In order to use this program, all you need to do is press"
  152. 2090 DATA "one  of  the  arrow  keys which will move the  month  number"
  153. 2100 DATA "forwards  and backwards  (up and down arrows)  or change the"
  154. 2110 DATA "year in the same manner  (left arrow is one year ago,  right"
  155. 2120 DATA "arrow is one year later).  In order to specify a date, press"
  156. 2130 DATA "<ENTER> and  you will be  prompted to  enter a  month  and a"
  157. 2140 DATA "year  (4 digits).  To quit, press the <ESC> key and you will"
  158. 2150 DATA "exit to BASIC.....Have fun, y'all!                          "
  159. 2160 DATA "$END"
  160. 2170 '
  161. 2172 MAX%=20   'Maximum number of lines per screen!
  162. 2175 LC%=0     'Line Counter for multiple-screens
  163. 2180 READ A$
  164. 2185 IF A$="$END" THEN IF NOT IN% THEN RETURN ELSE M$="Press any key to begin.":GOSUB 5000:GOSUB 3100:GOSUB 3040:RETURN ELSE IF NOT IN% THEN 2180
  165. 2190 IF LEFT$(A$,1)="$" THEN GOSUB 2500:GOTO 2180
  166. 2195 LC%=LC%+1:IF LC%>MAX% THEN GOSUB 3000'Another screen!
  167. 2200 PRINT STRING$(40-FIX(LEN(A$)/2),32);A$
  168. 2210 GOTO 2180
  169. 2470 '
  170. 2480 'Print ML% blank lines.
  171. 2490 '
  172. 2500 ML%=VAL(RIGHT$(A$,LEN(A$)-1))
  173. 2510 IF ML%=0 THEN RETURN
  174. 2520 FOR IL%=1 TO ML%
  175. 2530    PRINT:LC%=LC%+1:IF LC%>MAX% THEN GOSUB 3000' Another Screen
  176. 2540 NEXT IL%
  177. 2550 RETURN
  178. 3000 M$="Press any key to continue instructions....."
  179. 3010 GOSUB 5000
  180. 3020 GOSUB 3100        'Wait for keypress
  181. 3030 LC%=0             'Zero Line Counter
  182. 3040 CLS
  183. 3050 RETURN
  184. 3100 IF INKEY$="" THEN 3100 ELSE RETURN '* Wait for a key *
  185. 5000 LOCATE 22,1 : PRINT FNCLEARLINE$;TAB(40-LEN(M$)/2);M$;:RETURN
  186. 6000 CLS : LOCATE ,,1 : PRINT "Do you need instructions (Y/N) ? ";
  187. 6020 IN$=INKEY$:IF IN$="" THEN 6020
  188. 6040 IN$=CHR$( (ASC(IN$) OR 32)-32)
  189. 6050 IF INSTR("YN",IN$) THEN LOCATE ,,0
  190. 6060 IF IN$="N" THEN PRINT "No":RETURN
  191. 6080 IF IN$="Y" THEN PRINT "Yes":RETURN
  192. 6090 M$="Press 'Y' or 'N' ONLY!":GOSUB 1040:GOTO 6000
  193. 8000 DATA 31,28,31,30,31,30,31,31,30,31,30,31
  194. 8010 DATA "January","February","March","April","May","June"
  195. 8020 DATA "July","August","September","October","November"
  196. 8030 DATA "December"
  197. 9000 '
  198. 9010 'Note: PLEASE pardon the sloppy condition of this pgm.
  199. 9020 '      If it looks like it was thrown together in short
  200. 9030 '      order, that's because it was!!! Thanks,   IJK
  201. 9040 '
  202. 10000 '
  203. 10010 'End stuff - Set up <F2> for 'RUN'
  204. 10020 '
  205. 12000 LOCATE 1,22 : COLOR 7,0 : PRINT "Press ";
  206. 12010 COLOR 8,7 : PRINT " F2 ";
  207. 12020 COLOR 7,0 : PRINT " to use this program again."
  208. 12030 PRINT
  209. 12040 KEY 2, "RUN" + CHR$(13)
  210. 12050 RETURN
  211. 15120 FL$="":LOCATE ,,1
  212. 15140 A$=INKEY$ : IF A$="" THEN GOSUB 15500:GOTO 15140 ELSE A$=CHR$(((ASC(A$)>96) AND (ASC(A$)<123))* 32+ASC(A$))
  213. 15160 IF ASC(A$)<32 THEN 15260
  214. 15180 IF INSTR(V$,A$)=0 THEN BEEP:GOTO 15140
  215. 15200 IF LEN(FL$)>20 THEN BEEP:GOTO 15140
  216. 15220 PRINT A$;
  217. 15240 FL$=FL$+A$ : GOTO 15140
  218. 15260 A%=ASC(A$)
  219. 15280 IF A%=13 THEN LOCATE ,,0:RETURN
  220. 15300 IF A%=27 THEN IF LEN(FL$)>0 THEN PRINT STRING$(LEN(FL$),29);STRING$(LEN(FL$),32);STRING$(LEN(FL$),29);:GOTO 15120
  221. 15320 IF A%<>8 THEN BEEP:GOTO 15140
  222. 15340 IF LEN(FL$)<1 THEN BEEP:GOTO 15140
  223. 15360 PRINT CHR$(29);" ";CHR$(29);:FL$=LEFT$(FL$,LEN(FL$)-1):GOTO 15140
  224. 15500 POKE 1047, (PEEK(1047) OR 32) : RETURN 'NUM LOCK on
  225. 50000 '****** End of program listing ******
  226. EN(FL$)-1):GOTO 15140
  227. 15500 POKE 1047, (PEEK(1047) OR 32) : RETURN 'NUM LOCK on
  228. 50000 '****** En of program listing ******
  229. EN(FL$)-1):GOTO 15140
  230. 15500 POKE 1047, (PEEK(1047) OR 32) : RETURN 'NUM LOCK on
  231. 50000 '****** En