KBK (2002-01-11) - I've been getting tired of all the talk about calendar stuff in Tcl - with varying amounts of actual work getting done.
So I went and added a 'calendar' module to tcllib. I'm trying to make this module as extensible as possible, so I've used namespace structure that isn't quite compatible with anyone else's code as it stands. (I also have yet to write the man pages, but the source code is well commented and has a test suite, so it meets at least the minimal standards for tcllib code.)
Right now, what's there is conversion between dates on the (proleptic) Gregorian calendar and Julian Day Number. The dates can be expressed in any of the following formats:
Any of these formats can be converted both to and from Julian Day Number.
In addition there are a couple of service routines, the most interesting of which are:
Finds the last weekday on or before a given Julian Day.
(e.g., the last Monday on or before 7 September).
This function can be made to do a variety of tasks; for
instance, the fourth Thursday in November is the last
Thursday on or before 28 November. Tests whether a given year of the Gregorian calendar is
a leap year.High on my 'list of things to do' is to integrate equivalent functionality to that which Glenn Jackman, Torsten Reincke, and others propose below. This is one step toward Reworking the clock command.
This is a proposed new module for tcllib -- ::calendar
On my todo list is to write the docs and tests. Feeback welcome -- Glenn Jackman
I made a note in setfirstweekday -- CLN, 2002-01-02
SEH -- Jan 6, 2005 -- I think it would be very useful to have some kind of calendar data object; that is, something like a Tk calendar widget but with no gui component. Once instantiated, it would maintain some kind of indexes corresponding to "current day", "current month" and "current year", with incrementors and decrementors for each. Thus for example if "current day" was 31, incrementing it would make "current day" 1 and increment "current month", which might in turn increment "current year" if it happened to be December.
Then perhaps the ability to add attributes to dates might be added, like iCal-format events. Then a calendar-walking algorithm analagous to a tree data object node walker, to assemble complete iCal versions of your calendar.
I envision being able to use such an object for HTML calendar displays of weblog entry archives, for example.
# calendar.tcl --
#
# Calendar printing functions (a la Python).
#
# Note, this package uses [clock scan ...], which can only convert dates in the
# range "1902-01-01 00:00:00" to "2037-12-31 23:59:59" inclusive (tcl 8.3.2).
package require Tcl 8
package require textutil
package provide calendar 0.1
namespace eval ::calendar {
variable month_days {31 28 31 30 31 30 31 31 30 31 30 31}
variable day_names [list]
for {set day 2} {$day <= 8} {incr day} {
set date [clock scan "2001-12-${day}"]
lappend day_names [clock format $date -format "%a"]
}
variable month_names [list]
for {set month 1} {$month <= 12} {incr month} {
set mon [format "%02d" $month]
set date [clock scan "2001-${month}-01"]
lappend month_names [clock format $date -format "%B"]
}
# firstweekday=0 ~ sunday, firstweekday=1 ~ monday
variable firstweekday 0
variable monthcalendar_cache
array set monthcalendar_cache {}
namespace export isleap leapdays
namespace export validatedate weekday monthrange
namespace export setfirstweekday monthcalendar month calendar
namespace import ::textutil::strRepeat ::textutil::adjust
}
# ::calendar::isleap --
#
# Return true if year is a leap year, false otherwise
proc ::calendar::isleap {year} {
return [expr {($year % 4 == 0) && (($year % 100 != 0) || ($year % 400 == 0))}]
}
# ::calendar::leapdays --
#
# Calculate the number of leap days in the range of years from
# "year1" up to, but not including, "year2".
proc ::calendar::leapdays {year1 year2} {
if {$year1 > $year2} {
# swap year1, year2
foreach {year2 year1} [list $year1 $year2] {break}
}
incr year1 -1
incr year2 -1
return [expr {($year2/4 - $year1/4) - ($year2/100 - $year1/100) + ($year2/400 - $year1/400)}]
}
# ::calendar::validatedate --
#
# Validates a given date, "year-month-day":
# - each element is an integer
# - the month and day are legal
#
# Returns:
# 1 if year-month-day is a valid date, else
# throws an error with a message indicating the "failure mode"
proc ::calendar::validatedate {year month day} {
foreach item {year month day} {
if {![string is integer [set $item]]} {
error "$item is not an integer: [set $item]"
}
}
if {$month < 1 || $month > 12} {
error "error: month must be between 1 and 12 inclusive"
}
set d [DaysInMonth $year $month]
if {$day < 1 || $day > $d} {
error "error: day must be between 1 and $d inclusive"
}
return 1
}
# ::calendar::DaysInMonth -- private procedure
#
# Return the number of days in the specified month,
# adjusted for leap year
proc ::calendar::DaysInMonth {year month} {
variable month_days
set days_in_month [lindex $month_days [expr {$month - 1}]]
if {[isleap $year] && $month == 2} {incr days_in_month}
return $days_in_month
}
# ::calendar::weekday --
#
# Return the weekday number of the specified day.
# 0 ~ Sunday, 1 ~ Monday, ... 6 ~ Saturday
proc ::calendar::weekday {year month day} {
validatedate $year $month $day
set date [format "%04d-%02d-%02d" $year $month $day]
return [clock format [clock scan $date] -format %w]
}
# ::calendar::monthrange --
#
# Returns a list containing the weekday number of the first day of the
# specified month, and the number of days in the month.
proc ::calendar::monthrange {year month} {
return [list [weekday $year $month 1] [DaysInMonth $year $month]]
}
# ::calendar::setfirstweekday --
#
# For formatted monthly calendars, should Sunday or Monday be
# printed as the first day of the week.
#
# Arguments:
# day: 0 or any abbreviation of "sunday" to set Sunday as the first day
# 1 or any abbreviation of "monday" to set Monday as the first day
# CLN - This seems to be the only routine to assume English. Others
# Would produce or test against localized values (Lunedi, etc.) if
# clock were, itself, localized. Might you use clock format to get
# the string for sunday and monday and use _that_ instead of hard-
# coding?
proc ::calendar::setfirstweekday {day} {
variable firstweekday
switch -regexp -- [string tolower $day] {
{^0$} - {^s(u(n(d(ay?)?)?)?)?$} {set firstweekday 0}
{^1$} - {^m(o(n(d(ay?)?)?)?)?$} {set firstweekday 1}
default {error "error: first weekday must be either sunday or monday"}
}
}
# ::calendar::monthcalendar --
#
# Calculate the days in each week of a month
#
# Returns:
# A list of lists: each row represents a week; days outside this month
# are zero.
proc ::calendar::monthcalendar {year month} {
variable monthcalendar_cache
variable firstweekday
if {![info exists monthcalendar_cache($year,$month,$firstweekday)]} {
foreach {firstday ndays} [monthrange $year $month] {break}
if {$firstweekday == 1} {
incr firstday [expr {$firstday == 0 ? 6 : -1}]
}
set themonth [list]
set week [list]
for {set i 0} {$i < $firstday} {incr i} {lappend week 0}
for {set i 1} {$i <= $ndays} {incr i} {
if {[llength $week] == 7} {
lappend themonth $week
set week [list]
}
lappend week $i
}
for {set i [llength $week]} {$i < 7} {incr i} {lappend week 0}
lappend themonth $week
set monthcalendar_cache($year,$month,$firstweekday) $themonth
}
return $monthcalendar_cache($year,$month,$firstweekday)
}
# ::calendar::month --
#
# Returns a formatted calendar for the specified month.
#
# Arguments:
# year, month: obviously, the month
# daywidth: the column width for each day in the week (minimum 2)
# daylinesp: the number of blank lines to include for each week
proc ::calendar::month {year month {daywidth 2} {daylinesp 0}} {
variable month_names
if {$daywidth < 2} {set daywidth 2}
incr daylinesp
set cal [adjust "[lindex $month_names [expr {$month - 1}]] $year" \
-justify center \
-full "true" \
-length [expr {7 * $daywidth + 6}]]
append cal "\n" [FormatWeek [WeekHeader $daywidth] $daywidth] "\n"
foreach week [monthcalendar $year $month] {
append cal [FormatWeek $week $daywidth] [strRepeat "\n" $daylinesp]
}
regsub -all {\m0\M} $cal { } cal
return $cal
}
# ::calendar::FormatWeek -- private procedure
#
# Format the week (list of day numbers) with the specified width.
proc ::calendar::FormatWeek {week width} {
set format "%${width}s %${width}s %${width}s %${width}s %${width}s %${width}s %${width}s"
return [eval [concat format [list $format] $week]]
}
# ::calendar::WeekHeader -- private procedure
#
# Return a list of day names, Sunday or Monday first.
proc ::calendar::WeekHeader {width} {
variable firstweekday
variable day_names
if {$firstweekday == 0} {
set days $day_names
} else {
set days [concat [lrange $day_names 1 end] [lindex $day_names 0]]
}
set header [list]
incr width -1
foreach day $days {
lappend header [string range $day 0 $width]
}
return $header
}
# ::calendar::calendar --
#
# Returns a formatted calendar for the specified year.
#
# Arguments:
# year: obviously, the year
# columns: the number of months to print in each row
# daywidth: the column width for each day in the week (minimum 2)
# daylinesp: the number of blank lines to include for each week
# monthlinesp: the number of blank lines to include between each month
proc ::calendar::calendar {year {columns 3} {daywidth 2} {daylinesp 0} {monthlinesp 1}} {
incr monthlinesp -1
set months [list]
for {set month 1} {$month <= 12} {incr month} {
lappend months [month $year $month $daywidth $daylinesp]
}
set cal ""
set blank_week [strRepeat " " [expr {7 * $daywidth + 6}]]
for {set i 0} {$i < 12} {incr i $columns} {
set lines -1
for {set j 0} {$j < $columns} {incr j 1} {
set m($j) [split [lindex $months [expr {$j + $i}]] "\n"]
if {[set l [llength $m($j)]] > $lines} {set lines $l}
}
for {set k 0} {$k < $lines} {incr k} {
set line [list]
for {set j 0} {$j < $columns} {incr j 1} {
set week [lindex $m($j) $k]
if {[string length $week] == 0} {
set week $blank_week
}
lappend line $week
}
append cal [join $line "\t"] "\n"
}
append cal [strRepeat "\n" $monthlinesp]
}
return $cal
}
# Test:
catch {console show}
catch {wm withdraw .}
puts "Calendar-Demo\n\n [ ::calendar::calendar 2006 ]"I started working on that subject too and here is what I did until now. Some of the mentioned subcommands are not yet rewritten to a format that is suitable for the tcllib, so this is just not finished at present. The code lacks documentation, tests, and examples as well. Torsten Berg ([email protected])
# calendar.tcl # # Implementation of calendar calculations for Tcl. # # by Torsten Berg ([email protected]) # # some important notes: # #### all dates are given in the format day.month.year #### example: 1.12.2001 (1st December 2001) #### the only exeptions are: today, yesterday, and tomorrow # # julain dates are those upto 4.10.1582 (a Thursday) # then ten days are missing # gregorian dates start from 15.10.1582 (a Friday) # # A julian day is something completetly different, namely the days # that have passed by since 1st January 4713 B.C. # # You can safely use the command for all dates in the gregorian calendar. # # The julian day 2299160.5 corresponds to the gregorian date 15.10.1582 at 0 GMT # So saying "cal gregorian 2299161" will return 15.10.1582 (which is 12 GMT) # while "cal gregorian 2299160.4" returns 14.10.1582 # (which is shortly before midnight, in the proleptic gregorian calendar) # uses lindex $list end-1 # package require Tcl 8.2 # create a new namespace and put life to it: namespace eval ::calendar { # some definitions used throughout the code: # the '0' in front of each list is just a dummy in order to access # names and numbers by their monthly or weekly index set week(long,english) {0 Monday Tuesday Wednesday Thursday Friday Saturday Sunday} set week(short,english) {0 Mo Tu We Th Fr Sa Su} set week(long,german) {0 Montag Dienstag Mittwoch Donnerstag Freitag Samstag Sonntag} set week(short,german) {0 Mo Di Mi Do Fr Sa So} set month(german) {0 Januar Februar März April Mai Juni Juli August September Oktober November Dezember} set month(english) {0 January February March April May June July August September Oktober November December} set days(1) {0 31 29 31 30 31 30 31 31 30 31 30 31} set days(0) {0 31 28 31 30 31 30 31 31 30 31 30 31} # initial language used is German: variable language german # initial format for month names is a number: variable dateformat numeric # 'subcommands' is the list of subcommands # recognized by the cal command variable subcommands [list \ "daysbetween" \ "fromnumber" \ "gregorian" \ "isleapyear" \ "julian" \ "month" \ "today" \ "tonumber" \ "weekday" \ "year" ] ## unimplemented subcommands: # # cal easter [returns the date for easter (sunday) in the specified year] # ## # we export the procedure 'cal' namespace export cal } # ::calendar::cal # # Command that feeds all subcommands # # Arguments: # cmd subcommand to invoke # args arguments for subcommand # # Results: # Varies based on subcommand to be invoked proc ::calendar::cal {{cmd ""} {args ""}} { variable subcommands # do minimal args checks here: if { $cmd==""} { error "wrong # args: should be \"cal option ?arg arg ...?\"" } # was the subcommand ok? if {[lsearch -exact $subcommands $cmd] == -1} { error "bad option \"$cmd\": must be [join $subcommands {, }]" } # invoke the specified subcommand: eval ::calendar::_$cmd $args } # ::calendar::_daysbetween # # Return the number of days between to given dates # # Arguments: # firstDate Date denoting the beginning of the peroid # lastDate Date denoting the end of the period # # Results: # Number giving the number of days between the two given dates # proc ::calendar::_daysbetween {{firstDate ""} {lastDate ""}} { if {$firstDate=="" || $lastDate==""} { error "wrong # args: should be \"cal daysbetween firstDate lastDate\"" } #### calculate difference in julian dates: return [expr int([_julian $lastDate] - [_julian $firstDate])] } # ::calendar::_gregorian # # Calculates the gregorian date for a given julian date # adapted from JulianDatesG.html (Bill Jefferys, [email protected]) # # Arguments: # j_date A julian date # # Results: # A gregorian date in format 'dd.mm.yyyy' # proc ::calendar::_gregorian {{j_date ""}} { if {$j_date==""} { error "wrong # args: should be \"cal gregorian date\"" } set JD [expr $j_date+0.5] set W [expr int(($JD-1867216.25)/36524.25)] set B [expr $JD+1+$W-$W/4+1524] set C [expr int(($B-122.1)/365.25)] set D [expr int(365.25*$C)] set E [expr int(($B-$D)/30.6001)] set F [expr int(30.6001*$E)] set d [expr int($B-$D-$F)] if $E<=13 {set m [expr $E-1]} else {set m [expr $E-13]} if $m>2 {set y [expr $C-4716]} else {set y [expr $C-4715]} return "$d.$m.$y" } # ::calendar::_julian # # Return the julian date of a given gregorian date # (i.e. days since 1st January 4713 B.C.) # adapted from JulianDatesG.html (Bill Jefferys, [email protected]) # # Arguments: # g_date A gregorian date as 'dd.mm.yyyy' # # Results: # The corresponding julian date # # proc ::calendar::_julian {{g_date ""}} { if {$g_date==""} { error "wrong # args: should be \"cal julian date\"" } foreach {d m y} [split $g_date .] {} # take care of leading zeroes: set d [string trimleft $d 0] set m [string trimleft $m 0] if {$y<0} {incr y 1} if {$m<3} {incr y -1; incr m 12} return [expr 2-$y/100+$y/400+$d+int(365.25*($y+4716))+int(30.6001*($m+1))-1524.5] } # ::calendar::_isleapyear # # Calculates if the gives year is a leapyear # (from http://www.mitre.org/tech/cots/LEAPCALC.html) # # Arguments: # year A year # # Results: 1 if the year is a leapyear # 0 if the year is no leapyear # proc ::calendar::_isleapyear {{year ""}} { if {$year==""} { error "wrong # args: should be \"cal isleapyear year\"" } if {[expr $year%4 ]!=0} { return 0 } elseif {[expr $year%400]==0} { return 1 } elseif {[expr $year%100]==0} { return 0 } else { return 1 } } # ::calendar::today # # Returns the date of today # # Arguments: None # # Results: A string giving today's date # proc ::calendar::_today {args} { if {$args!=""} { error "wrong # args: should be \"cal today\"" } return [clock format [clock seconds] -format "%d.%m.%Y"] } ########################## TODO ########################################### # # # support alternative date input through the Tcl 'clock scan' command # adding time specifications # # # Test: catch {console show} catch {wm withdraw .} puts "Today: [ ::calendar::_today ]"
HJG 2006-11-10: Tests added
If there is code on this page that hasn't made it to tcllib yet, I strongly urge that you at least submit it as a feature request on the http://tcllib.sf.net/ page, so that it isn't overlooked.