# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: calendar.tcl,v 1.5 2006/01/28 19:16:59 jfontain Exp $


class calendar {

    set (leftArrow) [image create photo -data {
        R0lGODlhFgAWAMZyAAAAcgECdAIFdgQKewUKewQMewUOfQYQfwgVggAYjAEYjAAZjAAajQkYhAQajAoZhQcbjAocjAseiQMhkg0hjA0ijA8mkAYpmRAqkxAr
        kwkwnhIvlhQ0mgw4pBU4nRc9oQ9Aqhg+ohlBpBJIsBtGqBhHqyFDqhtHqRxKqx5PrxtQsh9QsCBTsiFWtCFXtSNbuCNcuSVfvCVgvBZs0wB39gh57QF79gx6
        7Ql79gB//wCC/wqA9gGD/wCE/wGE/wCG/wqD/wWI/xeC9giI/wmK/w+L/xGM/xmL/yeI60B/3CCM9iaJ9jCG7TmD5RaQ/xyT/ymR9zGP7yKW/yWV/ymT/yqU
        +SeY/ymX/zGW9y+Y+y2b/zqa+Dia/zKe/0KY9z6d+Teg/0Kf+D6h/0Ch+0Gj/0ei/1Gf9lmu/3C6/4fE/53P/7Pa/7ve/8jk/83n/9zu/9/w/+/3////////
        /////////////////////////////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAfVgH+Cg4SDKy0vMYWLiycqSGMzMoyUISVRcHFZMJSLHCNV
        bm9vYC6dhBggX2xtrV0sp4IUHWFrtrZaKbENGltqv8BWKKcGF1hpyMlpUiSdAhNQaNLT0k8ilAAMSmfc3d1OH9g3ZOTl5WJBHtg1V+3u7VNEPxzYCztG+EVD
        Pfz8G50AFtjwwUOHwYM6MpwCkIBGjocQH1qIBUABDiAYMwKpEOsPAAdCjogcKaGjRwhLqKhU+cCkxwhMuMjkgsClxwFNypTxcsCmRwJJzJgo4NMjAAABCgUC
        ADs=
    }]
    set (rightArrow) [image create photo -data {
        R0lGODlhFgAWAMZ1AAAAcgEEdQIGdgQKewUKewUNfAYPfgcRfwAYjAgWgwEYjAAZjAAajgQajAoZhQoahgcbjAocjAwfigMikw0ijQ0jjQYqmQ8okREslAkx
        nxMxmBQ1mww5pRY6nhg+og9Bqxg/oxlCpRJIsRtHqRhIrCFEqxxIqh1LrB9QsBxRsx9RsSBUsyFXtSJZtiNcuSRduiVhvRZt1AB39gB69gB89gp57Ql79g17
        7QB//wCA/wGB/wCC/wGD/wCE/wOD/wSF/wqD/waH/xeC9gqJ/wyL/xKO/xSN/xmL/yeI7EB/3CaJ9jCG7TmD5RmP/yKN9xiR/x2T/zGP7yqS9yOW/ymT/yqV
        +SeX/ymY/yiZ/zOW9y+Y+y2Z/y2b/zCb/zia/zKe/zub+EOZ9zeg/z6e+UOf+ECh+0Ok/0ei/1Gf9kem/16x/3W8/4vG/6DR/7Xb/7zf/8nl/87o/93u/+Dw
        /+/3/////////////////////////////////////////////yH5BAEKAH8ALAAAAAAWABYAAAffgH+CgjAuLCqDiYqKMDFlSCkmi5ODL1p0c1EkIJSTLWJy
        cnFVIhudiitfcKtvYx8Yp4MoXG61tWQcFLF/J1htv8BgGQ6xI1NsyMlsWRYGpyFQa9LT0lITAp0eT2rc3d1ODACUHUVp5mlmZudpN+KTG0Rd8l1b81dWNe6L
        GkFN/v5GhvToQWOBPkUYePxY+MPHjoczDHa6gEOHxRw4MspAcHBRBSAgQwKxoaDjIglHUqoU0sDkogdUYsZUAsHlogRecnpZEsHmogNhzpxhMsDnogIl0CQh
        YHRSAABQd/0JBAA7
    }]
    set (doubleLeftArrow) [image create photo -data {
        R0lGODlhFgAWAOepAAAAcgEDdQIGdwMHdwMJewQKegQKewUKewUNfAUOfQcRfwcTgAgVggAYjAAZjAIZjAkXhAEbjgUajAobhwgcigsciAkdigseiwMhkwwf
        igwfiw0giwcikQ0jjQUnlwsmkg8mjxAqkhAqkwgtnA4tlxEtlRIwlxMxmBE0nBQzmhQ0mhQ1mw84ohU3nBU3nRI5oBY5nhY6nxY7nxc9oRg+ohVApRlBpR4/
        pxpFpxhGqxxIqh1MrBpNsB5Prw5XwyBSsh1UtSFWtCJYtiJZtyNcuSRduiVgvANr6A5p3wJx7wB17S9lxg9x6BJy3Rpu3gJ39gB59gB89gB+9g587SZz3QJ/
        /wCB/wKA/xx46BB+7gKC/wCE/xB+9gSD/wCG/xKA7xp+5xSC8Ch65QeG/wSI/wiI/zN53QqI/x+D7BGH/yp/6AyK/wuL/zt72Q6M/xeJ9yOF7B+G9hON/yqG
        6jCE5RyL9zaC5RSP/xiP/zGH5yCO9y+J6zeG6BuQ/yiM8jaI5RqS/yKP/ySQ+B6S/x+S/zuL5kOI5SCV/yaY/yyZ/zKX/yyb/zGd/zWe/zag/zif/zui/z6i
        /0Og/z6k/0yp/1So/1Gr/2e2/2m2/3i+/4HC/43I/47I/5jN/5/R/6PT/6/Y/7DZ/7jd/8Dh/8Xj/8zm/9rt/97v/+33////////////////////////////
        ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
        ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////////////////////////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoMGD
        Ak+sgDHDoBAiRhCKQAFnko+GA4GAmdQkYsEOJPacQpUnxkAeYUahglSkYIUPc0qZMlWohcAcX0LNdDSEIIMRgkSRGvonRYsaWTwNJcUoyEAEHvR8AkUVFB0T
        L6Zsqgpq0Q+BAjDU4dSpbFk/LNCQNdsJUY9/ACK8yaSprt1LkejarXtoBwAHUhphGky4sGFMgHQAUOKFDSVLkCNLnnwHx2IvXsgkesS5s2fPbmz8jbKl9Bk8
        gwgRGoRHzpo1cvqoLkMDbgMoVnLr3r27yxgtMgQCaPCkivHjSTgcOW78yhUXAwE84JKmenUkCigwsW5dBUEAEuJNBBofyEmCBRawkB9voiAAAmIUyadSQOAF
        NfLllzAIwIAdSZKYMcBAGvABoCQhHATAAYZUckMABG3QRiVLgIAQABgCYBAEE2SA0IcGBQQAOw==
    }]
    set (doubleRightArrow) [image create photo -data {
        R0lGODlhFgAWAOeqAAAAcgABcgIEdQMHdwMIeAMJewQKewUKewQLewYOfQYPfQcSgAgUgQAYjAgWgwAZjAIZjAkYhQUajAEcjwsciAgdiwsdiAoeiwsfiwMi
        kwwfjAwgiw0gjAcjkg4kjgYomAwnkg8nkBAqkxErkwgunA4umBIulRMxmBMymRQ0mhE1nRQ1mxU2nA84ohU4nRM6oRY6nxc7oBc8oBg+ohg/oxVBphlCpR8/
        pxtGqBhHqxxJqx1NrRtOsR9QsA5XxCBTsh1VtiFXtSJZtyNauCRduiReuiVgvCVhvQNs6A5p3wJy7wB17TBlxg9x6BJy3Rpu3gJ39gB59gB89gB+9g587QJ/
        /wCB/wKA/yd03hx46BB+7gKC/wCE/xB+9gSD/wCG/xKA7xp+6BSC8Ch65QeG/wSI/wiI/zN53QqI/x+D7BGH/yp/6AyK/wuL/zx72Q6M/xeJ9yOF7B+G9hON
        /yqG6hyL9zCF5TaC5RSP/xiP/yCO9zKI5zeG6BuQ/yiM8i+K6zaI5RqS/yKP/ySQ+B6S/x+S/0OI5SCV/zyM5iaY/yyZ/zKX/yyb/zGd/zWe/zag/zif/zui
        /z6i/0Og/z6k/0yp/1So/1Gr/2e2/2m2/3i+/4HC/43I/47I/5jN/5/R/6PT/6/Y/7DZ/7jd/8Dh/8Xj/8zm/9rt/97v/+33////////////////////////
        ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
        ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
        /////////////////////////////////////////////////////////////////////////////////yH5BAEKAP8ALAAAAAAWABYAAAj+AP8JHEiwoEGB
        RogIMTgDBgsUB/8dcUIpDBCCM3xQiqNixMEikVKREsNjYIw9qVD9KeHB4JBHp06JApNDoAtEMU3RAWGhYJBGpYJ+0lLDRQpAQUuNGkTCAcEfjEJJDcWJyosT
        dqaGAqXnQ4KBPRJ5Gju2U5oWfsiWrZNhgMAdhzbJnatJEqa5dOFMCPBPR6BMgAMLHpzJ0ZQHAHDgucS4sePHldp8WQLAxhtImDNr1qyozJfJAGiYKVSozxw2
        bObkIUSaUB40XGJLQSxjCxkvVnLr3r07SgMA/1xcuVKleHEkHZQYNw7lt8AVaqJLb1JhQRLp0btAAC7whKDv37NJXGCg4Al4QXIkcBdoYpH7RWswCESA5f2Y
        AusFipjEn4+GgQScwd8dBuQnUAhMWOIGBwQJcIMlhhxg4EAbUBCBQQBkOGFEHB4UEAA7
    }]

