
# Named point stuff.

# named_point(names)
# named_point($name,active)
# named_point($name,selected)
# named_point($name,object)
# named_point($name,x)
# named_point($name,y)
# named_point($name,z)
# named_point($name,x_units)
# named_point($name,y_units)
# named_point($name,z_units)
# named_point($name,temperature)
# named_point($name,pressure)
# named_point($name,velocity)
# named_point($name,nodes)
# named_point_image($name,text)
# named_point_image($name,point)

proc named_point_update_version {} {
    global named_point
    
    set un [unit_get_default_choice length]
    
    if ![info exists named_point(names)] {
	array set onp [array get named_point]
	catch {unset named_point}
	set named_point(names) ""
	foreach p [array names onp] {
	    puts "p = $p"
	    if {[lindex $onp($p) 0] == "xyz"} {
		foreach i {1 2 3} v {x y z} {
		    set named_point($p,$v) [lindex [lindex $onp($p) $i] 0]
		    set named_point($p,${v}_units) [lindex [lindex $onp($p) $i] 1]
		}
		set named_point($p,active) [lindex $onp($p) 4]
		set named_point($p,object) ""
		set mon [lrange $onp($p) 5 end]
		
	    } elseif {[llength [lindex $onp($p) 0]] == 2} {
		# This is an old-style named point, e.g.
		# {.908 in} {.693 in} {2.285 in} 1
		foreach i {0 1 2} v {x y z} {
		    set named_point($p,$v) [lindex [lindex $onp($p) $i] 0]
		    set named_point($p,${v}_units) [lindex [lindex $onp($p) $i] 1]
		}
		set named_point($p,active) [lindex $onp($p) 3]
		set named_point($p,object) ""
		set mon ""
		
	    } else {
		set named_point($p,object) $p
		foreach v {x y z} { set named_point($p,${v}_units) $un }
		named_point_update_xyz $p
		set named_point($p,active) 1
		set mon $onp($p)
	    }
	    set named_point($p,nodes) ""
	    set named_point($p,selected) 0
	    foreach v {temperature pressure velocity} { set named_point($p,$v) 0 }
	    foreach v $mon {
		switch -glob $v {
		    Temperature - Pressure - Velocity {
			set named_point($p,[string tolower $v]) 1
		    }
		    int* {
			lappend named_point($p,nodes) $v
		    }
		}
	    }
	    lappend named_point(names) $p
	}
    }
}

proc named_point_update_xyz {name} {
    global named_point
    set p $named_point($name,object)
    set obj [db_get_name $p]
    if {$obj == ""} {
	mess "Warning: no object named $p\n" red
	return
    }
    foreach v {x y z} c [centroid_of_objects $obj] {
	if {![info exists named_point($name,$v)] || ($named_point($name,$v) == "")} {
	    set named_point($name,$v) \
		[unit_convert $c $named_point($name,${v}_units) 1]
	}
    }
}

proc named_point_entry {w var geo act {unitsvar none} {white_dot 1}} {
    futil_listentry $w $var "named_point_list_names" $geo $act \
	"named_point_pick_by_name $var \"$unitsvar\"" 1
    bind $w <Enter> "named_point_val_focus $var 1 \"$unitsvar\" $white_dot"
    bind $w <Return> "named_point_val_focus $var 1 \"$unitsvar\" $white_dot"
    bind $w <Leave> "named_point_val_focus $var 0 \"$unitsvar\" $white_dot"
}

