diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index 804c2b5fb1..f700d244f5 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,15 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -! [ 2004 12 32 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 2 30 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2003 2 29 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 -2 9 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 0 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 24 0 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 23 60 0 0 ] [ "invalid timestamp" = ] must-fail-with -! [ 2004 12 1 23 59 60 0 ] [ "invalid timestamp" = ] must-fail-with +[ f ] [ 2004 12 32 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 2 30 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2003 2 29 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 -2 9 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 0 0 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 24 0 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 60 0 0 valid-timestamp? ] unit-test +[ f ] [ 2004 12 1 23 59 60 0 valid-timestamp? ] unit-test +[ t ] [ now valid-timestamp? ] unit-test [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 044553067b..2b80a8dce6 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -37,9 +37,12 @@ C: duration : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ; : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ; -: average-month ( -- x ) - #! length of average month in days - 30.41666666666667 ; +: average-month 30+5/12 ; inline +: months-per-year 12 ; inline +: days-per-year 3652425/10000 ; inline +: hours-per-year 876582/100 ; inline +: minutes-per-year 5259492/10 ; inline +: seconds-per-year 31556952 ; inline whole-part swapd 365.2425 * +day swap +year ] unless-zero ; + [ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ; : months/years ( n -- months years ) 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline @@ -191,33 +194,37 @@ M: timestamp time+ >r clone r> (time+) drop ; M: duration time+ - [ year>> ] +slots - [ month>> ] +slots - [ day>> ] +slots - [ hour>> ] +slots - [ minute>> ] +slots - [ second>> ] +slots - 2drop ; + dup timestamp? [ + swap time+ + ] [ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop + ] if ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data 0 swap [ year>> + ] keep - [ month>> 12 / + ] keep - [ day>> 365.2425 / + ] keep - [ hour>> 8765.82 / + ] keep - [ minute>> 525949.2 / + ] keep - second>> 31556952.0 / + ; + [ month>> months-per-year / + ] keep + [ day>> days-per-year / + ] keep + [ hour>> hours-per-year / + ] keep + [ minute>> minutes-per-year / + ] keep + second>> seconds-per-year / + ; M: duration <=> [ dt>years ] compare ; -: dt>months ( dt -- x ) dt>years 12 * ; -: dt>days ( dt -- x ) dt>years 365.2425 * ; -: dt>hours ( dt -- x ) dt>years 8765.82 * ; -: dt>minutes ( dt -- x ) dt>years 525949.2 * ; -: dt>seconds ( dt -- x ) dt>years 31556952 * ; -: dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; +: dt>months ( dt -- x ) dt>years months-per-year * ; +: dt>days ( dt -- x ) dt>years days-per-year * ; +: dt>hours ( dt -- x ) dt>years hours-per-year * ; +: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; +: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; : convert-timezone ( timestamp n -- timestamp ) over gmt-offset>> over = [ drop ] [ @@ -233,26 +240,16 @@ M: duration <=> [ dt>years ] compare ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: time- ( timestamp timestamp -- seconds ) - #! Exact calendar-time difference +: (time-) ( timestamp timestamp -- n ) [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; -: unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; foldable +GENERIC: time- ( time1 time2 -- time ) -: millis>timestamp ( n -- timestamp ) - >r unix-1970 r> milliseconds time+ ; - -: timestamp>millis ( timestamp -- n ) - unix-1970 time- 1000 * >integer ; - -: gmt ( -- timestamp ) - #! GMT time, right now - unix-1970 millis milliseconds time+ ; - -: now ( -- timestamp ) gmt >local-time ; +M: timestamp time- + #! Exact calendar-time difference + (time-) seconds ; : before ( dt -- -dt ) [ year>> neg ] keep @@ -263,10 +260,34 @@ M: timestamp <=> ( ts1 ts2 -- n ) second>> neg ; -: from-now ( dt -- timestamp ) now swap time+ ; -: ago ( dt -- timestamp ) before from-now ; +M: duration time- + before time+ ; -: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; +: 0 0 0 0 0 0 0 ; + +: valid-timestamp? ( timestamp -- ? ) + clone 0 >>gmt-offset + dup time- time+ = ; + +: unix-1970 ( -- timestamp ) + 1970 1 1 0 0 0 0 ; foldable + +: millis>timestamp ( n -- timestamp ) + >r unix-1970 r> milliseconds time+ ; + +: timestamp>millis ( timestamp -- n ) + unix-1970 (time-) 1000 * >integer ; + +: gmt ( -- timestamp ) + #! GMT time, right now + unix-1970 millis milliseconds time+ ; + +: now ( -- timestamp ) gmt >local-time ; + +: from-now ( dt -- timestamp ) now swap time+ ; +: ago ( dt -- timestamp ) now swap time- ; + +: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline : zeller-congruence ( year month day -- n ) #! Zeller Congruence @@ -347,7 +368,7 @@ M: timestamp day-of-year ( timestamp -- n ) : beginning-of-year ( timestamp -- new-timestamp ) beginning-of-month 1 >>month ; -: seconds-since-midnight ( timestamp -- x ) +: time-since-midnight ( timestamp -- duration ) dup beginning-of-day time- ; M: timestamp sleep-until timestamp>millis sleep-until ; diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index 391af05ffa..a2c3ebcd1f 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -45,25 +45,20 @@ IN: project-euler.019 ; + 1901 1 1 ; : end-date ( -- timestamp ) - 2000 12 31 0 0 0 0 ; + 2000 12 31 ; -: (first-days) ( end-date start-date -- ) - 2dup time- 0 >= [ - dup day-of-week , 1 months time+ (first-days) - ] [ - 2drop - ] if ; - -: first-days ( start-date end-date -- seq ) - [ swap (first-days) ] { } make ; +: first-days ( end-date start-date -- days ) + [ 2dup after=? ] + [ dup 1 months time+ swap day-of-week ] + [ ] unfold 2nip ; PRIVATE> : euler019a ( -- answer ) - start-date end-date first-days [ zero? ] count ; + end-date start-date first-days [ zero? ] count ; ! [ euler019a ] 100 ave-time ! 131 ms run / 3 ms GC ave time - 100 trials diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 011f500d88..62d2805f01 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -23,7 +23,7 @@ IN: windows.time : timestamp>windows-time ( timestamp -- n ) #! 64bit number representing # of nanoseconds since Jan 1, 1601 (UTC) - >gmt windows-1601 time- >integer 10000000 * ; + >gmt windows-1601 (time-) 10000000 * >integer ; : windows-time>FILETIME ( n -- FILETIME ) "FILETIME"