# Miscellaneous Functions
# 
# This file contains a few miscellaneous functions used by OpenVerse.  They're
# generic enough to work with other Tcl programs, however.
#
# TODO: determine whether Cruise holds copyright
# Copyright (C) 1999-2002 David Gale <cruise@openverse.com>
# For more information visit http://www.openverse.com/
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307,
# USA.

# --- LIST PROCS --------------------------------------------------------------

# Return true if 'b' is an element of 'a'
proc lcontains {a b} {return [expr [lsearch -exact $a $b] != -1]}

# Return true if 'a' is a subset of 'b'
proc lsubset {a b} {
	foreach elem $a {if ![lcontains $b $elem] {return 0}}
	return 1
}

# Return 'a' minus every element from 'b'
proc ldifference {a b} {
	if ![llength $a] {return ""}
	if ![llength $b] {return $a}

	set result ""
	foreach elem $a {if ![lcontains $b $elem] {lappend result $elem}}

	return $result
}

# Return all lists merged, sans duplicate elements
proc lunion {args} {
	if ![arg_pop a args] {return {}}
	while 1 {
		if ![arg_pop b args] break
		set a [concat $a [ldifference $b $a]]
	}
	return $a
}

# Return a list containing every element common to 'a' and 'b'
proc lintersect {a b} {
	if {!([llength $a] && [llength $b])} {return ""}

	set result ""
	foreach elem $a {if [lcontains $b $elem] {lappend result $elem}}

	return $result
}

# --- MISC PROCS --------------------------------------------------------------

# Useful tool for processing variadic arguments; return true on success
# in: list of variables to put data into
# out: name of list to grab data from
proc arg_pop {out in} {
	# Make sure argz is big enough
	if [expr [uplevel llength \$[list $in]] - [llength $out] < 0] {
		return 0
	}

	# Iterate through arg
	set idx 0
	foreach var $out {
		uplevel set [list $var] \[lindex \$[list $in] $idx\]
		incr idx
	}

	# Pop off used elements
	uplevel set [list $in] \[lrange \$[list $in] [llength $out] end\]
	return 1
}

# Swap variables named $a and $b
proc swap {a b} {
	set t [uplevel set [list $a]]
	uplevel set [list $a] \$[list $b]
	uplevel set [list $b] [list $t]
}

# Return the minimal argument
proc min {args} {
	set retval [lindex $args 0]
	foreach arg [lrange $args 1 end] {if {$arg < $retval} {set retval $arg}}
	return $retval
}

# Return the maximal argument
proc max {args} {
	set retval [lindex $args 0]
	foreach arg [lrange $args 1 end] {if {$arg > $retval} {set retval $arg}}
	return $retval
}

# Interpolate from a to b; f scales from 0.0 to 1.0; colors scale from 0 to 64k
proc interp_color {a b f} {
	set r [expr int([lindex $a 0] * (1.0 - $f) + [lindex $b 0] * $f)]
	set g [expr int([lindex $a 1] * (1.0 - $f) + [lindex $b 1] * $f)]
	set b [expr int([lindex $a 2] * (1.0 - $f) + [lindex $b 2] * $f)]
	return [format "#%04x%04x%04x" $r $g $b]
}