proc named_point_val_focus {var in {unitsvar ""} {white_dot 1}} {
    global tdv_default
    global named_point_im named_point
    
    puts "fix named_point_val_focus"
    return
    
    if {$unitsvar == "none"} { set unitsvar "" }
    
    upvar \#0 $var lvar
    set pt $lvar
    
    if {$unitsvar == ""} {
	set units m
    } else {
	upvar \#0 $unitsvar luvar
	set units $luvar
    }
    
    if [info exists named_point_im] {
	foreach im $named_point_im {
	    $im delete
	}
	unset named_point_im
    }
    if $in {
	set txt $pt
	if [info exists named_point($pt)] {
	    set txt $pt
	    set pt [named_point_get $pt]
	    set unitstring ""
	} elseif {[scan $pt "%g %g %g" x y z] == 3} {
	    set unitstring " $units"
	} else {
	    return
	}
	
	catch {
	    if {$unitstring != ""} {
		set upt ""
		foreach u $pt {
		    lappend upt [unit_convert $u $units 0]
		}
	    } else {
		set upt $pt
	    }
	    set named_point_im ""
	    if $white_dot {
		set im1 [tdv_point_im -color white -size 3 -point $upt]
		$tdv_default add_image $im1
		lappend named_point_im $im1
	    }
	    set im2 [tdv_text_im -color white -point $upt -text " $txt$unitstring"]
	    $tdv_default add_image $im2
	    lappend named_point_im $im2
	}
    }
}

proc named_point_listbox {w} {
    global named_point_listbox_selected input_background toplevel_others
    
    set m .named_point_listbox
    set named_point_listbox_selected ""
    update idle
    catch {destroy $m}
    toplevel $m
    wm overrideredirect $m 1
    wm withdraw $m
    set toplevel_others($m) 1
    
    set_cursor $m "left_ptr OrangeRed"
    
    listbox $m.list -relief sunken -borderwidth 2 -yscroll "$m.scroll set" \
	-background $input_background -exportselection 0 \
	-width 12 -height 10
    scrollbar $m.scroll -command "$m.list yview" \
	-background #cdb79e
    button $m.cancel -text Cancel -command \
	"set named_point_listbox_selected \"\""
    pack $m.cancel -side bottom -fill both
    pack $m.list -side left -fill both
    pack $m.scroll -side left -fill both
    
    bind $m.list <ButtonPress-1> "named_point_listbox_select_one $m %y"
    
    named_point_listbox_fill $m
    
    set width 16
    set height 8
    
    $m.list configure -width $width -height $height
    $m.list selection clear 0 end
    $m.list selection set 0
    
    wm geometry $m +5000+5000
    wm deiconify $m
    update idle
    
    set x [winfo rootx $w]
    set y [winfo rooty $w]
    set xoff [expr {[winfo screenwidth $m] - $x - [winfo width $m]}]
    set yoff [expr {[winfo screenheight $m] - $y - [winfo height $m]}]
    if {$xoff < 0} { incr x $xoff }
    if {$yoff < 0} { incr y $yoff }
    wm geometry $m +$x+$y
    update idle
    raise $m
    
    tkwait variable named_point_listbox_selected
    
    catch {destroy $m}
    return $named_point_listbox_selected
}

proc named_point_listbox_fill {m} {
    global named_point
    
    $m.list delete 0 end
    $m.list insert end "New point"
    foreach p [lsort $named_point(names)] {
	$m.list insert end $p
    }
}

proc named_point_listbox_select_one {m y} {
    global named_point_listbox_selected
    
    set ch [$m.list get [$m.list nearest $y]]
    
    if {$ch == ""} return
    if {$ch == "New point"} {
	destroy $m
	set ch [named_point_edit]
    }
    set named_point_listbox_selected $ch
}

proc named_point_exists {name} {
    global named_point
    
    return [lmember $named_point(names) $name]
}

# return the location

proc named_point_get {name {defunits ""}} {
    global named_point
    
    if [named_point_exists $name] {
	set ret ""
	foreach v {x y z} {
	    set p [expression_evaluate $named_point($name,$v)]
	    lappend ret [unit_convert $p $named_point($name,${v}_units) 0]
	}
	return $ret
    } else {
	if {$defunits == ""} {
	    return $name
	} else {
	    set nname ""
	    foreach n $name {
		lappend nname [unit_convert $n $defunits 0]
	    }
	    return $nname
	}
    }
}

# Pass in SI location values, sets it in the units defined

proc named_point_set {name sipoint} {
    global named_point

    foreach n {x y z} v $sipoint {
	set named_point($name,$n) [unit_convert $v $named_point($name,${n}_units) 1]
    }
    named_point_config_xyz $name ""
}

