libs/calendar/calendar.factor

   1 IN: calendar
   2 USING: arrays errors generic hashtables io kernel math
   3 namespaces sequences strings prettyprint tools ;
   4
   5 TUPLE: timestamp year month day hour minute second gmt-offset ;
   6 TUPLE: dt year month day hour minute second ;
   7
   8 : month-names
   9     {
  10         "Not a month" "January" "February" "March" "April" "May" "June"
  11         "July" "August" "September" "October" "November" "December"
  12     } ;
  13
  14 : months-abbreviations
  15     {
  16         "Not a month"
  17         "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
  18     } ;
  19
  20 : day-names
  21     {
  22         "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
  23     } ;
  24
  25 : day-abbreviations2 { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
  26 : day-abbreviations3 { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
  27
  28 : average-month ( -- x )
  29     #! length of average month in days
  30     30.41666666666667 ;
  31
  32 : compare-timestamps ( tuple tuple -- n )
  33     [ tuple-slots ] 2apply <=> ;
  34
  35 SYMBOL: a
  36 SYMBOL: b
  37 SYMBOL: c
  38 SYMBOL: d
  39 SYMBOL: e
  40 SYMBOL: y
  41 SYMBOL: m
  42
  43 : julian-day-number ( year month day -- n )
  44     #! Returns a composite date number
  45     #! Not valid before year -4800
  46     [
  47         14 pick - 12 /i a set
  48         pick 4800 + a get - y set
  49         over 12 a get * + 3 - m set
  50         2nip 153 m get * 2 + 5 /i + 365 y get * +
  51         y get 4 /i + y get 100 /i - y get 400 /i + 32045 -
  52     ] with-scope ;
  53
  54 : julian-day-number>date ( n -- year month day )
  55     #! Inverse of julian-day-number
  56     [
  57         32044 + a set
  58         4 a get * 3 + 146097 /i b set
  59         a get 146097 b get * 4 /i - c set
  60         4 c get * 3 + 1461 /i d set
  61         c get 1461 d get * 4 /i - e set
  62         5 e get * 2 + 153 /i m set
  63         100 b get * d get + 4800 -
  64         m get 10 /i + m get 3 +
  65         12 m get 10 /i * -
  66         e get 153 m get * 2 + 5 /i - 1+
  67     ] with-scope ;
  68
  69 : set-date ( year month day timestamp -- )
  70     [ set-timestamp-day ] keep
  71     [ set-timestamp-month ] keep
  72     set-timestamp-year ;
  73
  74 : set-time ( hour minute second timestamp -- )
  75     [ set-timestamp-second ] keep
  76     [ set-timestamp-minute ] keep
  77     set-timestamp-hour ;
  78
  79 : >date< ( timestamp -- year month day )
  80     [ timestamp-year ] keep
  81     [ timestamp-month ] keep
  82     timestamp-day ;
  83
  84 : >time< ( timestamp -- hour minute second )
  85     [ timestamp-hour ] keep
  86     [ timestamp-minute ] keep
  87     timestamp-second ;
  88
  89 : zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ;
  90 : years ( n -- dt ) zero-dt [ set-dt-year ] keep ;
  91 : months ( n -- dt ) zero-dt [ set-dt-month ] keep ;
  92 : weeks ( n -- dt ) 7 * zero-dt [ set-dt-day ] keep ;
  93 : days ( n -- dt ) zero-dt [ set-dt-day ] keep ;
  94 : hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ;
  95 : minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ;
  96 : seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ;
  97
  98 : julian-day-number>timestamp ( n -- timestamp )
  99     julian-day-number>date 0 0 0 0 <timestamp> ;
 100
 101 GENERIC: +year ( timestamp x -- timestamp )
 102 GENERIC: +month ( timestamp x -- timestamp )
 103 GENERIC: +day ( timestamp x -- timestamp )
 104 GENERIC: +hour ( timestamp x -- timestamp )
 105 GENERIC: +minute ( timestamp x -- timestamp )
 106 GENERIC: +second ( timestamp x -- timestamp )
 107
 108 : /rem ( f n -- q r )
 109     #! q is positive or negative, r is positive from 0 <= r < n
 110     [ /f floor >bignum ] 2keep rem ;
 111
 112 : float>whole-part ( float -- int float )
 113     [ floor >bignum ] keep dupd swap - ;
 114
 115 : leap-year? ( year -- ? )
 116     dup 100 mod zero? 400 4 ? mod zero? ;
 117
 118 : adjust-leap-year ( timestamp -- timestamp )
 119     dup >date< 29 = swap 2 = and swap leap-year? not and [
 120         dup >r timestamp-year 3 1 r> [ set-date ] keep
 121     ] when ;
 122
 123 M: integer +year ( timestamp n -- timestamp )
 124     over timestamp-year + swap [ set-timestamp-year ] keep
 125     adjust-leap-year ;
 126 M: real +year ( timestamp n -- timestamp )
 127     float>whole-part rot swap 365.2425 * +day swap +year ;
 128
 129 M: integer +month ( timestamp n -- timestamp )
 130     over timestamp-month + 12 /rem
 131     dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
 132     +year ;
 133 M: real +month ( timestamp n -- timestamp )
 134     float>whole-part rot swap average-month * +day swap +month ;
 135
 136 M: integer +day ( timestamp n -- timestamp )
 137     swap [
 138         >date< julian-day-number + julian-day-number>timestamp
 139     ] keep swap >r >time< r> [ set-time ] keep ;
 140 M: real +day ( timestamp n -- timestamp )
 141     float>whole-part rot swap 24 * +hour swap +day ;
 142
 143 M: integer +hour ( timestamp n -- timestamp )
 144     over timestamp-hour + 24 /rem pick set-timestamp-hour
 145     +day ;
 146 M: real +hour ( timestamp n -- timestamp )
 147     float>whole-part rot swap 60 * +minute swap +hour ;
 148
 149 M: integer +minute ( timestamp n -- timestamp )
 150     over timestamp-minute + 60 /rem pick
 151     set-timestamp-minute +hour ;
 152 M: real +minute ( timestamp n -- timestamp )
 153     float>whole-part rot swap 60 * +second swap +minute ;
 154
 155 M: number +second ( timestamp n -- timestamp )
 156     over timestamp-second + 60 /rem >r >bignum r>
 157     pick set-timestamp-second +minute ;
 158
 159 : +dt ( timestamp dt -- timestamp )
 160     dupd
 161     [ dt-second +second ] keep
 162     [ dt-minute +minute ] keep
 163     [ dt-hour +hour ] keep
 164     [ dt-day +day ] keep
 165     [ dt-month +month ] keep
 166     dt-year +year
 167     swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
 168
 169 : make-timestamp ( year month day hour minute second gmt-offset -- timestamp )
 170     <timestamp> [ 0 seconds +dt ] keep
 171     [ = [ "invalid timestamp" throw ] unless ] keep ;
 172
 173 : array>dt ( vec -- dt ) { dt f } swap append >tuple ;
 174 : +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
 175
 176 : dt>years ( dt -- x )
 177     #! Uses average month/year length since dt loses calendar
 178     #! data
 179     tuple-slots
 180     { 1 12 365.2425 8765.82 525949.2 31556952.0 }
 181     [ / ] 2map sum ;
 182 : dt>months ( dt -- x ) dt>years 12 * ;
 183 : dt>days ( dt -- x ) dt>years 365.2425 * ;
 184 : dt>hours ( dt -- x ) dt>years 8765.82 * ;
 185 : dt>minutes ( dt -- x ) dt>years 525949.2 * ;
 186 : dt>seconds ( dt -- x ) dt>years 31556952 * ;
 187
 188 : convert-timezone ( timestamp n -- timestamp )
 189     [ over timestamp-gmt-offset - hours +dt ] keep
 190     over set-timestamp-gmt-offset ;
 191
 192 : >local-time ( timestamp -- timestamp )
 193     gmt-offset convert-timezone ;
 194
 195 : >gmt ( timestamp -- timestamp )
 196     0 convert-timezone ;
 197
 198 : unix-1970
 199     1970 1 1 0 0 0 0 <timestamp> ;
 200
 201 : unix>gmt ( n -- timestamp )
 202     unix-1970 swap seconds +dt ;
 203
 204 : gmt ( -- timestamp )
 205     #! GMT time, right now
 206     unix-1970 millis 1000 /f seconds +dt ;
 207
 208 : timestamp- ( timestamp timestamp -- dt )
 209     [ >gmt tuple-slots ] 2apply v- array>dt ;
 210
 211 : now ( -- timestamp ) gmt >local-time ;
 212 : before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ;
 213 : from-now ( dt -- timestamp ) now swap +dt ;
 214 : ago ( dt -- timestamp ) before from-now ;
 215
 216 : days-in-year ( year -- n ) leap-year? 366 365 ? ;
 217 : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ;
 218 : days-in-month ( year month -- n )
 219     swap leap-year? [
 220         [ day-counts nth ] keep 2 = [ 1+ ] when
 221     ] [
 222         day-counts nth
 223     ] if ;
 224
 225 : zeller-congruence ( year month day -- n )
 226     #! Zeller Congruence
 227     #! http://web.textfiles.com/computers/formulas.txt
 228     #! good for any date since October 15, 1582
 229     >r dup 2 <= [ 12 + >r 1- r> ] when
 230     >r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
 231         [ 1+ 3 * 5 /i + ] keep 2 * + r>
 232     1+ + 7 mod ;
 233
 234 : day-of-week ( timestamp -- n )
 235     [ timestamp-year ] keep
 236     [ timestamp-month ] keep
 237     timestamp-day
 238     zeller-congruence ;
 239
 240 : day-of-year ( timestamp -- n )
 241     [
 242         [ timestamp-year leap-year? ] keep
 243         [ >date< 3array ] keep timestamp-year 3 1 3array <=>
 244         0 >= and 1 0 ?
 245     ] keep
 246     [ timestamp-month day-counts swap head-slice sum + ] keep
 247     timestamp-day + ;
 248
 249 : print-day ( n -- )
 250     number>string dup length 2 < [ bl ] when write ;
 251
 252 : print-month ( year month -- )
 253     [ month-names nth write bl . ] 2keep
 254     [ 1 zeller-congruence ] 2keep
 255     days-in-month day-abbreviations2 " " join print
 256     over [ "   " write ] times
 257     [
 258         [ 1+ print-day ] keep
 259         1+ + 7 mod zero? [ terpri ] [ bl ] if
 260     ] each-with terpri ;
 261
 262 : print-year ( year -- )
 263     12 [ 1+ print-month terpri ] each-with ;
 264
 265 : (timestamp>string) ( timestamp -- )
 266     dup day-of-week day-abbreviations3 nth write ", " write
 267     dup timestamp-day unparse write bl
 268     dup timestamp-month months-abbreviations nth write bl
 269     dup timestamp-year unparse write bl
 270     dup timestamp-hour unparse 2 CHAR: 0 pad-left write ":" write
 271     dup timestamp-minute unparse 2 CHAR: 0 pad-left write ":" write
 272     timestamp-second >fixnum unparse 2 CHAR: 0 pad-left write ;
 273
 274 : timestamp>string ( timestamp -- str )
 275     [
 276         (timestamp>string)
 277     ] string-out ;
 278
 279 : timestamp>http-string ( timestamp -- str )
 280     #! http timestamp format
 281     #! Example: Tue, 15 Nov 1994 08:12:31 GMT
 282     >gmt [
 283         (timestamp>string)
 284         " GMT" write
 285     ] string-out ;
 286