#!/usr/dist/bin/wishx -f

######################################################################
#
# score.tcl
#
# Copyright (C) 1993,1994 by John Heidemann <johnh@ficus.cs.ucla.edu>
# All rights reserved.  See the main Jacoby (currently
# ``dontspace'' file for a full copyright
# notice.
#
# $Id: score.tcl,v 2.8 1997/04/26 06:48:26 johnh Exp $
#
######################################################################

set rcsid(score.tcl) {$Id: score.tcl,v 2.8 1997/04/26 06:48:26 johnh Exp $}


# external
proc mkScore {w game x y methodVar} {
	global score table

	set score(tableW) $w

	set score(game) $game
	# NEEDSWORK: should capitalize
	set score(Game) $game
	traceScoreMethodVariable $methodVar
	foreach i {official unofficial non-scored} {
		set score(scoreFormat,$i) "%d"
		set score(score,$i) 0
	}
	set score(message) ""

	set score(showScoresWhen) high
	set score(ourScorePresent) 0

	set score(scoreFileVersion) 764050802
	set score(scoreFileHeader) "$score(game) score file version $score(scoreFileVersion)"

	# this is used in making the writeScores cookie
	set score(startTime) [getclock]

	# Make the widget
	set score(id) [$score(tableW) create text $x $y \
		-anchor nw \
		-font $table(font) -text "" \
		-fill $table(fg) ]
	tableRegisterDumbItem $score(id)
}

proc traceScoreMethodVariable {var} {
	global score
	upvar 2 $var method
	set score(method) $method
	# Arrange to track that variable
	trace variable method w trackScoreMethod
}

proc trackScoreMethod {name element op} {
	global score
	if { $element != ""} {
		set name ${name}($element)
	}
	upvar $name method
	# puts "Method $name set to $method"
	set score(method) $method
}

proc mkNewScore {} {
	global score

	set score(score,$score(method)) 0
	refreshScoreDisplay
}


proc reportError {where error} {
	global score table errorInfo errorCode

	set padValue $table(padValue)

	# Uncomment to enable standard Tk error handling mechanism.
	# return -code error -errorinfo $errorInfo -errorcode $errorCode $error

	set w ".error"
	catch {unmenuHelp $w}

	toplevel $w -relief raised -bd 3
	wmConfig $w "$score(Game)--error"
	wm transient $w .
	grab set $w
	setMenuHelpKeyboardBindings $w $w

	frame $w.top

	label $w.top.icon -bitmap error
	pack $w.top.icon -padx $padValue -side left
	message $w.top.msg -text $error -width 4i
	pack $w.top.msg -padx $padValue -side right
	button $w.ok -text OK -padx [expr 2*$padValue] -command "unmenuHelp $w"
	pack $w.top $w.ok -side top -padx $padValue -pady $padValue
}


proc scoreFileName {} {
	global score
	return "$score(scorefile).$score(game).$score(method)"
}

proc readScores {method} {
	global table errorCode score

	if { $score(writeScores) == 0 } {
		# not allowed disk access.
		if { [info exists score(list,$method)] == 0} {
			set score(list,$method) ""
		}
		return
	}

	set catchval [catch {
			set score(list,$method) ""
			set f [open [scoreFileName] r]
			while {[gets $f line] >= 0} {
				lappend score(list,$method) $line
			}
			close $f
			if { [llength $score(list,$method)] > 0 } {
				if {[lindex $score(list,$method) 0] !=
						$score(scoreFileHeader) } {
					set score(list,$method) ""
					error "Old version of score file.\nHigh scores reset."
				}
				set score(list,$method) [lrange $score(list,$method) 1 end]
			}
		} error]
	if { $catchval == 0 } {
		return
	}
	switch -exact [lindex $errorCode 1] {
		ENOENT {}
		default { reportError "readScores" $error }
	}
}



