#!/usr/local/bin/tclsh8.4

# JStrack:  copyright 1997/2010 by Jim Graham, N5IAL, all rights reserved.

set watchwarn() [list]


# Read_vtec.tcl written by Jim Graham, N5IAL.  28 June 2010, 1800 UTC
# No copyright, no license, no anything.

# This simple Tcl script reads a P-VTEC string and translates it into
# variables that can be used in Tcl/Tk code.  A simple example is included
# at the end.  Comment it out if using this as library code.

lappend k() O ; set k(O) "Operational Product"
lappend k() T ; set k(T) "Test product" 
lappend k() E ; set k(E) "Experimental product"
lappend k() X ; set k(X) "Experimental VTEC in an Operational product"

lappend aaa() NEW ; set aaa(NEW) "New event"
lappend aaa() CON ; set aaa(CON) "Event continued"
lappend aaa() EXT ; set aaa(EXT) "Event extended - time"
lappend aaa() EXA ; set aaa(EXA) "Event extended - area"
lappend aaa() EXB ; set aaa(EXB) "Event extended - both time and area"
lappend aaa() UPG ; set aaa(UPG) "Event upgraded"
lappend aaa() CAN ; set aaa(CAN) "Event cancelled"
lappend aaa() EXP ; set aaa(EXP) "Event expired"
lappend aaa() COR ; set aaa(COR) "Correction"
lappend aaa() ROU ; set aaa(ROU) "Routine"

lappend pp() AF ; set pp(AF) "Ashfall"
lappend pp() AS ; set pp(AS) "Air Stagnation"
lappend pp() BS ; set pp(BS) "Blowing Snow"
lappend pp() BW ; set pp(BW) "Brisk Wind"
lappend pp() BZ ; set pp(BZ) "Blizzard"
lappend pp() CF ; set pp(CF) "Coastal Flood"
lappend pp() DS ; set pp(DS) "Dust Storm"
lappend pp() DU ; set pp(DU) "Blowing Dust"
lappend pp() EC ; set pp(EC) "Extreme Cold"
lappend pp() EH ; set pp(EH) "Excessive Heat"
lappend pp() EW ; set pp(EW) "Extreme Wind"
lappend pp() FA ; set pp(FA) "Areal Flood"
lappend pp() FF ; set pp(FF) "Flash Flood"
lappend pp() FG ; set pp(FG) "Dense Fog"
lappend pp() FL ; set pp(FL) "Flood"
lappend pp() FR ; set pp(FR) "Frost"
lappend pp() FW ; set pp(FW) "Fire Weather"
lappend pp() FZ ; set pp(FZ) "Freeze"
lappend pp() GL ; set pp(GL) "Gale"
lappend pp() HF ; set pp(HF) "Hurricane Force Wind"
lappend pp() HI ; set pp(HI) "Inland Hurricane"
lappend pp() HS ; set pp(HS) "Heavy Snow"
lappend pp() HT ; set pp(HT) "Heat"
lappend pp() HU ; set pp(HU) "Hurricane"
lappend pp() HW ; set pp(HW) "High Wind"
lappend pp() HY ; set pp(HY) "Hydrologic"
lappend pp() HZ ; set pp(HZ) "Hard Freeze"
lappend pp() IP ; set pp(IP) "Sleet"
lappend pp() IS ; set pp(IS) "Ice Storm"
lappend pp() LB ; set pp(LB) "Lake Effect Snow and Blowing Snow"
lappend pp() LE ; set pp(LE) "Lake Effect Snow"
lappend pp() LO ; set pp(LO) "Low Water"
lappend pp() LS ; set pp(LS) "Lakeshore Flood"
lappend pp() LW ; set pp(LW) "Lake Wind"
lappend pp() MA ; set pp(MA) "Marine"
lappend pp() RB ; set pp(RB) "Small Craft for Rough Bar"
lappend pp() SB ; set pp(SB) "Snow and Blowing Snow"
lappend pp() SC ; set pp(SC) "Small Craft"
lappend pp() SE ; set pp(SE) "Hazardous Seas"
lappend pp() SI ; set pp(SI) "Small Craft for Winds"
lappend pp() SM ; set pp(SM) "Dense Smoke"
lappend pp() SN ; set pp(SN) "Snow"
lappend pp() SR ; set pp(SR) "Storm"
lappend pp() SU ; set pp(SU) "High Surf"
lappend pp() SV ; set pp(SV) "Severe Thunderstorm"
lappend pp() SW ; set pp(SW) "Small Craft for Hazardous Seas"
lappend pp() TI ; set pp(TI) "Inland Tropical Storm"
lappend pp() TO ; set pp(TO) "Tornado"
lappend pp() TR ; set pp(TR) "Tropical Storm"
lappend pp() TS ; set pp(TS) "Tsunami"
lappend pp() TY ; set pp(TY) "Typhoon"
lappend pp() UP ; set pp(UP) "Ice Accretion"
lappend pp() WC ; set pp(WC) "Wind Chill"
lappend pp() WI ; set pp(WI) "Wind"
lappend pp() WS ; set pp(WS) "Winter Storm"
lappend pp() WW ; set pp(WW) "Winter Weather"
lappend pp() ZF ; set pp(ZF) "Freezing Fog"
lappend pp() ZR ; set pp(ZR) "Freezing Rain"