proc named_point_copy {newname oldname args} {
    global named_point
    
    set newname [named_point_new_name_object $newname]
    
    if ![lmember $named_point(names) $newname] {
	lappend named_point(names) $newname
    }
    foreach n {active selected temperature velocity pressure object nodes x y z x_units y_units z_units} {
	set named_point($newname,$n) $named_point($oldname,$n)
    }
    foreach {n v} $args { set named_point($newname,$n) $v }
    return $newname
}

proc named_point_make_new {name args} {
    global named_point
    
    set un [unit_get_default_choice length]
    if ![lmember $named_point(names) $name] {
	lappend named_point(names) $name
    }
    foreach {n v} {active 1 selected 0 temperature 1 velocity 0 pressure 0 object "" nodes ""} {
	set named_point($name,$n) $v
    }
    foreach v {x y z} {
	set named_point($name,$v) ""
	set named_point($name,${v}_units) $un
    }
    foreach {n v} $args {
	set named_point($name,$n) $v
    }
    if {$named_point($name,x) == ""} {
	named_point_update_xyz $name
    }
}

proc named_point_pick_by_name {val unitsvar} {
    global form_entry_datatype named_point futil_menu_prev_value
    
    if {$unitsvar == "none"} { set unitsvar "" }
    
    upvar \#0 $val lval
    
    if {$unitsvar == ""} {
	set units m
    } else {
	upvar \#0 $unitsvar luvar
	set units $luvar
    }
    
    set cur $futil_menu_prev_value
    set ch [string trim $lval]
    switch $ch {
	"View location" {
	    set loc [named_point_get $cur]
	    set locf ""
	    foreach px $loc v {x y z} {
		lappend locf "[format %g $px] $named_point($cur,${v}_units)"
	    }
	    mess "Location of point $cur = [join $loc " ,"]\n"
	    set lval $cur
	}
	"Create new" {
	    set vv [named_point_edit]
	    if {$vv != ""} {
		set lval $vv
	    } else {
		set lval $cur
	    }
	}
	"Edit definition" {
	    set lval [named_point_edit $cur]
	    set lval $cur
	}
	"Screen select" {
	    set loc [auto_get_location]
	    if {$loc != ""} {
		set upt ""
		foreach u $loc {
		    lappend upt [format %.4g [unit_convert $u $units 1]]
		}
		
		set name [question "Name for new point\n(cancel if none)" \
			      [named_point_new_name]]
		if {$name != ""} {
		    named_point_make_new $name x [lindex $upt 0] x_units $units \
			y [lindex $upt 1] y_units $units \
			z [lindex $upt 2] z_units $units
		    set lval $name
		} else {
		    set lval $upt
		}
	    }
	}
	"" { set lval $cur }
	default {
	    named_point_val_focus $val 1
	}
    }
}

# ---------------------------------------------------------------------------

# Stuff for the object-based monitor points.

proc named_point_new_name {} {
    global named_point
    for {set p 1} {[info exists named_point(mon_pt_$p,active)]} {incr p} {}
    return mon_pt_$p
}

proc named_point_new_name_object {objname} {
    global named_point
    foreach n $named_point(names) { set got($n) 1 }
    if ![info exists got($objname)] { return $objname }
    for {set p 1} {[info exists got($objname.$p)]} {incr p} {}
    return $objname.$p
}

