ypp-chatlog-alerter

   1 #!/usr/bin/wish
   2
   3 proc manyset {list args} {
   4     foreach val $list var $args {
   5         upvar 1 $var my
   6         set my $val
   7     }
   8 }
   9
  10 set progname ypp-chatlog-alerter
  11 set height 5
  12
  13 proc menuent {w l a x} {
  14     set c [list .mbar.$w add command -label $l -command $x]
  15     if {[string length $a]} { lappend c -accel Command-$a }
  16     eval $c
  17 }
  18 proc menus {} {
  19     global height
  20
  21     menu .mbar -tearoff 0
  22     foreach w {file edit} l {File Edit} {
  23         menu .mbar.$w -tearoff 0
  24         .mbar add cascade -menu .mbar.$w -label $l
  25     }
  26     foreach l {Open Quit} a {O Q} x {newfile exit} {
  27         menuent file $l $a $x
  28     }
  29     foreach l {Cut Copy Paste Clear} a {X C V {}} {
  30         menuent edit $l $a [list event generate {[focus]} <<$l>>]]
  31     }
  32     . configure -menu .mbar
  33 }
  34
  35 proc nonportability {} {
  36     global progname defaultfile
  37
  38     switch -exact [tk windowingsystem] {
  39         aqua {
  40             set defaultfile ~/Library/Preferences/$progname.prefs
  41         }
  42         x11 {
  43             set defaultfile ~/.$progname.rc
  44         }
  45         default {
  46             error ?
  47         }
  48     }
  49 }
  50
  51 proc widgets {} {
  52     global height
  53     listbox .t -width 5 -height $height -borderwidth 0
  54     listbox .p -width 14 -height $height -borderwidth 0
  55     listbox .m -width 80 -height $height -borderwidth 0
  56     pack .t .p .m -side left
  57 }
  58
  59 proc newfile {} {
  60     global currentfile defaultfile
  61
  62     set newfile [tk_getOpenFile -multiple 0 -initialfile $currentfile \
  63                      -title "Select YPP log to track"]
  64     if {![string length $newfile]} return
  65
  66     set currentfile $newfile
  67     set newdefaults [open $defaultfile.new w]
  68     puts $newdefaults "[list set currentfile $currentfile]"
  69     close $newdefaults
  70     file rename -force $defaultfile.new $defaultfile
  71
  72     #fixme refresh
  73 }
  74
  75 set lw_ls {times pirates messages}
  76 set lw_ws {t p m}
  77
  78 proc for_lw {body} {
  79     global lw_ls lw_ws
  80     uplevel 1 [list \
  81                    foreach l $lw_ls \
  82                            w $lw_ws \
  83                        $body]
  84 }
  85
  86 set e_life 120
  87 set tint_switch 90
  88 set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }]
  89
  90 proc retint {} {
  91     global times e_life retint_after otherevent
  92     catch { after cancel $retint_after }
  93     set i 0
  94     set now [clock seconds]
  95     set latest $otherevent
  96     foreach time $times {
  97         set latest [expr { $time > $latest ? $time : $latest }]
  98         set tint [expr {
  99                         exp( -($now >= $time ? $now-$time : 0) / $e_life )
 100                     }]
 101         tintentries .t $i $tint
 102         incr i
 103     }
 104     set next [expr { ($now - $latest < 10 ? 10 :
 105                       $now - $latest > 3000 ? 3000 :
 106                       $now - $latest
 107                       ) * 10 }]
 108 puts "nexting $latest $now $next"
 109     set retint_after [after $next retint]
 110 }
 111
 112 proc tintentries {ws y tint} {
 113     global tint_switched
 114     #puts "$tint $tint_switched"
 115     set yellow [format "%02x" [expr {round( 255 *
 116         ( $tint >= $tint_switched ? $tint : 0 )
 117                                             )}]]
 118     set black [format "%02x" [expr {round( 255 *
 119         ( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 )
 120                                            )}]]
 121     set fg [format "#${black}${black}${black}"]
 122     set bg [format "#${yellow}${yellow}00"]
 123     foreach w $ws { $w itemconfigure $y -foreground $fg -background $bg }
 124 }
 125
 126 proc clearlists {} {
 127     global height otherevent
 128     global times pirates messages
 129     set currentfile {}
 130
 131     for_lw { .$w delete 0 end; set $l {} }
 132     set ntimes {}
 133     for {set i 0} {$i<$height} {incr i} {
 134         for_lw { lappend $l {}; .$w insert end {} }
 135         lappend ntimes 0
 136     }
 137     set times $ntimes
 138     set otherevent [clock seconds]
 139     retint
 140 }
 141
 142 proc showtints {} {
 143     global e_life
 144     set divs 20
 145     listbox .tints -width 60 -height [expr {$divs+1}]
 146     for {set y 0} {$y <= $divs} {incr y} {
 147         set tint [expr {($y+0.0)/$divs}]
 148         .tints insert end \
 149             "[format "#%2d   %6f   %4ds" $y $tint [expr {round(
 150                 $tint > 0 ? -log($tint) * $e_life : "9999"
 151             )}]]  The quick brown fox jumped over the lazy dog"
 152         tintentries .tints $y $tint
 153     }
 154     pack .tints -side bottom
 155 }
 156
 157 proc parseargs {} {
 158     global argv
 159     foreach arg $argv {
 160         if {![string compare $arg --test-tints]} {
 161             showtints
 162         } else {
 163             error "unknown option $arg"
 164         }
 165     }
 166 }
 167
 168 menus
 169 nonportability
 170 parseargs
 171 widgets
 172 clearlists
 173
 174 if {[file exists $defaultfile]} {
 175     source $defaultfile
 176 }
 177
 178 #fixme refresh