home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 5
/
ctrom5b.zip
/
ctrom5b
/
PROGRAM
/
DIVERSEN
/
TIPI2A
/
CAL.TPI
< prev
next >
Wrap
Text File
|
1994-10-02
|
2KB
|
118 lines
# CALENDAR.TPI by Kent Peterson
# 12/03/93
defvar x
defvar month
defvar day
defvar year
define Date2Julian ( m d y -- j )
year store day store month store
year fetch 1583 < if
"Date2Julian: Year is less than 1583"
print$ 1 bye endif
month fetch dup 2 > if 3 - month store
else 9 + month store
year fetch 1 - year store
endif
146097 year fetch 100 / * 4 /
1461 year fetch 100 mod * 4 / +
153 month fetch * 2 + 5 /
day fetch + 1721119 + +
enddef
define Julian2Date ( j -- m d y )
4 * 6884477 - dup x store
146097 / 100 * year store
x fetch 146097 mod 4 /
4 * 3 + dup x store
1461 / year fetch + year store
x fetch 1461 mod 4 / 1 +
dup day store
5 * 3 - dup x store
153 / 1 + month store
x fetch 153 mod 5 / 1 + day store
month fetch dup 11 <
if 2 + else 10 - year fetch
1 + year store endif
dup month store
day fetch
year fetch
enddef
deftable day$
"Sunday" "Monday" "Tuesday"
"Wednesday" "Thursday" "Friday"
"Saturday"
endtable
define dow ( m d y -- dow )
Date2Julian 1 + 7 mod 1 +
enddef
deftable month$
"January" "February" "March"
"April" "May" "June"
"July" "August" "September"
"October" "November" "December"
endtable
define print4 ( n -- )
# prints n in a space 4 chars wide
str$ len 1 =
if " " else " " endif
swap$ +$ " " +$ print$
enddef
define calendar ( m y -- m y )
# Displays a one month calendar
0 0 locate
|
| ┌─────────────────────────────┐
| │ │
| ├─────────────────────────────┤
| │ Sun Mon Tue Wed Thu Fri Sat │
| ├─────────────────────────────┤
| │ │
| │ │
| │ │
| │ │
| │ │
| │ │
| └─────────────────────────────┘
over over
row 11 - 2 locate
over month$ print$ " " print$ dup print
row 4 + 2 locate
1 swap
3 pick 12 = if 1 1 3 pick 1 +
else 3 pick 1 + 1 3 pick
endif
Date2Julian
4 pick 4 pick 4 pick
Date2Julian -
push Dow 1 - 4 * column + row swap
locate
0 pop
do
1 +
dup print4
column 26 > if row 1 + 2 locate endif
loop
drop
cr
enddef
date$ dup$
2 left$ val
4 right$ val
calendar
0 cursor
begin
2 21 locate time$ print$
key
until
cls
1 cursor