proc named_point_edit {{name ""}} {
    global named_point named_point_edit
    
    set params {
	active object x y z x_units y_units z_units temperature pressure
	velocity nodes
    }
    array set named_point_edit {
	active      1
	object      ""
	x           ""
	y           ""
	z           ""
	temperature 1
	pressure    0
	velocity    0
	nodes       ""
    }
    set un [unit_get_default_choice length]
    foreach v {x y z} { set named_point_edit(${v}_units) $un }
    
    if {$name != ""} {
	set named_point_edit(name) $name
	foreach i $params {
	    set named_point_edit($i) $named_point($name,$i)
	}
	set orig_name $name
	set title "Modify point"
    } else {
	set named_point_edit(name) [named_point_new_name]
	set orig_name ""
	set title "Create point"
    }
    set r 0
    set d [form_init .named_point_edit $title "" "" "" 1 1 1]
    if {$d != ""} {
	form_label $d.namel "Name" "$r 0"
	form_entry $d.name named_point_edit(name) string "$r 1" ; incr r
	
	form_checkbutton $d.act "Active" named_point_edit(active) "$r 0 -cols 2" ; incr r
	
	form_label $d.objl "Object" "$r 0"
	tree_standalone_model_pick_entry $d.obj named_point_edit(object) \
	    {__func__  named_point_edit_check_object} "$r 1" \
	    "" "named_point_edit_update_object 1" 1
	
	set r 10
	set lact !named_point_edit(node_listbox_active)
	set d2 [form_label_frame $d.off "Location" "$r 0 -cols 3" $lact]

	incr r
	set xyzf $d2.xyz_frame
	form_frame $xyzf flat 0 "$r 0"
	set xr 0

	form_label $xyzf.xoffl "X" "$xr 0" $lact
	model_unitentry $xyzf.xoff named_point_edit(x) length "$xr 1" $lact 8 \
	    named_point_edit(x_units) 1 ; incr xr

	form_label $xyzf.yoffl "Y" "$xr 0" $lact
	model_unitentry $xyzf.yoff named_point_edit(y) length "$xr 1" $lact 8 \
	    named_point_edit(y_units) 1 ; incr xr

	form_label $xyzf.zoffl "Z" "$xr 0" $lact
	model_unitentry $xyzf.zoff named_point_edit(z) length "$xr 1" $lact 8 \
	    named_point_edit(z_units) 1 ; incr r
	
	set br 0
	set bf $d2.button_frame
	set bf [form_label_frame $bf "Align with" "$r 0 -cols 3" 1]

	form_button $bf.locations "Nearest" \
	    named_point_create_xyz_screen_nearest "$br 0" $lact

	form_button $bf.edges "Vertex" \
	    "named_point_create_xyz_screen vertex" "$br 1" $lact ; incr br

	form_button $bf.centrs "Edge" \
	    "named_point_create_xyz_screen edge" "$br 0" $lact
	
	form_button $bf.faces "Face" \
	    "named_point_create_xyz_screen face" "$br 1" $lact ; incr br

	form_button $bf.objects "Object" \
	    "named_point_create_xyz_screen object" "$br 0" $lact
	
	form_button $bf.plane "Plane" \
	    named_point_create_xyz_screen_plane "$br 1" $lact ; incr r

	form_label $d.mm Monitor: "$r 0"
	form_checkbutton $d.mt Temperature named_point_edit(temperature) \
	    "$r 1" ; incr r
	form_checkbutton $d.mp Pressure named_point_edit(pressure) \
	    "$r 1" ; incr r
	form_checkbutton $d.mv Velocity named_point_edit(velocity) \
	    "$r 1" ; incr r
	form_listbox $d.nodesl  "Network nodes" "" "" "" 4x4 \
	    "$r 0 -cols 2" named_point_edit(node_listbox_active) 0 0 1
	set named_point_edit(node_listbox) $d.nodesl
	form_finish bot
    }
    named_point_edit_update_object 0
    if ![form_wait .named_point_edit] { return "" }
    
    set name $named_point_edit(name)
    foreach i $params {
	set named_point($name,$i) $named_point_edit($i)
    }
    
    set named_point($name,nodes) \
	[form_listbox_get_selected $named_point_edit(node_listbox)]
    
    if ![lmember $named_point(names) $name] {
	lappend named_point(names) $name
    }
    if {$orig_name != $name} {
	tree_named_point_add $name $named_point($name,object) $orig_name
	if {$orig_name != ""} {
	    named_point_delete $orig_name
	}
    } else {
	tree_named_point_add $name $named_point($name,object)
    }
    
    set vis [tree_check_node_opened named_point_container]
    named_point_config_xyz $name $vis
    return $name
}

proc named_point_edit_check_object {dummy obj} {
    global object_sections
    return [info exists object_sections([$obj getval obtype])]
}

