steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

More calendar cleanups

release
slava 2006-07-25 17:32:11 +00:00
parent 276a9f5928
commit 99e1df4a31
1 changed files with 20 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
contrib/calendar/calendar.factor
View File

@ -48,19 +48,28 @@ SYMBOL: m
: julian-day-number ( year month day -- n ) : julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
[
14 pick - 12 /i a set 14 pick - 12 /i a set
pick 4800 + a get - y set pick 4800 + a get - y set
over 12 a get * + 3 - m set over 12 a get * + 3 - m set
2nip 153 m get * 2 + 5 /i + 365 y get * + 2nip 153 m get * 2 + 5 /i + 365 y get * +
y get 4 /i + y get 100 /i - y get 400 /i + 32045 - ; y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
] with-scope ;
: julian-day-number>date ( n -- year month day ) : julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number #! Inverse of julian-day-number
32044 + a set 4 a get * 3 + 146097 /i b set a get 146097 b [
get * 4 /i - c set 4 c get * 3 + 1461 /i d set c get 1461 d 32044 + a set
get * 4 /i - e set 5 e get * 2 + 153 /i m set 100 b get * d 4 a get * 3 + 146097 /i b set
get + 4800 - m get 10 /i + m get 3 + 12 m get 10 /i * - e a get 146097 b get * 4 /i - c set
get 153 m get * 2 + 5 /i - 1+ ; 4 c get * 3 + 1461 /i d set
c get 1461 d get * 4 /i - e set
5 e get * 2 + 153 /i m set
100 b get * d get + 4800 -
m get 10 /i + m get 3 +
12 m get 10 /i * -
e get 153 m get * 2 + 5 /i - 1+
] with-scope ;
: set-date ( year month day timestamp -- ) : set-date ( year month day timestamp -- )
[ set-timestamp-day ] keep [ set-timestamp-day ] keep
@ -109,11 +118,7 @@ GENERIC: +second ( timestamp x -- timestamp )
[ floor >bignum ] keep dupd swap - ; [ floor >bignum ] keep dupd swap - ;
: leap-year? ( year -- ? ) : leap-year? ( year -- ? )
[ 100 mod zero? ] keep over [ dup 100 mod zero? 400 4 ? mod zero? ;
400 mod zero? and
] [
nip 4 mod zero?
] if ;
: adjust-leap-year ( timestamp -- timestamp ) : adjust-leap-year ( timestamp -- timestamp )
dup date 29 = swap 2 = and swap leap-year? not and [ dup date 29 = swap 2 = and swap leap-year? not and [