    set (background) $widget::option(listbox,background)
    set (foreground) $widget::option(listbox,foreground)
    set (disabled,foreground) $widget::option(listbox,disabledforeground)
    set (select,background) $widget::option(listbox,selectbackground)
    set (select,foreground) $widget::option(listbox,selectforeground)

    proc calendar {this parentPath args} composite {[new frame $parentPath] $args} {
        set path $widget::($this,path)
        composite::manage $this [new frame $path -relief raised] monthYear [new frame $path -relief sunken -background white] days
        set monthYear $composite::($this,monthYear,path)
        set button [new imageButton $monthYear -image $(doubleLeftArrow) -command "calendar::month $this -12"]
        lappend ($this,buttons) $button
        pack $widget::($button,path) -side left
        set button [new imageButton $monthYear -image $(leftArrow) -command "calendar::month $this -1"]
        lappend ($this,buttons) $button
        pack $widget::($button,path) -side left
        set ($this,monthLabel) [label $monthYear.month]
        pack $($this,monthLabel) -fill x -expand 1 -side left
        set button [new imageButton $monthYear -image $(doubleRightArrow) -command "calendar::month $this 12"]
        lappend ($this,buttons) $button
        pack $widget::($button,path) -side right
        set button [new imageButton $monthYear -image $(rightArrow) -command "calendar::month $this 1"]
        lappend ($this,buttons) $button
        pack $widget::($button,path) -side right
        pack $monthYear -fill x
        set ($this,yearLabel) [label $monthYear.year]
        pack $($this,yearLabel) -fill x -expand 1 -side right
        set daysPath $composite::($this,days,path)
        pack $daysPath -fill both -expand 1
        set row 0
        grid [frame $daysPath.top -relief sunken -height 1 -background black] -row $row -column 0 -columnspan 100 -sticky ew
        incr row
        set column 0
        foreach day [list [mc Mon] [mc Tue] [mc Wed] [mc Thu] [mc Fri] [mc Sat] [mc Sun]] {
            set label [label $daysPath.day$column -text $day]
            if {$column < 5} {
                $label configure -background $(select,background) -foreground $(select,foreground)
            } else {
                $label configure -background lightgray -foreground black
            }
            grid $label -row $row -column $column -sticky nsew
            grid columnconfigure $daysPath $column -uniform day -weight 1
            lappend titles $label
            incr column
        }
        grid rowconfigure $daysPath $row -weight 1
        grid [frame $daysPath.separator -relief sunken -height 1 -background black]\
            -row [incr row] -column 0 -columnspan 100 -sticky ew
        set selector [new objectSelector -selectcommand "calendar::select $this"]
        for {incr row; set days 0} {$days < 42} {incr row; incr days 7} {
            for {set column 0} {$column < 7} {incr column} {
                set label [new label $daysPath -background $(background) -borderwidth 0 -highlightthickness 1 -pady 0]
                selector::add $selector $label
                bind $widget::($label,path) <ButtonPress-1> "selector::select $selector $label"
                bind $widget::($label,path) <Shift-ButtonPress-1> "selector::extend $selector $label"
                grid $widget::($label,path) -row $row -column $column -sticky nsew
                lappend labels $label
            }
            grid rowconfigure $daysPath $row -weight 1
        }
        set ($this,selector) $selector
        set ($this,labels) $labels
        composite::complete $this
        $($this,monthLabel) configure -font $($this,bold)
        $($this,yearLabel) configure -font $($this,bold)
        foreach label $titles {
            $label configure -font $($this,bold)
        }
        foreach label $labels {
            widget::configure $label -font $($this,normal)
        }
        if {[llength $composite::($this,-seconds)] == 0} {
            composite::configure $this -seconds [clock seconds]                                              ;# which also refreshes
        } else {
            refresh $this
        }
    }

