# Date/time functions
# Rick Smereka, Copyright (C) 2005-2006.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, get a copy via the Internet at
# http://gnu.org/copyleft/gpl.html or write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA

# You can contact the author via email at rsmereka@future-lab.com

# Initial tcl version Mar/2005, Rick Smereka

# Fixed bug in proc 'juldate' by calling 'int_remove_lz' to strip
# a leading zero from a number before addition. Aug/2006, Rick Smereka

# Corrected another bug in proc 'juldate' by calling 'int_remove_lz' to
# strip a leading zero from the month number. Sep/2006, Rick Smereka

# julian base year
const DATIME_JUL_BASE 1954

# month short names
set datime_smonth [list NA JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC]

# number of days in each month
set datime_numdays [list 0 31 28 31 30 31 30 31 31 30 31 30 31]

proc datime_month_name_2_num {mname} {
   # Convert a month name to a month number. Only the first three
   # characters of the month name are compared so you may use the
   # long or short month names. January is considered month one.
   # Returns the month number upon success, 0 otherwise.
   global datime_smonth
   set len [string length $mname]

   # must have a minimum of three characters
   if {$len < 3} {
      return 0
   }

   # grab only the first 3 chars
   set smon [string toupper [string range $mname 0 2]]
   set ret [lsearch -exact $datime_smonth $smon]

   if {$ret == -1} {
      return 0
   }

   return $ret
}

proc datime_month_num_2_name {mnum mname} {
   # Translate a month number (1=Jan) to the short month name.
   # Returns 1 upon success with the month name loaded into
   # 'mname'. Returns 0 upon failure.
   global datime_smonth
   upvar $mname lk
   set lk ""

   if {$mnum <= 0 || $mnum > 12} {
      return 0
   }

   set lk [lindex $datime_smonth $mnum]
   return 1
}

proc get_ftime {} {
   # Format and return the current time string. Returned format is:
   #
   #    yyyy/mm/dd hh:mm:ss
   set secs [clock seconds]
   return [clock format $secs -format "%Y/%m/%d %H:%M:%S"]
}

proc get_time {} {
   # Format and return the current time string. Format of the time
   # string is:

   #    yyyymmddhhmmss
   set secs [clock seconds]
   set ret [clock format $secs -format "%Y%m%d%H%M%S"]
   return $ret
}

proc datime_hour12_2_hour24 {intime outime sep_flag} {
   # Convert a time string expressed in 12 hour format
   # to a time string expressed in 24 hour format. The input
   # time string ('intime') may be in any of the following
   # formats:
   #
   #    hh[:mm][:ss]p, hh[:mm][:ss] p, hh[:mm][:ss]pm, hh[:mm][:ss] pm
   #    hh[:mm][:ss]a, hh[:mm][:ss] a, hh[:mm][:ss]am, hh[:mm][:ss] am
   #    hh[:mm][:ss]m, hh[:mm][:ss] m, hh[:mm][:ss]n, hh[:mm][:ss] n
   #
   # Where 'p' and 'pm' are the same, 'a' and 'am' are also the
   # same. A trailing 'm' indicates midnight and a trailing
   # 'n' indicates noon. When a trailing 'm' or 'n' is used,
   # the time is assumed to be '12:00' regardless of any
   # other hour/minute value. Spaces may or may not be present
   # after the time and before the 'am' or 'pm' designator. The
   # colon separater is required in the input time string. The flag
   # 'sep_flag' is used to indicate whether the output time
   # string should have a colon separater. The minute and seconds fields
   # are completly optional. The output time string always contains
   # two digits each for the hour, minute and optional seconds.
   # The hour and minute are always present in the output string.
   # Seconds are only present in the output string if present in
   # the input string. Returns 1 with the converted time loaded
   # into 'outime' upon success. Returns 0 otherwise.
   upvar $outime lk
   set lk ""
   set len [string length $intime]

   if {!$len} {
      return 0
   }

   set hr 0
   set min 0
   set sec 0
   set is_sec 0
   set ap ""
   set new_inp [strip_space $intime]
   set nwords [ll_words $new_inp ":"]

   if {$nwords > 3} {
      return 0
   }

   # tape apart the input time string
   for {set i 1} {$i <= $nwords} {incr i} {
      if {![ll_word $new_inp wrd $i ":"]} {
         return 0
      }

      # one the last part of the input time string, get
      # the 'am/pm' designator
      if {$i == $nwords} {
         if {![datime_get_ampm wrd ap]} {
            return 0
         }
      }

      switch $i {
         1 {
            # hour
            if {![num $wrd]} {
               return 0
            }

            if {$wrd < 1 || $wrd > 12} {
               return 0
            }

            set hr $wrd
         }

         2 {
            # minute
            if {![num $wrd]} {
               return 0
            }

            if {$wrd < 0 || $wrd > 59} {
               return 0
            }

            set min $wrd
         }

         3 {
            # second
            if {![num $wrd]} {
               return 0
            }

            if {$wrd < 0 || $wrd > 59} {
               return 0
            }

            set sec $wrd
            set is_sec 1
         }
      }
   }

   # build 24hr time
   # first, adjust time
   switch $ap {
      A {
         if {$hr == 12} {
            set hr 0
         }
      }

      P {
         if {$hr != 12} {
            set hr [expr $hr + 12]
         }
      }

      M {
         # midnight is always hour zero, minute zero
         set hr 0
         set min 0
      }

      N {
         # noon is always hour 12, minute zero
         set hr 12
         set min 0
      }
   }

   if {$sep_flag} {
      if {$is_sec} {
         set lk [format "%02d:%02d:%02d" $hr $min $sec]
      } else {
         set lk [format "%02d:%02d" $hr $min]
      }
   } else {
      if {$is_sec} {
         set lk [format "%02d%02d%02d" $hr $min $sec]
      } else {
         set lk [format "%02d%02d" $hr $min]
      }
   }

   return 1
}

