calendar: Add word for getting dates from ordinals.

diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
index a5aa8ece366923e7cf65db521c4871a4b17d1c19..8e18bea051d415c0e0431f97ca4cdd160b532f65 100644 (file)
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@@ -1,4 +1,5 @@
-USING: accessors kernel math.order random threads tools.test ;
+USING: accessors grouping kernel math math.order math.ranges
+random sequences threads tools.test ;
 IN: calendar
 
 [ 2004 12 32 0   0  0 instant <timestamp> ] [ not-in-interval? ] must-fail-with
@@ -213,4 +214,39 @@ IN: calendar
 { f } [ now dup end-of-year eq? ] unit-test
 
 { f } [ now dup midnight eq? ] unit-test
-{ t } [ now dup midnight! eq? ] unit-test
\ No newline at end of file
+{ t } [ now dup midnight! eq? ] unit-test
+
+{
+    T{ timestamp { year 2019 } { month 11 } { day 4 } }
+} [ 2019 308 year-ordinal>timestamp >gmt midnight ] unit-test
+
+{
+    T{ timestamp { year 2020 } { month 11 } { day 3 } }
+} [ 2020 308 year-ordinal>timestamp >gmt midnight ] unit-test
+
+{
+    T{ timestamp { year 2019 } { month 12 } { day 31 } }
+} [ 2019 365 year-ordinal>timestamp >gmt midnight ] unit-test
+
+{
+    T{ timestamp { year 2020 } { month 12 } { day 31 } }
+} [ 2020 366 year-ordinal>timestamp >gmt midnight ] unit-test
+
+{ t } [
+    2020 <year> timestamp>year-dates
+    [ >date< ymd>ordinal ] map [ < ] monotonic?
+] unit-test
+
+{ t } [
+    1999 2025 [a,b] [
+        <year> timestamp>year-dates
+        [ >date< ymd>ordinal ] map [ < ] monotonic?
+    ] map [ ] all?
+] unit-test
+
+{ t } [
+    1999 2025 [a,b] [
+        <year-gmt> timestamp>year-dates
+        [ >date< ymd>ordinal ] map [ < ] monotonic?
+    ] map [ ] all?
+] unit-test
\ No newline at end of file

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index ea86f416a7bfb3800c3bd85a0000de35e0409d31..691018bab0bea4e2d3e18724c833b823e5a47816 100644 (file)
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -1,9 +1,10 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.tuple combinators
+USING: accessors classes.tuple combinators
 combinators.short-circuit kernel locals math math.functions
-math.intervals math.order sequences summary system vocabs vocabs.loader
-assocs ;
+math.intervals math.order math.parser sequences splitting system
+vocabs vocabs.loader ;
+QUALIFIED-WITH: math.ranges R
 IN: calendar
 
 ERROR: not-in-interval value interval ;
@@ -135,6 +136,20 @@ M: timestamp easter
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
+: set-time! ( timestamp hours minutes seconds -- timestamp )
+    [ >>hour ] [ >>minute ] [ >>second ] tri* ;
+
+: set-time ( timestamp hours minutes seconds -- timestamp )
+    clone set-time! ;
+
+: time>hms ( str -- hms-seq )
+    ":" split [ string>number ] map
+    3 0 pad-tail ;
+
+: time>offset ( str -- hms-seq )
+    "-" ?head [ time>hms ] dip
+    [ [ neg ] map ] when ;
+
 : years ( x -- duration ) instant swap >>year ;
 : months ( x -- duration ) instant swap >>month ;
 : days ( x -- duration ) instant swap >>day ;
@@ -447,8 +462,7 @@ M: integer end-of-year 12 31 <date> end-of-day! ;
 
 :: nth-day-this-month ( timestamp n day -- new-timestamp )
     timestamp beginning-of-month day day-this-week
-    dup timestamp [ month>> ] same? [ 1 weeks time+ ] unless
-    n 1 - [ weeks time+ ] unless-zero ;
+    dup timestamp [ month>> ] same? [ 1 weeks time+ ] unless ;
 
 : last-day-this-month ( timestamp day -- new-timestamp )
     [ 1 months time+ 1 ] dip nth-day-this-month 1 weeks time- ;
@@ -576,6 +590,25 @@ M: timestamp december clone 12 >>month ;
 : quarter ( timestamp -- [1,4] )
     month>> 3 /mod [ drop 1 + ] unless-zero ; inline
 
+! January and February need a fixup with this algorithm.
+! Find a better algorithm.
+: ymd>ordinal ( year month day -- ordinal )
+    [ leap-year? dup -2 -3 ? ]
+    [ tuck dup 3 < [ 12 + ] when [ 1 - 30 * ] [ 1 + .6 * floor ] bi + ]
+    [ ] tri* + + >integer
+    rot 366 365 ?
+    rot 3 < [ - ] [ drop ] if ;
+
+: timestamp>year-dates ( timestamp -- seq )
+    [ beginning-of-year >date< julian-day-number ]
+    [ days-in-year ] bi
+    [ drop ] [ + ] 2bi
+    R:[a,b) [ julian-day-number>date <date> ] map ;
+
+: year-ordinal>timestamp ( year ordinal -- timestamp )
+    [ 1 1 julian-day-number ] dip
+    + 1 - julian-day-number>date <date> ;
+
 GENERIC: weeks-in-week-year ( obj -- n )
 M: integer weeks-in-week-year
     { [ 1 1 <date> thursday? ] [ 12 31 <date> thursday? ] } 1|| 53 52 ? ;