proc writeScores {method} {
	global table errorCode score

	if { $score(writeScores) == 0 } {
		return
	}

	#
	# The score file is updated optimistically.
	#
	# To write scores atomically without locking
	# we write the file to a tmp file and then use rename
	# to commit our changes.
	#
	# At worst, our change is lost because of concurrent
	# update.  The score file cannot be corrupted, though.
	#
	# NEEDSWORK: We should then check to make sure our
	# update made it and re-try if it didn't.
	#

	# Generate a (almost) guaranteed unique cookie to identify us.
	set cookie "$score(startTime).[random 10000]"

	set newPath [scoreFileName]
	set oldPath "$newPath.$cookie"
	set catchval [catch {
			set f [open $oldPath w]
			puts $f $score(scoreFileHeader)
			foreach i $score(list,$method) {
				puts $f $i
			}
			close $f
			# commit
			frename $oldPath $newPath
		} error]
	if { $catchval != 0 } {
		# Try to clean up.
		catch {unlink $oldPath}
		reportError "writeScores" $error
	}
}


proc determineUser {} {
	global score game
	# cache the result
	if { [info exists score(user)] } {
		return $score(user)
	}
	# first try the environment
	# $USER is a bsd-ism
	if { [info exists env(USER)] } {
		return [set score(user) $env(USER)]
	}
	# $LOGNAME is the svr4-ism
	if { [info exists env(LOGNAME)] } {
		return [set score(user) $env(LOGNAME)]
	}
	# If these fail, try whoami.
	# Bug workaround:  under Linux ``who'' is often set to:
	#	johnh
	#	error waiting for process to exit: No child processes
	# (We get the correct results, plus an error message attached.)
	# Work around the problem by taking only the first line here.
	if { [catch {exec "whoami"} who] == 0 } {
		return [set score(user) [lindex $who 0]]
	}
	# Give up.  Let the user know and disable writing scores.
	reportError "determineUser" {Could not determine user name.  \
Set the environment variable USER or LOGNAME to your user name \
and re-run $game(package).  \
Score saving is disabled.}
	set score(writeScores) 0
	return [set score(user) "nobody"]
}


proc computeNewScoreListEntry {method} {
	global table score env game

	#
	# Get information for the score
	#
	set scoreValue $score(score,$method)
	set fancyScore [format $score(scoreFormat,$method) $score(score,$method)]
	# Add to scores to avoid sorting both negative and positive numbers.
	set scoreValue [expr $scoreValue + 10000]
	if { $scoreValue < 0 } { set scoreValue 0 }
	set scoreClock $game(endTime)
	set scoreDate [fmtclock $scoreClock "%e-%b-%Y"]
	set scoreName [determineUser]
	set scoreSeed $game(randomSeed)
	# Always ASCII sort by score key.
	# Switch the sign by subtracting from 2^30.
	set scoreKey [format "%08d:%08d" $scoreValue [expr 1073741824-$scoreClock]]

	set newListEntry [list $scoreKey \
			 $fancyScore $scoreDate $scoreName $scoreClock $scoreSeed]

	return [list $newListEntry $scoreClock]
}


proc updateScoreList {newListEntry method} {
	global score table

	readScores $method
	set oldScoreList $score(list,$method)

	#
	# Add score to score-list.
	# Scorelist format:
	# SortKey(score,clock) value date name clock
	#
	set score(list,$method) [lsort -decreasing [linsert $score(list,$method) 0 $newListEntry]]
	if { [llength $score(list,$method)] > 100 } {
		set score(list,$method) [lrange $score(list,$method) 0 99]
	}

	#
	# Limit any given user to ten scores on the list.
	#
	set badScores {}
	foreach i $score(list,$method) {
		set user [lindex $i 3]
		if { [info exists userCount($user)] == 0 } {
			set userCount($user) 1
		} else {
			incr userCount($user)
		}
		if { $userCount($user) > 10 } {
			lappend badScores $i
		}
	}
	# remove extra scores
	foreach i $badScores {
		set index [lsearch -exact $score(list,$method) $i]
		set score(list,$method) \
			[lreplace $score(list,$method) $index $index]
	}

	if { $score(list,$method) != $oldScoreList } {
		writeScores $method
	}
}