proc named_point_edit_update_object {reset} {
    global named_point_edit
    
    set nodes ""
    if {$named_point_edit(object) != ""} {
	set obj [db_get_name $named_point_edit(object)]
	if {$obj != ""} {
	    if {[$obj getval obtype] == "network"} {
		for {set i 0} {$i < [$obj getval num_int]} {incr i} {
		    lappend nodes [$obj getval int${i}_name]
		}
	    } elseif {([$obj getval obtype] == "block") && \
			  ([$obj getval block_type] == "network")} {
		for {set i 0} {$i < [$obj getval res_nextra]} {incr i} {
		    lappend nodes int$i
		}
	    } else {
		if $reset {
		    set cc [centroid_of_objects $obj]
		    foreach n {x y z} v $cc {
			set named_point_edit($n) \
			    [unit_convert $v $named_point_edit(${n}_units) 1]
		    }
		}
	    }
	}
    }
    form_listbox_set $named_point_edit(node_listbox) $nodes
    set named_point_edit(node_listbox_active) [llength $nodes]
    if $reset {
	foreach n $named_point_edit(nodes) {
	}
    }
}

proc named_point_create_xyz_screen_nearest {} {
    global named_point_edit
    
    set xyz [get_one_location]
    if {$xyz != ""} {
	foreach p $xyz x {x y z} {
	    set named_point_edit($x) \
		[unit_convert $p $named_point_edit(${x}_units) 1]
	}
    }
}

