#!/usr/bin/wish

proc manyset {list args} {
    foreach val $list var $args {
        upvar 1 $var my
        set my $val
    }
}

set progname ypp-chatlog-alerter
set height 5

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
}
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
    }
    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
}

proc nonportability {} {
    global progname defaultfile
    
    switch -exact [tk windowingsystem] {
	aqua {
	    set defaultfile ~/Library/Preferences/$progname.prefs
	}
	x11 {
	    set defaultfile ~/.$progname.rc
	}
	default {
	    error ?
	}
    }
}

set lw_ls {times pirates messages}
set lw_ws {.time .pirate .msg}

proc widgets {} {
    global height lw_ws prtimes
    listbox .time   -width  5 -background black \
	-listvariable prtimes -foreground white
    listbox .pirate -width 14 -background black
    listbox .msg    -width 80
    for_lw {
	$w configure -height $height -borderwidth 0 -activestyle none \
	    -highlightthickness 0
    }
    eval pack $lw_ws -side left
    label .overlay -relief raised -foreground white
}

proc shownotice {colour message} {
    .overlay configure -text $message -background $colour
    place .overlay -relx 0.5 -rely 0.5 -anchor center
}
proc hidenotice {} {
    place forget .overlay
}

proc newfile {} {
    global currentfile defaultfile logfile
    
    set newfile [tk_getOpenFile -multiple 0 -initialfile $currentfile \
		     -title "Select YPP log to track"]
    if {![string length $newfile]} return

    catch { close $logfile }
    catch { unset logfile }

    set currentfile $newfile
    set newdefaults [open $defaultfile.new w]
    puts $newdefaults "[list set currentfile $currentfile]"
    close $newdefaults
    file rename -force $defaultfile.new $defaultfile

    clearlists
    pollfile
}

proc for_lw {args} {
    global lw_ls lw_ws
    set body [lindex $args end]
    set args [lreplace $args end end]
    uplevel 1 [list \
		   foreach l $lw_ls \
		           w $lw_ws] \
		           $args \
	                 [list $body]
}

set e_life 120
set tint_switch 90
set bell_again 60
set tint_switched [expr { exp( -($tint_switch+0.0) / $e_life ) }]

proc retint {} {
    global times e_life retint_after otherevent prtimes
    catch { after cancel $retint_after }
    set i 0
    set now [clock seconds]
    set latest $otherevent
    set newprtimes {}
    foreach time $times {
	set age [expr {$now-$time}]
	if {!$time} {
	    lappend newprtimes {}
	} elseif {$age < 60} {
	    lappend newprtimes [format "%3ds" $age]
	} elseif {$age < 3600} {
	    lappend newprtimes [format "%3dm" [expr {$age/60}]]
	} else {
	    lappend newprtimes [format "%3dh" [expr {$age/3600}]]
	}
	set latest [expr { $time > $latest ? $time : $latest }]
	set tint [expr { exp( (-($age >= 0 ? $age : 0) + 0.0) / $e_life ) }]
#puts "AGE $age LA $latest TI $tint"
	tintentries .msg $i $tint
	incr i
    }
    set prtimes $newprtimes
    set next [expr { ($now - $latest < 10 ? 10 :
		      $now - $latest > 3000 ? 3000 :
		      $now - $latest
		      ) * 10 }]
#puts "nexting $latest $now $next"
    set retint_after [after $next retint]
}

proc tintentries {ws 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 )
					   )}]]
    set fg [format "#${black}${black}${black}"]
    set bg [format "#${yellow}${yellow}00"]
    foreach w $ws { $w itemconfigure $y -foreground $fg -background $bg }
}

proc clearlists {} {
    global height otherevent
    global times prtimes pirates messages
    set currentfile {}
    
    for_lw { $w delete 0 end; set $l {} }
    set ntimes {}
    set prtimes {}
    for {set i 0} {$i<$height} {incr i} {
	for_lw { lappend $l {}; $w insert end {} }
	lappend ntimes 0
	lappend prtimes {}
    }
    set times $ntimes
    set otherevent [clock seconds]
    retint
}

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}]
	.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"
	tintentries .tints $y $tint
    }
    pack .tints -side bottom
}

