#!/usr/bin/env wish
# Displays a Calendar widget.
#
# Copyright 2005 - PDQ Interfaces/Peter MacDonald.   (See http://pdqi.com/)
# $Id$

package require Tk
namespace eval ::lib::calendar {
  proc init {} { # autoloads images. }
  variable _
  variable Opts {
    {-trace     0       "Trace debugging flag"}
    {-command   {}      "Command to callback with result"}
    {-parent    {}      "Parent window"}
    {-format    %Y-%m-%d "Date format."}
    {-toplevel  {}      "Toplevel widget."}
    {-date	{}	"Initial date." }
    {-title	Calendar "Title for window" }
    {-year	{}	"Initial year" }
    {-month	{}	"Initial month" }
    {-day	{}	"Initial day" }
    {-range	0	"Return a range of dates" }
  }

  variable pc
  array set  pc {calendarid 0 pad1 10 pad2 5 pad3 1 widx 0}
  set pc(oneday) [expr {3600*24}]
  image create bitmap image:ahead -data {#define rarrow_width 11
#define rarrow_height 11
static unsigned char rarrow_bits[] = {
   0x08, 0x00, 0x10, 0x00, 0x20, 0x00, 0x40, 0x00, 0x80, 0x00, 0x00, 0x01,
   0x80, 0x00, 0x40, 0x00, 0x20, 0x00, 0x10, 0x00, 0x08, 0x00};
}
  image create bitmap image:back -data {#define larrow_width 11
#define larrow_height 11
static unsigned char larrow_bits[] = {
   0x80, 0x00, 0x40, 0x00, 0x20, 0x00, 0x10, 0x00, 0x08, 0x00, 0x04, 0x00,
   0x08, 0x00, 0x10, 0x00, 0x20, 0x00, 0x40, 0x00, 0x80, 0x00};
}
    image create bitmap image:ahead2 -data {#define next_width 11
#define next_height 11
static char next_bits[] = {
   0x21, 0x00, 0x42, 0x00, 0x84, 0x00, 0x08, 0x01, 0x10, 0x02, 0x20, 0x04,
   0x10, 0x02, 0x08, 0x01, 0x84, 0x00, 0x42, 0x00, 0x21, 0x00};
}
    image create bitmap image:back2 -data {#define previous_width 11
#define previous_height 11
static char previous_bits[] = {
   0x20, 0x04, 0x10, 0x02, 0x08, 0x01, 0x84, 0x00, 0x42, 0x00, 0x21, 0x00,
   0x42, 0x00, 0x84, 0x00, 0x08, 0x01, 0x10, 0x02, 0x20, 0x04};
}

  image create photo image:datetime -data {R0lGODlhGQAUAMIAAMDAwAQEBPz8/ISEhICAgPwEBP///////yH5BAEKAAcA
LAAAAAAZABQAAANyCLHc2jCAGYS9d+E9pN4XUYEWIX5CUWDdpa7WcI4pXI6v
Ws6u3WA6gYnRY9FqMBnRErz1bENUU9BCsnjMpij72i1JW5IQS6qWsRBBRaH+
jb8bN0j5SQtH9uhxEwaTQX2AMyaEhSKGiAqIhQGLhBGQkRAJADs=}

  proc CalHdl {__ sel} {
    # Default Calendar handler.  Call callback with date and close widget.
    upvar $__ _
    set day {}
    if {![info exists _($sel)] || $_($sel) == {} } return
    set date "$_(-year)-$_(-month)-$_($sel)"
    if {$_(-range) && ![info exists _(range)]} {
      set _(range) $date
      return
    }
    if {$_(-command) != {}} {
        if {[info exists _(range)]} {
	  eval $_(-command) [list $_(range) $date]
	} else {
	  eval $_(-command) [list $date]
	}
    } else {
      puts "Clicked : $date"
    }
    $__ close
  }

  proc CalFill {__ args} {
    # Fill the Cal array variable with the day values
    upvar $__ _
    variable pc
    set day $_(-day)
    set mon $_(-month)
    set yr $_(-year)
    set fmon [format %02d $_(-month)]
    set sdat [clock scan "$yr-${fmon}-01"]
    set idx [clock format $sdat -format %w]
    if {[incr mon] > 12} {
	set mon 1
	incr yr
    }
    set fmon [format %02d $mon]
    set edat [clock scan "$yr-${fmon}-01"]
    set ndays [scan [clock format [expr {$edat-$sdat}] -format %j] %d]
    set scol $idx
    set srow 1
    if {[info exists _(lastsel)]} {
      $_(lastsel) conf -bg white
    }
    for {set i 1} {$i < 7} {incr i} {
      for {set j 0} {$j < 7} {incr j} {
        set _($i,$j) {}
      }
    }
    set rc {}
    for {set i 1} {$i <= $ndays} {incr i} {
	set _($srow,$scol) $i
	if {$i == $day} {
	  set rc $srow,$scol
          set w $_(wid:buttons).r${srow}c$scol
	  set _(lastsel) $w
	  $w conf -bg lightblue
	}
	if {[incr scol] >= 7} {
	    set scol 0
	    incr srow
	}
    }
    set mname "[clock format $sdat -format %B] $_(-year)"
    $_(lbl) conf -text $mname
    return $rc
  }

  proc __ {__ args} {
    # Message handler.
    upvar $__ _
    variable pc
    switch [lindex $args 0] {
	new {
	  after idle [namespace current]::_
	  return
	}
	back {
	  if {[incr _(-month) -1]<=0} {
	    set _(-month) 12
	    incr _(-year) -1
	   }
	}
	fwd { if {[incr _(-month)]>=12} { set _(-month) 1; incr _(-year) } }
	back2 { if {[incr _(-year) -1]<=1901} { set _(-year) 2037 } }
	fwd2 { if {[incr _(-year)]>=2038} { set _(-year) 1902 } }
        close {
	  after idle "$__ delete"
	}
	delete {  destroy $_(top); array unset $__; return }
	default { error "unknown cmd: $args" }
     }
    $__ CalFill
  }

 proc bindcmd {e fmt cmd num} {
  variable pc
  if {[set str [$e get]] == {}} return
  if {[catch {clock scan $str} date]} { bell; return }
  switch $cmd {
    day {
      set secs [expr {$pc(oneday)*$num}]
      incr date $secs
      if {$fmt == {}} { set fmt $pc(-format) }
      set str [clock format $date -format $fmt]
      $e delete 0 end
      $e insert 0 $str
    }
    month {
      foreach {y m d} [clock format $date -format {%Y %m %d}] break
      foreach i {y m d} { set $i [string trimleft [set $i] 0] }
      if {[incr m $num] <1} { set m 12; incr y -1
      } elseif {$m >12} { set m 1; incr y 1 }
      if {[catch {clock scan $y-$m-$d} date]} { bell; puts $date; return }
      if {$fmt == {}} { set fmt $pc(-format) }
      set str [clock format $date -format $fmt]
      $e delete 0 end
      $e insert 0 $str
    }
    year {
      foreach {y m d} [clock format $date -format {%Y %m %d}] break
      foreach i {y m d} { set $i [string trimleft [set $i] 0] }
      if {[incr y $num] <1970} return
      if {$y >2037} return
      if {[catch {clock scan $y-$m-$d} date]} { bell; return }
      if {$fmt == {}} { set fmt $pc(-format) }
      set str [clock format $date -format $fmt]
      $e delete 0 end
      $e insert 0 $str
    }
  }
 }

  proc bindings {e {fmt {}}} {
    regsub -all % $fmt %% fmt
    set ns [namespace current]
    bind $e <Up>    [list ${ns}::bindcmd $e $fmt day 1]
    bind $e <Down>  [list ${ns}::bindcmd $e $fmt day -1]
    bind $e <Left>  [list ${ns}::bindcmd $e $fmt month 1]
    bind $e <Right> [list ${ns}::bindcmd $e $fmt month -1]
    bind $e <Prior> [list ${ns}::bindcmd $e $fmt year 1]
    bind $e <Next>  [list ${ns}::bindcmd $e $fmt year -1]
  }

  proc new {__ args} {
    upvar $__ _
    variable pc
    array set _ $args
    if {$_(-toplevel) != {}} {
      set _(base) [set _(top) $_(-toplevel)]
      if {$_(-toplevel) == {.}} { set _(base) {}; }
    } else {
      toplevel [set _(top) [set _(-toplevel) .datetimewid[incr pc(widx)]]]
      set _(base) $_(top)
    }
    if {$_(-parent) != {}} {
      catch {wm transient $_(top) $_(-parent)}
    }
    wm protocol $_(top) WM_DELETE_WINDOW "$__ delete"
    bind $_(top) <Escape> "$__ delete"
    pack [frame [set ww $_(base).w] -relief raised -bd 1] -padx 10 -pady 10 \
      -fill both -expand y
    set w $ww.t
    set now [clock seconds]
    foreach {i j} {year Y month m day d} {
      if {![string length $_(-$i)]} {
        set _(-$i) [clock format $now -format %$j]
      }
    }
    if {[string length $_(-date)]} {
      set now [clock scan $_(-date)]
      array set _ [list -year [clock format $now -format %Y] \
	-month [string trimleft [clock format $now -format %m] 0] \
	-day [string trimleft [clock format $now -format %d] 0] ]
    }
    wm title $_(top) $_(-title)
    set mon $_(-month)
    set yr $_(-year)
    pack [frame $ww.f] -fill x -anchor n
    if {$_(-parent) != {}} { catch {wm transient $_(top) $_(-parent)} }
    pack [button $ww.f.bl2 -image image:back2 -command "$__ back2"] -side left
    pack [button $ww.f.bl -image image:back -command "$__ back"] -side left
    pack [button $ww.f.br2 -image image:ahead2 -command "$__ fwd2"] -side right
    pack [button $ww.f.br -image image:ahead -command "$__ fwd"] -side right
    pack [button [set _(lbl) $ww.f.mn] -padx $pc(pad2) -pady $pc(pad3) \
      -command "$__ new"] -side left -expand y -fill x
    if {$mon == {} || $yr == {}} {
	set now [clock seconds]
	if {$mon == {}} {
	    set mon [string trim "[clock format $now -format %m] " 0]
	}
	if {$yr == {}} {
	    set yr [clock format $now -format %Y]
	}
    }
    pack [frame $w] -expand y -fill both
    grid conf [frame [set fw $w.f]] -sticky news
    set _(wid:buttons) $fw
    for {set row 0} {$row<7} {incr row} {
      grid rowconfigure $fw $row -weight 1
      set lst {}
      for {set col 0} {$col<7} {incr col} {
	button [set bw $fw.r${row}c$col] -textvariable ${__}($row,$col)\
	  -padx $pc(pad2) -pady $pc(pad3) -anchor e -font {Helvetica -10}\
	  -command "$__ CalHdl $row,$col"
	grid configure $bw -column $col -row $row -sticky news
        if {$row} {
	  $bw conf -relief flat -bg white
	} else {
          grid columnconfigure $fw $col -weight 1
	}
      }
    }
    set j -1
    set wdays {Sun Mon Tue Wed Thu Fri Sat}
    foreach s $wdays { 
      if {[info commands mc] == {}} {
	set _(0,[incr j]) $s
      } else {
	set _(0,[incr j]) [mc $s]
      }
    }
    set idx [$__ CalFill]
  }

  proc CallObj {_ cmd args} {
    set ccmd [namespace current]::$cmd
    if {[namespace which $ccmd] != {}} {
       return [uplevel 1 [list $ccmd $_] $args]
    }
    return [eval __ $_ $cmd $args]
  }

  if {[info script] == $::argv0} {

     proc GetDate args {
       puts "Got Dates: $args"
     }
     set o [namespace current]::_1
     upvar $o V
     foreach i $Opts { set V([lindex $i 0]) [lindex $i 1] }
     #wm withdraw .
     interp alias {} $o {} [namespace current]::CallObj $o
     eval new $o -toplevel . -command GetDate $argv
  }
}