proc named_point_create_xyz_screen {partname} {
    global named_point_edit tdv_mouse_bindings

    set part [expr {$partname == "vertex" ? "vert" : $partname}] 

    set left [lindex {x left middle right} $tdv_mouse_bindings(select)]
    set middle [lindex {x left middle right} $tdv_mouse_bindings(done)]
    set right [lindex {x left middle right} $tdv_mouse_bindings(cancel)]

    banner "Select the destination $partname with the $left button; \
	$middle = accept, $right = cancel."

    set sel [select_shape_feature all $part "" \#ff4444]
    banner ""
    if {$sel == ""} return

    set undo [lindex $sel 1]
    eval $undo

    set fullSubentName [lindex $sel 0]
    if {$fullSubentName == ""} return

    set entityName [lindex $fullSubentName 0]
    set subEntityType [lindex $fullSubentName 1]
    set subEntityIndex [lindex $fullSubentName 2]

    set fcentroid [expr {$partname == "object" ? \
        [$entityName get_centroid] : \
        [$entityName feature_centroid $subEntityType $subEntityIndex]}]

    foreach x {x y z} centroidx $fcentroid {
	set named_point_edit($x) \
	    [unit_convert $centroidx $named_point_edit(${x}_units) 1]
    }
}

proc named_point_create_xyz_screen_plane {} {
    global named_point_edit tdv_last_viewer_clicked
    
    set xyz1 [get_one_location \
	  "Pick a point to locate the Construction Plane"]
    if {$xyz1 != ""} {
	set xy [get_one_xy_location \
	    "Pick the location of the new Named Point on the \
             Construction Plane"]
	if {$xy != ""} {
	    set xyz [lindex [$tdv_last_viewer_clicked screen2world_proj \
				 [lindex $xy 0] [lindex $xy 1] \
				 $xyz1 "0 0 0" 0] 0]

	    foreach p $xyz x {x y z} {
		set named_point_edit($x) \
		    [unit_convert $p $named_point_edit(${x}_units) 1]
	    }
	}
    }
}

proc named_point_create {obj} {
    global named_point
    
    set name [$obj getval name]
    set pname [named_point_new_name_object $name]
    switch [$obj getval obtype] {
	network {
	    if ![$obj getval num_int] {
		# we have to do after idle because there are some wierd
		# bugs with drag&drop events getting sent endlessly.
		after idle {user_error "Can't create monitor points for that network because it doesn't have any internal nodes."}
		return
	    }
	    set nodes ""
	    for {set i 0} {$i < [$obj getval num_int]} {incr i} {
		lappend nodes int$i
	    }
	    named_point_make_new $pname object $name nodes $nodes
	}
	default {
	    named_point_make_new $pname object $name
	}
    }
    named_point_update_xyz $pname
    tree_named_point_add $pname $name
    
    named_point_config_xyz $pname \
	[tree_check_node_opened named_point_container]
}

proc named_point_make_selected {name on} {
    global named_point
    set named_point($name,selected) $on
    named_point_config_xyz $name ""
}

proc named_point_delete_for_object {obj} {
    global named_point
    
    if ![info exists named_point(names)] return
    
    set objname [$obj getval name]
    foreach name $named_point(names) {
	if {$named_point($name,object) == $objname} {
	    named_point_delete $name
	}
    }
}
    
proc named_point_delete {name} {
    global named_point named_point_image
    global batch_mode
    
    if !$batch_mode {
       tree_named_point_delete $name
    }
    foreach t {text point} {
	if [info exists named_point_image($name,$t)] {
	    $named_point_image($name,$t) delete
	    unset named_point_image($name,$t)
	}
    }
    set named_point(names) [ldelete $named_point(names) $name]
}

# First this sets up the tree stuff, then converts the really old stuff to the sort of
# old stuff.  Finally call named_point_update_version to update to the newest version

proc named_point_setup {} {
    global named_point monitor_point batch_mode
    global uns_mon_units unit_default
    
    if !$batch_mode {
	set vis [tree_check_node_opened named_point_container]
    } else {
	set vis 0
    }
    
    # For backward compatibility
    foreach mon [array names monitor_point] {
	set named_point($mon) $monitor_point($mon)
    }
    catch {unset monitor_point}
    
    if [info exists uns_mon_units] {
	set un $uns_mon_units
	if {$un == "def"} { set un $unit_default(length) }
	for {set i 1} 1 {incr i} {
	    global uns_mon_pt$i uns_mon_loc$i uns_mon_var$i
	    if ![info exists uns_mon_pt$i] break
	    set xyz [set uns_mon_loc$i]
	    set named_point(uns_mon_$i) \
		[list xyz [list [lindex $xyz 0] $un] \
		     [list [lindex $xyz 1] $un] \
		     [list [lindex $xyz 2] $un] \
		     [set uns_mon_pt$i] \
		     [set uns_mon_var$i]]
	    unset uns_mon_pt$i
	    unset uns_mon_loc$i
	    unset uns_mon_var$i
	}
    }
    
    named_point_update_version
    
    foreach name [lsort $named_point(names)] {
	set named_point($name,selected) 0 ;# just in case
	if !$batch_mode {
	    tree_named_point_add $name $named_point($name,object)
	}
	named_point_config_xyz $name $vis
    }
    
}

proc named_point_add_one {name vals} {
    global named_point
    
    set vis [tree_check_node_opened named_point_container]
    eval named_point_make_new [list $name] $vals
    tree_named_point_add $name $named_point($name,object)
    named_point_config_xyz $name $vis
}

proc named_point_clear {} {
    global named_point
    if [info exists named_point(names)] {
	foreach name $named_point(names) {
	    named_point_delete $name
	}
    }
    catch {unset named_point}
}

proc named_point_list_monitors {} {
    global named_point
    set ret ""
    foreach name $named_point(names) {
	if !$named_point($name,active) continue ;# point is not active
	
	if {$named_point($name,object) != ""} {
	    set obj [db_get_name $named_point($name,object)]
	    if {($obj != "") && ($named_point($name,nodes) != "")} {
		foreach n $named_point($name,nodes) {
		    lappend ret [list "$named_point($name,object) function $n" \
				     [list network $name $n] Temperature]
		}
		continue
	    }
	}
	foreach p {temperature pressure velocity} {
	    if $named_point($name,$p) {
		lappend ret [list "$name $p" [named_point_get $name] \
				 [string totitle $p]]
	    }
	}
    }
    return $ret
}

proc named_point_list_names {} {
    global named_point
    return [lsort $named_point(names)]
}

proc named_point_show_all {on} {
    global named_point named_point_colors_printed named_point_image
    
    if !$on {
	foreach name $named_point(names) {
	    foreach t {text point} {
		if [info exists named_point_image($name,$t)] {
		    $named_point_image($name,$t) configure -visible 0
		}
	    }
	}
    } else {
	if ![info exists named_point_colors_printed] {
	    set named_point_colors_printed 1
	    mess "Monitor point colors: "
	    mess "red " red
	    mess "= temperature, "
	    mess "blue " blue
	    mess "= velocity, "
	    mess "yellow " orange
	    mess "= pressure, "
	    mess "violet " purple
	    mess "= multiple, "
	    mess "gray " \#666
	    mess "= none\n"
	}
	foreach name $named_point(names) {
	    if [info exists named_point_image($name,text)] {
		foreach t {text point} {
		    $named_point_image($name,$t) configure -visible 1
		}
	    } else {
		named_point_config_xyz $name 1
	    }
	}
    }
}

# Returns text, color, size

proc named_point_draw_params {ptname} {
    global named_point
    
    if ![info exists named_point($ptname,selected)] { set named_point($ptname,selected) 0 }
    
    set sel $named_point($ptname,selected)
    
    set text " $ptname"
    #if {($named_point($ptname,object) != "") && !$sel} { set text "" }
    set col gray
    foreach t {temperature pressure velocity} c {red yellow cyan} {
	if $named_point($ptname,$t) {
	    if {$col == "gray"} {
		set col $c
	    } else {
		set col violet
	    }
	}
    }
    if $sel {
	set size 8
	set tcol white
    } else {
	set size 4
	set tcol gray
    }
    return [list $text $tcol $col $size]
}

proc named_point_config_xyz {name vis} {
    global named_point named_point_image tdv_default batch_mode
    
    if $batch_mode return
    
    if ![info exists named_point_image($name,text)] {
	set im1 [tdv_point_im -size 4]; $tdv_default add_image $im1
	set im2 [tdv_text_im -color white]; $tdv_default add_image $im2
	set named_point_image($name,text) $im2
	set named_point_image($name,point) $im1
	$tdv_default add_tag $im1 named_point
    }
    
    if !$named_point($name,active) { set vis 0 }
    if {$vis == ""} {
	set vis [$named_point_image($name,text) cget -visible $vis]
    }
    set pt [named_point_get $name]
    set stuff [named_point_draw_params $name]
    $named_point_image($name,point) configure -visible $vis \
	-color [lindex $stuff 2] -point $pt -size [lindex $stuff 3]
    $named_point_image($name,text) configure -visible $vis \
	-color [lindex $stuff 1] -text [lindex $stuff 0] -point $pt
}

proc named_point_update_all {} {
    global named_point
    foreach name $named_point(names) {
	named_point_config_xyz $name ""
    }
}

proc named_point_copymove_object {obj oldobj cmds} {
    global named_point
    set objname [$obj getval name]
    set oldobjname ---not---used---
    if {$oldobj != ""} { set oldobjname [$oldobj getval name] }
    foreach name $named_point(names) {
	if {$named_point($name,object) == $objname} {
	    named_point_transform $name $cmds
	} elseif {$named_point($name,object) == $oldobjname} {
	    # Put it in the same relative position as the old one
	    set newname [named_point_copy $objname $name object $obj]
	    named_point_transform $newname $cmds
	    tree_named_point_add $newname $objname
	}
    }
}

proc named_point_transform {name cmds} {
    global named_point
    set pt [named_point_get $name]
    foreach cmd $cmds {
	set pt [eval transform_coords [list $pt] $cmd]
    }
    named_point_set $name $pt
}

proc named_point_copymove {copy names} {
    global named_point_copymove named_point

    if $copy {
	set ff .named_point_copy 
	set d [form_init $ff "Copy point" "" "accept cancel"]
    } else {
	set ff .named_point_move
	set d [form_init $ff "Move point" "" "accept cancel"]
    }
    if ![info exists named_point_copymove] {
	set un [unit_get_default_choice length]
	array set named_point_copymove [list num 1 x 0 y 0 z 0 \
					    xunits $un yunits $un zunits $un]
    }
    if {$d != ""} {
	if $copy {
	    form_label $d.numl "Num copies" {0 0}
	    form_entry $d.num named_point_copymove(num) int {0 1} "" 4
	}
	form_label $d.xoffl "X" {2 0}
	form_label $d.yoffl "Y" {3 0}
	form_label $d.zoffl "Z" {4 0}
	model_unitentry $d.x named_point_copymove(x) length {2 1} "" 8 \
	    named_point_copymove(xunits)
	model_unitentry $d.y named_point_copymove(y) length {3 1} "" 8 \
	    named_point_copymove(yunits)
	model_unitentry $d.z named_point_copymove(z) length {4 1} "" 8 \
	    named_point_copymove(zunits)
	form_finish bot
    }
    if ![form_wait $ff] return
    set off ""
    foreach i {x y z} {
	lappend off [unit_convert $named_point_copymove($i) \
			 $named_point_copymove(${i}units) 0]
    }
    set cmds [list [list translate $off]]
    foreach name $names {
	if $copy {
	    for {set c 0} {$c < $named_point_copymove(num)} {incr c} {
		set newname [named_point_copy $name $name]
		for {set i 0} {$i <= $c} {incr i} {
		    named_point_transform $newname $cmds
		}
		tree_named_point_add $newname $named_point($newname,object)
	    }
	} else {
	    named_point_transform $name $cmds
	}
    }
}

# ----------------------------

proc named_point_pick_annotation {x y} {
    global tdv_default named_point_xyz_image named_point_pick
    
    set ims ""
    foreach name [array names named_point_xyz_image] {
	set im [lindex $named_point_xyz_image($name) 0]
	lappend ims $im
	set nom($im) [string range [[lindex $named_point_xyz_image($name) 1] cget -text] 1 end]
    }
    if {$ims == ""} { return "" }
    set im [lindex [$tdv_default pick $x $y $ims "" 15] 0]
    if {$im == ""} { return ""}
    set name $nom($im)
    
    set named_point_pick [list $name [$im cget -size] [$im cget -color]]
    $im configure -size [expr [$im cget -size] + 2] -color white
    return $im
}

proc named_point_move_annotation {im ox oy nx ny} {
    global tdv_default named_point_xyz_image named_point_pick named_point
    global named_point_edit domain
    
    set name [lindex $named_point_pick 0]
    set oldpos ""
    foreach p [lrange $named_point($name) 1 3] {
	set px [expression_evaluate [lindex $p 0]]
	lappend oldpos [unit_convert $px [lindex $p 1] 0]
    }
    set pos [lindex [$tdv_default screen2world $nx $ny] 0]
    set sipos [$tdv_default project $oldpos $pos]
    set sipos [[$domain getval body_shape] restrict_point $oldpos $sipos]
    set newpos ""
    foreach p [lrange $named_point($name) 1 3] v $sipos {
	lappend newpos [list [unit_convert $v [lindex $p 1] 1] [lindex $p 1]]
    }
    set named_point($name) [eval lreplace [list $named_point($name)] 1 3 $newpos]
    named_point_config_xyz $name 1
    
    if {[winfo exists .named_point_edit] && [winfo viewable .named_point_edit]} {
	if {$named_point_edit(name) != $name} {
	    form_cancel .named_point_edit
	    after idle [list named_point_edit $name]
	} else {
	    set data $named_point($name)
	    foreach i {1 2 3} x {x y z} {
		set named_point_edit($x) [lindex [lindex $data $i] 0]
	    }
	}
    }
}

proc named_point_release_annotation {im} {
    global tdv_default named_point_xyz_image named_point_pick named_point
    set im [lindex $named_point_xyz_image([lindex $named_point_pick 0]) 0]
    $im configure -size [lindex $named_point_pick 1] \
	-color [lindex $named_point_pick 2]
    unset named_point_pick
}

proc named_point_list_expressions {} {
    global named_point
    set ret ""
    foreach name $named_point(names) {
	foreach v {x y z} {
	    set p $named_point($name,$v)
	    if [string match *\$* $p] { lappend ret $name $p }
	}
    }
    return $ret
}
