# -*- tcl -*-
#
# dateentry.tcl -
#
#       dateentry widget
#
# This widget provides an entry with a visual calendar for
# choosing a date. It is mostly a gathering compoments.
#
# The basics for the entry were taken from the "MenuEntry widget"
# of the widget package in the tklib.
# The visual calendar is taken from http://wiki.tcl.tk/1816.
#
# So many thanks to Richard Suchenwirth for visual calendar
# and to Jeff Hobbs for the widget package in tklib.
#
# See the example at the bottom.
#

# Creation and Options - widget::dateentry $path ...
#  -command        -default {}
#  -dateformat     -default "%m/%d/%Y"
#  -font           -default {Helvetica 9}
#  -background     -default white
#  -textvariable   -default {}  -configuremethod C-textvariable
#
# Following are passed to widget::calendar component:
#  -firstday
#  -highlightcolor
#  -language
#
# Methods
#  $widget post   - display calendar dropdown
#  $widget unpost - remove calendar dropdown
#  All other methods to entry
#
# Bindings
#  NONE
#

###

package require widget
package require widget::calendar

namespace eval ::widget {
    # http://www.famfamfam.com/lab/icons/mini/
    # ?Mini? is a set of 144 GIF icons available for free use for any purpose.
    variable dateentry_gifdata {
	R0lGODlhEAAQAMQAANnq+K7T5HiUsMHb+v/vlOXs9IyzzHWs1/T5/1ZtjUlVa+z1/+3
	x9uTx/6a2ysng+FFhe0NLXIDG/fD4/ykxQz5FVf/41vr8/6TI3MvM0XHG/vbHQPn8//
	b8/4PL/f///yH5BAAAAAAALAAAAAAQABAAAAWV4Cdam2h+5AkExCYYsCC0iSAGTisAP
	JC7kNvicPBIjkeiIyHCMDzQaFRTYH4wBY6W0+kgvpNC8GNgXLhd8CQ8Lp8f3od8sSgo
	RIasHPGY0AcNdiIHBV0PfHQNgAURIgKFfBMPCw2KAIyOkH0LA509FY4TXn6UDT0MoB8
	JDwwFDK+wrxkUjgm2EBAKChERFRUUYyfCwyEAOw==
    }
    # http://www.famfamfam.com/lab/icons/silk/
    # ?Silk? is a smooth, free icon set,
    variable dateentry_gifdata {
	R0lGODlhEAAQAPZ8AP99O/9/PWmrYmytZW6uaHOxbP+EQv+LR/+QTf+UUv+VVP+WVP+
	YV/+ZWP+aWv+dXP+eXf+fX/+nVP+rWv+gYP+hYf+iYv+jZP+kZP+kZf+wYf+zaP+4bf
	+5cf+7df+9eUJ3u1KEw1SGxFWGxlaHx12KxVyKxl+MxlmKyFuKyV+NyF6Oy1+Py2OSz
	mSTzmiW0WqX0W6Z02+b1HKe1nSg13Wh13qj2nqk2X2l3H6o3ZHBjJvHlqXNoa/Sq4Cp
	3YOr3IKq34mu2Yyw24mw3pG03Za434Ss4Ieu4Yiv4oyx44+14Yyy5I+05ZC15pO355S
	355W445294Zq75p++5pa66Zi66Zq865u9652+656/7KG/55/A7aTB5KTB56vG5abD6a
	HB7qLB76rG6a7J6rLL6rfO6rrQ67zQ68PdwNfp1dji8Nvk8d7n8t7n8+Lq9Obt9urw9
	+vx9+3y+O7z+e/z+fD0+vH2+vL2+vT3+/n8+f7+/v7//v///wAAAAAAAAAAACH5BAEA
	AH0ALAAAAAAQABAAAAfMgH2Cg4SFg2FbWFZUTk1LSEY+ODaCYHiXmJmXNIJZeBkXFBA
	NCwgHBgF4MoJXeBgfHh0cGxoTEgB4MIJVnxcWFREPDgwKCXgugk94X3zNzs1ecSyCTH
	difD0FaT0DPXxcbCiCSXZjzQJpO3kFfFFqI4JHdWTnaTp8AnxFaiKCQHRl+KARwKMHA
	W9E1KgQlIOOGT569uyB2EyIGhOCbsw500XLFClQlAz5EUTNCUE15MB546bNGjUwY5YQ
	NCPGixYrUpAIwbMnCENACQUCADs=
    }
}

