#lang scheme/base ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; DATE-TZ.plt - provides time-zone-based date calculations ;; ;; Bonzai Lab, LLC. All rights reserved. ;; ;; released under LGPL. ;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; normalize.ss - normalize a raw zone into a tz struct, by expanding the zone/rules into spans ;; as well as keeping the minimum rules (rules before the span) and maximum rules (rules after the ;; span) for dynamic calculations ;; yc 10/2/2009 - first version (require "base.ss" mzlib/trace (planet bzlib/date) srfi/19 scheme/match scheme/contract "util.ss" ) (define (raw-zoneinfo->normalized-zoneinfo zoneinfo) (hash-map zoneinfo (lambda (tz zone) (cons tz (raw-zone->normalized-zone zone))))) (provide raw-zoneinfo->normalized-zoneinfo) #| conversion from a raw zone, which contains a list of zone-span and a list of rules. (listof zone-span?) we want to basically go from each zone span upwards, and then within the zonespan, come down... ("US" (1918 1919 - 3 (last 0) (2 0 0 w) 3600 "D") (1918 1919 - 10 (last 0) (2 0 0 w) 0 "S") (1942 1942 - 2 9 (2 0 0 w) 3600 "W") (1945 1945 - 8 14 (23 0 0 u) 3600 "P") (1945 1945 - 9 30 (2 0 0 w) 0 "S") (1967 2006 - 10 (last 0) (2 0 0 w) 0 "S") (1967 1973 - 4 (last 0) (2 0 0 w) 3600 "D") (1974 1974 - 1 6 (2 0 0 w) 3600 "D") (1975 1975 - 2 23 (2 0 0 w) 3600 "D") (1976 1986 - 4 (last 0) (2 0 0 w) 3600 "D") (1987 2006 - 4 (match 0 >= 1) (2 0 0 w) 3600 "D") (2007 +inf.0 - 3 (match 0 >= 8) (2 0 0 w) 3600 "D") (2007 +inf.0 - 11 (match 0 >= 1) (2 0 0 w) 0 "S")) ("CA" (1948 1948 - 3 14 (2 0 0 w) 3600 "D") (1949 1949 - 1 1 (2 0 0 w) 0 "S") (1950 1966 - 4 (last 0) (2 0 0 w) 3600 "D") (1950 1961 - 9 (last 0) (2 0 0 w) 0 "S") (1962 1966 - 10 (last 0) (2 0 0 w) 0 "S")) ("America/Los_Angeles" (-28378 #f "LMT" (1883 11 18 12 7 2 w)) (-28800 "US" "P~aT" (1946 1 1 0 0 0 #f)) (-28800 "CA" "P~aT" (1967 1 1 0 0 0 #f)) (-28800 "US" "P~aT" #f)) each zone-span will start from the previous zone's UNTIL (or -inf.0)... so the first America/Los_Angeles's zone-span will become.... (-28378 #f "LMT" (1883 11 18 12 7 2 w)) FROM TO STD DST (-inf.0 (1883 11 18 12 7 2:00:00 -28378) -28378 0) Then the TO (1883 11 18 12 7 2:00:00 -28378) is passed to the next span... as its base... ((1919 10 (last 0) 2:00:00 -25200) -28800 0 "PST") ((1919 3 (last 0) 2:00:00 -28800) -28800 3600 "PDT") ((1918 10 (last 0) 2:00:00 -25200) -28800 0 "PST") ((1918 3 (last 0) 2:00:00 -28800) -28800 3600 "PDT") ((1883 11 18 12 7 2:00:00 -28378) -28800 0 "PST") ;; not sure how to generate the PST... (by default use S) (-inf.0 -28378 0 "LMT") ;; these are the reversed, normalized zonespans. (+inf.0 -28800 0) ((1967 1 1 0 0 0 w) -28800 0) ((1946 1 1 0 0 0 w) -28800 0) ((1883 11 18 12 7 2:00:00 w) -28800 0) ;; the only trouble is that the w depends on the next timezone... (-inf.0 -28378 0) ;;|# (define (spans-lower-bound spans) (cond ((equal? -inf.0 (span-bound (car spans))) (cons (make-span* (build-date TZ-YEAR-MAX 12 1 #:tz (span-std (car spans))) (span-std (car spans)) (span-dst (car spans))) spans)) ((equal? -inf.0 (span-bound (cadr spans))) spans) (else (spans-lower-bound (cdr spans))))) (define (raw-zone->normalized-zone zone) (define (helper spans) (make-tz spans (normalize-zone-rules zone) (spans-lower-bound spans))) (helper (foldl normalize-zone-spans '() zone))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; converting zone-span/rules to the left over infinite rules... (define (normalize-zone-rules zone) ;; we want to find the ones that have +inf.0 as he (define (rule-helper zone acc) (make-*zone-span (zone-span-offset zone) (filter (lambda (rule) (equal? +inf.0 (rule-to rule))) (if (not (zone-span-rule zone)) '() (zone-span-rule zone))) (zone-span-format zone))) (define (helper rest acc) (if (null? rest) acc (let ((zone (car rest))) (helper (cdr rest) (if (not (zone-span-until zone)) (rule-helper zone acc) acc))))) (helper zone '())) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; converting zone-span/rules to spans (define (normalize-zone-spans zone spans) (define (end-helper acc) ;; end-helper will either add an upper bound or will have no upper bounds... ;; adding an upper bound means there is another span on top of this span... (if (not (zone-span-until zone)) acc (cons (make-span* (apply spec->date (zone-span-offset zone) (if (number? (zone-span-rule zone)) (zone-span-rule zone) 0) (zone-span-until zone)) (zone-span-offset zone) 0) acc))) (define (rule-helper acc) ;; rules-helper normalizes the rules into the correct spans and then calls end-helper (end-helper (normalize-rules (zone-span-rule zone) acc (if (equal? (span-bound (car acc)) -inf.0) TZ-YEAR-MIN (date-year (span-bound (car acc)))) (if (not (zone-span-until zone)) TZ-YEAR-MAX (car (zone-span-until zone))) (zone-span-offset zone)))) (define (helper acc) ;; if there are rules, call rule-helper, otherwise call end-helper (cond ((list? (zone-span-rule zone)) (rule-helper acc)) (else (end-helper acc)))) (define (previous-helper acc) ;; first-helper helps process the *previous* values. ;; if there were previous values - it was the boundary from the last zone-span ;; convert it to use the current zone's standard offset (but keep the boundary) ;; if there are no previous value - it means this is the first zone-span we are processing ;; we'll add a -inf.0 as the bound (i.e. no lower bounds). (if (null? acc) (list (make-span* -inf.0 (zone-span-offset zone) 0)) ;; we have the boundary from the previous span... and we want to convert it into the ;; current std-offset. (cons (make-span* (span-bound (car acc)) (zone-span-offset zone) (if (number? (zone-span-rule zone)) (zone-span-rule zone) 0)) (cdr acc)))) (helper (previous-helper spans))) (define (normalize-rules rules spans from to std-offset) ;; normalize-rules will generate the applicable rules by year basd on the from -> to ;; and then sort them according to the month ascending, and then apply the correct wall-time ;; (which comes from the previous span's daylight saving offset + the standard-offset) (define (helper year acc) (define (normalize rules acc) (if (null? rules) acc (let ((rule (car rules))) (normalize (cdr rules) (cons (make-span* (apply spec->date std-offset ;; if there are no previous spans - dst = 0 ;; otherwise, get the dst from the previous span... (if (null? spans) 0 (span-dst (car acc))) year (rule-month rule) (rule-date rule) (rule-time rule)) std-offset (rule-offset rule)) acc))))) (if (> year to) acc (let ((rules (applicable-rules-by-year rules year))) (helper (add1 year) (normalize rules acc))))) (helper from spans)) (define (applicable-rules-by-year rules year) ;; filter the rules based on whether the year falls within the from-to range ;; and then sort the rules according to the months first ;; if they have the same month - then sort according to the date. (define (rule<? r1 r2) (cond ((< (rule-month r1) (rule-month r2)) #t) ((> (rule-month r1) (rule-month r2)) #f) (else (date<? (spec->date 0 0 year (rule-month r1) (rule-date r1) 0 0 0 'u) (spec->date 0 0 year (rule-month r1) (rule-date r1) 0 0 0 'u))))) (sort (filter (lambda (rule) (<= (rule-from rule) year (rule-to rule))) rules) rule<?)) (provide normalize-rules)