home *** CD-ROM | disk | FTP | other *** search
/ C!T ROM 5 / ctrom5b.zip / ctrom5b / PROGRAM / DIVERSEN / TIPI2A / CAL.TPI < prev    next >
Text File  |  1994-10-02  |  2KB  |  118 lines
  1. # CALENDAR.TPI by Kent Peterson
  2. # 12/03/93
  3.  
  4. defvar x
  5. defvar month
  6. defvar day
  7. defvar year
  8.  
  9. define Date2Julian ( m d y -- j )
  10.  year store day store month store
  11.  year fetch 1583 < if
  12.  "Date2Julian: Year is less than 1583"
  13.  print$ 1 bye endif
  14.  month fetch dup 2 > if 3 - month store
  15.   else 9 + month store
  16.        year fetch 1 - year store
  17.   endif
  18.  146097 year fetch 100 / * 4 /
  19.  1461 year fetch 100 mod * 4 / +
  20.  153 month fetch * 2 + 5 /
  21.  day fetch + 1721119 + +
  22. enddef
  23.  
  24. define Julian2Date ( j -- m d y )
  25.  4 * 6884477 - dup x store
  26.  146097 / 100 * year store
  27.  x fetch 146097 mod 4 /
  28.  4 * 3 + dup x store
  29.  1461 / year fetch + year store
  30.  x fetch 1461 mod 4 / 1 +
  31.  dup day store
  32.  5 * 3 - dup x store
  33.  153 / 1 + month store
  34.  x fetch 153 mod 5 / 1 + day store
  35.  month fetch dup 11 <
  36.  if 2 + else 10 - year fetch
  37.     1 + year store endif
  38.  dup month store
  39.  day fetch
  40.  year fetch
  41. enddef
  42.  
  43. deftable day$
  44.  "Sunday" "Monday" "Tuesday"
  45.  "Wednesday" "Thursday" "Friday"
  46.  "Saturday"
  47. endtable
  48.  
  49. define dow ( m d y -- dow )
  50.  Date2Julian 1 + 7 mod 1 +
  51. enddef
  52.  
  53. deftable month$
  54.  "January" "February" "March"
  55.  "April" "May" "June"
  56.  "July" "August" "September"
  57.  "October" "November" "December"
  58. endtable
  59.  
  60. define print4 ( n -- )
  61. # prints n in a space 4 chars wide
  62.  str$ len 1 =
  63.  if "  " else " " endif
  64.  swap$ +$ " " +$ print$
  65. enddef
  66.  
  67. define calendar ( m y -- m y )
  68. # Displays a one month calendar
  69. 0 0 locate
  70. |
  71. | ┌─────────────────────────────┐
  72. | │                             │
  73. | ├─────────────────────────────┤
  74. | │ Sun Mon Tue Wed Thu Fri Sat │
  75. | ├─────────────────────────────┤
  76. | │                             │
  77. | │                             │
  78. | │                             │
  79. | │                             │
  80. | │                             │
  81. | │                             │
  82. | └─────────────────────────────┘
  83.  over over
  84.  row 11 - 2 locate
  85.  over month$ print$ " " print$ dup print
  86.  row 4 + 2 locate
  87.  1 swap
  88.  3 pick 12 = if 1 1 3 pick 1 +
  89.             else 3 pick 1 + 1 3 pick
  90.             endif
  91.  Date2Julian
  92.  4 pick 4 pick 4 pick
  93.  Date2Julian -
  94.  push Dow 1 - 4 * column + row swap
  95.  locate
  96.  0 pop
  97.  do
  98.   1 +
  99.   dup print4
  100.   column 26 > if row 1 + 2 locate endif
  101.  loop
  102.  drop
  103.  cr
  104. enddef
  105.  
  106. date$ dup$
  107. 2 left$ val
  108. 4 right$ val
  109.  
  110. calendar
  111. 0 cursor
  112. begin
  113.   2 21 locate time$ print$
  114.   key
  115. until
  116. cls
  117. 1 cursor
  118.