! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables io io.streams.string kernel math math.vectors math.functions math.parser namespaces sequences strings tuples system debugger combinators vocabs.loader calendar.backend structs alien.c-types math.vectors math.ranges shuffle ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp TUPLE: dt year month day hour minute second ; C:
dt : month-names { "Not a month" "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December" } ; : month-abbreviations { "Not a month" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec" } ; : day-names { "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" } ; : 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 ; SYMBOL: a SYMBOL: b SYMBOL: c SYMBOL: d SYMBOL: e SYMBOL: y SYMBOL: m : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 [ 14 pick - 12 /i a set pick 4800 + a get - y set over 12 a get * + 3 - m set 2nip 153 m get * 2 + 5 /i + 365 y get * + y get 4 /i + y get 100 /i - y get 400 /i + 32045 - ] with-scope ; : julian-day-number>date ( n -- year month day ) #! 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 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-timestamp-day ] keep [ set-timestamp-month ] keep set-timestamp-year ; : set-time ( hour minute second timestamp -- ) [ set-timestamp-second ] keep [ set-timestamp-minute ] keep set-timestamp-hour ; : >date< ( timestamp -- year month day ) [ timestamp-year ] keep [ timestamp-month ] keep timestamp-day ; : >time< ( timestamp -- hour minute second ) [ timestamp-hour ] keep [ timestamp-minute ] keep timestamp-second ; : zero-dt ( --
) 0 0 0 0 0 0
; : years ( n -- dt ) zero-dt [ set-dt-year ] keep ; : months ( n -- dt ) zero-dt [ set-dt-month ] keep ; : days ( n -- dt ) zero-dt [ set-dt-day ] keep ; : weeks ( n -- dt ) 7 * days ; : hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; : minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; : seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; : milliseconds ( n -- dt ) 1000 /f seconds ; : julian-day-number>timestamp ( n -- timestamp ) julian-day-number>date 0 0 0 0 ; GENERIC: +year ( timestamp x -- timestamp ) GENERIC: +month ( timestamp x -- timestamp ) GENERIC: +day ( timestamp x -- timestamp ) GENERIC: +hour ( timestamp x -- timestamp ) GENERIC: +minute ( timestamp x -- timestamp ) GENERIC: +second ( timestamp x -- timestamp ) : /rem ( f n -- q r ) #! q is positive or negative, r is positive from 0 <= r < n [ /f floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) [ floor >integer ] keep over - ; GENERIC: leap-year? ( obj -- ? ) M: integer leap-year? ( year -- ? ) dup 100 mod zero? 400 4 ? mod zero? ; M: timestamp leap-year? ( timestamp -- ? ) timestamp-year leap-year? ; : adjust-leap-year ( timestamp -- timestamp ) dup >date< 29 = swap 2 = and swap leap-year? not and [ dup >r timestamp-year 3 1 r> [ set-date ] keep ] when ; M: integer +year ( timestamp n -- timestamp ) over timestamp-year + swap [ set-timestamp-year ] keep adjust-leap-year ; M: real +year ( timestamp n -- timestamp ) float>whole-part rot swap 365.2425 * +day swap +year ; M: integer +month ( timestamp n -- timestamp ) over timestamp-month + 12 /rem dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month +year ; M: real +month ( timestamp n -- timestamp ) float>whole-part rot swap average-month * +day swap +month ; M: integer +day ( timestamp n -- timestamp ) swap [ >date< julian-day-number + julian-day-number>timestamp ] keep swap >r >time< r> [ set-time ] keep ; M: real +day ( timestamp n -- timestamp ) float>whole-part rot swap 24 * +hour swap +day ; M: integer +hour ( timestamp n -- timestamp ) over timestamp-hour + 24 /rem pick set-timestamp-hour +day ; M: real +hour ( timestamp n -- timestamp ) float>whole-part rot swap 60 * +minute swap +hour ; M: integer +minute ( timestamp n -- timestamp ) over timestamp-minute + 60 /rem pick set-timestamp-minute +hour ; M: real +minute ( timestamp n -- timestamp ) float>whole-part rot swap 60 * +second swap +minute ; M: number +second ( timestamp n -- timestamp ) over timestamp-second + 60 /rem >r >integer r> pick set-timestamp-second +minute ; : +dt ( timestamp dt -- timestamp ) dupd [ dt-second +second ] keep [ dt-minute +minute ] keep [ dt-hour +hour ] keep [ dt-day +day ] keep [ dt-month +month ] keep dt-year +year swap timestamp-gmt-offset over set-timestamp-gmt-offset ; : make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) [ 0 seconds +dt ] keep [ = [ "invalid timestamp" throw ] unless ] keep ; : make-date ( year month day -- timestamp ) 0 0 0 gmt-offset make-timestamp ; : array>dt ( vec -- dt ) { dt f } swap append >tuple ; : +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data tuple-slots { 1 12 365.2425 8765.82 525949.2 31556952.0 } v/ sum ; : 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 * ; : convert-timezone ( timestamp n -- timestamp ) [ over timestamp-gmt-offset - hours +dt ] keep over set-timestamp-gmt-offset ; : >local-time ( timestamp -- timestamp ) gmt-offset convert-timezone ; : >gmt ( timestamp -- timestamp ) 0 convert-timezone ; M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; : timestamp- ( timestamp timestamp -- seconds ) #! Exact calendar-time difference [ >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 ; : unix-time>timestamp ( n -- timestamp ) >r unix-1970 r> seconds +dt ; : timestamp>unix-time ( timestamp -- n ) unix-1970 timestamp- >integer ; : timestamp>timeval ( timestamp -- timeval ) timestamp>unix-time 1000 * make-timeval ; : timeval>timestamp ( timeval -- timestamp ) [ timeval-sec ] keep timeval-usec 1000000 / + unix-time>timestamp ; : gmt ( -- timestamp ) #! GMT time, right now unix-1970 millis 1000 /f seconds +dt ; : now ( -- timestamp ) gmt >local-time ; : before ( dt -- -dt ) tuple-slots vneg array>dt ; : from-now ( dt -- timestamp ) now swap +dt ; : ago ( dt -- timestamp ) before from-now ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; : zeller-congruence ( year month day -- n ) #! Zeller Congruence #! http://web.textfiles.com/computers/formulas.txt #! good for any date since October 15, 1582 >r dup 2 <= [ 12 + >r 1- r> ] when >r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r> [ 1+ 3 * 5 /i + ] keep 2 * + r> 1+ + 7 mod ; GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; GENERIC: days-in-month ( obj -- n ) M: array days-in-month ( obj -- n ) first2 dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ; M: timestamp days-in-month ( timestamp -- n ) { timestamp-year timestamp-month } get-slots 2array days-in-month ; GENERIC: day-of-week ( obj -- n ) M: timestamp day-of-week ( timestamp -- n ) >date< zeller-congruence ; M: array day-of-week ( array -- n ) first3 zeller-congruence ; GENERIC: day-of-year ( obj -- n ) M: array day-of-year ( array -- n ) first3 3dup day-counts rot head-slice sum + swap leap-year? [ -roll pick 3 1 make-date >r make-date r> <=> 0 >= [ 1+ ] when ] [ 3nip ] if ; M: timestamp day-of-year ( timestamp -- n ) { timestamp-year timestamp-month timestamp-day } get-slots 3array day-of-year ; GENERIC: day. ( obj -- ) M: integer day. ( n -- ) number>string dup length 2 < [ bl ] when write ; M: timestamp day. ( timestamp -- ) timestamp-day day. ; GENERIC: month. ( obj -- ) M: array month. ( pair -- ) first2 [ month-names nth write bl number>string print ] 2keep [ 1 zeller-congruence ] 2keep 2array days-in-month day-abbreviations2 " " join print over " " concat write [ [ 1+ day. ] keep 1+ + 7 mod zero? [ nl ] [ bl ] if ] with each nl ; M: timestamp month. ( timestamp -- ) { timestamp-year timestamp-month } get-slots 2array month. ; GENERIC: year. ( obj -- ) M: integer year. ( n -- ) 12 [ 1+ 2array month. nl ] with each ; M: timestamp year. ( timestamp -- ) timestamp-year year. ; : pad-00 number>string 2 CHAR: 0 pad-left write ; : (timestamp>string) ( timestamp -- ) dup day-of-week day-abbreviations3 nth write ", " write dup timestamp-day number>string write bl dup timestamp-month month-abbreviations nth write bl dup timestamp-year number>string write bl dup timestamp-hour pad-00 ":" write dup timestamp-minute pad-00 ":" write timestamp-second >fixnum pad-00 ; : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT >gmt [ (timestamp>string) " GMT" write ] string-out ; : (timestamp>rfc3339) ( timestamp -- ) dup timestamp-year number>string write CHAR: - write1 dup timestamp-month pad-00 CHAR: - write1 dup timestamp-day pad-00 CHAR: T write1 dup timestamp-hour pad-00 CHAR: : write1 dup timestamp-minute pad-00 CHAR: : write1 timestamp-second >fixnum pad-00 CHAR: Z write1 ; : timestamp>rfc3339 ( timestamp -- str ) >gmt [ (timestamp>rfc3339) ] string-out ; : expect read1 assert= ; : (rfc3339>timestamp) ( -- timestamp ) 4 read string>number ! year CHAR: - expect 2 read string>number ! month CHAR: - expect 2 read string>number ! day CHAR: T expect 2 read string>number ! hour CHAR: : expect 2 read string>number ! minute CHAR: : expect 2 read string>number ! second 0 ; : rfc3339>timestamp ( str -- timestamp ) [ (rfc3339>timestamp) ] string-in ; : file-time-string ( timestamp -- string ) [ [ timestamp-month month-abbreviations nth write ] keep bl [ timestamp-day number>string 2 32 pad-left write ] keep bl dup now [ timestamp-year ] 2apply = [ [ timestamp-hour pad-00 ] keep ":" write timestamp-minute pad-00 ] [ timestamp-year number>string 5 32 pad-left write ] if ] string-out ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline : day-this-week ( timestamp n -- timestamp ) day-offset days +dt ; : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; : tuesday ( timestamp -- timestamp ) 2 day-this-week ; : wednesday ( timestamp -- timestamp ) 3 day-this-week ; : thursday ( timestamp -- timestamp ) 4 day-this-week ; : friday ( timestamp -- timestamp ) 5 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ; : beginning-of-day ( timestamp -- new-timestamp ) clone dup >r 0 0 0 r> { set-timestamp-hour set-timestamp-minute set-timestamp-second } set-slots ; inline : beginning-of-month ( timestamp -- new-timestamp ) beginning-of-day 1 over set-timestamp-day ; : beginning-of-week ( timestamp -- new-timestamp ) beginning-of-day sunday ; : beginning-of-year ( timestamp -- new-timestamp ) beginning-of-month 1 over set-timestamp-month ; : seconds-since-midnight ( timestamp -- x ) dup beginning-of-day timestamp- ; { { [ unix? ] [ "calendar.unix" ] } { [ windows? ] [ "calendar.windows" ] } } cond require