lappend s() W ; set s(W) "Warning"
lappend s() A ; set s(A) "Watch"
lappend s() Y ; set s(Y) "Advisory"
lappend s() S ; set s(S) "Statement"
lappend s() F ; set s(F) "Forecast"
lappend s() O ; set s(O) "Outlook"
lappend s() N ; set s(N) "Synopsis"

proc exp_dtg {dtg} {
   global begins ends
   foreach {b e} [split $dtg -] { break }

   if {[string compare $b "000000T0000Z"] == 0} {
      set begins() -1
   } elseif {[regexp {(..)(..)(..)T(..)(..)Z} $b a yy mm dd hh nn]} {
      set begins() 1
      set begins(yy) $yy ; set begins(mm) $mm ; set begins(dd) $dd
      set begins(hh) $hh ; set begins(nn) $nn
      set begins(str) "20$yy-$mm-$dd / $hh${nn}Z"
   }
   if {[string compare $e "000000T0000Z"] == 0} {
      set ends() -1
   } else {
      set ends() 1
      if {[regexp {(..)(..)(..)T(..)(..)Z} $e a yy mm dd hh nn]} {
         set ends(yy) $yy ; set ends(mm) $mm ; set ends(dd) $dd
         set ends(hh) $hh ; set ends(nn) $nn
         set ends(str) "20$yy-$mm-$dd / $hh${nn}Z"
      }
   }
}


# P-VTEC String: /k.aaa.cccc.pp.s.####.yymmddThhnnZ(b)-yymmddThhnnZ(e)/

proc read_p-vtec-string {s} {
   global kval aaaval cccc ppval sval etn dtg
   regsub {^ */} $s {} s2 ;# remove any leading spaces and start/end flags
   regsub {/$} $s2 {} s

   set plist [split $s "."] ;# split it up into easy chunks
   set kval    [lindex $plist 0] ;# product class
   set aaaval  [lindex $plist 1] ;# action
   set cccc    [lindex $plist 2] ;# office
   set ppval   [lindex $plist 3] ;# phenomena
   set sval    [lindex $plist 4] ;# Significance (W, A, Y, S, F, O, N)
   set etn     [lindex $plist 5] ;# (####) Event Tracking Number (ETN)
   set dtg     [lindex $plist 6] ;# date/time group (more splits needed)
   exp_dtg $dtg
}

proc new_ww {idx} {
   global watchwarn

   set sttype $watchwarn($idx:st_type)
   set evtype $watchwarn($idx:ww_type)
   foreach {x1 y1 x2 y2} $watchwarn($idx:xycoords) { break }
   foreach {c1 c2 width dash} $watchwarn($idx:plotvals) { break }
   set tr [.c create line $x1 $y1 $x2 $y2 -fill $c1 -dash $dash \
      -width $width]

   set watchwarn($idx:tag) $tr
   set st_name $watchwarn($idx:st_name)
   set idtag "IDTAG: $sttype $evtype for $st_name)"

   addtags $tr WATCHWARN $idx $idtag WATCHWARN.$st_name
   addtags $tr ww:$idx

   .c raise $tr ; .c raise $tr ; .c raise $tr ; .c raise $tr

   set tmpval  "$sttype $evtype for $watchwarn($idx:st_name)"

   .c bind ww.$idx <Enter> "
      set ptrstormid \"$tmpval\"
         .ptrloc.l3 configure -foreground yellow -background black
   "
   .c bind ww.$idx <Leave> {
      set ptrstormid ""
      .ptrloc.l3 configure -foreground black -background #d9d9d9
   }
}


