proc string_equal {args} {eval return \[expr \[string compare $args\] == 0\]}
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
}
proc swap {a b} {
	set t [uplevel set [list $a]]
	uplevel set [list $a] \$[list $b]
	uplevel set [list $b] [list $t]
}
proc lcontains {a b} {
	if {[lsearch -exact $a $b] != -1} {return 1}
	return 0
}
proc lsubset {a b} {
	foreach elem $a {if ![lcontains $b $elem] {return 0}}
	return 1
}
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
}
proc lunion {a b} {
	return [concat $a [ldifference $b $a]]
}
proc lintersect {a b} {
	if {!([llength $a] && [llength $b])} {return ""}

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

	return $result
}
proc arg_pop {out in} {
	if [expr [uplevel llength \$[list $in]] - [llength $out] < 0] {
		return 0
	}
	set idx 0
	foreach var $out {
		uplevel set [list $var] \[lindex \$[list $in] $idx\]
		incr idx
	}
	uplevel set [list $in] \[lrange \$[list $in] [llength $out] end\]
	return 1
}
proc min {args} {
	set retval [lindex $args 0]
	foreach arg [lrange $args 1 end] {if {$arg < $retval} {set retval $arg}}
	return $retval
}
proc max {args} {
	set retval [lindex $args 0]
	foreach arg [lrange $args 1 end] {if {$arg > $retval} {set retval $arg}}
	return $retval
}
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]
}
namespace eval balloon {
proc create {x y cnv tag args} {
	set right [expr [winfo width $cnv] - 1]
	set bottom [expr [winfo height $cnv] - 1]
	set callout_side "left"
	set calc_side 1
	set margin 10
	set clip 1
	set balloon_w 25
	set balloon_h 25
	set msg ""
	set balloon_font ""
	set text_width 240
	set icon ""
	set fill "white"
	set outline "black"
	set foreground "black"
	set shadow "black"
	set opacity 0.35
	while 1 {
		if ![arg_pop arg args] break
		switch -- $arg {
		"-side" {arg_pop callout_side args}
		"-calc-side" {arg_pop calc_side args}
		"-margin" {arg_pop margin args}
		"-clip" {arg_pop clip args}
		"-min-width" {arg_pop balloon_w args}
		"-min-height" {arg_pop balloon_h args}
		"-text" {arg_pop msg args}
		"-font" {arg_pop fnt args; set balloon_font "-font \{$fnt\}"}
		"-text-width" {arg_pop text_width args}
		"-icon" {arg_pop icon args}
		"-fill" {arg_pop fill args}
		"-outline" {arg_pop outline args}
		"-foreground" {arg_pop foreground args}
		"-shadow" {arg_pop shadow args}
		"-opacity" {arg_pop opacity args}
		}
	}
	if [string length $msg] {
		set common "$cnv create text -1000 -1000 -text [list $msg]\
				$balloon_font -width $text_width -tags \[list\
				$tag \$which\]"
		set which "$tag-t4"; eval $common -fill $foreground
		if {$opacity > 0.0} {
			set fg [winfo rgb $cnv $shadow]
			set bg [winfo rgb $cnv $fill]
			set color [interp_color $bg $fg [expr $opacity / 2]]
			set which "$tag-t1"; eval $common -fill $color
			set which "$tag-t2"; eval $common -fill $color
			set color [interp_color $bg $fg $opacity]
			set which "$tag-t3"; eval $common -fill $color
		}
		set box [$cnv bbox "$tag-t4"]
		set text_w [expr [lindex $box 2] - [lindex $box 0]]
		set text_h [expr [lindex $box 3] - [lindex $box 1]]
		set balloon_w [max $balloon_w [expr $text_w + 15]]
		set balloon_h [max $balloon_h [expr $text_h + 15]]
	} else {
		set text_w 0
		set text_h 0
	}
	if [string length $icon] {
		$cnv create image -1000 -1000 -image $icon -tag "$tag $tag-i"
		set box [$cnv bbox "$tag-i"]
		set icon_w [expr [lindex $box 2] - [lindex $box 0]]
		set icon_h [expr [lindex $box 3] - [lindex $box 1]]
		if [string length $msg] {
			incr balloon_w [expr $icon_w + 4]
		} else {
			set balloon_w [max $balloon_w [expr $icon_w + 7]]
		}
		set balloon_h [max $balloon_h [expr $icon_h + 7]]
	} else {
		set icon_w 0
		set icon_h 0
	}
	if $clip {
		if {$x < $margin} {
			set x $margin
		} elseif [expr $x > $right - $margin] {
			set x [expr $right - $margin]
		}
		if {$y < $margin} {
			set y $margin
		} elseif [expr $y > $bottom - $margin] {
			set y [expr $bottom - $margin]
		}
	}
	if $calc_side {
		if [expr $y < $margin + 12] {
			if [expr $x < $margin + 12 || $x > $right - $margin -\
					12] {
				set callout_side "hide"
			} else {
				set callout_side "top"
			}
		} elseif [expr $y > $bottom - $margin - 12] {
			if [expr $x < $margin + 12 || $x > $right - $margin -\
					12] {
				set callout_side "hide"
			} else {
				set callout_side "bottom"
			}
		} elseif [expr $x - $balloon_w < $margin + 12] {
			set callout_side "left"
		} elseif [expr $x + $balloon_w > $right - $margin - 12] {
			set callout_side "right"
		}
		if [expr ([string_equal $callout_side "left"] && $x +\
				$balloon_w > $right - $margin - 12) ||\
				([string_equal $callout_side "right"] &&\
				$x - $balloon_w < $margin + 12)] {
			if [expr $x - $balloon_w < $margin + 12 ||\
					$x + $ballon_w > $margin - 12] {
				set callout_side "hide"
			} elseif [expr $y - $balloon_h < $margin + 12] {
				set callout_side "top"
			} else {
				set callout_side "bottom"
			}
		}
	}
	switch -- $callout_side {
	"left" - "right" - "hide" {
		if [expr $y + $balloon_h / 2 > $bottom - $margin && $clip] {
			set t [expr $bottom - $margin - $balloon_h]
			set b [expr $bottom - $margin]
		} elseif [expr $y - $balloon_h / 2 < $margin && $clip] {
			set t $margin
			set b [expr $balloon_h + $margin]
		} else {
			set t [expr $y - $balloon_h / 2]
			set b [expr $y + $balloon_h / 2]
		}
	}}
	switch -- $callout_side {
	"top" - "bottom" - "hide" {
		if [expr $x + $balloon_w / 2 > $right - $margin && $clip] {
			set l [expr $right - $margin - $balloon_w]
			set r [expr $right - $margin]
		} elseif [expr $x - $balloon_w / 2 < $margin && $clip] {
			set l $margin
			set r [expr $balloon_w + $margin]
		} else {
			 set l [expr $x - $balloon_w / 2]
			 set r [expr $x + $balloon_w / 2]
		}
	}}
	switch -- $callout_side {
	"left" {set l [expr $x + 10]; set r [expr $l + $balloon_w]}
	"top" {set t [expr $y + 10]; set b [expr $t + $balloon_h]}
	"right" {set r [expr $x - 10]; set l [expr $r - $balloon_w]}
	"bottom" {set b [expr $y - 10]; set t [expr $b - $balloon_h]}
	}
	$cnv create arc $l $t [expr $l + 14] [expr $t + 14] -start 90\
			-extent 90 -outline $fill -fill $fill -tag $tag
	$cnv create arc $l $t [expr $l + 14] [expr $t + 14] -start 90\
			-extent 90 -outline $outline -style arc -tag $tag
	$cnv create arc $r $t [expr $r - 14] [expr $t + 14] -start 0\
			-extent 90 -outline $fill -fill $fill -tag $tag
	$cnv create arc $r $t [expr $r - 14] [expr $t + 14] -start 0\
			-extent 90 -outline $outline -style arc -tag $tag
	$cnv create arc $l $b [expr $l + 14] [expr $b - 14] -start 180\
			-extent 90 -outline $fill -fill $fill -tag $tag
	$cnv create arc $l $b [expr $l + 14] [expr $b - 14] -start 180\
			-extent 90 -outline $outline -style arc -tag $tag
	$cnv create arc $r $b [expr $r - 14] [expr $b - 14] -start 270\
			-extent 90 -outline $fill -fill $fill -tag $tag
	$cnv create arc $r $b [expr $r - 14] [expr $b - 14] -start 270\
			-extent 90 -outline $outline -style arc -tag $tag
	$cnv create rectangle [expr $l + 7] $t [expr $r - 7] $b\
			-outline $fill -fill $fill -tag $tag
	$cnv create rectangle $l [expr $t + 7] $r [expr $b - 7]\
			-outline $fill -fill $fill -tag $tag
	$cnv create line $l [expr $t + 7] $l [expr $b - 6] -fill $outline\
			-tag $tag
	$cnv create line [expr $l + 7] $t [expr $r - 6] $t -fill $outline\
			-tag $tag
	$cnv create line $r [expr $t + 7] $r [expr $b - 6] -fill $outline\
			-tag $tag
	$cnv create line [expr $l + 7] $b [expr $r - 6] $b -fill $outline\
			-tag $tag
	switch -- $callout_side {
	"left" {
		$cnv create polygon $l [expr $y - 5] $l [expr $y + 5] $x $y\
				-fill $fill -outline $outline -tag $tag
		$cnv create line $l [expr $y - 5] $l [expr $y + 5] -fill $fill\
				-tag $tag
	} "top" {
		$cnv create polygon [expr $x - 5] $t [expr $x + 5] $t $x $y\
			-fill $fill -outline $outline -tag $tag
		$cnv create line [expr $x - 5] $t [expr $x + 5] $t -fill $fill\
			-tag $tag
	} "right" {
		$cnv create polygon $r [expr $y - 5] $r [expr $y + 5] $x $y\
				-fill $fill -outline $outline -tag $tag
		$cnv create line $r [expr $y - 5] $r [expr $y + 5] -fill $fill\
				-tag $tag
	} "bottom" {
		$cnv create polygon [expr $x - 5] $b [expr $x + 5] $b $x $y\
			-fill $fill -outline $outline -tag $tag
		$cnv create line [expr $x - 5] $b [expr $x + 5] $b -fill $fill\
			-tag $tag

	}}
	set text_x [expr ($l + $r) / 2]
	set text_y [expr ($t + $b) / 2 + 1]
	if [string length $icon] {
		if [string_equal $callout_side "right"] {
			incr text_x [expr -$icon_w / 2]
			set icon_x [expr $r - 4]
			set anchor "e"
		} else {
			incr text_x [expr $icon_w / 2]
			set icon_x [expr $l + 4]
			set anchor "w"
		}
		$cnv itemconfigure "$tag-i" -anchor $anchor
		$cnv coords "$tag-i" $icon_x $text_y
		$cnv raise "$tag-i"
	}
	if [string length $msg] {
		if {$opacity > 0.0} {
			$cnv coords "$tag-t1" [expr $text_x + 1] $text_y
			$cnv coords "$tag-t2" $text_x [expr $text_y + 1]
			$cnv coords "$tag-t3" [expr $text_x + 1]\
					[expr $text_y + 1]
			for {set i 1} {$i < 4} {incr i} {$cnv raise "$tag-t$i"}
		}
		$cnv coords "$tag-t4" $text_x $text_y
		$cnv raise "$tag-t4"
	}
}
}