proc computeNewScoreText {method} {
	global score

	if { [info exists score(lastScoreToken)] } {
		set ourScoreToken $score(lastScoreToken)
	} else {
		set ourScoreToken "xxx"
	}
	set score(ourScorePresent) 0
	#
	# Regenerate score-text from score-list.
	#
	set fancyMethod "[string toupper [string index $method 0]][string range $method 1 end]"
	set score(text,$method) "<big>${fancyMethod} Scores</big>\n\n<computer>"
	set j 0
	foreach i $score(list,$method) {
		incr j
		set thisClock [lrange $i 4 4]
		set thisText ""
		if { $thisClock == $ourScoreToken } {
			set style "reverse"
			set score(ourScorePresent) 1
		} else {
			set style ""
		}
		if { $style != "" } {
			set thisText "${thisText}<${style}>"
		}
		set thisText "${thisText}[format "%3d" $j].   [format "%4s" [lindex $i 1]]   [lindex $i 2]   [format "%-10s" [lindex $i 3]] ([lindex $i 5])"
		if { $style != "" } {
			set thisText "${thisText}</${style}>"
		}
		set score(text,$method) "$score(text,$method)$thisText\n"
	}
	set score(text,$method) "$score(text,$method)</computer>"

	if { [llength $score(list,$method)] == 0 } {
		set score(text,$method) "$score(text,$method)No current scores."
	}

	if { $score(writeScores) == 0 } {
		set score(text,$method) "$score(text,$method)\n<italic>Permanent storage of score file not enabled.</italic>"
	}
}


# external
proc registerNewScore {} {
	global score

	set method $score(method)

	#
	# Figure the new data.
	#
	set foo [computeNewScoreListEntry $method]
	set newScoreListEntry [lindex $foo 0]
	set score(lastScoreToken) [lindex $foo 1]

	#
	# Add it to old scores.
	#
	updateScoreList $newScoreListEntry $method

	#
	# Refigure score text.
	# 
	computeNewScoreText $method

	#
	# Tell the jubliant user.
	#
	if { $score(showScoresWhen) == "always" ||
		($score(showScoresWhen) == "high" && $score(ourScorePresent)) } {
		displayHighScores
		menuHelpScrollToTag $method reverse 
	}
}


# external
proc displayHighScores {} {
	global score help

	set method $score(method)
#	debugLog "displayHighScores ($method)"

	readScores $method
	computeNewScoreText $method
	
	#
	# re-use the help system code
	#

	# generate "help" text
	set help($method) $score(text,$method)
	menuHelp $method "${method} scores"
}


# external
proc incrScore {delta} {
	global score
	incr score(score,$score(method)) $delta
	refreshScoreDisplay

	#
	# Time out the game after a while.
	#
	if { $score(score,$score(method)) < -800 } {
		endGame "quit"
	}
}

# external
proc setScoreMessage {message} {
	global score
	set score(message) $message
	refreshScoreDisplay
}

# external
proc getScore {} {
	global score
	return $score(score,$score(method))
}



#
# Call updateScore after score changes to update the display.
#
proc refreshScoreDisplay {} {
	global score
       
	set method $score(method)
	set s [format $score(scoreFormat,$method) $score(score,$method)]
	$score(tableW) itemconfig $score(id) -text "$s\n$score(message)"
}


#
# Random number seed routines
#

proc mkRandomSeed {} {
	# First try and get a good random seed from the dictionary.
	if {[catch {mkRandomSeedWord} seed] != 0} {
		# If it fails, just generate a number.
		set seed [expr [pid]+[getclock]]
	}
	return $seed
}

proc mkRandomSeedWord {} {
	global score
	# first get the length
	file stat $score(dictionary) stats
	if { $stats(size) < 2048 } {
		error "dictionary too small"
	}
	# pick a random spot
	random seed [expr [pid]+[getclock]]
	set place [random [expr $stats(size)-1024]]
	set nth [expr [random 12]+1]
	# open the file
	# seek to $place and read the $nth word following that place.
	set f [open $score(dictionary) r]
	seek $f $place start
	while { $nth >= 0 } {
		if {[gets $f line] < 0} {
			close $f
			error "end of file reached"
		}
		incr nth -1
	}
	close $f
	return $line
}


proc setRandomSeed {seed} {
	if { [regexp -- {^[0-9]+$} $seed] } {
		# simple numbers are the seed themselves
	} else {
		# otherwise turn the string into a seed
		set seedString $seed
		set seed 0
		while {"$seedString" != ""} {
			regexp {^(.)} $seedString ch
			regsub {^(.)} $seedString {} seedString
			scan $ch "%c" chval
			set seed [expr ($seed<<3)^$chval]
			if {$seed < 0} {
				set seed [expr -$seed]
			}
		}
	}
        random seed $seed
	# Throw away some random numbers.
	random 1000; random 1000; random 1000; random 1000; random 1000
}
