# Miscellaneous Functions
# 
# This file contains a few miscellaneous functions used by OpenVerse.  They're
# generic enough to work with other Tcl programs, however.
#
# Module Name		- Main Module
# Sourced By		- Main Module
#
# 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 --------------------------------------------------------------
# Returns true if 'b' is an element of 'a'
proc lcontains {a b} {
	if {[lsearch -exact $a $b] != -1} {return 1}
	return 0
}

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

# Returns '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
}

# Returns 'a' merged with 'b', and remove duplicate elements
proc lunion {a b} {
	return [concat $a [ldifference $b $a]]
}

# Returns 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 --------------------------------------------------------------
# Pass this proc two variable *names*.  The second should be that of a list.
# This proc removes the leftmost element in the list and stores it in the
# variable named by the first argument.  It returns 1 if successful and 0 if
# the list is empty.  It's useful for processing varidic arguments, one at a
# time.
proc arg_pop {arg argz} {
        set len [uplevel llength \"\$$argz\"]
        if !$len {return 0}
        uplevel set \"$arg\" \[lindex \$$argz 0\]
        uplevel set \"$argz\" \[lrange \$$argz 1 [expr $len - 1]\]
        return 1
}

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

# --- TCL 8.0 COMPATIBILITY PROCS ---------------------------------------------
# Duplicate the functionality of "string equal"
proc string_equal {args} {eval return \[expr \[string compare $args\] == 0\]}

# Duplicate "string map"
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 "expr \[string compare $nocase \[string range \$str \$idx\
			\[expr \$idx + \[string length \$from\] - 1\]\] \
			\$from\] == 0"
	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
}