proc file-read-lines {lvar body} {
    upvar 1 $lvar l
    global logfile poll_after lastactivity bufdata
    
#puts f-r-l
    if {![info exists logfile]} {
	return
    }
    while 1 {
	if {[catch { read $logfile } got]} {
	    file-error $got
	    return
	}
#puts "f-r-l [string length $got]"
        if {![string length $got] && [eof $logfile]} {
	    set ago [expr { [clock seconds] - $lastactivity }]
	    set interval [expr {( $ago < 10 ? 10 :
				  $ago > 3000 ? 3000 :
				  $ago ) * 10}]
#puts "requeue filepoll $interval"
	    set poll_after [after $interval pollfile]
	    return
	}
	set lastactivity [clock seconds]

	while {[regexp {^(.*?)[\r\n]+(.*)$} $got dummy lhs rhs]} {
	    set l "$bufdata$lhs"
	    set bufdata {}
	    set got $rhs
#puts ">>$l<<"
	    uplevel 1 $body
	}
	append bufdata $got
    }
}

proc file-error {emsg} {
    global logfile
    
    shownotice red "Error reading logfile $currentfile:\n$emsg"
    catch { close $logfile }
    catch { unset logfile }
}	

proc pollfile {} {
    global poll_after logfile currentfile
    global errorCode errorInfo bufdata lastactivity

    catch { after cancel $poll_after }
    if {![string length $currentfile]} {
	shownotice red "No log file selected.  Use File / Open."
	return
    }
    if {![info exists logfile]} {
	set bufdata {}
	set lastactivity [clock seconds] 
	if {[catch { set logfile [open $currentfile r] } emsg]} {
	    shownotice red "Error opening logfile $currentfile:\n$emsg"
	    return
	}
	shownotice \#000080 "Reading $currentfile"
	if {[catch {
	    seek $logfile -1024 end
	} emsg]} {
	    if {![string match {POSIX EINVAL *} $errorCode]} {
		file-error $emsg
	    }
	}
	file-read-lines l { }
    }
    file-read-lines l {
	hidenotice
	if {[regexp {^\[\d+:\d+:\d+\] (.*)} $l dummy rhs]} {
#puts PROCLINE
	    process-line $rhs
	}
    }
}

proc process-line {l} {
    if {[regexp {^(\w+) tells ye, \"(.*)\"$} $l dummy pirate msg]} {
#puts "MESSAGE $l"
	message $pirate $msg
    }
}

proc message {pirate msg} {
    global times pirates messages height
    global lw_ls lw_ws bell_again
    
    set ix [lsearch -exact $pirates $pirate]
    set now [clock seconds]
    
    if {$bell_again > -2 &&
	($ix<0 || [lindex $times $ix] < $now-$bell_again)} {
	bell -nice
    }
    if {$ix < 0} {
	set cix 0
	set oldest $now
	foreach time $times {
	    if {$time < $oldest} {
		set oldest $time
		set ix $cix
	    }
	    incr cix
	}
	for_lw {
	    set $l [lreplace [set $l] $ix $ix]
	    lappend $l {}
	    $w delete $ix
	    $w insert end {}
	}
	set ix [expr {$height-1}]
    }
    for_lw new [list $now $pirate $msg] {
	set $l [lreplace [set $l] $ix $ix $new]
	$w delete $ix
	$w insert $ix $new
    }
#puts "TIMES $times"
    .pirate itemconfigure $ix -foreground white
    retint
}

proc parseargs {} {
    global argv
    foreach arg $argv {
	if {![string compare $arg --test-tints]} {
	    showtints
	} elseif {![string compare $arg --no-bell]} {
	    set bell_again -2
	} else {
	    error "unknown option $arg"
	}
    }
}

menus
nonportability
parseargs
widgets
clearlists

if {[file exists $defaultfile]} {
    source $defaultfile
}

pollfile