proc ::widget::createdateentryLayout {} {
    variable dateentry
    if {[info exists dateentry]} { return }
    set dateentry 1
    variable dateentry_pngdata
    variable dateentry_gifdata
    set img ::widget::img_dateentry
    image create photo $img -format GIF -data $dateentry_gifdata
    namespace eval ::ttk [list set dateimg $img] ; # namespace resolved
    namespace eval ::ttk {
	# Create -padding for space on left and right of icon
	set pad [expr {[image width $dateimg] + 6}]
	style theme settings "default" {
	    style layout dateentry {
		Entry.field -children {
		    dateentry.icon -side left
		    Entry.padding -children {
			Entry.textarea
		    }
		}
	    }
	    # center icon in padded cell
	    style element create dateentry.icon image $dateimg \
		-sticky "" -padding [list $pad 0 0 0]
	}
	if 0 {
	    # Some mappings would be required per-theme to adapt to theme
	    # changes
	    foreach theme [style theme names] {
		style theme settings $theme {
		    # Could have disabled, pressed, ... state images
		    #style map dateentry -image [list disabled $img]
		}
	    }
	}
    }
}

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

    option -command      -default {}
    option -dateformat   -default "%m/%d/%Y"    -configuremethod C-passtocalendar
    option -font         -default {Helvetica 9} -configuremethod C-passtocalendar
    option -textvariable -default {}            -configuremethod C-textvariable
    option -language     -default en            -configuremethod C-passtocalendar

    delegate option -highlightcolor to calendar
    delegate option -shadecolor     to calendar
    delegate option -firstday       to calendar
    delegate option -showpast       to calendar

    component dropbox
    component calendar

    variable formattedDate	;# Chosen date, formatted, linked to calendar, shown in entry
    variable rawDate		;# Same, as seconds.
    variable startOnMonday 1	;# !! Unused

    constructor args {
	::widget::createdateentryLayout

	installhull using ttk::entry -style dateentry

	bindtags $win [linsert [bindtags $win] 1 TDateEntry]

	$self MakeCalendar
	$self configurelist $args

	# Initialize entry to current date, midnight
	set rawDate       [expr {([clock seconds] / 86400) * 86400}]
	set formattedDate [clock format $rawDate -format $options(-dateformat)]

	$self UpdateEntry
    }

    destructor {
	# Drop link to outer textvariable
	$self configure -textvariable {}
    }
    
    method C-passtocalendar {option value} {
	set options($option) $value
	$calendar configure $option $value
    }

    method C-textvariable {option value} {
	if {$options(-textvariable) ne {}} {
	    trace remove variable $options(-textvariable) write [mymethod DateSet]
	}
	set options($option) $value
	if {$options(-textvariable) ne {}} {
	    trace add variable $options(-textvariable) write [mymethod DateSet]
	}	
    }
    
    method MakeCalendar {args} {
	set dropbox $win.__drop
	destroy $dropbox
	toplevel $dropbox -takefocus 0
	wm withdraw $dropbox

	if {[tk windowingsystem] ne "aqua"} {
	    wm overrideredirect $dropbox 1
	    wm transient $dropbox [winfo toplevel $win]
	    wm group     $dropbox [winfo parent $win]
	} else {
	    tk::unsupported::MacWindowStyle style $dropbox \
		help {noActivates hideOnSuspend}
	}
	wm resizable $dropbox 0 0

	# Unpost on Escape or whenever user clicks outside the dropdown
	bind $dropbox <Escape> [list $win unpost]
	bind $dropbox <ButtonPress> [subst -nocommands {
	    if {[string first "$dropbox" [winfo containing %X %Y]] != 0} {
		$win unpost
            }
	}]
	bindtags $dropbox [linsert [bindtags $dropbox] 1 TDateEntryPopdown]

	set calendar $dropbox.calendar
	widget::calendar $calendar \
	    -textvariable   [myvar formattedDate] \
	    -dateformat     $options(-dateformat) \
	    -font           $options(-font) \
	    -language       $options(-language)\
	    -borderwidth    1 \
	    -relief         solid \
            -enablecmdonkey 0 \
	    -command        [mymethod DateChosen]

	bind $calendar <Map> [list focus -force $calendar]
	pack $calendar -expand 1 -fill both

	return $dropbox
    }

    method set {date} {
	# Run the incoming value through scan to ensure that it has the proper format.
	set rawDate       [clock scan   $date     -format $options(-dateformat)]
	set formattedDate [clock format $rawDate  -format $options(-dateformat)]
	$self UpdateEntry
	return
    }
    
    method post { args } {
	# TODO TCL 8.5+: `"disabled" in [$self state]`
	if {[lsearch -exact [$self state] "disabled"] >= 0} {
	    return
	}
	
	# XXX should we reset date on each display?
	if {![winfo exists $dropbox]} { $self MakeCalendar }

	foreach {x y} [$self PostPosition] { break }
	wm geometry $dropbox "+$x+$y"
	wm deiconify $dropbox
	raise $dropbox

	if {[tk windowingsystem] ne "aqua"} {
	    tkwait visibility $dropbox
	}

	focus -force $calendar
	return
    }

    method unpost {args} {
	if {![winfo exists $dropbox]} return
	wm withdraw  $dropbox
	grab release $dropbox ; # just in case
	return
    }

    method PostPosition {} {
	# PostPosition --
	#	Returns the x and y coordinates where the menu
	#	should be posted, based on the dateentry and menu size
	#	and -direction option.
	#
	# TODO: adjust menu width to be at least as wide as the button
	#	for -direction above, below.
	#
	set x [winfo rootx $win]
	set y [winfo rooty $win]
	set dir "below" ; #[$win cget -direction]

	set bw [winfo width $win]
	set bh [winfo height $win]
	set mw [winfo reqwidth $dropbox]
	set mh [winfo reqheight $dropbox]
	set sw [expr {[winfo screenwidth  $dropbox] - $bw - $mw}]
	set sh [expr {[winfo screenheight $dropbox] - $bh - $mh}]

	switch -- $dir {
	    above { if {$y >= $mh} { incr y -$mh } { incr y  $bh } }
	    below { if {$y <= $sh} { incr y  $bh } { incr y -$mh } }
	    left  { if {$x >= $mw} { incr x -$mw } { incr x  $bw } }
	    right { if {$x <= $sw} { incr x  $bw } { incr x -$mw } }
	}

	return [list $x $y]
    }

    #
    #  DateChosen --
    #
    #  Called from the calendar when a date was selected.
    #
    #  Formats the date, calls the callback -command if specified and
    #  then updates the entry.
    #
    ##
    method DateChosen { args } {
	$self UpdateEntry

	# synch raw date - Ensures that chosen format is held to
	set rawDate [clock scan $formattedDate -format $options(-dateformat)]
	
	# Export to linked variable
	upvar 0  $options(-textvariable) date
	set date $formattedDate

	# Export via callback
	$self CallCommand

        $self unpost
	return
    }

    # Handle changes to the contents of the linked -textvariable
    method DateSet {n1 n2 op} {
	upvar #0 $options(-textvariable) date
	# ignore non-changes
	if {$date eq $formattedDate} return
	# pass into the system
	$self set $date
	return
    }
    
    method CallCommand {} {
	if {![llength $options(-command)]} return
	uplevel \#0 $options(-command) [list $formattedDate] $rawDate
    }
    
    method UpdateEntry {} {
	$hull configure -state normal
	$hull delete 0 end
	$hull insert end $formattedDate
	$hull configure -state readonly
	return
    }    
}