proc datime_get_ampm {wrd ap} {
   # Get the 'am', 'pm' designator in the time string 'wrd'.
   # If found, the designator will be removed from 'wrd' and
   # a single character will be loaded into 'ap'. Acceptable
   # designators are 'a', 'am', 'p', 'pm', 'n' and 'm'.
   # Returns 1 upon success, 0 otherwise.
    upvar $ap lk
    upvar $wrd lk2
    set lk ""
    set len [string length $lk2]

    if {!$len} {
      return 0
    }

   set pos 0

   # loop to identify the designator
   for {set i 0} {$i < $len} {incr i} {
      set ch [string toupper [string index $lk2 $i]]

      if {[string match {[0-9]} $ch]} {
         continue
      }

      # set position of first non-digit
      if {!$pos} {
         set pos $i
      }

      # if its a space, ignore
      if {$ch == " "} {
         continue
      }

      # load first character of designator
      set lk $ch
      break
   }

   # error on no designator
   if {$lk == ""} {
      return 0
   }

   # designator must be one of 'a', 'p', 'm' or 'n'
   if {$lk != "A" && $lk != "P" && $lk != "M" && $lk != "N"} {
      set lk ""
      return 0
   }

   set lk2 [string range $lk2 0 [expr $pos - 1]]
   return 1
}

proc run_year {} {
   # Get the year of program run via 'get_time'. Returns year as a
   # number upon success, zero otherwise.
   set tbuf [get_time]
   set year [string range $tbuf 0 3]

   if {![num $year]} {
      return 0
   }

   return $year
}

proc days_in_month {year month} {
   # Determine the number of days in a month taking into account
   # leap years. Returns the number of day in 'month' upon
   # success, 0 otherwise.
   global datime_numdays

   if {$month < 1 || $month > 12} {
      return 0
   }

   set leap [isleap $year]

   if {$month == 2 && $leap} {
      return 29
   }

   return [lindex $datime_numdays $month]
}

proc isleap {year} {
   # Determine whether the 'year' is a leap year. Returns 1 if
   # the 'year' is a leap year, 0 otherwise.
   return [expr ($year % 4 == 0 && $year % 100 != 0) || $year % 400 == 0]
}

proc juldate {dte julout} {
   # Convert a date in the form 'yyyymmdd' to a Julian value
   # using 'DATIME_JUL_BASE' as the base year. Returns 1 upon
   # success with the julian date loaded into 'julout'. Returns
   # 0 otherwise.
   global DATIME_JUL_BASE
   upvar $julout lk
   set lk 0

   if {[string length $dte] != 8} {
      return 0
   }

   set d_year [string range $dte 0 3]

   if {![num $d_year]} {
      return 0
   }

   set d_mo [int_remove_lz [string range $dte 4 5]]

   if {![num $d_mo]} {
      return 0
   }

   set d_day [int_remove_lz [string range $dte 6 7]]

   if {![num $d_day]} {
      return 0
   }

   set ret $d_day

   # for every month preceding the current, add days

   for {set i 1} {$i < $d_mo} {incr i} {
      set ret [expr $ret + [days_in_month $d_year $i]]
   }

   # add days from preceding years
   for {set i $DATIME_JUL_BASE} {$i < $d_year} {incr i} {
      if {[isleap $i]} {
         set ret [expr $ret + 366]
      } else {
         set ret [expr $ret + 365]
      }
   }

   set lk $ret
   return 1
}
      
proc datdif {d1 d2 dif} {
   # Find the number of days difference between two dates.
   # 'd1' is assumed to be the later of the two dates.
   # Dates are expected in the form 'yyyymmdd'.
   # Returns 1 upon success with the number of days
   # difference loaded into 'dif' upon success.
   # Returns 0 upon failure.
   upvar $dif lk
   set lk 0

   if {![string length $d1] || ![string length $d2]} {
      return 0
   }

   if {![juldate $d1 jul1]} {
      return 0
   }

   if {![juldate $d2 jul2]} {
      return 0
   }

   set lk [expr $jul1 - $jul2]
   return 1
}
