tklib 0.5-3 / usr / share / tcltk / tklib0.5 / widget / calendar.tcl

# -*- tcl -*-
#
# calendar.tcl -
#
#	Calendar widget drawn on a canvas.
#	Adapted from Suchenwirth code on the wiki.
#
# RCS: @(#) $Id: calendar.tcl,v 1.2 2008/12/11 18:07:20 hobbs Exp $
#

# Creation and Options - widget::calendar $path ...
# -command        -default {}
# -dateformat     -default "%m/%d/%Y"
# -font           -default {Helvetica 9}
# -textvariable   -default {}
# -firstday       -default "monday"
# -highlightcolor -default "#FFCC00"
# -shadecolor     -default "#888888"
#
#  All other options to canvas
#
# Methods
#  $path get           => selected date
#  All other methods to canvas
#
# Bindings
#  NONE
#

if 0 {
    # Samples
    package require widget::calendar
    #set db [widget::calendar .db]
    #pack $sw -fill both -expand 1
}

###

package require widget

snit::widgetadaptor widget::calendar {
    delegate option * to hull
    delegate method * to hull

    option -firstday -default monday -configuremethod C-refresh \
	-type [list snit::enum -values [list sunday monday]]
    option -textvariable -default {} -configuremethod C-textvariable

    option -command -default {}
    option -dateformat -default "%m/%d/%Y" -configuremethod C-refresh
    option -font -default {Helvetica 9} -configuremethod C-font
    option -highlightcolor -default "#FFCC00" -configuremethod C-refresh
    option -shadecolor -default "#888888" -configuremethod C-refresh

    option -language -default en

    # showpast not currently correct
    option -showpast -default 1 -type {snit::boolean} \
	-configuremethod C-refresh

    variable fullrefresh 1
    variable pending "" ; # pending after id for refresh
    variable data -array {
	day 01 month 01 year 2007
	linespace 0 cellspace 0
	selday {} selmonth {} selyear {}
    }

    constructor args {
	installhull using canvas -highlightthickness 0 -borderwidth 0 \
	    -background white
	bindtags $win [linsert [bindtags $win] 1 Calendar]

	set now [clock scan today]
	set x [clock format $now -format "%d/%m%/%Y"]
	set now [clock scan "$x 00:00:00" -format "%d/%m%/%Y %H:%M:%S"]

	foreach {data(day) data(month) data(year)} \
	    [clock format $now -format "%d %m %Y"] { break }

	# Binding for the 'day' tagged items
	$win bind day <1> [mymethod invoke]

	$self configurelist $args

	$self reconfigure
	$self refresh
    }

    method C-font {option value} {
	set options($option) $value
	$self reconfigure
	set fullrefresh 1
	$self refresh
    }

    method C-refresh {option value} {
	set options($option) $value
	$self refresh
    }

    method C-textvariable {option value} {
	set options($option) $value
	if {$value ne "" && [info exists $value]} {
	    set tmp [set $value]
	    if {$tmp eq ""} { return }
	    set date [clock scan $tmp -format $options(-dateformat)]

	    foreach {data(selday) data(selmonth) data(selyear)} \
		[clock format $date -format "%d %m %Y"] { break }
	    $self refresh
	}
    }

    method get {{what all}} {
	switch -exact -- $what {
	    "day"   { return $data(selday) }
	    "month" { return $data(selmonth) }
	    "year"  { return $data(selyear) }
	    "all"   {
		if {$data(selday) ne ""} {
		    set date [clock scan $data(selmonth)/$data(selday)/$data(selyear)]
		    set fmtdate [clock format $date -format $options(-dateformat)]
		    return $fmtdate
		}
	    }
	    default {
		return -code error "unknown component to retrieve \"$what\",\
			must be one of day, month or year"
	    }
	}
    }

    method adjust {dmonth dyear} {
	incr data(year)  $dyear
	incr data(month) $dmonth

	if {$data(month) > 12} {
	    set data(month) 1
	    incr data(year)
	}

	if {$data(month) < 1}  {
	    set data(month) 12
	    incr data(year) -1
	}
	set maxday [$self numberofdays $data(month) $data(year)]
	if {$maxday < $data(day)} {set data(day) $maxday}

	$self refresh
    }

    method cbutton {x y w command} {
	# Draw simple arrowbutton using Tk's line arrows
	set wd [expr {abs($w)}]
	set wd2 [expr {$wd/2. - ((abs($w) < 10) ? 1 : 2)}]
	set poly [$hull create line $x $y [expr {$x+$w}] $y -arrow last \
		      -arrowshape [list $wd $wd $wd2] \
		      -tags [list cbutton shadetext]]
	$hull bind $poly <1> $command
    }

    method reconfigure {} {
	set data(cellspace) [expr {[font measure $options(-font) "30"] * 2}]
	set w [expr {$data(cellspace) * 8}]
	set data(linespace) [font metrics $options(-font) -linespace]
	set h [expr {int($data(linespace) * 9.25)}]
	$hull configure -width $w -height $h
    }

    method refresh {} {
	# Idle deferred refresh
	after cancel $pending
	set pending [after idle [mymethod Refresh]]
    }

    method Refresh {} {
	# Set up coords based on font spacing
	set x  [expr {$data(cellspace) / 2}]; set x0 $x
	set dx $data(cellspace)

	set y [expr {int($data(linespace) * 1.75)}]
	set dy $data(linespace)
	set pad [expr {$data(linespace) / 2}]

	set xmax [expr {$x0+$dx*6}]
	set winw [$hull cget -width]
	set winh [$hull cget -height]

	if {$fullrefresh} {
	    set fullrefresh 0
	    $hull delete all

	    # Left and Right buttons
	    set xs [expr {$data(cellspace) / 2}]
	    $self cbutton [expr {$xs+2}] $pad -$xs [mymethod adjust 0 -1]; # <<
	    $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust -1 0]; # <
	    set lxs [expr {$winw - $xs - 2}]
	    $self cbutton $lxs $pad $xs [mymethod adjust 0 1]; # >>
	    incr lxs -$xs
	    $self cbutton $lxs $pad [expr {$xs/1.5}] [mymethod adjust 1 0]; # >

	    # day (row) and weeknum (col) headers
	    $hull create rect 0 [expr {$y - $pad}] $winw [expr {$y + $pad}] \
		-tags shade
	    $hull create rect 0 [expr {$y - $pad}] $dx $winh -tags shade
	} else {
	    foreach tag {title otherday day highlight week} {
		$hull delete $tag
	    }
	}

	# Title "Month Year"
	set title [$self formatMY $data(month) $data(year)]
	$hull create text [expr {$winw/2}] $pad -text $title -tag title \
	    -font $options(-font) -fill blue

	# weekdays - could be drawn on fullrefresh, watch -firstday change
	set weekdays $LANGS(weekdays,$options(-language))
	if {$options(-firstday) eq "monday"} { $self lcycle weekdays }
	foreach i $weekdays {
	    incr x $dx
	    $hull create text $x $y -text $i -fill white \
		-font $options(-font) -tag title
	}

	# place out the days
	set first $data(month)/1/$data(year)
	set weekday [clock format [clock scan $first] -format %w]
	if {$options(-firstday) eq "monday"} {
	    set weekday [expr {($weekday+6)%7}]
	}

	# Print days preceding the 1st of the month
	set x [expr {$x0+$weekday*$dx}]
	set x1 $x; set offset 0
	incr y $dy
	while {$weekday} {
	    set t [clock scan "$first [incr offset] days ago"]
	    set day [clock format $t -format "%e"] ; # %d w/o leading 0
	    $hull create text $x1 $y -text $day \
		-font $options(-font) -tags [list otherday shadetext]
	    incr weekday -1
	    incr x1 -$dx
	}
	set dmax [$self numberofdays $data(month) $data(year)]

	for {set d 1} {$d <= $dmax} {incr d} {
	    incr x $dx
	    if {($options(-showpast) == 0)
		&& ($d < $data(selday))
		&& ($data(month) <= $data(selmonth))
		&& ($data(year) <= $data(selyear))} {
		# XXX day in the past - above condition currently broken
		set id [$hull create text $x $y -text $d \
			    -tags [list otherday shadetext] \
			    -font $options(-font)]
	    } else {
		# current month day
		set id [$hull create text $x $y -text $d -tag day \
			    -font $options(-font)]
	    }
	    if {$d == $data(selday) && ($data(month) == $data(selmonth))} {
		# selected day
		$hull create rect [$hull bbox $id] -tags [list day highlight]
	    }
	    $hull raise $id
	    if {$x > $xmax} {
		# Week of the year
		set x $x0
		set week [$self getweek $d $data(month) $data(year)]
		$hull create text [expr {$x0}] $y -text $week -tag week \
		    -font $options(-font) -fill white
		incr y $dy
	    }
	}
	# Week of year (last day)
	if {$x != $x0} {
	    set week [$self getweek $d $data(month) $data(year)]
	    $hull create text [expr {$x0}] $y -text $week -tag week \
		-font $options(-font) -fill white
	    for {set d 1} {$x <= $xmax} {incr d} {
		incr x $dx
		$hull create text $x $y -text $d \
		    -tags [list otherday shadetext] \
		    -font $options(-font)
	    }
	}

	# Display Today line
	set now [clock seconds]
	set today "Today is [clock format $now -format $options(-dateformat)]"
	$hull create text [expr {$winw/2}] [expr {$winh - $pad}] -text $today \
	    -tag week -font $options(-font) -fill black

	# Make sure options-based items are set
	$hull itemconfigure highlight \
		    -fill $options(-highlightcolor) \
		    -outline $options(-highlightcolor)
	$hull itemconfigure shadetext -fill $options(-shadecolor)
	$hull itemconfigure shade -fill $options(-shadecolor) \
		    -outline $options(-shadecolor)
    }

    method getweek {day month year} {
	set _date [clock scan $month/$day/$year]
	return [clock format $_date -format %V]
    }

    method invoke {} {
	set item [$hull find withtag current]
	set data(day) [$hull itemcget $item -text]

	set data(selday) $data(day)
	set data(selmonth) $data(month)
	set data(selyear) $data(year)
	set date [clock scan $data(month)/$data(day)/$data(year)]
	set fmtdate [clock format $date -format $options(-dateformat)]

	if {$options(-textvariable) ne {}} {
	    set $options(-textvariable) $fmtdate
	}

	if {$options(-command) ne {}} {
	    # pass single arg of formatted date chosen
	    uplevel \#0 $options(-command) [list $fmtdate]
	}

	$self refresh
    }

    method formatMY {month year} {
	set lang $options(-language)
	if {[info exists LANGS(mn,$lang)]} {
	    set month [lindex $LANGS(mn,$lang) $month]
	} else {
	    set _date [clock scan $month/1/$year]
	    set month [clock format $_date -format %B] ; # full month name
	}
	if {[info exists LANGS(format,$lang)]} {
	    set format $LANGS(format,$lang)
	} else {
	    set format "%m %Y" ;# default
	}
	# Replace month/year and do any necessary substs
	return [subst [string map [list %m $month %Y $year] $format]]
    }

    method numberofdays {month year} {
	if {$month == 12} {set month 0; incr year}
	clock format [clock scan "[incr month]/1/$year	1 day ago"] -format %d
    }

    method lcycle _list {
	upvar $_list list
	set list [concat [lrange $list 1 end] [list [lindex $list 0]]]
    }

    typevariable LANGS -array {
	mn,crk {
	    . Kis\u01E3p\u012Bsim Mikisiwip\u012Bsim Niskip\u012Bsim Ay\u012Bkip\u012Bsim
	    S\u0101kipak\u0101wip\u012Bsim
	    P\u0101sk\u0101wihowip\u012Bsim Paskowip\u012Bsim Ohpahowip\u012Bsim
	    N\u014Dcihitowip\u012Bsim Pin\u0101skowip\u012Bsim Ihkopiwip\u012Bsim
	    Paw\u0101cakinas\u012Bsip\u012Bsim
	}
	weekdays,crk {P\u01E3 N\u01E3s Nis N\u01E3 Niy Nik Ay}

	mn,crx-nak {
	    . {Sacho Ooza'} {Chuzsul Ooza'} {Chuzcho Ooza'} {Shin Ooza'} {Dugoos Ooza'} {Dang Ooza'}\
		{Talo Ooza'} {Gesul Ooza'} {Bit Ooza'} {Lhoh Ooza'} {Banghan Nuts'ukih} {Sacho Din'ai}
	}
	weekdays,crx-nak {Ji Jh WN WT WD Ts Sa}

	mn,crx-lhe {
	    . {'Elhdzichonun} {Yussulnun} {Datsannadulhnun} {Dulats'eknun} {Dugoosnun} {Daingnun}\
		{Gesnun} {Nadlehcho} {Nadlehyaz} {Lhewhnandelnun} {Benats'ukuihnun} {'Elhdziyaznun}
	}
	weekdays,crx-lhe {Ji Jh WN WT WD Ts Sa}

	mn,de {
	    . Januar Februar März April Mai Juni Juli August
	    September Oktober November Dezember
	}
	weekdays,de {So Mo Di Mi Do Fr Sa}

	mn,en {
	    . January February March April May June July August
	    September October November December
	}
	weekdays,en {Su Mo Tu We Th Fr Sa}

	mn,es {
	    . Enero Febrero Marzo Abril Mayo Junio Julio Agosto
	    Septiembre Octubre Noviembre Diciembre
	}
	weekdays,es {Do Lu Ma Mi Ju Vi Sa}

	mn,fr {
	    . Janvier Février Mars Avril Mai Juin Juillet Août
	    Septembre Octobre Novembre Décembre
	}
	weekdays,fr {Di Lu Ma Me Je Ve Sa}

	mn,gr {
	    . Îýý???Ïýý?Ïýý??Ïýý ???Ïýý?Ïýý?Ïýý??Ïýý Îýý?ÏýýÏýý??Ïýý ÎýýÏýýÏýý????Ïýý Îýý?Îýý?Ïýý Îýý?Ïýý???Ïýý Îýý?Ïýý???Ïýý ÎýýÏýý??ÏýýÏýýÏýý?Ïýý
	    ??ÏýýÏýýÎýý??Ïýý??Ïýý Îýý?ÏýýÏýý??Ïýý??Ïýý Îýý?Îýý??Ïýý??Ïýý Îýý??Îýý??Ïýý??Ïýý
	}
	weekdays,gr {ÎýýÏýýÏýý Îýý?Ïýý TÏýý? ??Ïýý Î ?? Î ?Ïýý ???}

	mn,he {
	    . ×ýý× ×ýý×ýý? ?×ýý?×ýý×ýý? ×ýý?? ×ýý??×ýý×ýý ×ýý×ýý×ýý ×ýý×ýý× ×ýý ×ýý×ýý×ýý×ýý ×ýý×ýý×ýý×ýý?×ýý ??×ýý×ýý×ýý? ×ýý×ýý?×ýý×ýý×ýý? × ×ýý×ýý×ýý×ýý? ×ýý?×ýý×ýý?
	}
	weekdays,he {?×ýý?×ýý×ýý ?× ×ýý ?×ýý×ýý?×ýý ?×ýý×ýý?×ýý ×ýý×ýý×ýý?×ýý ?×ýý?×ýý ?×ýý?}
	mn,it {
	    . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto
	    Settembre Ottobre Novembre Dicembre
	}
	weekdays,it {Do Lu Ma Me Gi Ve Sa}

	format,ja {%Y\u5e74 %m\u6708}
	weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f}

	mn,nl {
	    . januari februari maart april mei juni juli augustus
	    september oktober november december
	}
	weekdays,nl {Zo Ma Di Wo Do Vr Za}

	mn,ru {
	    . \u042F\u043D\u0432\u0430\u0440\u044C
	    \u0424\u0435\u0432\u0440\u0430\u043B\u044C \u041C\u0430\u0440\u0442
	    \u0410\u043F\u0440\u0435\u043B\u044C \u041C\u0430\u0439
	    \u0418\u044E\u043D\u044C \u0418\u044E\u043B\u044C
	    \u0410\u0432\u0433\u0443\u0441\u0442
	    \u0421\u0435\u043D\u0442\u044F\u0431\u0440\u044C
	    \u041E\u043A\u0442\u044F\u0431\u0440\u044C \u041D\u043E\u044F\u0431\u0440\u044C
	    \u0414\u0435\u043A\u0430\u0431\u0440\u044C
	}
	weekdays,ru {
	    \u432\u43e\u441 \u43f\u43e\u43d \u432\u442\u43e \u441\u440\u435
	    \u447\u435\u442 \u43f\u44f\u442 \u441\u443\u431
	}

	mn,sv {
	    . januari februari mars april maj juni juli augusti
	    september oktober november december
	}
	weekdays,sv {s\u00F6n m\u00E5n tis ons tor fre l\u00F6r}

	mn,pt {
	    . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho
	    Julho Agosto Setembro Outubro Novembro Dezembro
	}
	weekdays,pt {Dom Seg Ter Qua Qui Sex Sab}

	format,zh {%Y\u5e74 %m\u6708}
	mn,zh {
	    . \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03
	    \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c
	}
	weekdays,zh {\u65e5 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d}
	mn,fi {
	    . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Kesäkuu
	    Heinäkuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu
	}
	weekdays,fi {Ma Ti Ke To Pe La Su}
	mn,tr {
	    . ocak \u015fubat mart nisan may\u0131s haziran temmuz a\u011fustos eyl\u00FCl ekim kas\u0131m aral\u0131k
	}
	weekdays,tr {pa'tesi sa \u00e7a pe cu cu'tesi pa}
    }
}

package provide widget::calendar 0.9