home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / dev / aforth-1.4.lha / AForth-1.4 / progs / calendar.f < prev    next >
Encoding:
Text File  |  1994-03-31  |  3.3 KB  |  117 lines
  1. ( Calendar Vocabulary)
  2. ( based upon material in the book 'The Complete FORTH' by Alan Winfield)
  3. ( published by Sigma Technical Press ISBN: 0 905104 22 6)
  4. ( amended by Steve Martin for Stratagem4's AFORTH)
  5.  
  6. DECIMAL
  7. FORTH DEFINITIONS
  8. VOCABULARY calendar
  9. calendar DEFINITIONS
  10.  
  11. ( Zeller's congruence)
  12. VARIABLE Y VARIABLE M VARIABLE D    ( Year, Month, Day)
  13.  
  14. VARIABLE a VARIABLE b    ( work variables for jan1st)
  15. : jan1st        ( return day of week as a number, 0-6)
  16.     Y @ 1- 100 / a !
  17.     Y @ 1- 100 a @ * - b !
  18.     799 b @ + b @ 4 / + a @ 4 / + 2 a @ * -
  19.     7 MOD ;    ( -> n)
  20.  
  21. ( string printing)
  22. : "days"    ( weekday string table)
  23.     ." Sunday   " ." Monday   " ." Tuesday  " ." Wednesday"
  24.     ." Thursday " ." Friday   " ." Saturday " ;
  25.  
  26. : printday    ( print weekday 0-6)
  27.     14 * S->D ' "days" D+ 5 S->D D+ 9 TYPE ;    ( n-> )
  28.  
  29. : "months"    ( month string table)
  30.     ." January  " ." February " ." March    " ." April    "
  31.     ." May      " ." June     " ." July     " ." August   "
  32.     ." September" ." October  " ." November " ." December " ;
  33.  
  34. : printmonth    ( print month 0-11)
  35.     14 * S->D ' "months" D+ 5 S->D D+ 9 TYPE ;    ( n -> )
  36.  
  37. ( date checking)
  38. CREATE dpmtable        ( table of days per month)
  39.     31 C, 28 C, 31 C, 30 C, 31 C, 30 C,
  40.     31 C, 31 C, 30 C, 31 C, 30 C, 31 C,
  41.  
  42. : leap?        ( is year a leap year?)
  43.     Y @ 4    MOD 0=
  44.     Y @ 100 MOD 0= NOT AND
  45.     Y @ 400 MOD 0= OR ;    ( -> flag)
  46.  
  47. : dpm    ( return number of days per month)
  48.     DUP S->D dpmtable D+ C@
  49.     SWAP 1 = leap? AND    ( add 1 if February and leap year)
  50.     IF 1+ THEN ;        ( n1 -> n2)
  51.  
  52. ( Check date within range, all return 'true' if not)
  53. : Ycheck Y @ DUP 1582 < SWAP 4902 > OR ;    ( -> flag)
  54. : Mcheck M @ 12 U< NOT ;                    ( -> flag)
  55. : Dcheck D @ 1- M @ dpm U< NOT ;            ( -> flag)
  56. : datecheck
  57.     Ycheck Mcheck Dcheck OR OR
  58.     IF ." Date error" ABORT THEN ;
  59.  
  60. ( daynumber and day)
  61. : C CONSTANT ;
  62.  
  63. 0 C january   1 C february  2 C march     3 C april
  64. 4 C may       5 C june      6 C july      7 C august
  65. 8 C september 9 C october  10 C november 11 C december
  66.  
  67. : daynumber    ( calculate days up to D/M/Y)
  68.     0 12 0 DO
  69.         M @ I = IF                ( loop through months)
  70.                     D @ + LEAVE    ( until M=I)
  71.                 ELSE
  72.                     I dpm +        ( accumulate days)
  73.                 THEN
  74.         LOOP ;                    ( -> n)
  75.  
  76. ( calculate days of week of date D/M/Y, 0-6)
  77. : D/M/Y jan1st daynumber + 1- 7 MOD ;    ( -> n)
  78. : day    ( print day of date given)
  79.     Y ! M ! D ! D/M/Y printday ;        ( d m y -> )
  80.  
  81. ( month and year)
  82. VARIABLE chars        ( character count)
  83. : month    ( print specified month)
  84.     Y ! M ! 1 D ! datecheck
  85.     CR M @ printmonth SPACE ." : " Y @ .    ( heading)
  86.     CR SPACE ." Sun Mon Tue Wed Thu Fri Sat" CR
  87.     D/M/Y                    ( calculate 1st day of month)
  88.     4 * DUP SPACES chars !    ( go to day column)
  89.     M @ dpm 1+ 1 DO            ( step thru days in month)
  90.         I 4 .R 4 chars +!
  91.         chars @ 24 > IF CR 0 chars ! THEN
  92.     LOOP CR CR ;    ( m y -> )
  93.  
  94. : year    ( print whole year calendar)
  95.     12 0 DO        ( loop thru months)
  96.         I OVER month
  97.     LOOP DROP ;        ( y -> )
  98.  
  99. ( yearend and daysleft)
  100. VARIABLE Mend VARIABLE Dend        ( current end of year)
  101. : yearend        ( initialise end of year)
  102.     OVER OVER 1 = SWAP 29 = AND    ( 29th of Feb?)
  103.     IF ." You can't be serious!" ABORT THEN
  104.     Mend ! Dend ! ;            ( d m -> )
  105.  
  106. : daysinY    ( how many days in year Y)
  107.     leap? IF 366 ELSE 365 THEN ;    ( -> n)
  108.  
  109. : daysleft    ( number of days to year end)
  110.     Y ! M ! D !                datecheck daynumber
  111.     Mend @ M ! Dend @ D !    datecheck daynumber
  112.     OVER OVER > NOT IF ( specified date BEFORE yearend?)
  113.             SWAP - .
  114.         ELSE daysinY SWAP -
  115.             1 Y +!             datecheck daynumber + .
  116.         THEN ;    ( d m y -> )
  117.