# Escape all characters special to Tcl
proc tcl_escape {a args} {
	set map {[ \\[ ] \\] \{ \\\{ \} \" \\\" \\\} $ \$ \\ \\\\ \! \\\!}
	if {[lindex $args 0] != "-no-space"} {append map { \  \\\ }}
	return [string_map $map $a]
}

# Return a unique value
variable next_id 0
proc unique_id {} {
	variable next_id
	set retval $next_id
	incr next_id
	return $retval
}

# --- TCL 8.0 COMPATIBILITY PROCS ---------------------------------------------

# Duplicate "string equal"
if ![catch {string equal "test" "test"}] {
proc string_equal {args} {return [eval string equal $args]}
} elseif ![catch {string compare -length 1 "test" "test"}] {
proc string_equal {args} {eval return \[expr \[string compare $args\] == 0\]}
} else {
proc string_equal {args} {
	set s1 [lindex $args [expr [llength $args] - 2]]
	set s2 [lindex $args [expr [llength $args] - 1]]
	set args [lrange $args 0 [expr [llength $args] - 3]]
	set nocase 0
	set length -1
	while 1 {
		if ![arg_pop arg args] break
		switch -- $arg {
		"-nocase" {set nocase 1}
		"-length" {
			arg_pop length args
			if ![string_is integer $length] {
				error "expected integer but got \"$length\""
			}
		} default {
			error "bad option \"$arg\": must be -nocase or\
				-length"
		}}
	}

	if $nocase {
		set s1 [string tolower $s1]
		set s2 [string tolower $s2]
	}

	if {$length >= 0} {
		set s1 [string range $s1 0 [expr $length - 1]]
		set s2 [string range $s2 0 [expr $length - 1]]
	}

	return [expr [string compare $s1 $s2] == 0]
}
}

# Duplicate "string map"
if ![catch {string map {} "test"}] {
proc string_map {args} {return [eval string map $args]}
} else {
proc string_map {args} {
	set nocase ""
	if {[llength $args] < 2 || [llength $args] > 3} {
		error "wrong # args: should be \"string_map ?-nocase? charMap\
				string\""
	} elseif {[llength $args] == 3} {
		if {[lindex $args 0] == "-nocase"} {
			set nocase "-nocase"
			set map [lindex $args 1]
			set str [lindex $args 2]
		} else {
			error "bad option \"[lindex $args 0]\": must be -nocase"
		}
	} else {
		set map [lindex $args 0]
		set str [lindex $args 1]
	}
	if [expr [llength $map] % 2 == 1] {error "char map list unbalanced"}

	set compare "string_equal $nocase \[string range \$str \$idx \[expr\
			\$idx + \[string length \$from\] - 1\]\] \$from"
	for {set idx 0} {$idx < [string length $str]} {incr idx} {
		foreach {from to} $map {
			if [eval $compare] {
				set str [string_replace $str $idx [expr $idx +\
					[string length $from] - 1] $to]
				incr idx [expr [string length $to] - 1]
				break
			}
		}
	}

	return $str
}
}

# Duplicate "string replace"
if ![catch {string replace "test" 0 0}] {
proc string_replace {args} {return [eval string replace $args]}
} else {
proc string_replace {s a b args} {
	incr a -1; incr b 1
	switch -- [llength $args] {
	0 {return "[string range $s 0 $a][string range $s $b end]"}
	1 {return "[string range $s 0 $a][lindex $args 0][string range $s $b\
			end]"}
	default {
		error "wrong # args: should be \"string_replace string first\
				last ?string?\""
	}}
}
}

# Duplicate "string totitle"
if ![catch {string totitle "test"}] {
proc string_totitle {args} {return [eval string totitle $args]}
} else {
proc string_totitle {s args} {
	switch -- [llength $args] {
	0 {set a 0; set b "end"}
	1 {set a [lindex $args 0]; set b "end"}
	2 {set a [lindex $args 0]; set b [lindex $args 1]}
	default {
		error "wrong # args: should be \"string_totitle string ?first?\
				?last?\""
	}}
	foreach var {"a" "b"} {
		if {[set $var] == "end"} {
			set $var [expr [string length $s] - 1]
		} elseif [string_equal -length 4 [set $var] "end-"] {
			set o [string range [set $var] 4 end]
			if ![string_is integer -strict $o] {
				error "bad index \"[set $var]\": must be\
						integer or end?-integer?"
			}
			set $var [expr [string length $s] - 1 - $o]
		} elseif ![string_is integer [set $var]] {
			error "bad index \"[set $var]\": must be integer or\
					end?-integer?"
		}
	}
	puts "$a $b"
	return "[string range $s 0 [expr $a - 1]][string toupper [string range\
			$s $a $a]][string tolower [string range $s [expr $a +\
			1] $b]][string range $s [expr $b + 1] end]"
}
}

# Duplicate "string first ... ?startindex?"
if ![catch {string first "t" "test" 1}] {
proc string_first {args} {return [eval string first $args]}
} else {
proc string_first {s1 s2 args} {
	switch -- [llength $args] {
	0 {return [eval string first $s1 $s2 $args]}
	1 {
		set idx [lindex $args 0]
		if {$idx == "end"} {
			set idx [expr [string length $s2] - 1]
		} elseif [string_equal -length 4 $idx "end-"] {
			set o [string range $idx 4 end]
			if ![string_is integer -strict $o] {
				error "bad index \"$idx\": must be integer or\
						end?-integer?"
			}
			set idx [expr [string length $s2] - 1 - $o]
		} elseif ![string_is integer $idx] {
			error "bad index \"$idx\": must be integer or\
					end?-integer?"
		}
		set match [string first $s1 [string range $s2 $idx end]]
		if {$match == -1} {
			return -1
		} else {
			return [expr $match + $idx]
		}
	} default {
		error "wrong # args: should be \"string_first string1 string2\
				?startIndex?\""
	}}
}
}

# Duplicate "string match -nocase ..."
if ![catch {string match -nocase "t*" "test"}] {
proc string_match {args} {return [eval string match $args]}
} else {
proc string_match {args} {
	switch -- [llength $args] {
	2 {return [eval string match $args]}
	3 {
		set pat [lindex $args 1]
		set str [lindex $args 2]
		switch -- [lindex $args 0] {
		"-nocase" {
			set pat [string tolower $pat]
			set str [string tolower $str]
		} default {
			error "bad option \"[lindex $args 0]\": must be -nocase"
		}}
		return [eval string match $pat $str]
	} default {
		error "wrong # args: should be \"string_match ?-nocase?\
				pattern string"
	}}
}
}

# Duplicate "string is"
if ![catch {string is lower "TEST"}] {
proc string_is {args} {return [eval string is $args]}
} else {
# Note: this is not complete
proc string_is {class args} {
	set s [lindex $args [expr [llength $args] - 1]]
	set args [lrange $args 0 [expr [llength $args] - 2]]

	set strict 0
	while 1 {
		if ![arg_pop arg args] break
		switch -- $arg {
		"-strict" {set strict 1}
		"-failindex" {error "-failindex not implemented"}
		default {
			error "bad option \"$arg\": must be -strict or\
					-failindex"
		}}
	}
	if {$s == ""} {return !$strict}
	
	switch -- $class {
	"alnum" {
		return [expr [string_is alpha $s] || [string_is digit $s]]
	} "alpha" {
		return [string_is lower [string tolower $s]]
	} "ascii" {
		for {set i 0} {$i < [string length $s]} {incr i} {
			binary scan [string range $s $i $i] "c1" val
			if {$val < 0} {return 0}
		}
	} "boolean" {
		return [expr [string_is true $s] || [string_is false $s]]
	} "digit" {
		return [expr ![string length [string trim $s "0123456789"]]]
	} "double" {
		if [string length [string trim $s "-0123456789eE."]] {return 0}
		if [set idx [string first "eE" $s]] {
			if [string_first "eE" $s $idx] {return 0}
		}
		if [set idx [string first "." $s]] {
			if [string_first "." $s $idx] {return 0}
		}
	} "false" {
		return [lcontains {0 "f" "fa" "fal" "fals" "false" "n" "no" "of"
				"off"} [string tolower $s]]
	} "integer" {
		return [expr ![string length [string trim $s " -0123456789"]]]
	} "lower" {
		return [expr ![string length [string trim $s\
				"abcdefghijklmnopqrstuvwxyz"]]]
	} "space" {
		return [expr ![string length [string trim $s " \x09\x0a"]]]
	} "true" {
		return [lcontains {1 "t" "tr" "tru" "true" "y" "ye" "yes" "on"}\
				[string tolower $s]]
	} "upper" {
		return [expr ![string length [string trim $s\
				"ABCDEFGHIJKLMNOPQRSTUVWXYZ"]]]
	} "xdigit" {
		return [expr ![string length [string trim [string tolower $s]\
				"-0123456789abcdef"]]]
	} "control" - "graph" - "print" - "punct" - "wordchar" {
		error "class \"$class\" not implemented"
	} default {
		error "bad class \"$class\": must be alnum, alpha, ascii,\
		control, boolean, digit, double, false, graph, integer, lower,\
		print, punct, space, true, upper, wordchar, or xdigit"
	}}
}
}

# Duplicate "string repeat"
if ![catch {string repeat "test" 5}] {
proc string_repeat {args} {return [eval string repeat $args]}
} else {
proc string_repeat {str count} {
	if {$count <= 0} {return ""}
	set retval $str
	for {} {$count > 1} {incr count -1} {append retval $str}
	return $retval
}
}

# Duplicate "array unset"
set test(x) "moo"
if ![catch {array unset test x}] {
proc array_unset {args} {return [eval array unset $args]}
} else {
proc array_unset {ar args} {
	if ![uplevel info exists [list $ar]] return
	switch -- [llength $args] {
	0 {uplevel unset [list $ar]}
	1 {
		foreach name [uplevel array names [list $ar] [lindex $args 0]] {
			uplevel unset [list ${ar}($name)]
		}
	} default {
		error "wrong # args: should be \"array unset arrayName\
				?pattern?\""
	}}
}
}