From: Ian Jackson <ian@liberator.relativity.greenend.org.uk>
Date: Sat, 2 Oct 2010 13:17:27 +0000 (+0100)
Subject: ypp-chatlog-alerter: tints sorted
X-Git-Tag: 6.7.0~10
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=commitdiff_plain;h=c9e9cc60807876413c150c24f8971b4c01c25214;hp=7d142da06236017c26ea877427784e36d0363e7f

ypp-chatlog-alerter: tints sorted
---

diff --git a/ypp-chatlog-alerter b/ypp-chatlog-alerter
index 7dea3ac..396d69e 100755
--- a/ypp-chatlog-alerter
+++ b/ypp-chatlog-alerter
@@ -8,43 +8,53 @@ proc manyset {list args} {
 }
 
 set progname ypp-chatlog-alerter
+set height 5
 
-menu .mbar -tearoff 0
-foreach w {file edit} l {File Edit} {
-    menu .mbar.$w -tearoff 0
-    .mbar add cascade -menu .mbar.$w -label $l
-}
 proc menuent {w l a x} {
     set c [list .mbar.$w add command -label $l -command $x]
     if {[string length $a]} { lappend c -accel Command-$a }
     eval $c
 }
-foreach l {Open Quit} a {O Q} x {newfile exit} {
-    menuent file $l $a $x
-}
-foreach l {Cut Copy Paste Clear} a {X C V {}} {
-    menuent edit $l $a [list event generate {[focus]} <<$l>>]]
-}
-. configure -menu .mbar
-
-switch -exact [tk windowingsystem] {
-    aqua {
-	set defaultfile ~/Library/Preferences/$progname.prefs
+proc menus {} {
+    global height
+    
+    menu .mbar -tearoff 0
+    foreach w {file edit} l {File Edit} {
+	menu .mbar.$w -tearoff 0
+	.mbar add cascade -menu .mbar.$w -label $l
     }
-    x11 {
-	set defaultfile ~/.$progname.rc
+    foreach l {Open Quit} a {O Q} x {newfile exit} {
+	menuent file $l $a $x
     }
-    default {
-	error ?
+    foreach l {Cut Copy Paste Clear} a {X C V {}} {
+	menuent edit $l $a [list event generate {[focus]} <<$l>>]]
     }
+    . configure -menu .mbar
 }
 
-set height 5
+proc nonportability {} {
+    global progname defaultfile
+    
+    switch -exact [tk windowingsystem] {
+	aqua {
+	    set defaultfile ~/Library/Preferences/$progname.prefs
+	}
+	x11 {
+	    set defaultfile ~/.$progname.rc
+	}
+	default {
+	    error ?
+	}
+    }
+}
 
-listbox .t -width 5 -height $height -borderwidth 0
-listbox .p -width 14 -height $height -borderwidth 0
-listbox .m -width 80 -height $height -borderwidth 0
-pack .t .p .m -side left
+proc widgets {} {
+    global height
+    listbox .t -width 5 -height $height -borderwidth 0
+    listbox .p -width 14 -height $height -borderwidth 0
+    listbox .m -width 80 -height $height -borderwidth 0
+    pack .t .p .m -side left
+}
 
 proc newfile {} {
     global currentfile defaultfile
@@ -58,64 +68,96 @@ proc newfile {} {
     puts $newdefaults "[list set currentfile $currentfile]"
     close $newdefaults
     file rename -force $defaultfile.new $defaultfile
-    refresh
+    
+    #fixme refresh
 }
 
-proc for_ll {varname body} {
-    upvar 1 $varname l
-    foreach l {times pirates messages} {
-	set rc [catch { uplevel 1 $body } emsg]
-	switch -exact $rc {
-	    0 {
-		# ok
-	    }
-	    4 {
-		# continue
-	    }
-	    3 {
-		# break
-		return
-	    }
-	    default {
-		# error, return, etc.
-		return -code $rc -errorinfo $errorInfo \
-		    -errorcode $errorCode $emsg
-	    }
-	}
-    }
+set lw_ls {times pirates messages}
+set lw_ws {t p m}
+
+proc for_lw {body} {
+    global lw_ls lw_ws
+    uplevel 1 [list \
+		   foreach l $lw_ls \
+		           w $lw_ws \
+		       $body]
 }
 
+set e_life 120
+set tint_switch 90
+set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }]
+
 proc retint {} {
-    global messages
+    global times e_life
     set i 0
     set now [clock seconds]
-    foreach minfo $messages {
-	manyset $minfo then pirate msg
-	set !
+    foreach time $times {
+	set agescale [expr {
+			    exp( -($now >= $time ? $now-$time : 0) / $e_life )
+			}]
+    }
 }
 
-proc init {} {
-    global currentfile height
+proc tintentry {w y tint} {
+    global tint_switched
+    #puts "$tint $tint_switched"
+    set yellow [format "%02x" [expr {round( 255 *
+        ( $tint >= $tint_switched ? $tint : 0 )
+					    )}]]
+    set black [format "%02x" [expr {round( 255 *
+	( $tint >= $tint_switched ? 0 : ($tint / $tint_switched)*0.75 + 0.25 )
+					   )}]]
+    $w itemconfigure $y \
+	-foreground [format "#${black}${black}${black}"] \
+	-background [format "#${yellow}${yellow}00"]
+}
+
+proc clearlists {} {
+    global height
     global times pirates messages
     set currentfile {}
     
-    foreach w {t p m} { .$w delete 0 end }
-    foreach l {times pirates messages} 
+    for_lw { .$w delete 0 end; set $l {} }
     for {set i 0} {$i<$height} {incr i} {
-	lappend times 0
-	lappend pirates {}
-	lappend messages {}
-	foreach w {t p m} { .$w insert end {} }
+	for_lw { lappend $l {}; .$w insert end {} }
     }
 }
 
-proc refresh {} {
+proc showtints {} {
+    global e_life
+    set divs 20
+    listbox .tints -width 60 -height [expr {$divs+1}]
+    for {set y 0} {$y <= $divs} {incr y} {
+	set tint [expr {($y+0.0)/$divs}]
+	puts "$y $tint"
+	.tints insert end \
+	    "[format "#%2d   %6f   %4ds" $y $tint [expr {round(
+                $tint > 0 ? -log($tint) * $e_life : "9999"
+            )}]]  The quick brown fox jumped over the lazy dog"
+	tintentry .tints $y $tint
+    }
+    pack .tints -side bottom
+}
+	    
+proc parseargs {} {
+    global argv
+    foreach arg $argv {
+	if {![string compare $arg --test-tints]} {
+	    showtints
+	} else {
+	    error "unknown option $arg"
+	}
+    }
 }
 
-init
+menus
+nonportability
+parseargs
+widgets
+clearlists
 
 if {[file exists $defaultfile]} {
     source $defaultfile
 }
 
-refresh
+#fixme refresh