    proc ~calendar {this} {
        variable ${this}seconds

        eval delete $($this,buttons) $($this,selector) $($this,labels)
        font delete $($this,bold) $($this,normal)
        unset ${this}seconds
    }

    proc options {this} {
        return [list\
            [list -command {} {}]\
            [list -seconds {} {}]\
            [list -font $widget::option(label,font)]\
        ]
    }

    proc set-command {this value} {}

    proc set-font {this value} {
        if {$composite::($this,complete)} {
            error {option -font cannot be set dynamically}
        }
        set ($this,bold) [eval font create [font actual $value]]
        font configure $($this,bold) -weight bold
        set ($this,normal) [eval font create [font actual $value]]
        font configure $($this,normal) -weight normal
    }

    proc set-seconds {this value} {                                    ;# value is either single or a list of start and end instants
        refresh $this
    }

    proc month {this increment} {                                                                          ;# note: fails after 2037
        if {[catch {set seconds [clock scan "$increment months" -base [lindex $composite::($this,-seconds) 0]]}]} return
        selector::clear $($this,selector)
        composite::configure $this -seconds $seconds
    }

    proc select {this labels select} {
        variable ${this}seconds

        if {![info exists composite::($this,-seconds)]} return                        ;# no selection possible before date is chosen
        set month [clock format [lindex $composite::($this,-seconds) 0] -format %m]
        foreach label $labels {
            if {$select} {
                widget::configure $label -background $(select,background) -foreground $(select,foreground)
            } else {
                widget::configure $label -background $(background)
                if {[clock format [set ${this}seconds($label)] -format %m] == $month} {
                    widget::configure $label -foreground $(foreground)
                } else {
                    widget::configure $label -foreground $(disabled,foreground)
                }
            }
        }
        if {$select && ($composite::($this,-command) ne "")} {                               ;# pass bounds in seconds as parameters
            uplevel #0 $composite::($this,-command) [list\
                [set ${this}seconds([lindex $labels 0])]\
                [expr {[set ${this}seconds([lindex $labels end])] + (24 * 3600) - 1}]\
            ]                                                                               ;# always invoke command at global level
        }
    }

    proc refresh {this} {
        variable ${this}seconds

        set today [clock format [clock seconds] -format %Y-%j]
        set start [lindex $composite::($this,-seconds) 0]; set end [lindex $composite::($this,-seconds) end]
        set seconds $start
        set month [clock format $seconds -format %m]
        $($this,monthLabel) configure -text [mc [clock format $seconds -format %B]]
        $($this,yearLabel) configure -text [clock format $seconds -format %Y]
        set seconds [clock scan [clock format $seconds -format %Y]-[clock format $seconds -format %m]-01]    ;# point to month start
        set day [clock format $seconds -format %u]
        if {$day == 1} {set day 8}
        set seconds [clock scan "[expr {1 - $day}] days" -base $seconds]   ;# point to first second of monday before displayed month
        set select {}
        foreach label $($this,labels) {
            widget::configure $label -text [clock format $seconds -format %e]
            if {[clock format $seconds -format %m] == $month} {
                widget::configure $label -foreground $(foreground)
            } else {
                widget::configure $label -foreground $(disabled,foreground)
            }
            if {[clock format $seconds -format %Y-%j] eq $today} {
                widget::configure $label -highlightbackground black
            } else {
                widget::configure $label -highlightbackground $(background)
            }
            set ${this}seconds($label) $seconds
            set next [clock scan day -base $seconds]                                                            ;# point to next day
            if {($start < $next) && ($seconds <= $end)} {                                               ;# encompass selected period
                lappend select $label
            }
            set seconds $next
        }
        selector::select $($this,selector) $select
    }

}
