From: sani@merlot.NoSubdomain.NoDomain (Sani Nassif [227])
Newsgroups: comp.lang.tcl
Subject: a small calendar widget in wish
Date: 8 Apr 92 11:54:48 GMT
Organization: Bell Laboratories

Here is a simple calendar widget in wish. I thought someone
might have a use for it. Right now, the day buttons are bound
to simply print out the date... 
--------------------------------------------------------------------------------------
#!/usr/local/X11R5/bin/wish -f
#
global year month day1
proc make_month_frame { w } {
    toplevel $w
    frame $w.top
    set tfont "-*-lucidatypewriter-bold-r-*-*-14-*-*-*-*-*-*-*"
    button $w.top.prev -text "prev" -command "prev_month $w" -font $tfont
    message $w.top.month -aspect 1000 -text "     " -font $tfont
    button $w.top.next -text "next" -command "next_month $w" -font $tfont
    message $w.top.year -aspect 1000 -text "    " -font $tfont
    pack append $w.top	$w.top.prev {left}\
			$w.top.month {left}\
			$w.top.next {left}\
			$w.top.year {right}
    frame $w.bot
    set daynames {Sun Mon Tue Wed Thu Fri Sat}
    for {set i 0} {$i < 7} {incr i} {
	frame $w.bot.$i
	message $w.bot.$i.msg -aspect 1000 -text [lindex $daynames $i] -font $tfont
	pack append $w.bot.$i $w.bot.$i.msg {top fillx}
	for {set j 0} {$j < 6} {incr j} {
	    button $w.bot.$i.$j -text "    " -font $tfont -command ""
	    pack append $w.bot.$i $w.bot.$i.$j {top fillx}
	}
	pack append $w.bot $w.bot.$i {left}
    }
    pack append $w $w.top {top frame w fillx} $w.bot {top}
}
proc clear_month_frame { w } {
    $w.top.month conf -text "     "
    $w.top.year  conf -text "    "
    for {set i 0} {$i < 7} {incr i} {
	for {set j 0} {$j < 6} {incr j} {
	    $w.bot.$i.$j conf -text "    " -command ""
	}
    }
}
proc days_in_a_month { m y } {
    set normal {31 28 31 30 31 30 31 31 30 31 30 31}
    set leap   {31 29 31 30 31 30 31 31 30 31 30 31}
    if {$y % 4} {
	return [lindex $normal $m]
    } else {
	return [lindex $leap   $m]
    }
}
proc prev_month {w} {
    global year month day1
    if {$month} {
	incr month -1
    } else {
	incr year -1
	set month 11
    }
    set ndays [days_in_a_month $month $year]
    set day1 [expr ($day1-$ndays+35)%7]
    clear_month_frame $w
    fill_month_frame $w
}
proc next_month {w} {
    global year month day1
    set ndays [days_in_a_month $month $year]
    set day1 [expr ($day1+$ndays)%7]
    incr month
    if {$month == 12} {
	incr year
	set month 0
    }
    clear_month_frame $w
    fill_month_frame $w
}
proc fill_month_frame { w } {
    global year month day1
    set monthnames {Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
    $w.top.month conf -text [lindex $monthnames $month]
    $w.top.year  conf -text [format "19%2d" $year]
    set ndays [days_in_a_month $month $year]
    for {set i 0} {$i < $ndays} {incr i} {
	set bx [expr ($i+$day1)%7]
	set by [expr ($i+$day1)/7]
	$w.bot.$bx.$by conf -text [format " %2d " [expr $i+1]]\
	    -command "puts stdout [format \"%2d/%2d/%2d\n\" [expr $i+1] [expr $month+1] $year]"
    }
}
set date [exec date {+%a %m %d %y}]
set weekday [lsearch [list Sun Mon Tue Wed Thu Fri Sat] [lindex $date 0]]
set month   [expr [string trim [lindex $date 1] "0"]-1]
set day	    [expr [string trim [lindex $date 2] "0"]-1]
#set day	    [string trim [lindex $date 2] "0"]
set year    [lindex $date 3]
set day1    [expr ($day-$weekday+13)%7]
make_month_frame .month
fill_month_frame .month
-------------------------------------------------------------------------------------------