1# -*- tcl -*-
2#
3# calendar.tcl -
4#
5#	Calendar widget drawn on a canvas.
6#	Adapted from Suchenwirth code on the wiki.
7#
8# Copyright (c) 2008 R�diger H�rtel
9#
10# RCS: @(#) $Id: calendar.tcl,v 1.9 2010/07/16 00:19:57 hobbs Exp $
11#
12
13#
14# Creation and Options - widget::calendar $path ...
15# -command        -default {}
16# -dateformat     -default "%m/%d/%Y"
17# -font           -default {Helvetica 9}
18# -textvariable   -default {}
19# -firstday       -default "monday"
20# -highlightcolor -default "#FFCC00"
21# -shadecolor     -default "#888888"
22# -language       -default en   Supported languages: de, en, es, fr, gr,
23#                                he, it, ja, sv, pt, zh, fi ,tr, nl, ru,
24#                                crk, crx-nak, crx-lhe
25#
26#  All other options to canvas
27#
28# Methods
29#  $path get <part>   => selected date, part can be
30#                              day,month,year, all
31#                         default is all
32#  All other methods to canvas
33#
34# Bindings
35#  NONE
36#
37
38if 0 {
39    # Samples
40    package require widget::calendar
41    #set db [widget::calendar .db]
42    #pack $sw -fill both -expand 1
43}
44
45###
46
47package require widget
48
49snit::widgetadaptor widget::calendar {
50    delegate option * to hull
51    delegate method * to hull
52
53    option -firstday       -default monday        -configuremethod C-refresh \
54					      -type [list snit::enum -values [list sunday monday]]
55    option -textvariable   -default {}            -configuremethod C-textvariable
56
57    option -command        -default {}
58    option -dateformat     -default "%m/%d/%Y"    -configuremethod C-refresh
59    option -font           -default {Helvetica 9} -configuremethod C-font
60    option -highlightcolor -default "#FFCC00"     -configuremethod C-refresh
61    option -shadecolor     -default "#888888"     -configuremethod C-refresh
62    option -language       -default en            -configuremethod C-language
63    option -showpast       -default 1             -configuremethod C-refresh \
64						  -type {snit::boolean}
65
66
67    variable fullrefresh 1
68    variable pending "" ; # pending after id for refresh
69    variable data -array {
70	day 01 month 01 year 2007
71	linespace 0 cellspace 0
72	selday {} selmonth {} selyear {}
73    }
74
75    constructor args {
76	installhull using canvas -highlightthickness 0 -borderwidth 0 \
77	    -background white
78	bindtags $win [linsert [bindtags $win] 1 Calendar]
79
80	set now [clock scan "today 00:00:00"]
81
82	foreach {data(day) data(month) data(year)} \
83	    [clock format $now -format "%e %m %Y"] { break }
84	scan $data(month) %d data(month) ; # avoid leading 0 issues
85
86	set data(selday)   $data(day)
87	set data(selmonth) $data(month)
88	set data(selyear)  $data(year)
89
90	# Binding for the 'day' tagged items
91	$win bind day <1>           [mymethod invoke]
92
93	    # move days
94	bind $win <Left>            [mymethod adjust -1  0  0]
95	bind $win <Right>           [mymethod adjust  1  0  0]
96	    # move weeks
97	bind $win <Up>              [mymethod adjust -7  0  0]
98	bind $win <Down>            [mymethod adjust  7  0  0]
99	    # move months
100	bind $win <Control-Left>    [mymethod adjust  0 -1  0]
101	bind $win <Control-Right>   [mymethod adjust  0  1  0]
102	    # move years
103	bind $win <Control-Up>      [mymethod adjust  0  0 -1]
104	bind $win <Control-Down>    [mymethod adjust  0  0  1]
105
106	$self configurelist $args
107
108	$self reconfigure
109	$self refresh
110    }
111
112    destructor {
113	if { $options(-textvariable) ne "" } {
114	    trace remove variable $options(-textvariable) write [mymethod DoUpdate]
115	}
116    }
117
118    #
119    # C-font --
120    #
121    #  Configure the font of the widget
122    #
123    ##
124    method C-font {option value} {
125	set options($option) $value
126	$self reconfigure
127	set fullrefresh 1
128	$self refresh
129    }
130
131    #
132    # C-refresh --
133    #
134    #  Place holder for all options that need a refresh after
135    #  takeing over the new option.
136    #
137    ##
138    method C-refresh {option value} {
139	set options($option) $value
140	$self refresh
141    }
142
143    #
144    # C-textvariable --
145    #
146    #  Configure the textvariable for the widget. Installs a
147    #  trace handler for the variable.
148    #  If an empty textvariable is given the trace handler is
149    #  uninstalled.
150    #
151    ##
152    method C-textvariable {option value} {
153
154        if { [string match "::widget::dateentry::Snit*" $value] } {
155            return
156        }
157
158	if {![string match ::* $value]} {
159	    set value ::$value
160	}
161	set options($option) $value
162
163	if {$value ne "" } {
164	    trace remove variable $options(-textvariable) write [mymethod DoUpdate]
165
166	    if { ![info exists $options($option)] } {
167	        set now [clock seconds]
168	        set $options($option) [clock format $now -format $options(-dateformat)]
169	    }
170
171	    trace add variable ::$value write [mymethod DoUpdate]
172	    if { [info exists $value] } {
173		$self DoUpdate
174	    }
175	}
176    }
177
178    #
179    # C-language --
180    #
181    #  Configure the language of the calendar.
182    #
183    ##
184    method C-language {option value} {
185
186	set langs [list \
187		    de en es fr gr he it ja sv pt zh fi tr nl ru \
188		    crk  \
189		    crx-nak \
190		    crx-lhe \
191	]
192	if { $value ni $langs } {
193	    return -code error "Unsupported language. Choose one of: $langs"
194	}
195
196	set options($option) $value
197
198	$self refresh
199    }
200
201    #
202    # DoUpdate --
203    #
204    #  Update the internal values of day, month and year when the
205    #  textvariable is written to (trace callback).
206    #
207    ##
208    method DoUpdate { args } {
209
210	set value $options(-textvariable)
211	set tmp [set $value]
212	if {$tmp eq ""} { return }
213	if {$::tcl_version < 8.5} {
214	    # Prior to 8.4, users must use [clock]-recognized dateformat
215	    set date [clock scan $tmp]
216	} else {
217	    set date [clock scan $tmp -format $options(-dateformat)]
218	}
219
220	foreach {data(day) data(month) data(year)} \
221	    [clock format $date -format "%e %m %Y"] { break }
222	scan $data(month) %d data(month) ; # avoid leading 0 issues
223
224	set data(selday)   $data(day)
225	set data(selmonth) $data(month)
226	set data(selyear)  $data(year)
227
228	$self refresh
229    }
230
231    #
232    # get --
233    #   Return parts of the selected date or the complete date.
234    #
235    # Arguments:
236    #   what  - Selects the part of the date or the complete date.
237    #            values <day,month,year, all>, default is all
238    #
239    ##
240    method get {{what all}} {
241	switch -exact -- $what {
242	    "day"   { return $data(selday) }
243	    "month" { return $data(selmonth) }
244	    "year"  { return $data(selyear) }
245	    "all"   {
246		if {$data(selday) ne ""} {
247		    set date [clock scan $data(selmonth)/$data(selday)/$data(selyear)]
248		    set fmtdate [clock format $date -format $options(-dateformat)]
249		    return $fmtdate
250		}
251	    }
252	    default {
253		return -code error "unknown component to retrieve \"$what\",\
254			must be one of day, month or year"
255	    }
256	}
257    }
258
259    #
260    # adjust --
261    #
262    #   Adjust internal values of the calendar and update the contents
263    #   of the widget. This function is invoked by pressing the arrows
264    #   in the widget and on key bindings.
265    #
266    # Arguments:
267    #   dday    - Difference in days
268    #   dmonth  - Difference in months
269    #   dyear   - Difference in years
270    #
271    ##
272    method adjust {dday dmonth dyear} {
273	incr data(year)  $dyear
274	incr data(month) $dmonth
275
276	set maxday [$self numberofdays $data(month) $data(year)]
277
278	if { ($data(day) + $dday) < 1}  {
279	    incr data(month) -1
280
281	    set maxday [$self numberofdays $data(month) $data(year)]
282	    set  data(day) [expr {($data(day) + $dday) % $maxday}]
283
284	} else {
285
286	    if { ($data(day) + $dday) > $maxday } {
287
288		incr data(month) 1
289		set  data(day)   [expr {($data(day) + $dday) % $maxday}]
290
291	    } else {
292		incr data(day) $dday
293	    }
294	}
295
296
297	if { $data(month) > 12} {
298	    set  data(month) 1
299	    incr data(year)
300	}
301
302	if { $data(month) < 1}  {
303	    set  data(month) 12
304	    incr data(year)  -1
305	}
306
307
308	set maxday [$self numberofdays $data(month) $data(year)]
309	if { $maxday < $data(day) } {
310	    set data(day) $maxday
311	}
312	set data(selday)   $data(day)
313	set data(selmonth) $data(month)
314	set data(selyear)  $data(year)
315
316	$self refresh
317    }
318
319    method cbutton {x y w command} {
320	# Draw simple arrowbutton using Tk's line arrows
321	set wd [expr {abs($w)}]
322	set wd2 [expr {$wd/2. - ((abs($w) < 10) ? 1 : 2)}]
323	set poly [$hull create line $x $y [expr {$x+$w}] $y -arrow last \
324		      -arrowshape [list $wd $wd $wd2] \
325		      -tags [list cbutton shadetext]]
326	$hull bind $poly <1> $command
327    }
328
329    method reconfigure {} {
330	set data(cellspace) [expr {[font measure $options(-font) "30"] * 2}]
331	set w [expr {$data(cellspace) * 8}]
332	set data(linespace) [font metrics $options(-font) -linespace]
333	set h [expr {int($data(linespace) * 9.25)}]
334	$hull configure -width $w -height $h
335    }
336
337    method refresh { } {
338	# Idle deferred refresh
339	after cancel $pending
340	set pending [after idle [mymethod Refresh ]]
341    }
342
343    method Refresh { } {
344	# Set up coords based on font spacing
345	set x  [expr {$data(cellspace) / 2}]; set x0 $x
346	set dx $data(cellspace)
347
348	set y [expr {int($data(linespace) * 1.75)}]
349	set dy $data(linespace)
350	set pad [expr {$data(linespace) / 2}]
351
352	set xmax [expr {$x0+$dx*6}]
353	set winw [$hull cget -width]
354	set winh [$hull cget -height]
355
356	if {$fullrefresh} {
357	    set fullrefresh 0
358	    $hull delete all
359
360	    # Left and Right buttons
361	    set xs [expr {$data(cellspace) / 2}]
362	    $self cbutton [expr {$xs+2}] $pad -$xs              [mymethod adjust 0  0 -1]; # <<
363	    $self cbutton [expr {$xs*2}] $pad [expr {-$xs/1.5}] [mymethod adjust 0 -1  0]; # <
364	    set lxs [expr {$winw - $xs - 2}]
365	    $self cbutton $lxs $pad $xs                         [mymethod adjust 0  0  1]; # >>
366	    incr lxs -$xs
367	    $self cbutton $lxs $pad [expr {$xs/1.5}]            [mymethod adjust 0  1  0]; # >
368
369	    # day (row) and weeknum (col) headers
370	    $hull create rect 0 [expr {$y - $pad}] $winw [expr {$y + $pad}] \
371		-tags shade
372	    $hull create rect 0 [expr {$y - $pad}] $dx $winh -tags shade
373	} else {
374	    foreach tag {title otherday day highlight week} {
375		$hull delete $tag
376	    }
377	}
378
379	# Title "Month Year"
380	set title [$self formatMY $data(month) $data(year)]
381	$hull create text [expr {$winw/2}] $pad -text $title -tag title \
382	    -font $options(-font) -fill blue
383
384	# weekdays - could be drawn on fullrefresh, watch -firstday change
385	set weekdays $LANGS(weekdays,$options(-language))
386	if {$options(-firstday) eq "monday"} { $self lcycle weekdays }
387	foreach i $weekdays {
388	    incr x $dx
389	    $hull create text $x $y -text $i -fill white \
390		-font $options(-font) -tag title
391	}
392
393	# place out the days
394	set first $data(month)/1/$data(year)
395	set weekday [clock format [clock scan $first] -format %w]
396	if {$options(-firstday) eq "monday"} {
397	    set weekday [expr {($weekday+6)%7}]
398	}
399
400	# Print days preceding the 1st of the month
401	set x [expr {$x0+$weekday*$dx}]
402	set x1 $x; set offset 0
403	incr y $dy
404	while {$weekday} {
405	    set t [clock scan "$first [incr offset] days ago"]
406	    set day [clock format $t -format "%e"] ; # %d w/o leading 0
407	    $hull create text $x1 $y -text $day \
408		-font $options(-font) -tags [list otherday shadetext]
409	    incr weekday -1
410	    incr x1 -$dx
411	}
412	set dmax [$self numberofdays $data(month) $data(year)]
413
414	for {set d 1} {$d <= $dmax} {incr d} {
415	    incr x $dx
416	    if {($options(-showpast) == 0)
417		&& ($d < $data(selday))
418		&& ($data(month) <= $data(selmonth))
419		&& ($data(year) <= $data(selyear))} {
420		# XXX day in the past - above condition currently broken
421		set id [$hull create text $x $y -text $d \
422			    -tags [list otherday shadetext] \
423			    -font $options(-font)]
424	    } else {
425		# current month day
426		set id [$hull create text $x $y -text $d -tag day \
427			    -font $options(-font)]
428	    }
429	    if {$d == $data(selday) && ($data(month) == $data(selmonth))} {
430		# selected day
431		$hull create rect [$hull bbox $id] -tags [list day highlight]
432	    }
433	    $hull raise $id
434	    if {$x > $xmax} {
435		# Week of the year
436		set x $x0
437		set week [$self getweek $d $data(month) $data(year)]
438		$hull create text [expr {$x0}] $y -text $week -tag week \
439		    -font $options(-font) -fill white
440		incr y $dy
441	    }
442	}
443	# Week of year (last day)
444	if {$x != $x0} {
445	    set week [$self getweek $dmax $data(month) $data(year)]
446	    $hull create text [expr {$x0}] $y -text $week -tag week \
447		-font $options(-font) -fill white
448	    for {set d 1} {$x <= $xmax} {incr d} {
449		incr x $dx
450		$hull create text $x $y -text $d \
451		    -tags [list otherday shadetext] \
452		    -font $options(-font)
453	    }
454	}
455
456	# Display Today line
457	set now [clock seconds]
458	set today "$LANGS(today,$options(-language)) [clock format $now -format $options(-dateformat)]"
459	$hull create text [expr {$winw/2}] [expr {$winh - $pad}] -text $today \
460	    -tag week -font $options(-font) -fill black
461
462	# Make sure options-based items are set
463	$hull itemconfigure highlight \
464	    -fill $options(-highlightcolor) \
465	    -outline $options(-highlightcolor)
466	$hull itemconfigure shadetext -fill $options(-shadecolor)
467	$hull itemconfigure shade -fill $options(-shadecolor) \
468	    -outline $options(-shadecolor)
469    }
470
471    method getweek {day month year} {
472	set _date [clock scan $month/$day/$year]
473	return [clock format $_date -format %V]
474    }
475
476    method invoke {} {
477
478	catch {focus -force $win} msg
479	if { $msg ne "" } {
480	#    puts $msg
481	}
482	set item [$hull find withtag current]
483	set data(day) [$hull itemcget $item -text]
484
485	set data(selday) $data(day)
486	set data(selmonth) $data(month)
487	set data(selyear) $data(year)
488	set date    [clock scan   $data(month)/$data(day)/$data(year)]
489	set fmtdate [clock format $date -format $options(-dateformat)]
490
491	if {$options(-textvariable) ne {}} {
492	    set $options(-textvariable) $fmtdate
493	}
494
495	if {$options(-command) ne {}} {
496	    # pass single arg of formatted date chosen
497	    uplevel \#0 $options(-command) [list $fmtdate]
498	}
499
500	$self refresh
501    }
502
503    method formatMY {month year} {
504	set lang $options(-language)
505	if {[info exists LANGS(mn,$lang)]} {
506	    set month [lindex $LANGS(mn,$lang) $month]
507	} else {
508	    set _date [clock scan $month/1/$year]
509	    set month [clock format $_date -format %B] ; # full month name
510	}
511	if {[info exists LANGS(format,$lang)]} {
512	    set format $LANGS(format,$lang)
513	} else {
514	    set format "%m %Y" ;# default
515	}
516	# Replace month/year and do any necessary substs
517	return [subst [string map [list %m $month %Y $year] $format]]
518    }
519
520    method numberofdays {month year} {
521	if {$month == 12} {set month 0; incr year}
522	clock format [clock scan "[incr month]/1/$year	1 day ago"] -format %d
523    }
524
525    method lcycle _list {
526	upvar $_list list
527	set list [concat [lrange $list 1 end] [list [lindex $list 0]]]
528    }
529
530    typevariable LANGS -array {
531	mn,crk {
532	    . Kis\u01E3p\u012Bsim Mikisiwip\u012Bsim Niskip\u012Bsim Ay\u012Bkip\u012Bsim
533	    S\u0101kipak\u0101wip\u012Bsim
534	    P\u0101sk\u0101wihowip\u012Bsim Paskowip\u012Bsim Ohpahowip\u012Bsim
535	    N\u014Dcihitowip\u012Bsim Pin\u0101skowip\u012Bsim Ihkopiwip\u012Bsim
536	    Paw\u0101cakinas\u012Bsip\u012Bsim
537	}
538	weekdays,crk {P\u01E3 N\u01E3s Nis N\u01E3 Niy Nik Ay}
539	today,crk {}
540
541	mn,crx-nak {
542	    . {Sacho Ooza'} {Chuzsul Ooza'} {Chuzcho Ooza'} {Shin Ooza'} {Dugoos Ooza'} {Dang Ooza'}\
543		{Talo Ooza'} {Gesul Ooza'} {Bit Ooza'} {Lhoh Ooza'} {Banghan Nuts'ukih} {Sacho Din'ai}
544	}
545	weekdays,crx-nak {Ji Jh WN WT WD Ts Sa}
546	today,crx-nak {}
547
548	mn,crx-lhe {
549	    . {'Elhdzichonun} {Yussulnun} {Datsannadulhnun} {Dulats'eknun} {Dugoosnun} {Daingnun}\
550		{Gesnun} {Nadlehcho} {Nadlehyaz} {Lhewhnandelnun} {Benats'ukuihnun} {'Elhdziyaznun}
551	}
552	weekdays,crx-lhe {Ji Jh WN WT WD Ts Sa}
553	today,crx-lhe {}
554
555	mn,de {
556	    . Januar Februar M�rz April Mai Juni Juli August
557	    September Oktober November Dezember
558	}
559	weekdays,de {So Mo Di Mi Do Fr Sa}
560	today,de {Heute ist der}
561
562	mn,en {
563	    . January February March April May June July August
564	    September October November December
565	}
566	weekdays,en {Su Mo Tu We Th Fr Sa}
567	today,en {Today is}
568
569	mn,es {
570	    . Enero Febrero Marzo Abril Mayo Junio Julio Agosto
571	    Septiembre Octubre Noviembre Diciembre
572	}
573	weekdays,es {Do Lu Ma Mi Ju Vi Sa}
574	today,es {}
575
576	mn,fr {
577	    . Janvier F�vrier Mars Avril Mai Juin Juillet Ao�t
578	    Septembre Octobre Novembre D�cembre
579	}
580	weekdays,fr {Di Lu Ma Me Je Ve Sa}
581	today,fr {}
582
583	mn,gr {
584	    . ���???���?���??��� ???���?���?���??��� ���?������??��� ���������????��� ���?���?��� ���?���???��� ���?���???��� ������??���������?���
585	    ??���������??���??��� ���?������??���??��� ���?���??���??��� ���??���??���??���
586	}
587	weekdays,gr {��������� ���?��� T���? ??��� � ?? � ?��� ???}
588	today,gr {}
589
590	mn,he {
591	    . ���� ������? ?���?������? ���?? ���??������ ��������� ������� ��� ������������ ������������?��� ??���������? ������?���������? � ������������? ���?������?
592	}
593	weekdays,he {?���?������ ?� ��� ?������?��� ?������?��� ���������?��� ?���?��� ?���?}
594	today,he {}
595
596	mn,it {
597	    . Gennaio Febraio Marte Aprile Maggio Giugno Luglio Agosto
598	    Settembre Ottobre Novembre Dicembre
599	}
600	weekdays,it {Do Lu Ma Me Gi Ve Sa}
601	today,it {}
602
603	format,ja {%Y\u5e74 %m\u6708}
604	weekdays,ja {\u65e5 \u6708 \u706b \u6c34 \u6728 \u91d1 \u571f}
605	today,ja {}
606
607	mn,nl {
608	    . januari februari maart april mei juni juli augustus
609	    september oktober november december
610	}
611	weekdays,nl {Zo Ma Di Wo Do Vr Za}
612	today,nl {}
613
614	mn,ru {
615	    . \u042F\u043D\u0432\u0430\u0440\u044C
616	    \u0424\u0435\u0432\u0440\u0430\u043B\u044C \u041C\u0430\u0440\u0442
617	    \u0410\u043F\u0440\u0435\u043B\u044C \u041C\u0430\u0439
618	    \u0418\u044E\u043D\u044C \u0418\u044E\u043B\u044C
619	    \u0410\u0432\u0433\u0443\u0441\u0442
620	    \u0421\u0435\u043D\u0442\u044F\u0431\u0440\u044C
621	    \u041E\u043A\u0442\u044F\u0431\u0440\u044C \u041D\u043E\u044F\u0431\u0440\u044C
622	    \u0414\u0435\u043A\u0430\u0431\u0440\u044C
623	}
624	weekdays,ru {
625	    \u432\u43e\u441 \u43f\u43e\u43d \u432\u442\u43e \u441\u440\u435
626	    \u447\u435\u442 \u43f\u44f\u442 \u441\u443\u431
627	}
628	today,ru {}
629
630	mn,sv {
631	    . januari februari mars april maj juni juli augusti
632	    september oktober november december
633	}
634	weekdays,sv {s\u00F6n m\u00E5n tis ons tor fre l\u00F6r}
635	today,sv {}
636
637	mn,pt {
638	    . Janeiro Fevereiro Mar\u00E7o Abril Maio Junho
639	    Julho Agosto Setembro Outubro Novembro Dezembro
640	}
641	weekdays,pt {Dom Seg Ter Qua Qui Sex Sab}
642	today,pt {}
643
644	format,zh {%Y\u5e74 %m\u6708}
645	mn,zh {
646	    . \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d \u4e03
647	    \u516b \u4e5d \u5341 \u5341\u4e00 \u5341\u4e8c
648	}
649	weekdays,zh {\u65e5 \u4e00 \u4e8c \u4e09 \u56db \u4e94 \u516d}
650	today,zh {}
651
652	mn,fi {
653	    . Tammikuu Helmikuu Maaliskuu Huhtikuu Toukokuu Kes�kuu
654	    Hein�kuu Elokuu Syyskuu Lokakuu Marraskuu Joulukuu
655	}
656	weekdays,fi {Ma Ti Ke To Pe La Su}
657	today,fi {}
658
659	mn,tr {
660	    . ocak \u015fubat mart nisan may\u0131s haziran temmuz a\u011fustos eyl\u00FCl ekim kas\u0131m aral\u0131k
661	}
662	weekdays,tr {pa'tesi sa \u00e7a pe cu cu'tesi pa}
663	today,tr {}
664    }
665}
666
667package provide widget::calendar 0.95
668