# Bindings for menu portion.
#
# This is a variant of the ttk menubutton.tcl bindings.
# See menubutton.tcl for detailed behavior info.
#

bind TDateEntry <Enter>     { %W state active }
bind TDateEntry <Leave>     { %W state !active }
bind TDateEntry <<Invoke>>  { %W post }
bind TDateEntry <Control-space> { %W post }
bind TDateEntry <Escape>        { %W unpost }

bind TDateEntry <ButtonPress-1> { %W state pressed ; %W post }
bind TDateEntry <ButtonRelease-1> { %W state !pressed }

# These are to get around issues on aqua (see ttk::combobox bindings)
bind TDateEntryPopdown <Map> { ttk::globalGrab %W }
bind TDateEntryPopdown <Unmap> { ttk::releaseGrab %W }

package provide widget::dateentry 0.98

##############
# TEST CODE ##
##############

# PhG: this does not work in R
#if { [info script] eq $argv0 } {
#    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
#    package require widget::dateentry
#    destroy {*}[winfo children .]
#    proc getDate { args } {
#	puts [info level 0]
#	puts "DATE $::DATE"
#	update idle
#    }
#
#    # Samples
#    # package require widget::dateentry
#    set ::DATE ""
#    set start [widget::dateentry .s -textvariable ::DATE \
#		   -dateformat "%d.%m.%Y %H:%M" \
#		   -command [list getDate .s]]
#    set end [widget::dateentry .e \
#		 -command [list getDate .e] \
#		 -highlightcolor dimgrey \
#		 -font {Courier 10} \
#		 -firstday sunday]
#    grid [label .sl -text "Start:"] $start  -padx 4 -pady 4
#    grid [label .el -text "End:"  ] $end    -padx 4 -pady 4
#
#    puts [$end get]
#}