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
# 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
}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 Reincke ([email protected])
# calendar.tcl # # Implementation of calendar calculations for Tcl. # # by Torsten Reincke ([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/research/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 # # #