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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-11-11 19:31:21 -06:00
parent c2b3d6b894 a9eb2de22d
commit 1407fa5410
3 changed files with 217 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
basis/calendar/calendar.factor
View File

@ -157,6 +157,18 @@ M: timestamp easter ( timestamp -- timestamp )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
GENERIC: year ( obj -- n )
M: integer year ;
M: timestamp year year>> ;
GENERIC: month ( obj -- n )
M: integer month ;
M: timestamp month month>> ;
GENERIC: day ( obj -- n )
M: integer day ;
M: timestamp day day>> ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
@ -398,14 +410,72 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: day-of-year ( timestamp -- n )
>date< (day-of-year) ;
: midnight ( timestamp -- new-timestamp )
clone 0 >>hour 0 >>minute 0 >>second ; inline
: noon ( timestamp -- new-timestamp )
midnight 12 >>hour ; inline
: beginning-of-month ( timestamp -- new-timestamp )
midnight 1 >>day ;
<PRIVATE
: day-offset ( timestamp m -- timestamp n )
: day-offset ( timestamp m -- new-timestamp n )
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp )
: day-this-week ( timestamp n -- new-timestamp )
day-offset days time+ ;
:: nth-day-this-month ( timestamp n day -- new-timestamp )
timestamp beginning-of-month day day-this-week
dup timestamp [ month>> ] bi@ = [ 1 weeks time+ ] unless
n 1 - [ weeks time+ ] unless-zero ;
: last-day-this-month ( timestamp day -- new-timestamp )
[ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
PRIVATE>
GENERIC: january ( obj -- timestamp )
GENERIC: february ( obj -- timestamp )
GENERIC: march ( obj -- timestamp )
GENERIC: april ( obj -- timestamp )
GENERIC: may ( obj -- timestamp )
GENERIC: june ( obj -- timestamp )
GENERIC: july ( obj -- timestamp )
GENERIC: august ( obj -- timestamp )
GENERIC: september ( obj -- timestamp )
GENERIC: october ( obj -- timestamp )
GENERIC: november ( obj -- timestamp )
GENERIC: december ( obj -- timestamp )
M: integer january 1 1 <date> ;
M: integer february 2 1 <date> ;
M: integer march 3 1 <date> ;
M: integer april 4 1 <date> ;
M: integer may 5 1 <date> ;
M: integer june 6 1 <date> ;
M: integer july 7 1 <date> ;
M: integer august 8 1 <date> ;
M: integer september 9 1 <date> ;
M: integer october 10 1 <date> ;
M: integer november 11 1 <date> ;
M: integer december 12 1 <date> ;
M: timestamp january clone 1 >>month ;
M: timestamp february clone 2 >>month ;
M: timestamp march clone 3 >>month ;
M: timestamp april clone 4 >>month ;
M: timestamp may clone 5 >>month ;
M: timestamp june clone 6 >>month ;
M: timestamp july clone 7 >>month ;
M: timestamp august clone 8 >>month ;
M: timestamp september clone 9 >>month ;
M: timestamp october clone 10 >>month ;
M: timestamp november clone 11 >>month ;
M: timestamp december clone 12 >>month ;
: sunday ( timestamp -- new-timestamp ) 0 day-this-week ;
: monday ( timestamp -- new-timestamp ) 1 day-this-week ;
: tuesday ( timestamp -- new-timestamp ) 2 day-this-week ;
@ -414,14 +484,21 @@ PRIVATE>
: friday ( timestamp -- new-timestamp ) 5 day-this-week ;
: saturday ( timestamp -- new-timestamp ) 6 day-this-week ;
: midnight ( timestamp -- new-timestamp )
clone 0 >>hour 0 >>minute 0 >>second ; inline
: sunday-of-month ( timestamp n -- new-timestamp ) 0 nth-day-this-month ;
: monday-of-month ( timestamp n -- new-timestamp ) 1 nth-day-this-month ;
: tuesday-of-month ( timestamp n -- new-timestamp ) 2 nth-day-this-month ;
: wednesday-of-month ( timestamp n -- new-timestamp ) 3 nth-day-this-month ;
: thursday-of-month ( timestamp n -- new-timestamp ) 4 nth-day-this-month ;
: friday-of-month ( timestamp n -- new-timestamp ) 5 nth-day-this-month ;
: saturday-of-month ( timestamp n -- new-timestamp ) 6 nth-day-this-month ;
: noon ( timestamp -- new-timestamp )
midnight 12 >>hour ; inline
: beginning-of-month ( timestamp -- new-timestamp )
midnight 1 >>day ;
: last-sunday-of-month ( timestamp -- new-timestamp ) 0 last-day-this-month ;
: last-monday-of-month ( timestamp -- new-timestamp ) 1 last-day-this-month ;
: last-tuesday-of-month ( timestamp -- new-timestamp ) 2 last-day-this-month ;
: last-wednesday-of-month ( timestamp -- new-timestamp ) 3 last-day-this-month ;
: last-thursday-of-month ( timestamp -- new-timestamp ) 4 last-day-this-month ;
: last-friday-of-month ( timestamp -- new-timestamp ) 5 last-day-this-month ;
: last-saturday-of-month ( timestamp -- new-timestamp ) 6 last-day-this-month ;
: beginning-of-week ( timestamp -- new-timestamp )
midnight sunday ;

1
extra/calendar/holidays/us/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

130
extra/calendar/holidays/us/us.factor Normal file
View File

@ -0,0 +1,130 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar kernel math words ;
IN: calendar.holidays.us
<<
SYNTAX: us-federal
word "us-federal" dup set-word-prop ;
>>
! Federal Holidays
: new-years-day ( timestamp/n -- timestamp )
january 1 >>day ; us-federal
: martin-luther-king-day ( timestamp/n -- timestamp )
january 3 monday-of-month ; us-federal
: inauguration-day ( timestamp/n -- timestamp )
year dup neg 4 rem + january 20 >>day ; us-federal
: washington's-birthday ( timestamp/n -- timestamp )
february 3 monday-of-month ; us-federal
ALIAS: presidents-day washington's-birthday us-federal
: memorial-day ( timestamp/n -- timestamp )
may last-monday-of-month ; us-federal
: independence-day ( timestamp/n -- timestamp )
july 4 >>day ; us-federal
: labor-day ( timestamp/n -- timestamp )
september 1 monday-of-month ; us-federal
: columbus-day ( timestamp/n -- timestamp )
october 2 monday-of-month ; us-federal
: veterans'-day ( timestamp/n -- timestamp )
november 11 >>day ; us-federal
: thanksgiving-day ( timestamp/n -- timestamp )
november 4 thursday-of-month ; us-federal
: christmas-day ( timestamp/n -- timestamp )
december 25 >>day ; us-federal
! Other Holidays
: belly-laugh-day ( timestamp/n -- timestamp )
january 24 >>day ;
: groundhog-day ( timestamp/n -- timestamp )
february 2 >>day ;
: lincoln's-birthday ( timestamp/n -- timestamp )
february 12 >>day ;
: valentine's-day ( timestamp/n -- timestamp )
february 14 >>day ;
: st-patrick's-day ( timestamp/n -- timestamp )
march 17 >>day ;
: ash-wednesday ( timestamp/n -- timestamp )
easter 46 days time- ;
ALIAS: first-day-of-lent ash-wednesday
: fat-tuesday ( timestamp/n -- timestamp )
ash-wednesday 1 days time- ;
: good-friday ( timestamp/n -- timestamp )
easter 2 days time- ;
: tax-day ( timestamp/n -- timestamp )
april 15 >>day ;
: earth-day ( timestamp/n -- timestamp )
april 22 >>day ;
: administrative-professionals'-day ( timestamp/n -- timestamp )
april last-saturday-of-month wednesday ;
: cinco-de-mayo ( timestamp/n -- timestamp )
may 5 >>day ;
: mother's-day ( timestamp/n -- timestamp )
may 2 sunday-of-month ;
: armed-forces-day ( timestamp/n -- timestamp )
may 3 saturday-of-month ;
: flag-day ( timestamp/n -- timestamp )
june 14 >>day ;
: parents'-day ( timestamp/n -- timestamp )
july 4 sunday-of-month ;
: grandparents'-day ( timestamp/n -- timestamp )
labor-day 1 weeks time+ ;
: patriot-day ( timestamp/n -- timestamp )
september 11 >>day ;
: stepfamily-day ( timestamp/n -- timestamp )
september 16 >>day ;
: citizenship-day ( timestamp/n -- timestamp )
september 17 >>day ;
: boss's-day ( timestamp/n -- timestamp )
october 16 >>day ;
: sweetest-day ( timestamp/n -- timestamp )
october 3 saturday-of-month ;
: halloween ( timestamp/n -- timestamp )
october 31 >>day ;
: election-day ( timestamp/n -- timestamp )
november 1 monday-of-month 1 days time+ ;
: black-friday ( timestamp/n -- timestamp )
thanksgiving-day 1 days time+ ;
: pearl-harbor-remembrance-day ( timestamp/n -- timestamp )
december 7 >>day ;
: new-year's-eve ( timestamp/n -- timestamp )
december 31 >>day ;