proc reload_ww {$idx} {
   global watchwarn
   catch { .c delete $watchwarn($idx:tag) }
   new_ww $idx
}


proc plot_ww {stname str lo1 la1 lo2 la2} { }
proc bp_plot_ww {stname str lo1 la1 lo2 la2} {
   global aaaval etn etnval k kval pp ppval s sval begins ends
   global watchwarn wwidx ww_sttype ww_wwtype

   set x1 [set_long $lo1]
   set x2 [set_long $lo2]
   set y1 [set_latt $la1] ;# yeah, should only have one 't' ...
   set y2 [set_latt $la2] ;# yeah, should only have one 't' ...
   read_p-vtec-string $str
   if {$kval != "O" } { return }

   set wwidx $stname:$pp($ppval):$s($sval):$etn  ;# index for this w/w
   if {[lsearch -exact $watchwarn() $wwidx] < 0} {
      lappend watchwarn() $wwidx
   }

   set ww_sttype $ppval
   set ww_wwtype $s($sval)

   # switch to storm abbreviations used by JStrack and set plot vals
   switch $ww_sttype {
      HU {
         set ww_sttype HR
         if {[string compare $ww_wwtype Warning] == 0} {
            set c1 #d90000 ; set c2 $c1 ; set width 8 ; set dash {}
         } else {
            set c1 #d90000 ; set c2 $c1 ; set width 12 ; set dash {4 2}
         }
      }
      TR {
         set ww_sttype TS
         if {[string compare $ww_wwtype Warning] == 0} {
            set c1 yellow ; set c2 $c1 ; set width 8 ; set dash {}
         } else {
            set c1 blue ; set c2 yellow ; set width 12 ; set dash {4 2}
         }
      }
      default { return }
   }

   set watchwarn($wwidx:st_type) $ww_sttype
   set watchwarn($wwidx:ww_type) $ww_wwtype
   set watchwarn($wwidx:xycoords) [list $x1 $y1 $x2 $y2]
   set watchwarn($wwidx:plotvals) [list $c1 $c2 $width $dash]
   set watchwarn($wwidx:st_name) $stname

   set nlist [array names watchwarn]

   if {[lsearch -exact $nlist $wwidx:tag] < 0} {
      switch $aaaval {
         NEW " new_ww $wwidx"
         CON " new_ww $wwidx "
         EXA " new_ww $wwidx "
         EXB " new_ww $wwidx "
         EXT " new_ww $wwidx "
         UPG " new_ww $wwidx "
         COR " new_ww $wwidx "
         ROU " new_ww $wwidx "
      }
   } else {

      switch $aaaval {
         CAN " 
            .c delete $watchwarn($wwidx:tag)
            array unset watchwarn $wwidx:.*
         "
         EXP "
            .c delete $watchwarn($wwidx:tag)
            array unset watchwarn $wwidx:.*
         "

         EXA " .c delete $watchwarn($wwidx:tag) ; new_ww $wwidx "
         EXB " .c delete $watchwarn($wwidx:tag) ; new_ww $wwidx "
         UPG " .c delete $watchwarn($wwidx:tag) ; new_ww $wwidx "
         COR " .c delete $watchwarn($wwidx:tag) ; new_ww $wwidx "
         ROU " .c delete $watchwarn($wwidx:tag) ; new_ww $wwidx "

         CON { return }
         EXT { return }
      }
   }


}


# TESTING

# set str {/O.NEW.KNHC.HU.A.1001.100628T1500Z-000000T0000Z/}
# set stname ALEX
# set la1 25.96 ; set lo1 97.15
# set la2 27.29 ; set lo2 97.38
# plot_ww $stname $str $lo1 $la1 $lo2 $la2


