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
}