
# Stuff to deal with models.
#
# Copyright (c) 1993, 1994 Pacific Marketing and Consulting
# Author:  Wayne A. Christopher, wayne@pmac.com
#          Pacific Marketing and Consulting, Berkeley, California
#
# current_object
# current_shape

proc object_defaults {obtype {which ""}} {
    global object_params default_object_params object_extra_units
    global use_conversion_routine_suffix

    if {$which != ""} {
	array set defs [object_defaults $obtype]
	if [info exists defs($which)] {
	    return $defs($which)
	} else {
	    return ""
	}
    }
    if ![info exists default_object_params($obtype)] {
        set list [list notes ""]
	foreach parm $object_params($obtype) {
	    if [string match \#* $parm] continue
	    # Order of the params is "title name type default units choices"
	    lappend list [lindex $parm 1]
	    lappend list [lindex $parm 3]
	}
	if {$obtype != "material"} {
	    lappend list obj_color white obj_color_default 1 \
		obj_shading default obj_texture "" obj_texture_scale 1.0 \
		obj_transparency 0.5 obj_transparency_on 0 \
		obj_linewidth default
	    #obj_visible 1
	}
	if [info exists object_extra_units($obtype)] {
	    foreach un $object_extra_units($obtype) {
		# This is a hack but is necessary to make the curves work right
		lappend list [lindex $un 0] 0
	    }
	}
	set default_object_params($obtype) $list
    }
    set list $default_object_params($obtype)
    if [info exists use_conversion_routine_suffix] {
	set proc [info command app_object_defaults_${obtype}_$use_conversion_routine_suffix]
	if {$proc != ""} {
	    set list [concat $list [$proc]]
	}
    }
    return $list
}

proc object_default_units {obtype} {
    global object_params default_object_units object_extra_units
    
    if [info exists default_object_units($obtype)] {
	return $default_object_units($obtype)
    }
    set list ""
    foreach parm $object_params($obtype) {
	if [string match \#* $parm] continue
	# Order of the params is "title name type default units defunits"
	set units [lindex $parm 4]
	set defunits [lindex $parm 5]
	if {$units == ""} {
	    set tt [lindex [lindex $parm 2] 0]
	    if {($tt == "prop") || ($tt == "nprop")} {
		set units [lindex [lindex $parm 2] 1]
	    } else {
		#puts "Can't find units for $obtype [lindex $parm 1]"
		continue
	    }
	}
	if {$defunits == ""} { set defunits [unit_get_default_choice $units] }
	lappend list [lindex $parm 1] $defunits
    }
    if [info exists object_extra_units($obtype)] {
	foreach un $object_extra_units($obtype) {
	    set defunits [unit_get_default_choice [lindex $un 1]]
	    lappend list [lindex $un 0] $defunits
	}
    }
    set default_object_units($obtype) $list
    return $list
}

proc object_possible_values {obtype param} {
    global object_params object_possible_values
    
    if ![info exists object_possible_values($obtype,$param)] {
	set object_possible_values($obtype,$param) ""
	foreach parm $object_params($obtype) {
	    if [string match \#* $parm] continue
	    # Order of the params is "title name type default units choices"
	    set name [lindex $parm 1]
	    set choices [lindex $parm 5]
	    if {$name == $param} {
		set object_possible_values($obtype,$param) $choices
		break
	    }
	}
    }
    return $object_possible_values($obtype,$param)
}

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

proc edit_new_button {type} {
    return [edit_new $type "" 1 "" "" "" "" "" 1]
}

proc edit_new {{obtype ""} {name ""} {put_undo 1} {shapetypes ""}
	       {objparams ""} {shparams ""} {from_obj ""} {visible ""}
	       {from_but 0}} {
    global domain creation_count model_container
    global current_mtype current_genus current_shape
    global object_edit_info type_visible problem_units type_name
    global model_data model_container_root current_object shape_data
    global app_has_clean_up

    if {$obtype == ""} { set obtype $current_mtype }
    if {($obtype == "") || ($obtype == "none")} {
	mess "No object type selected\n" red
	return ""
    }
    set spec [split $obtype -]
    set type [lindex $spec 0]
    set genus [lindex $spec 1]

    if {$from_but && ($current_object != "") &&
	([$current_object getval obtype] != $type)} {
	form_cancel_class model
    }
    if {($type != "domain") && ($domain == "")} {
	user_error "You must select a project or open a new project first."
	return ""
    }

    if {$type == "material"} {
	set container [part_get_root]
    } else {
	set container $model_container
	if {[$container getval part_type internal] != "internal"} {
	    user_error "It's not possible to create new objects in an external $type_name(part).  Please convert it to \"internal\" first."
	    return ""
	}
    }

    # Note that this must be done here because the db_dirty might cause the
    # whole model to get reloaded and in that case the object we created
    # would be lost.
    if [info exists object_edit_info($type)] {
	db_dirty mesh
    } else {
	db_dirty model ;# This is only for materials
    }

    if {$name == ""} {
        if [info exists type_name($obtype)] {
            set t $type_name($obtype)
        } elseif [info exists type_name($type)] {
            set t $type_name($type)
        } else {
            set t $type
        }
	set name [$model_container_root new_name $t]
    } else {
	set obj [$container get_name $name]
	if {$obj != ""} {
	    mess "Using existing $type \"$name\"\n"
	    return $obj
	}
    }

    if {$type == "part"} {
	set obj [model_container -model_container $container]
	$obj setval is_container 1
    } else {
	set obj [model_object -model_container $container]
    }

    $obj setval obtype $type name $name units Problem groups ""
    $container add $name $obj

    eval $obj setval [object_defaults $type] $objparams
    eval $obj setunits [object_default_units $type]

    if {($type == "material") || ($type == "property")} {
	$obj setval creation_order -1
    } else {
	if ![info exists creation_count] { set creation_count 0 }
	$obj setval creation_order [incr creation_count]
    }
    $obj setval active 1 fixvals 0

    set proc app_initialize_$type

    if {[info commands $proc] != ""} {
	$proc $obj "" "" ""
    }
    
    if {[info command $obj] == ""} {
	# It could have been deleted by the initialize function, in rare
	# cases ...  (outside domain, cancel)
	return ""
    }
	
    if [info exists object_edit_info($type)] {
	set gen [lindex $object_edit_info($type) 0]
        if {$genus != ""} {
            foreach i $object_edit_info($type) {
                if {[lindex $i 0] == $genus} {
                    set gen $i
                    break
                }
            }
        }
	set current_genus [lindex $gen 0]
	set sections [lindex $gen 2]
	if {[lindex [lindex $sections 0] 0] == "check_object"} {
	    set sections [lindex [$obj getval section_type_list] 0]
	}
	set current_section [lindex $sections 0]

	$obj setval current_genus $current_genus
	$obj setval current_section $current_section

	if {$shapetypes != "noshapes"} {
	    create_shapes $obj $from_obj $shapetypes "" 0 $shparams
	}

    } else {
	set current_genus ""
	set current_section ""
	set current_shape ""
    }

    if $put_undo { undo_record_create $obj }

    if $from_but {
	foreach sh [db_shapes $obj] {
	    $sh configure -selected 1
	}
    }

    set obn [$obj getval name]

    tree_add_object $obj 0

    # Something strange might have happened here ...
    set obj [db_get_name $obn]

    if $from_but {
	tree_sort_parent $obj
    }

    if {$shapetypes != "noshapes"} {
	if [info exists app_has_clean_up($type)] {
	    app_clean_up_$type $obj
	}
	if {($visible == "") && [info exists type_visible($type)]} {
	    set visible $type_visible($type)
	}
	if {$visible != ""} {
	    make_visible $obj $visible
	}
    }

    if {$type == $current_mtype} {
	if {$type == "material"} {
	    #edit_selection_put_type material
	    #edit_selection_set $obj
	} else {
	    edit_selection_add $obj ""
	}
    }

    if $from_but {
	model_set_current $obj
    }
    after idle "edit_check_outside $obj 1"
    
    return $obj
}

proc copy_object_parameters {old new} {
    foreach v [$old list_values] {
	set n [lindex $v 0]
	if [string match *_shape $n] continue
	if {[lsearch {name} $n] >= 0} continue
	$new setval $n [lindex $v 1]
    }
}

proc copy_shape_parameters {old new excl} {
    set vals ""
    foreach v [$old list_values canset nooffset] {
	set n [lindex $v 0]
	if {[lsearch $excl $n] >= 0} continue
	if {($n == "plane") || ($n == "axis")} {
	    $new setval -noconstr $n [lindex $v 1]
	} else {
	    lappend vals $n [lindex $v 1]
	}
    }
    eval $new setval -noconstr $vals
}

proc edit_delete {{put_undo 1} {obj ""} {dirty 1}} {
    global current_object
    global mesher_is_running domain object_type_title
    
    if [info exists mesher_is_running] {
	user_error "The mesher is running - you should not delete objects\
               right now.  If you don't want the mesh you can click on\
               \"Terminate mesher\" on the mesher form."
	return
    }
    
    if {$obj == ""} { set obj $current_object }
    if {$obj == ""} return
    if {$obj == $domain} {
	error "You can't delete the [string tolower $object_type_title(domain)]"
	return
    }
    
    if ![edit_delete_1 $obj $dirty] return
    
    if $put_undo { undo_record_delete $obj }
    
    edit_delete_2 $obj
}

# This does the common stuff for both edit_delete and trash_add (i.e.
# it doesn't actually delete the object)

proc edit_delete_1 {obj dirty} {
    global current_object model_data
    
    if {$obj == $current_object} {
	model_set_current ""
	set model_data(name) ""
    }
    tree_remove_object $obj
    if {[info command $obj] == ""} {
	# Note that this can happen if you delete an object while in 
	# postprocessing mode.
	# mess "Warning: object not deleted since you switched to another version\n" red
	return 0
    }
    [$obj get -model_container] remove [$obj getval name]
    foreach sh [db_shapes $obj] {
	[$sh get -container] remove $sh
    }

    coll_remove_from_all $obj
    if {[info command named_point_delete] != ""} {
        named_point_delete_for_object $obj
    }

    if $dirty {
	if {[$obj getval obtype] == "material"} {
	    db_dirty model
	} else {
	    db_dirty mesh
	}
    }

    return 1
}

# This really deletes the object.

proc edit_delete_2 {obj} {
    if {[$obj getval obtype] == "part"} {
	part_unload $obj
    }

    cad_before_delete $obj
    
    clear_shapes $obj 1
    $obj delete
}

proc clear_contents {con} {
    foreach obj [$con list_contents] {
	if [$obj checkval is_container] {
	    clear_contents $obj
	}
	clear_shapes $obj 1
	tree_remove_object $obj
	$con remove [$obj getval name]
	$obj delete
    }
}

proc edit_unselect {} {
    model_set_current ""
}

# Subroutines for dealing with objects.  ----------------------------

# If there is no shape defined for the section, create one.  If there is
# one of the wrong type, replace it with a new one of the right type,
# copying over as much information as possible.
# If only_sect is given then we assume this is being called from an
# initialize or cleanup function and don't call those.

proc create_shapes {obj {from_obj ""} {shapetypes ""} {only_sect ""} 
		    {always_init 0} {shparams ""} {put_undo 1}} {
    global object_edit_info domain current_shape selected_shape
    global problem_units job_diff_flag
    global in_create_shapes_function polygon_flat_only quad_thin_only
    global circ_can_have_iradius tdv_default new_shape_factor
    global object_labels_only_for_section batch_mode app_has_initialize
    global dont_catch_cleanup_errors
    
    # sometimes we can unintentionally get reentrant calls
    if [info exists in_create_shapes_function] return
    set in_create_shapes_function 1
    
    set type [$obj getval obtype]
    
    set conv 1.0

    set sections ""
    
    set cur_gen [$obj getval current_genus]
    if {$cur_gen == ""} { set cur_gen default }
    
    foreach gen $object_edit_info($type) {
	if {[lindex $gen 0] == $cur_gen} {
	    set sections [lrange $gen 2 end]
	    break
	}
    }
    if {$sections == ""} {
	unset in_create_shapes_function
	return
    }
    if {[lindex [lindex $sections 0] 0] == "check_object"} {
	set sections [$obj getval section_type_list]

	if {$sections == ""} {
	    unset in_create_shapes_function
	    return
	}
    }
    
    set scont [[$obj get -model_container] getval body_shape]
    
    set update_tree 0

    set newshapes ""
    foreach sect $sections {
	set sectname [lindex $sect 0]
	set sectname_okay($sectname) 1

	# Check to see if it is already there.
	set shape [$obj getval ${sectname}_shape]
	if {($only_sect != "") && ($only_sect != $sectname)} continue
	if {$shape == ""} {
	    set stype [$obj getval current_stype ""]
	} else {
	    set stype [$shape get -shtype]
	}
	if {$from_obj != ""} {
	    set osh [$from_obj getval ${sectname}_shape]
	    if {$osh != ""} { set stype [$osh get -shtype] }
	}

	if {$stype == ""} {
	    foreach st $shapetypes {
		if {[lindex $st 0] == $sectname} {
		    set stype [lindex $st 1]
		    break
		}
	    }
	}

	set ok 0
	foreach sss [lrange $sect 2 end] {
	    if {[lindex $sss 0] == $stype} { set ok 1; break }
	}
	if {!$ok || ($stype == "")} {

	    set stype [lindex [lindex $sect 2] 0] ;# The default shape type

	    set m ""
	    if { $shape != "" } {
		set m [$shape get -shtype]
	    }
	    

	    if {($shape != "") && ([$shape get -shtype] != $stype)} {
		$shape configure -exp_shape $stype
	    }
	}
	
	
	if {$shape != ""} {
	    set curtype [$shape get -type]
	    set exptype [$shape get -exp_shape]
	    if {($exptype == "") || ![string compare $curtype shape_$exptype]} {
		if {$always_init && [info exists app_has_initialize($type)]} {
		    set proc app_initialize_$type
		    
		    if [info exists dont_catch_cleanup_errors] {
			$proc $obj $shape $sectname $domain
		    } else {
			if [catch {$proc $obj $shape $sectname $domain} res] {
			    mess "$res\n" red
			    global errorInfo; puts $res\n$errorInfo
			}
		    }
		}
		continue
	    }
	    
	    set prev_shape $shape
	    set stype $exptype
	    
	    if $put_undo {
		undo_record_change_shtype $shape $exptype
	    }
	}
	
	set shape [shape_$stype -object $obj -name $sectname \
		       -container $scont]
	
	$shape init_units [unit_get_default_choice length]
	catch {$shape configure -diff_flag $job_diff_flag}
	
	if {($domain != "") && ($domain != $obj)} {
	    $shape configure -domain [lindex [db_shapes $domain] 0]
	} elseif {$domain == $obj} {
	    # Looks like we have to update the domain fields of all objects.
	    db_foreach_shape "configure -domain $shape"
	}
	
	# ---
	
	set force_flat 0
	switch $stype {
	    polygon {
		if [info exists polygon_flat_only($type)] {
		    set force_flat 1
		}
	    }
	    quad {
		if [info exists quad_thin_only($type)] {
		    set force_flat 1
		}
	    }
	}
	
	set did_init 0
	if {$from_obj != ""} {
	    set osh [$from_obj getval ${sectname}_shape]
	    if {$osh == ""} {
		set osh [db_shapes $from_obj 0] ;# just pick one of them
	    }
	    if {$osh != ""} {
		$shape initialize_shape $osh NULL $force_flat 0
		$shape setval coord_system [$osh getval coord_system]
		eval $shape setunits [$osh get_all_units 1]
		if {([$shape get -shtype] == "circ") && [$shape si_value iradius] && \
			![info exists circ_can_have_iradius($type)]} {
		    $shape setval iradius 0
		    mess "Warning: internal radius reset to 0 - area of object has changed\n" red
		}
		
		# Now make sure that the expressions are also copied.
		foreach {n e} [$osh get_all_exprs] {
		    $shape setexpr $n $e
		}
		set did_init 1
	    }
	    
	} elseif {[info exists prev_shape] && \
		      ([$prev_shape get -shtype] != "none") && !$always_init} {
	    $shape initialize_shape $prev_shape NULL $force_flat 0
		set did_init 1
	}
	
	if {!$did_init && ($only_sect == "")} {
	    set init 1
	    if [info exists app_has_initialize($type)] {
		if [catch {app_initialize_$type $obj $shape $sectname $domain} res] {
		    mess "$res\n" red
		    global errorInfo; puts $res\n$errorInfo
		} else {
		    if {$res == 1} { set init 0 }
		}
	    }
	    if $init {
		set dd [lindex [db_shapes $domain] 0]
		if {($type != "domain") && ($dd != "") &&
		    ([$dd get -shtype] != "none")} {
		    $shape initialize_shape NULL $dd $force_flat \
			$new_shape_factor
		} else {
		    $shape initialize_shape NULL NULL $force_flat 0
		}
	    }
	}
	if {$shparams != ""} {
	    eval $shape setval -noconstr $shparams
	}
	
	# ---
	
	$shape configure -visible 0 -exp_shape $stype
	if !$batch_mode {
	    $tdv_default add_image $shape
	    $tdv_default add_tag $shape obtype_$type
	    $tdv_default add_tag $shape obtype_all
	}
	$obj setval current_stype $stype
	$obj setval ${sectname}_shape $shape
	
	# ---
	
	if [info exists prev_shape] {
	    delete_shape $prev_shape
	    if {$current_shape == $prev_shape} {
		set current_shape $shape
	    }
	    set update_tree 1
	    unset prev_shape
	}
	if {[lsearch [$obj getval section_list] $sectname] < 0} {
	    $obj lappend section_list $sectname
	}
	lappend newshapes $shape
    }
    
    # This is a trick to make sure the section_list is in the same order as
    # the section_type_list.  *** should be improved
    if {[$obj getval section_type_list ""] != ""} {
	catch {unset got}
	foreach os [$obj getval section_list] { set got($os) 1 }

	set newsects ""
	foreach st [$obj getval section_type_list] {
	    set sn [lindex $st 0]
	    if [info exists got($sn)] {
		lappend newsects $sn
		unset got($sn)
	    }
	}
	
	# these are going to get deleted anyway.
	eval lappend newsects [array names got]
	$obj setval section_list $newsects
    }
    
    # We have to wait until all the shapes are created because the label on a
    # shape might depend on how many sections this object has.
    foreach shape $newshapes {
	shape_configure $shape
    }
    
    # Now go through the section_list and blow away the ones that don't belong.
    set nsl ""
    foreach sn [$obj getval section_list] {
	if ![info exists sectname_okay($sn)] {
	    set sh [$obj getval ${sn}_shape]
	    if {$sh != ""} {
		delete_shape $sh
		if {$current_shape == $sh} {
		    set current_shape ""
		}
		if {[info exists selected_shape] && ($selected_shape == $sh)} {
		    unset selected_shape
		}
		$obj unset ${sn}_shape
	    }
	} else {
	    lappend nsl $sn
	}
    }
    $obj setval section_list $nsl
    if [info exists object_labels_only_for_section($type)] {
	relabel_shapes $obj
    }
    if {($only_sect == "") && ([info procs app_clean_up_$type] != "") &&
	($type != "part")} {
	if [catch {app_clean_up_$type $obj} res] {
	    mess "$res\n" red
	    global errorInfo; puts $res\n$errorInfo
	}
    }
    if $update_tree {
	tree_changepos_object $obj shape
    }
    unset in_create_shapes_function
    return
}

proc set_label_for_shape {sh} {
    global object_labels_only_for_section

    set obj [$sh get -object]
    if [$obj getval no_draw_label 0] {
	$sh configure -label_text ""
	return
    }

    set sectname [$sh get -name]
    # This applies to networks ...
    set sectname [$obj getval ${sectname}_name $sectname]
    set type [$obj getval obtype] 
    set lab [$obj getval name]
    if [info exists object_labels_only_for_section($type)] {
	set ss $object_labels_only_for_section($type)
	if {$ss == "*first*"} {
	    set want [lindex [$obj getval section_list] 0]
	    if {$want != $sectname} { set lab "" }
	} elseif ![lmember $ss $sectname] {
	    set lab ""
	} elseif {[llength $ss] > 1} {
	    #append lab " ($sectname)"
	}
    } else {
	if {[llength [$obj getval section_list]] > 1} {
	    append lab " ($sectname)"
	}
    }
    if {$type != "domain"} {
	$sh configure -label_text $lab
    }
}

proc clear_shapes {obj delete} {
    foreach sect [$obj getval section_list] {
	set sh [$obj getval ${sect}_shape]
	if $delete {
	    # This might fail if a job load was only partially done
	    catch {delete_shape $sh}
	}
	$obj unset ${sect}_shape
    }
    $obj unset section_list
}

proc delete_shape {sh} {
    global selected_shape
    
    set decs [$sh get_decorations]
    $sh set_decorations ;# just be safe
    foreach im $decs {
	$im delete
    }
    if {[$sh get -shtype] == "cad"} {
	cad_clear_bsplines $sh
    }
    $sh delete
    if {[info exists selected_shape] && ($selected_shape == $sh)} {
	unset selected_shape
    }
}

proc relabel_shapes {obj} {
    set lab [$obj getval name]
    set sections [$obj getval section_list]
    foreach ss $sections {
	set sh [$obj getval ${ss}_shape]
	if {$sh == ""} continue ;# should DEFINITELY not happen
	set_label_for_shape $sh
    }
}

# Set general graphical options for this shape, based on the object type
# and other data.  Only call this when something has changed in the
# object definition or a material or group that this object uses.

proc shape_configure {sh {obj ""} {initialize 0} {real_shape ""} {recursive 1}} {
    global graph_color graph_width graph_shadepolicy graph_font
    global current_shape shading_type current_mtype type_visible
    global model_container group_container dont_reconfigure_decoration
    global current_object model_container_root
    global graph_highlight_prevcolor
    global graph_texture graph_texture_id graph_texture_string tdv_default
    global graph_texture_scale graph_transparency graph_transparency_on
    global grid_display grid_dtype grid_qtype app_has_graphparams
					   
    if {($obj == "") && ![$sh get -active]} return
    
    if [info exists dont_reconfigure_decoration($sh)] return

    set is_shape 0
    if {$obj == ""} {
	set obj [$sh get -object]; set is_shape 1
	set real_shape $sh
    } elseif {$real_shape != ""} {
	$sh configure -visible [$real_shape cget -visible]
	if ![$sh cget -visible] return
    }

    set t [$obj getval obtype]
    set shn [$real_shape get -name]
    
    if [info exists use_material_display_properties] {
	set mat [material_get_primary $obj]
    }
    
    # ---------------------------------------
    
    set color [$obj getval obj_color white]
    if [$obj getval obj_color_default 1] {
	if {([$obj getval obtype] == "part") && [$obj getval mesh_separate]} {
	    set color $graph_color(part_sep)
	} elseif [info exists graph_color($t)] {
	    set color $graph_color($t)
	} else {
	    set color white
	}
	if [info exists use_material_display_properties] {
	    if {$mat != ""} {
		set matc [$mat getval obj_color]
		if {$matc != ""} { set color $matc }
	    }
	}
	# Used for networks
	set color [$obj getval ${shn}_obj_color $color]
	
	foreach g [$obj getval groups] {
	    set w [$group_container($g) getval obj_color ""]
	    if {$w != ""} { set color $w ; break }
	}
    }

    # ---------------------------------------
    
    set linewidth [$obj getval obj_linewidth default]
    if {$linewidth == "default"} {
	if [info exists graph_width($t)] {
	    set linewidth $graph_width($t)
	} else {
	    set linewidth 1
	}
	if [info exists use_material_display_properties] {
	    if {$mat != ""} {
		set w [$mat getval obj_linewidth]
		if {$w != ""} { set linewidth $w }
	    }
	}
	foreach g [$obj getval groups] {
	    set w [$group_container($g) getval obj_linewidth ""]
	    if {$w != ""} { set linewidth $w ; break }
	}
    }
    
    # ---------------------------------------
    
    set transparency_on [$obj getval obj_transparency_on 0]
    set transparency [$obj getval obj_transparency 0.5]
    if !$transparency_on {
	if {[info exists graph_transparency_on($t)] && $graph_transparency_on($t)} {
	    set transparency_on 1
	    set transparency $graph_transparency($t)
	}
	if [info exists use_material_display_properties] {
	    if {$mat != ""} {
		if [$mat getval obj_transparency_on 0] {
		    set transparency_on 1
		    set transparency [$mat getval obj_transparency 0.5]
		}
	    }
	}
	foreach g [$obj getval groups] {
	    if [$group_container($g) getval obj_transparency_on 0] {
		set transparency_on 1
		set transparency [$group_container($g) getval obj_transparency 0.5]
	    }
	}
    }
    
    # ---------------------------------------
    
    if {$shading_type == "selected_solid"} {
	set shading selected_solid
    } else {
	set shading [$obj getval obj_shading default]
    }
    
    if {$shading == "default"} {
	if [info exists graph_shadepolicy($t)] {
	    set shading $graph_shadepolicy($t)
	} else {
	    set shading wire
	}
	if [info exists use_material_display_properties] {
	    if {$mat != ""} {
		set w [$mat getval obj_shading]
		if {$w != ""} { set shading $w }
	    }
	}
	foreach g [$obj getval groups] {
	    set w [$group_container($g) getval obj_shading ""]
	    if {$w != ""} { set shading $w ; break }
	}
    }
    set shading [string tolower $shading]
    if {($shading == "") || ($shading == "view")} {
	set shading $shading_type
    }
    if {[lsearch {flat solid gouraud} $shading] >= 0} { set shading flat_wire }

    if {$t == "domain"} { set shading wire }
    
    # ---------------------------------------
    
    set label_color $graph_color(names)
    if $is_shape {
	$sh configure -indicated_point -1 -selected_line -1 \
	    -selected_point -1 -selected_ell -1 -selected_arc -1
    } else {
	if {$shading == "selected_solid"} {
	    set shading wire
	}
    }

    set font fixed
    set linestyle 0

    # ---------------------------------------
    
    set texture [$obj getval obj_texture ""]
    set texture_scale [$obj getval obj_texture_scale 1.0]
    if {$texture == ""} {
	if {([$obj getval obtype] == "part") && [$obj getval mesh_separate]} {
	    set texture $graph_texture(part_sep)
	} elseif [info exists graph_texture($t)] {
	    set texture $graph_texture($t)
	} else {
	    set texture ""
	}
	if [info exists use_material_display_properties] {
	    if {$mat != ""} {
		set matc [$mat getval obj_texture]
		if {$matc != ""} { set texture $matc }
	    }
	}
	foreach g [$obj getval groups] {
	    set w [$group_container($g) getval obj_texture ""]
	    set sc [$group_container($g) getval obj_texture_scale 1.0]
	    if {$w != ""} { set texture $w; set texture_scale $sc; break }
	}
    }
    if {$texture != ""} {
	if ![info exists graph_texture_string($texture)] {
	    # Actually load the texture
	    set graph_texture_string($texture) [$tdv_default read_ppm_file $texture]
	    set graph_texture_scale($texture) $texture_scale
	}
	if ![info exists graph_texture_id($texture)] {
	    set graph_texture_id($texture) \
		[$tdv_default load_texture_string \
		     $graph_texture_string($texture)]
	}
	set texid $graph_texture_id($texture)
	#set texscale $graph_texture_scale($texture)
    } else {
	set texid 0
	set texture_scale 0
    }
    
    # ---------------------------------------
    
    if [info exists app_has_graphparams($t)] {
	foreach {n v} [app_graphparams_$t $obj $real_shape [$real_shape get -selected]] {
	    set $n $v
	}
    }

    set pickable 1
    set cont [$obj get -model_container]

    if $transparency_on {
	set alpha [expr 1.0 - $transparency]
    } else {
	set alpha 1.0
    }
    $sh configure -color $color -width $linewidth -shade $shading \
	-font $font -use_symmat 1 -texid $texid -texscale $texture_scale \
	-alpha $alpha
    
    if !$type_visible($t) { $sh configure -visible 0 }

    # In case this object is currently highlighted, make sure when it gets
    # unhighlighted it's the regular color
    if [info exists graph_highlight_prevcolor($sh)] {
	set graph_highlight_prevcolor($sh) $color
    }

    if {$is_shape && $recursive} {
	set_label_for_shape $sh
	$sh configure -label_color $label_color -linestyle $linestyle
	if {[$sh get -shtype] == "container"} {
	    foreach sh [$sh list] { shape_configure $sh }
	}
    }
}

# This is called whenever the user clicks on the shape or section
# button in the edit form.

proc model_section_fix {} {
    global current_object

    model_set_current $current_object
}

proc model_shape_fix {} {
    global current_object
    
    create_shapes $current_object
    model_set_current $current_object
    make_visible $current_object 1
}

proc make_visible {obj on {recursive 1}} {
    set obtype [$obj getval obtype]
    if {($obtype == "part") && $recursive} {
	foreach sub [$obj list_contents] {
	    make_visible $sub $on 1
	}
    }
    foreach sh [$obj getval section_list] {
	set shape [$obj getval ${sh}_shape]
	if {$shape == ""} continue
	if {[$shape get -shtype] == "container"} {
	    # This should not be needed since the recursive call above will
	    # handle it 
	    #set shapes [$shape list]
	    set shapes $shape
	} else {
	    set shapes $shape
	}
	foreach shape $shapes {
	    make_shape_visible $obj $shape $on 0
	}
    }
}

proc make_shape_visible {obj shape on {recursive 1}} {
    global type_visible app_has_shape_is_active app_has_decorate
    
    set obtype [$obj getval obtype]
    set act [$obj si_value active]
    set vis $on
    if [info exists app_has_shape_is_active($obtype)] {
	# This is *way* faster than info command $proc
	set proc app_shape_is_active_$obtype
	set act [$proc $obj $shape]
	set vis $act
    }
    if !$type_visible($obtype) { set vis 0 }
    if {[$shape get -object] == $obj} {
	set shcon [[$obj get -model_container] getval body_shape]
	catch {
	    # needed only because we have some old binaries ....
	    if [$shcon get -draw_bbox] {
		set vis 0
	    }
	}
	$shape configure -visible $vis -active $act
	if {$obtype == "part"} {
	    if $recursive {
		update_decorations $shape $vis 0
	    }
	} else {
	    if [info exists app_has_decorate($obtype)] {
		update_decorations $shape $vis 0
	    }
	}
    }
}

proc make_selected {obj only_sh on} {
    global current_shape current_object
    
    if !$on {
	set current_shape ""
	set current_object ""
    }
    if {$obj == ""} return
    
    foreach shn [$obj getval section_list] {
	set sh [$obj getval ${shn}_shape]
	if {($only_sh != "") && ($only_sh != $sh)} {
	    $sh configure -selected 0
	    $sh configure -selected_point -1 -selected_line -1 \
		-selected_arc -1 -selected_ell -1 -selected_poly -1
	} else {
	    $sh configure -selected $on
	    if !$on {
		$sh configure -selected_point -1 -selected_line -1 \
		    -selected_arc -1 -selected_ell -1 -selected_poly -1
	    }
	}
    }
    set func [info commands app_make_selected_[$obj getval obtype]]
    if {$func != ""} { $func $obj $on }
}

proc reconfigure_object {obj {recursive 1}} {
    if {$obj == ""} return
    foreach shn [$obj getval section_list] {
	set sh [$obj getval ${shn}_shape]
	shape_configure $sh "" 0 "" $recursive
	update_decorations $sh 1 0 $recursive
    }
}

proc update_all_decorations {} {
    foreach obj [db_list_objects_recursive] {
	foreach sh [db_shapes $obj] {
	    update_decorations $sh 1 0 0
	}
    }
}

proc update_decorations {sh {visible 1} {sel 0} {recursive 1}} {
    global graph_fancy app_has_decorate

    set obj [$sh get -object]
    set obtype [$obj getval obtype]
    if ![$sh get -visible] { set visible 0 }
    
    if {$obtype == "part"} {
	if $recursive {
	    set a [$sh list]
	    foreach sub [$sh list] {
		update_decorations $sub $visible $sel
	    }
	}
	return
    }
    if {!$visible || [string compare $graph_fancy($obtype) 1]} {
	set decs [$sh get_decorations]
	$sh set_decorations ;# just be safe
	foreach im $decs {
	    $im delete
	}
	return
    }
    if [info exists app_has_decorate($obtype)] {
	set stuff [$sh get_decorations]
	set nstuff [app_decorate_$obtype $sh [$sh get -name] $obj $stuff]
	eval $sh set_decorations $nstuff
	foreach im $nstuff {
	    shape_configure $im $obj 0 $sh
	}
    }
}

proc model_graph_options_changed {{also_decorations 1}} {
    global tdv_default
    global tdv_color graph_color
    
    foreach obj [db_list_objects_recursive] {
	model_graph_options_changed_one $obj $also_decorations
    }
    set tdv_color(axes) $graph_color(names)
    tdv_toggle_axes $tdv_default
}

proc model_graph_options_changed_one {obj also_decorations} {
    foreach sh [db_shapes $obj] {
	shape_configure $sh
	if $also_decorations {
	    update_decorations $sh
	}
    }
    if {[$obj getval obtype] == "part"} {
	foreach sub [$obj list_contents] {
	    model_graph_options_changed_one $sub $also_decorations
	}
    }
}

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

proc model_snap_grid {} {
    global domain snap_grid snap_grid_units
    global grid_gcount_i grid_gcount_j grid_gcount_k grid_type
    
    set un [unit_get_default_choice length]
    set bb [[$domain getval body_shape] get_bbox]
    foreach i {0 1 2} {
	set snap_grid(start$i) [unit_convert [lindex [lindex $bb 0] $i] $un 1]
	set snap_grid(end$i) [unit_convert [lindex [lindex $bb 1] $i] $un 1]
    }
    if ![info exists snap_grid(type)] {
	set snap_grid(type) incr
	
	foreach i {0 1 2} {
	    if {$grid_type == "global"} {
		set snap_grid(count$i) [set grid_gcount_[lindex {i j k} $i]]
	    } else {
		set snap_grid(count$i) 101
	    }
	    
	    set snap_grid(incr$i) \
		[expr {($snap_grid(end$i) - $snap_grid(start$i)) / \
			   ($snap_grid(count$i) - 1.0)}]
	    
	    set snap_grid_units(start$i) $un
	    set snap_grid_units(end$i) $un
	    set snap_grid_units(incr$i) $un
	}
    }
    
    set d [form_init .grid_snap "Snap to grid"]
    if {$d != ""} {
	set actc {{snap_grid(type) count}}
	set acti {{snap_grid(type) incr}}
	
	form_label $d.xcl "X" {1 0}
	form_label $d.ycl "Y" {2 0}
	form_label $d.zcl "Z" {3 0}
	form_radiobutton $d.incrl "Incr" snap_grid(type) incr {0 1}
	form_radiobutton $d.countl "Count" snap_grid(type) count {0 2}
	form_label $d.startl "Start" {0 3}
	form_label $d.endl "End" {0 4} $actc
	
	model_unitentry $d.xi snap_grid(incr0) length {1 1} $acti
	model_unitentry $d.yi snap_grid(incr1) length {2 1} $acti
	model_unitentry $d.zi snap_grid(incr2) length {3 1} $acti
	
	form_entry $d.xc snap_grid(count0) int {1 2} $actc
	form_entry $d.yc snap_grid(count1) int {2 2} $actc
	form_entry $d.zc snap_grid(count2) int {3 2} $actc
	
	model_unitentry $d.xs snap_grid(start0) length {1 3}
	model_unitentry $d.ys snap_grid(start1) length {2 3}
	model_unitentry $d.zs snap_grid(start2) length {3 3}
	
	model_unitentry $d.xe snap_grid(end0) length {1 4} $actc
	model_unitentry $d.ye snap_grid(end1) length {2 4} $actc
	model_unitentry $d.ze snap_grid(end2) length {3 4} $actc
	
	form_finish bot
    }
    if ![form_wait .grid_snap] return
    
    foreach i {0 1 2} {
	set st$i [unit_convert $snap_grid(start$i) \
		      $snap_grid_units(start$i) 0]
	set en$i [unit_convert $snap_grid(end$i) \
		      $snap_grid_units(end$i) 0]
	set incr$i 0
	if {$snap_grid(type) == "count"} {
	    if {$snap_grid(count$i) > 1} {
		set incr$i [expr {([set en$i] - [set st$i]) / \
				      ($snap_grid(count$i) - 1.0)}]
	    }
	} else {
	    if {$snap_grid_units(incr$i) > 0} {
		set incr$i [unit_convert $snap_grid(incr$i) \
				$snap_grid_units(incr$i) 0]
	    }
	}
    }
    
    set objects [db_list_all]
    
    model_do_snap_grid $objects $st0 $st1 $st2 $incr0 $incr1 $incr2
}

proc model_do_snap_grid {objects st0 st1 st2 incr0 incr1 incr2} {
    mess "Snapping [llength $objects] objects to grid ...\n"
    set all_undo ""
    busy 1
    foreach obj $objects {
	if ![$obj si_value active] continue
	foreach sh [db_shapes $obj] {
	    set stuff ""
	    catch {unset gotval}
	    switch [$sh get -shtype] {
		polygon {
		    set min [lindex [$sh get_bbox] 0]
		    set off ""
		    foreach i {0 1 2} {
			if {[$sh getval plane] == $i} {
			    lappend off 0
			} else {
			    set nv [snap_one_value [set st$i] [set incr$i] \
					[lindex $min $i]]
			    lappend off [expr $nv - [lindex $min $i]]
			}
		    }
		    foreach val [$sh list_values coords canset nooffset] {
			set n [lindex $val 0]; set v [lindex $val 1]; set nv ""
			if {[llength $v] != 3} continue
			if {$n == "offset"} continue
			foreach i {0 1 2} {
			    lappend nv [expr [lindex $v $i] + [lindex $off $i]]
			}
			if {$nv != $v} {
			    lappend stuff [list $n $v $nv]
			}
			set gotval($n) [list $v $nv]
		    }
		}
		default {
		    foreach val [$sh list_values coords canset nooffset] {
			set n [lindex $val 0]; set v [lindex $val 1]; set nv ""
			switch $n {
			    offset - ns_bbmin - ns_bbmax continue
			}
			if ![catch {$sh getval diff_flag} dflag] {
			    if {$dflag && ($n == "point2")} continue
			    if {!$dflag && ($n == "diff")} continue
			}
			if {[llength $v] != 3} continue
			foreach i {0 1 2} {
			    set ni [snap_one_value [set st$i] [set incr$i] \
					[lindex $v $i]]
			    lappend nv $ni
			}
			if {$nv != $v} {
			    lappend stuff [list $n $v $nv]
			}
			set gotval($n) [list $v $nv]
		    }
		}
	    }
	    foreach par {thickness height} {
		if {![catch {$sh getval $par} tval] && \
			![catch {$sh getval plane} pval]} {
		    catch {unset pos1}
		    foreach try {point1 center vert1} {
			if [info exists gotval($try)] {
			    set pos1 [lindex [lindex $gotval($try) 0] $pval]
			    set pos1a [lindex [lindex $gotval($try) 1] $pval]
			    break
			}
		    }
		    set pos2 [expr $pos1 + $tval]
		    set pos3 [snap_one_value [set st$pval] [set incr$pval] \
				  $pos2]
		    set nv [expr $pos3 - $pos1a]
		    if {($nv == 0) && ($tval != 0)} {
			# Make sure a nonzero value doesn't get collapsed to 0
			set nv [set incr$pval]
		    }
		    #puts "$pos1 $pos2 $pos3 $nv $tval"
		    if {$nv != $tval} {
			lappend stuff [list $par $tval $nv]
		    }
		}
	    }
	    foreach par {radius iradius radius2 iradius2} {
		if {![catch {$sh getval $par} tval] && \
			![catch {$sh getval plane} pval]} {
		    set pval [expr ($pval + 1) % 3] ;# either this or +2
		    set nv [snap_one_value 0 [set incr$pval] $tval]
		    if {($nv == 0) && ($tval != 0)} {
			# Make sure a nonzero value doesn't get collapsed to 0
			set nv [set incr$pval]
		    }
		    if {$nv != $tval} {
			lappend stuff [list $par $tval $nv]
		    }
		}
	    }
	    # if {$stuff != ""} { puts "OBJ $obj sh $sh stuff $stuff" }
	    change_geometric_values $sh $stuff 0
	    lappend all_undo $sh $stuff
	}
    }
    eval undo_record_change_shape $all_undo
    mess "Done\n"
    busy 0
    return $all_undo
}

proc snap_one_value {start incr val} {
    if !$incr { return $val }
    set val1 [expr $val - $start]
    set sgn [expr ($val1 > 0) ? 1 : -1]
    set step [expr {int(($val1 + $incr * $sgn / 2.0) / $incr)}]
    set nval [expr $step * $incr + $start]
    return $nval
}

proc change_geometric_values {sh stuff {undo 1}} {
    global current_shape current_object
    
    if $undo {
	undo_record_change_shape $sh $stuff
    }
    set pvol [$sh get_volume]
    
    foreach st $stuff {
	$sh setval -noconstr [lindex $st 0] [lindex $st 2]
    }
    set nvol [$sh get_volume]
    if {$pvol && !$nvol} {
	set obn [[$sh get -object] getval name]
	mess "Warning: not changing $obn - would have become 0 volume\n" red
	foreach st $stuff {
	    $sh setval -noconstr [lindex $st 0] [lindex $st 1]
	}
	return
    }
    set obj [$sh get -object]
    set func [info command app_make_object_fit_shape_[$obj getval obtype]]
    if {$func != ""} {
 	$func $obj $sh
    }
    update_decorations $sh
    if {$obj == $current_object} {
	edit_reset_params
    }
}

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

proc update_mtype {{mt ""}} {
    global tdv_default
    global current_mtype current_mtype_title object_type_title previous_mtype
    global tdv_pickable_tags type_visible small_screen_hack
    global object_type_title_short is_modelbuilder mainwindow_menubar
    global screen_select_all_types toplevel edit_frame
    
    set newstyle [expr {[info exists mainwindow_menubar] && 
			$mainwindow_menubar}]
    
    if {$mt == $current_mtype} return
    if {$mt != ""} { set current_mtype $mt }
    if {$current_mtype == "none"} return
    
    if {$current_mtype == "material"} {
	load_materials
    } elseif {!$is_modelbuilder && !$newstyle} {
	if [catch {pack info $edit_frame.mod.motion}] {
	    set two 2
	    if $small_screen_hack { set two 0 }
	    pack $edit_frame.mod.motion -side top -after $edit_frame.mod.objects \
		-fill x -padx $two -pady $two
	}
    }
    
    if [info exists object_type_title_short($current_mtype)] {
	set current_mtype_title $object_type_title_short($current_mtype)
    } else {
	set current_mtype_title $object_type_title($current_mtype)
    }
    edit_selection_put_type $current_mtype
    
    if [info exists previous_mtype] {
	foreach obj [db_list_objects $previous_mtype] {
	    foreach sh [db_shapes $obj] {
		$sh configure -draw_label 0
	    }
	}
    }
    foreach obj [db_list_objects $current_mtype] {
	foreach sh [db_shapes $obj] {
	    $sh configure -draw_label $type_visible(names)
	}
    }
    
    if {[info exists previous_mtype] && ($previous_mtype != $current_mtype)} {
	form_cancel_class model
    }
    
    set previous_mtype $current_mtype
    
    edit_update_mtype $current_mtype
    if {$current_mtype != "domain"} {
	model_set_current ""
    }
    
    set tdv_pickable_tags($tdv_default) "obtype_$current_mtype anno_pickable"
    if [info exists screen_select_all_types] {
	lappend tdv_pickable_tags($tdv_default) obtype_all
    }
    
    if !$toplevel(single) { raise .e }
    
    grid_update_images 0 0
    
    set proc [info command app_set_mtype_$current_mtype]
    if {$proc != ""} { $proc }
}

proc model_set_current {obj {force 0} {quiet 0}} {
    global current_object current_genus current_section current_shape
    global edit_current_active current_stype shape_data model_data
    global edit_current_visible model_container
    global batch_mode
    
    check_name_conflicts
    
    if $batch_mode return
    if {!$force && ($current_object == $obj)} return
    set is_changed [expr {$current_object != $obj}]
    
    # Get rid of the copy/move form for the previous object.
    copy_move_close
    
    if [info exists model_data] {
	# This is to make sure that values don't get inherited on the per-side
	# form.
	if {$current_shape != ""} {
	    set sides [$current_shape list_sides 0]
	    foreach side $sides {
		set s [lindex $side 1]
		foreach n [array names model_data] {
		    if {[string match ${s}_* $n] && ($n != "sides_on")} {
			unset model_data($n)
		    }
		}
	    }
	}
	# Also blow away any left-over network stuff.
	foreach m [array names model_data] {
	    if {[string match {int[0-9]*} $m] ||
		[string match {bound[0-9]*} $m] ||
		[string match {face[0-9]*} $m]} {
		unset model_data($m)
	    }
	}
    }
    
    if !$quiet {
	tree_highlight_object $obj
    }
    
    if {($current_object != "") && ($current_object != $obj)} {
	tree_change_selection $current_object 0
	make_selected $current_object "" 0
    }
    if $is_changed { set current_section "" }
    
    set current_object $obj
    if {$obj != ""} {
	edit_set_subform mod

	# First figure out what the current shape should be.
	if {[$obj getval section_list] != ""} {
	    if {($current_section == "") ||
		([$obj getval ${current_section}_shape] == "")} {
		set current_section [lindex [$obj getval section_list] 0]
		$obj setval current_section $current_section
	    }
	    set current_shape [$obj getval ${current_section}_shape]
	    $obj setval current_stype [$current_shape get -shtype]
	    if {$current_shape == ""} {
		error "no shape: current section = ${current_section}"
	    }
	    
	    regexp ^shape_(.*)$ [$current_shape get -type] dummy current_stype
	    # for the complex object types, may want to update 
	    # the object data too
	    $current_object to_var model_data model_date_units
	    $current_shape to_var shape_data shape_data_units
	    if {[$current_shape get -shtype] == "container"} update_container_bbvars
	}
	
	set edit_current_active [$obj si_value active]
	set edit_current_visible [expr {[$obj getval obj_shading ""] != "Invisible"}]
	
	set nowin [expr {[$obj checkval fix_shapes] && \
			     ![string compare [$obj getval fix_shapes] 1]}]
	
	
	set obn [$obj getval name]
	edit_set_params [$obj getval obtype] [$obj getval current_genus] \
	    [$obj getval current_section] [$obj getval current_stype] $nowin
	
	if {[info command app_after_set_current_[$obj getval obtype]] != ""} {
	    after idle app_after_set_current_[$obj getval obtype]
	}
	
	# Something strange might have happened here ...
	set obj [db_get_name $obn]
	if {$obj == ""} return
	
	#catch {unset model_data}
	edit_object_to_var $obj model_data model_data_units
	
#	foreach i {genus section stype} {
#	    set current_$i [$obj getval current_$i]
#	}
	
	if !$quiet {
	    if [$obj getval move_sections_together 0] {
		make_selected $current_object "" 1
	    } else {
		make_selected $current_object $current_shape 1
	    }
# bww - moved to make_selected
#	    set func [info commands app_make_selected_[$obj getval obtype]]
#	    if {$func != ""} { $func $obj }
	}
	if {$current_shape != ""} {
	    set func app_after_change_[$current_shape get -shtype]_num_sides
	    if {[info command $func] != ""} { $func }
	}
	
	set model_container [$obj get -model_container]
	
    } else {
	set edit_current_active 0
	set edit_current_visible 0
	edit_set_params "" "" "" "" 1
	edit_set_subform none
    }

    if !$quiet {
	edit_selection_set $obj
	grid_update_images 0 0

	# This is because individual sides forms can get broken
	if {($current_object != "") && \
		([info commands block_sides_form_object_changed] != "")} {
	    block_sides_form_object_changed
	}
    }
}

proc shapes_enclose {sh} {
    global model_container_root domain
    
    set ret ""
    foreach en [[$model_container_root getval body_shape] get_enclosing $sh] {
	if {$en != [$domain getval body_shape]} {
	    lappend ret $en
	}
    }
    return $ret
}

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

proc model_write {fp {objects ""}} {
    global model_container_root domain whoami version saving_as_version
    global is_iceboard model_had_checksum
    
    check_name_conflicts
    
    if ![info exists saving_as_version] { set saving_as_version 0 }
    
    # First put out the header.
    puts $fp "#@ $whoami $version model file\n"
    
    set names_string ""
    if {$objects == ""} {
	model_write_object $fp $domain ""
	set objects [$model_container_root list_contents creation_order int]
	
	append names_string [$domain getval name]
	
	# Let's write all the materials first, so we can catch conflicts
	# with existing ones correctly.
	foreach obj $objects {
	    set obtype [$obj getval obtype]
	    if {($obtype == "material") && \
		    ([$obj getval mat_lib_path ""] == "")} {
		model_write_object $fp $obj ""
		append names_string [$obj getval name]
	    }
	}
	
	foreach obj $objects {
	    set obtype [$obj getval obtype]
	    if {($obtype == "domain") || ($obtype == "material")} continue
	    if {[$obj getval mat_lib_path ""] != ""} continue
	    
	    model_write_object $fp $obj ""
	    append names_string [$obj getval name]
	}
	foreach obj [db_list_objects group] {
	    coll_write $fp $obj
	}
	
    } else {
	foreach obj $objects {
	    if {$obj == "domain"} {
		model_write_object $fp $domain ""
		append names_string [$domain getval name]
	    } else {
		model_write_object $fp $obj ""
		append names_string [$obj getval name]
	    }
	}
    }
    if {$is_iceboard || $model_had_checksum} {
	puts $fp "\nkey [names_string_checksum $names_string]"
    }
}

proc model_write_object {fp obj indent} {
    global compress_materials dont_write_bsplines saving_as_version
    global app_dont_write_shapes
    
    set obtype [$obj getval obtype]
    puts $fp "${indent}object [list $obtype [$obj getval name]]"
    set shapes ""
    if ![info exists app_dont_write_shapes($obtype)] {
	foreach sh [$obj getval section_list] {
	    lappend shapes ${sh}_shape
	}
    }
    
    set ignore_vals {
	obtype name inpart mat_lib_path section_list section_type_list
    }
    
    
    foreach key [$obj list] {
	if {[lsearch $shapes $key] >= 0} {
	    set sh [$obj getval $key]
	    set sht [$sh get -type]
	    puts $fp "$indent    shape $key $sht"
	    set config [$sh get_options config $saving_as_version]
	    if {$config != ""} { puts $fp "$indent        config $config" }
	    if {($sht == "shape_polygon") || ($sht == "shape_pipe")} {
		puts $fp "$indent        setval nverts [$sh getval nverts]"
	    }
	    puts $fp "$indent        setval [$sh get_options setval $saving_as_version]"
	    # If the default units are not SI and this object has SI then if
	    # we used get_all_units 1 we would get the wrong thing.
	    set defu [unit_get_default_choice length]
	    set units [$sh get_all_units [expr {$defu == "m"}]]
	    if {$units != ""} { puts $fp "$indent        setunits $units" }
	    foreach {n x} [$sh get_all_exprs] {
		puts $fp "$indent        setexpr $n \{$x\}"
	    }
	    if ![info exists dont_write_bsplines($obtype)] {
		foreach ll [$sh get_bspline_names] {
		    puts $fp "$indent        bsplines $ll"
		}
	    }
	    if {($sht == "shape_cad") && [$sh get -save_with_model]} {
		puts $fp "$indent        write_tetin_data"
		set fams "ds dc dp x1 x2 x3"
		set ns [llength [$sh list_sides 0]]
		for {set i 0} {$i < $ns} {incr i} { lappend fams f$i }
		foreach xx [eval $sh tetin_input 0 0 4 $fams] {
		    puts $fp $xx
		}
		puts $fp "$indent        end_tetin_data"
	    }
	    
	    puts $fp "$indent    end shape"
	    
	} elseif {([lsearch $ignore_vals $key] < 0) && \
		      ![string match *_shape $key]} {
	    set val [$obj si_expr $key]
	    
	    if [value_is_default $obtype $key $val] continue
	    
	    regsub -all \n $val \\n val
	    puts $fp "$indent    [list $key $val]"
	}
    }
    foreach units [$obj list_units] {
	set key [lindex $units 0]
	set un [lindex $units 1]
	
	if [unit_is_default $obtype $key $un] continue
	
	puts $fp "$indent    [list param_units $key $un]"
    }
    if {([$obj getval obtype] == "part") && \
	    ([$obj getval part_type] == "internal")} {
	puts $fp "$indent    contents"
	foreach sub [$obj list_contents creation_order int] {
	    if {[$obj getval mat_lib_path ""] != ""} continue
	    model_write_object $fp $sub "$indent    "
	}
	puts $fp "$indent    end contents"
    }
    
    puts $fp "${indent}end object\n"
}

proc value_is_default {type key val} {
    global never_ignore default_cache
    
    if {[info exists never_ignore($type,$key)] ||
	[info exists never_ignore(*,$key)]} { return 0 }
    
    if ![info exists default_cache($type,__got_data__)] {
	set defs [object_defaults $type]
	foreach {n v} $defs { set default_cache($type,$n) $v }
	set default_cache($type,__got_data__) 1
    }
    if [info exists default_cache($type,$key)] {
	return [expr {$val == $default_cache($type,$key)}]
    } elseif [info exists default_cache(*,$key)] {
	return [expr {$val == $default_cache(*,$key)}]
    } else {
	return 0
    }
}

proc unit_is_default {type key un} {
    global unit_default_cache
    
    if ![info exists unit_default_cache($type,__got_data__)] {
	set defs [object_default_units $type]
	foreach {n v} $defs { set unit_default_cache($type,$n) $v }
	set unit_default_cache($type,__got_data__) 1
    }
    if [info exists unit_default_cache($type,$key)] {
	return [expr {$un == $unit_default_cache($type,$key)}]
    } else {
	return 0
    }
}

# This is a bit tricky -- we have to read in all the objects, then create
# all the shapes, and then create all the constraints.

proc model_read {file {check 1} {sort_tree 0}} {
    global num_geo_override whoami version conversion_routine_suffix
    global use_conversion_routine_suffix batch_mode
    global loading_materials_flag current_project_version
    
    set fp [url_open $file r 0]
    if {$fp == ""} { return 0 }
    
    set first [gets $fp]
    if {[regexp {#@ (.+) model file} $first dummy oversion] == 1} {
	scan $version %f vnum
	if {[scan [lindex $oversion 1] %f ovnum] != 1} { set ovnum 0 }
	set nversion "$whoami$vnum"
	scan [lindex $oversion 1] %f vnum
	set current_project_version $vnum
	if {[llength $oversion] >= 2} {
	    set oversion [lindex $oversion 0]$vnum
	}
	
        if {!$batch_mode && ![info exists loading_materials_flag] && $ovnum && ($ovnum > $vnum)} {
            set mess "This job was written by $oversion but this program is $nversion.  You will probably have problems.  Continue reading?"
            if [tk_dialog .mismatch "Version mismatch" $mess "" "" Ok Cancel] {
                return 0
            }
        }
	
	set cvar [string tolower conversion_routine_suffix($oversion,$nversion)]
	if [info exists $cvar] {
	    set use_conversion_routine_suffix [set $cvar]
	} else {
	    catch {unset use_conversion_routine_suffix}
	}
	
	if ![regular_model_read $fp $check 0] { return 0 }
    } else {
	if {[info commands alternate_model_read] != ""} {
	    seek $fp 0
	    alternate_model_read $fp $check
	} else {
	    user_error "Invalid model file"
	    return 0
	}
	set current_project_version 0
    }
    url_close $fp
     	 
    if {[file tail $file] != "geometry"} {
	set geof [file dirname $file]/geometry
	set fp [url_open $geof r 0]
	if {$fp != ""} {
	    set first [gets $fp]
	    if [string match \#@* $first] {
		set num_geo_override 0
		if ![regular_model_read $fp $check 1] { return 0 }
		mess "Loaded geometry file, overriding info from model file for $num_geo_override objects\n"
	    } else {
		mess "Error: geometry file is not an icepak file\n" red
	    }
	    url_close $fp
	}
    }
    catch {unset use_conversion_routine_suffix}
    if $sort_tree {
#	puts "start sort [exec date]"
	tree_sort_all
#	puts "end sort [exec date]"
    }
    return 1
}

proc skip_rest_of_object {fp} {
    while {![eof $fp]} {
	set line [gets $fp]
	if [string match "end object" $line] break
	
    }
}

set m_read_level 0

proc regular_model_read {fp check only_geo} {
    global model_container creation_count domain model_load_extra_values env
    global object_load_group object_load_list num_geo_override
    global use_merge_transformation batch_mode object_params
    global material_load_count model_read_extra_container
    global model_data use_conversion_routine_suffix
    global old_fan_curves old_heat_tr_coeffs errorInfo
    global tdv_default model_container_root dont_load_groups
    global generic_object_import_type_vol generic_object_import_type_flat
    global rename_material_while_loading loading_materials_flag
    global is_iceboard skip_key_check model_had_checksum loading_part_contents
    global app_has_update_version app_has_clean_up rename_object_while_loading
    
    # This speeds up the loading process because we don't have to check
    # for per-side stuff.
    # catch {unset model_data}  broken?
    
    set old_prop_container [model_container]
    
    set all_shapes ""
    set all_objects ""
    set groups_to_handle ""
    
    catch {unset rename_material_while_loading}
    
    set mat_dups 0
    
    set names_string ""
    set checksum_okay 0
    set model_had_checksum 0
    
#    set loading_mat_lib [expr {[info exists model_load_extra_values] &&
#			       [string match *mat_lib_path* \
#				    $model_load_extra_values]}]
  
#global m_read_level; incr m_read_level
#if {$m_read_level == 1} { puts "started reading [exec date]" }
    while {![eof $fp]} {
	set line [gets $fp]
	if {($line == "") || [string match \#* $line]} continue
	if {[lindex $line 0] == "object"} {
	    set obtype [lindex $line 1]
	    set obname [lindex $line 2]
	    
	    append names_string $obname
	    
	    set prevname $obname
	    # this message comes up too much with idf files
	    if {[regsub -all / $obname _ obname] && !$is_iceboard} {
		mess "Warning: renamed $prevname to $obname\n" red
	    }
	    if 0 {
		# why is this here?  more trouble than it's worth
		set ch0 [string index $obname 0]
		if {[string first $ch0 "0123456789"] >= 0} {
		    mess "Changing \"$obname\" to \"_$obname\" because\
the names can't begin with '$ch0'\n" red
		    set obname _$obname
		}
	    }
	    	    
	    if {[info exists generic_object_import_type_vol] && \
		    [lsearch {hexa cyl polygon sphere ellipse cad} $obtype] >= 0} {
		set obtype $generic_object_import_type_vol
	    }
	    if {[info exists generic_object_import_type_flat] && \
		    [lsearch {circ quad incline} $obtype] >= 0} {
		set obtype $generic_object_import_type_flat
	    }
	    
#puts "$obtype $obname"
	    
	    if {($obtype != "property") && \
		    ![info exists object_params($obtype)]} {
		mess "Warning: unknown object type \"$obtype\"\
			-- skipping\n" red
		skip_rest_of_object $fp
		continue
	    }
	    
	    # If we're loading materials, or we're merging and we already have a
	    # cabinet, skip it
	    if {($obtype == "domain") && ([info exists loading_materials_flag] ||
					  ($domain != ""))} continue
	    
	    # If we are merging, don't bring in the stuff attached to the domain object
	    if {[info exists use_merge_transformation] &&
		[string match cabinet_default_side* $obname]} {
		mess "Warning: skipping cabinet side object $obname\n" red
		skip_rest_of_object $fp
		continue
	    }
	    
	    if $only_geo {
		switch $obtype {
		    part - property - material - profile { set obj "" }
		    default {
			set contain $model_container
			set obj [$contain get_name $obname]
			if {$obj == ""} {
			    mess "Can't find an $obtype named \"$obname\" -\
				skipping\n" red
			} else {
			    incr num_geo_override
			}
			lappend all_objects $obj
		    }
		}
	    } else {
		switch $obtype {
		    part {
			set contain $model_container
			set obj [model_container -model_container $contain]
		    }
		    property {
			set contain $old_prop_container
			set obj [model_object -model_container $contain]
		    }
		    material {
			set contain $model_container_root
			set obj [model_object -model_container $contain]
		    }
		    default {
			set contain $model_container
			set obj [model_object -model_container $contain]
		    }
		}
		
		#set prev [$contain get_name $obname]
		set prev [$model_container_root get_name $obname 1]
		
		if {$prev != ""} {
		    if {$obtype == "material"} {
			if [info exists loading_materials_flag] {
			    incr mat_dups
			    skip_rest_of_object $fp
			    continue
			} else {
			    # Is the previous material the same?  If so
			    # just re-use it
			    # NOT YET IMPLEMENTED
			}
		    }
		    if [string match "* *" [file extension $obname]] {
			set rootname $obname
		    } else {
			set rootname [file rootname $obname]
		    }
		    
		    set nn [$model_container_root new_name $rootname 1]
		    mess "Renaming $obtype \"$obname\" to \"$nn\" to avoid\
			name conflict with existing object\n"
		    
		    if {$obtype == "material"} {
			set rename_material_while_loading($obname) $nn
		    } else {
			set rename_object_while_loading($obname) $nn
		    }
		    
		    set obname $nn
		}
		set obname1 $obname
		if [regsub -all / $obname _ obname] {
		    mess "Renaming $obtype \"$obname1\" to \"$obname\"\
			because the / character is no longer allowed\
			in names\n"
		}
		
		if [info exists material_load_count] {
		    incr material_load_count
		}
		
		$obj setval obtype $obtype name $obname groups "" active 1
		$obj setval fixvals [expr {$obtype == "material"}]
		$contain add $obname $obj
		
		# This is so when we are reading library parts, etc we can
		# figure out what we read in and then move the objects
		if [info exists model_read_extra_container] {
		    $model_read_extra_container add $obname $obj
		}
		
		if {$obtype != "property"} {
		    eval $obj setval [object_defaults $obtype]
		    eval $obj setunits [object_default_units $obtype]
		    if [info exists model_load_extra_values] {
			foreach {n v} $model_load_extra_values {
			    $obj setval $n $v
			}
		    }
		    lappend all_objects $obj
		}
	    }
	    if {($obtype != "property") && ($obtype != "material") &&
		[info exists use_conversion_routine_suffix]} {
		#set conv_units 1 ?? is this needed??
		set conv_units 0
	    } else {
		set conv_units 0
	    }
	    set done 0
	    while {!$done && ![eof $fp]} {
		set line [gets $fp]
		if {($line == "") || [string match \#* $line]} continue
		switch [lindex $line 0] {
		    end {
			if {[lindex $line 1] == "object"} {
			    set done 1
			} else {
			    error "misplaced line: $line"
			}
		    }
		    object {
			error "misplaced line: $line"
		    }
		    section_list - name - obtype - inpart - current_section {}
		    shape {
			set shname [lindex [split [lindex $line 1] _] 0]
			set shtype [lindex $line 2]
			
			set sh [list $obj $shname $shtype]
			while {![eof $fp]} {
			    set line [gets $fp]
			    if [string match "*write_tetin_data*" $line] {
				set tmp [cmd_tempfile autohex_tmp]
				set tfp [open $tmp w]
				while {![eof $fp]} {
				    set line [gets $fp]
				    if [string match "*end_tetin_data*" $line] {
					break
				    }
				    puts $tfp $line
				}
				close $tfp
				lappend sh [list tetin_file $tmp]
			    } else {
				if [string match "*end shape*" $line] break
				lappend sh $line
			    }
			}
			if {$obj != ""} {
			    lappend all_shapes $sh
			}
			if !$only_geo {			    
			    $obj lappend section_list $shname

			}
		    }
		    contents {
			set contents ""
			set levels 1
			while {![eof $fp]} {
			    set line [gets $fp]
			    if {[lindex $line 0] == "contents"} {
				incr levels
			    } elseif {([lindex $line 0] == "end") && \
					  ([lindex $line 1] == "contents")} {
				incr levels -1
				if !$levels break
			    }
			    lappend contents $line
			}
			if !$only_geo {
			    $obj setval contents_string $contents
			} else {
			    mess "Warning: skipped contents line in geometry\
				file for $obtype \"$obname\"\n" red
			}
		    }
		    groups {
			if ![info exists dont_load_groups] {
			    if !$only_geo {
				set val ""
				foreach g [lindex $line 1] {
				    if {[string trim $g] != ""} {
					lappend val $g
				    }
				}
				$obj setval groups $val
				foreach g $val {
				    coll_add group $g $obj 0
				}
			    } else {
				mess "Warning: skipped groups line in geometry\
				file for $obtype \"$obname\"\n" red
			    }
			}
		    }
		    default {
			if !$only_geo {
			    set key [lindex $line 0]
			    if {$key == "param_units"} {
				$obj setunits [lindex $line 1] [lindex $line 2]
			    } else {
				set val [lindex $line 1]
				regsub -all \\\\n $val \n val
				if $conv_units {
				    $obj setval_inunits $key $val
				    #puts "$obj setval_inunits $key $val -> [$obj si_value $key]"
				    if {$key == "temp_volume"} {
					# This is because if we have a 2.2
					# source where one field served
					# for both types, this is the only way
					# to get the correct conversion.
					$obj setval_inunits temp_area $val
					
				    }
				} else {
				    $obj setval $key $val
				}
			    }
			} else {
			    mess "Warning: skipped [lindex $line 0] line in\
				geometry file for $obtype \"$obname\"\n" red
			}
		    }
		}
	    }
	    
	    if !$only_geo {
		if {($obtype != "property") && ($obtype != "material")} {
		    if ![info exists creation_count] { set creation_count 0 }
		    if ![$obj checkval creation_order] {
			# We don't want to mess up the priorities if they have
			# been changed by hand
			$obj setval creation_order $creation_count
		    }
		    incr creation_count
		    if {$obtype == "domain"} { set domain $obj }
		}
	    }
	    
	} elseif {([lindex $line 0] == "group") && ![info exists dont_load_groups]} {
	    if !$only_geo {
		# Entities get handled separately ...
		set gname [lindex $line 1]
		while {![eof $fp]} {
		    set line [gets $fp]
		    if {[lindex $line 0] == "end"} break
		    switch [lindex $line 0] {
			obj_color - obj_color_default - obj_shading - 
			obj_linewidth - obj_texture - obj_texture_scale -
			obj_use_as_family -
			obj_transparency - obj_transparency_on {
			    coll_setparam group $gname [lindex $line 0] \
				[lindex $line 1]
			    continue
			}
		    }
		    
		    # I think this code should be not necessary because 
		    # every object has a groups line in it.  Take it out 
		    # after 4.0 and see if stuff breaks ****
		    set obj [db_get_name [lindex $line 1]]
		    if {$obj == ""} {
			#mess "Warning: no object [lindex $line 1] found for group $gname\n" red
			continue
		    }
		    coll_add group $gname $obj 0
		    set ogroups [$obj getval groups]
		    if {[lsearch $ogroups $gname] < 0} {
			$obj setval groups [concat $ogroups [list $gname]]
		    }
		}
	    } else {
		mess "Warning: skipped groups section in geometry file\n" red
	    }
	} elseif {[lindex $line 0] == "key"} {
	    set exp [names_string_checksum $names_string]
	    if {$is_iceboard && ($exp != [lindex $line 1]) && ![info exists env(ICEBOARD_LOAD_ICEPAK)]} {
		user_error "This file seems to have been modified externally - iceboard can't load it"
		busy 0
		return 0
	    } else {
		set checksum_okay 1
	    }
	    set model_had_checksum 1
	}
    }
#if {$m_read_level == 1} { puts "done reading [exec date]" }
    
    if {$is_iceboard && ![info exists loading_part_contents] && !$checksum_okay && ![info exists loading_materials_flag] && ![info exists skip_key_check] && ![info exists env(ICEBOARD_LOAD_ICEPAK)]} {
	user_error "It is not possible to load an Icepak model using Iceboard.  Please choose a model created using Iceboard."
	busy 0
	return 0
    }
    set scont [$model_container getval body_shape]
    foreach sh $all_shapes {
	set obj [lindex $sh 0]
	set type [$obj getval obtype]
	set sname [lindex $sh 1]
	set stype [lindex $sh 2]
	
	set xtype [lindex [split $stype _] 1]
	
	set shape [$stype -object $obj -name $sname -visible 0 \
		       -exp_shape $xtype -container $scont]
    	
	set oldshape [$obj getval ${sname}_shape]
	
	$obj setval current_stype $xtype
	$obj setval ${sname}_shape $shape
	if !$batch_mode {
	    $tdv_default add_image $shape
	    $tdv_default add_tag $shape obtype_$type
	    $tdv_default add_tag $shape obtype_all
	}
	if {($domain != "") && ($domain != $obj)} {
	    $shape configure -domain [lindex [db_shapes $domain] 0]
	}
	
	set_label_for_shape $shape
	
	shape_configure $shape "" 1
	
	$shape init_units [unit_get_default_choice length]
	
	foreach line [lrange $sh 2 end] {
	    switch [lindex $line 0] {
		config {
		    eval $shape configure [lrange $line 1 end]
		}
		setval {
		    if [info exists use_conversion_routine_suffix] {
			# -inunits ???
			eval $shape setval -noconstr [lrange $line 1 end]
		    } else {
			eval $shape setval -noconstr [lrange $line 1 end]
		    }
		}
		setunits {
		    if {$obtype == "part"} {
 			set vals ""
 			# there was a bug in icepak 3.1 and we have to filter
 			# out setunits scale ...
 			foreach {n v} [lrange $line 1 end] {
 			    switch $n {
 				scale - rot_degrees {}
 				default {
 				    lappend vals $n $v
 				}
 			    }
 			}
 		    } else {
 			set vals [lrange $line 1 end]
 		    }
 		    eval $shape setunits $vals
		}
		setexpr {
		    eval $shape setexpr [lrange $line 1 end]
		}
		bsplines {
		    # not clear this is useful
		    #shape_cad_add_bsplines $shape [lindex $line 1] \
			[lrange $line 2 end]
		}
		tetin_file {
		    set file [lindex $line 1]
		    cad_shape_from_tetin $shape $file 0
		    cmd_rm $file
		}
		constraint {
		    lappend all_constraints($shape) [lrange $line 1 end]
		}
	    }
	}
	if [info exists use_merge_transformation] {
	    apply_transformation_shape $shape merge
        }
	if {$oldshape != ""} {
	    $oldshape delete
	}
	if {([$shape getval coord_system] == "") && \
		([$shape si_value xoff] || [$shape si_value yoff] || \
		     [$shape si_value zoff])} {
	    model_local_coords_from_shape $shape
	}
    }
    
    if !$only_geo {
	# This happens only with pre-3.1 jobs
	material_build_from_properties [part_get_root] $old_prop_container
    }
    
# if {$m_read_level == 1} { puts "done with shapes [exec date]" }

    set all_objects_2 ""
    foreach obj $all_objects {
	set t [$obj getval obtype]
	if [info exists app_has_update_version($t)] {
	    eval lappend all_objects_2 [app_update_version_$t $obj]
	} else {
	    lappend all_objects_2 $obj
	}
    }
    
    foreach obj $all_objects_2 {
	set t [$obj getval obtype]	
	if [info exists use_conversion_routine_suffix] {
	    set proc app_convert_${use_conversion_routine_suffix}_$t

	    if {[info commands $proc] != ""} {
		mess "Updating $t \"[$obj getval name]\" to new version\n"
		$proc $obj
	    } else {
		# useless message
		# mess "not Updating $t \"[$obj getval name]\" to new version\n"
	    }

	    set proc app_convert_${use_conversion_routine_suffix}_all
	    if {[info commands $proc] != ""} {
		$proc $obj
	    }
	}
	
	# This is something that has changed in 4.0
	if {[$obj getval obj_color ""] == "default"} {
	    $obj setval obj_color_default 1
	    $obj setval obj_color white
	}
	if !$only_geo {
	    if {$t == "part"} {
		if !$batch_mode {
		    tree_add_object $obj 0
		}
		part_load $obj 0
	    }
	    if {($t != "material") && ($t != "profile") &&
		[info exists object_load_group]} {
		$object_load_group add [$obj getval name] $obj
		$obj lappend groups [$object_load_group getval name]
		if !$batch_mode {
		    tree_add_object_to_group $object_load_group $obj 0
		}
	    }
	    if [info exists object_load_list] {
		lappend object_load_list $obj
	    }
	}
	
	if ![$obj checkval current_genus] {
	    $obj setval current_genus default
	}
	set poss [object_possible_values $t current_genus]
	if {($poss != "") && ![lmember $poss [$obj getval current_genus]]} {
	    $obj setval current_genus [object_defaults $t current_genus]
	}
	if {$check && [info exists app_has_clean_up($t)]} {
	    if {$t == "part"} {
		set rval [catch {app_clean_up_part $obj 0} res]
	    } else {
		set rval [catch {app_clean_up_$t $obj} res]
	    }
	    if $rval {
		mess "Error: [$obj getval obtype] \"[$obj getval name]\": $res\n" red
	
		puts $errorInfo
		busy 0
	    }
	}
    }

#if {$m_read_level == 1} { puts "done with first thing [exec date]" }
    foreach obj $all_objects_2 {
	set t [$obj getval obtype]
	
	foreach sl [$obj getval section_list] {
	    # This is kind of stupid
	    if ![$obj checkval ${sl}_shape] {
		$obj setval ${sl}_shape [shape_none -object $obj]
	    }
	}
	
	if {$t == "material" || $t == "profile"} {
	    tree_add_object $obj 0
	    continue
	}
	if ![$obj checkval current_section] {
	    set sect [lindex [$obj getval section_list] 0]
	    $obj setval current_section $sect
	}
	
	if ![$obj checkval current_stype] {
	    error "no shape type defined"
	}
	if {[$obj si_value active] == ""} { $obj setval active 1 }
	
	if !$batch_mode {
	    set v [$obj si_value active]
	    if {[$obj getval obj_shading ""] == "Invisible"} { set v 0 }
	    make_visible $obj $v 0
	}
	
    }

#if {$m_read_level == 1} { puts "done with second thing [exec date]" }

    foreach obj $all_objects_2 {
	set t [$obj getval obtype]
	if {$t == "material" || $t == "profile" } continue
	
	if {($t == "fan") && [info exists use_conversion_routine_suffix]} {
	    set curve [$obj si_value char_curveno ""]
	    if {$curve != ""} {
		if [info exists old_fan_curves($curve)] {
		    $obj setval curve $old_fan_curves($curve)
		} else {
		    mess "Warning: couldn't find fan curve \"$curve\" for\
			fan \"[$obj getval name]\"\n" red
		}
		$obj unset char_curveno
	    }
	}
	material_update_object_from_properties $obj
	
	if {$t != "part"} {
	    tree_add_object $obj 0
	}
    }
    if [info exists rename_material_while_loading] {
	rename_materials_after_loading $all_objects_2
    }
    
    return 1
#if {$m_read_level == 1} { puts "done with everything [exec date]" }
#incr m_read_level -1
}

proc names_string_checksum {string} {
    set num 0
    set n 0
    foreach c [split $string ""] {
	scan $c %c x
	set num [expr $num + $x * $n] ;# integer overflow is okay
	incr n
    }
    return $num
}

proc model_edit_priority {} {
    global object_priority domain object_type_title current_object app_name
    
    catch {unset object_priority}
    
    set ocur $current_object
    
    set objs [db_list_objects_recursive "" "" creation_order]
    form_kill .object_priority
    
    set d [form_init .object_priority "Object priority" "" "" "" 1 1 1]
    if {$d == ""} return
    
    form_label $d.lab "Objects with higher priority numbers will be\nassigned the mesh and boundary conditions\nwhen they overlap or intersect with objects\nthat have lower priority numbers." {0 0}
    $d.lab configure -justify left
    
    set fr [form_scroller $d.scr 400 {1 0}]

    set r 1
    foreach obj $objs {
	switch [$obj getval obtype] {
	    domain - material - profile - part continue
	}
	form_label $fr.l$r [$obj getval name] "$r 0"
	set object_priority($obj) [$obj getval creation_order]
	form_entry $fr.e$r object_priority($obj) int "$r 1"
	bind $fr.e$r <FocusIn> "model_set_current $obj"
	incr r
    }

    form_finish bot
    $d.scr configure -height [expr {[winfo reqheight $d.scr] + 1}]

    if [form_wait .object_priority] {
	foreach obj [array names object_priority] {
	    # Maybe the user deleted the object in the mean time
	    catch {$obj setval creation_order $object_priority($obj)}
	}
	db_dirty model
    }
    if {[info command $ocur] != ""} { ;# might have deleted this while the form was open
	model_set_current $ocur
    }
    tree_sort_children model
}

if {[info command app_clean_up_domain] == ""} {
    proc app_clean_up_domain {obj} {
	set sh [$obj getval body_shape]
	if {[$sh get -shtype] != "none"} {
	    # ???  I don't know why we do this
	    #$sh setval volume_flag 1
	}
    }
}

proc clean_up_all_objects {} {
    global app_has_clean_up
    
    foreach obj [db_list_objects_recursive] {
	set type [$obj getval obtype]
	if [info exists app_has_clean_up($type)] {
	    app_clean_up_$type $obj
	}
    }
}

proc do_macro {cmd {vals ""}} {
    global current_macro_cmd current_mtype
    
    if {$cmd == ""} {
	if [info exists current_macro_cmd] {
	    set cmd $current_macro_cmd
	} else {
	    return
	}
    }
    
    update_mtype none
    
    set current_macro_cmd $cmd
    uplevel \#0 $cmd  ;# [list $vals]
    catch {unset current_macro_cmd}
}

# This code is similar to edit_copyfrom

proc change_object_type {objs type} {
    global no_fix_shape_data shape_data shape_data_units model_data
    global model_container current_object_sel object_type_can_change

    if {$objs == "current_sel"} { set objs $current_object_sel }

    foreach obj $objs {
	set otype [$obj getval obtype]
	if ![info exists object_type_can_change($otype,$type)] {
	    mess "Can't change \"[$obj getval name]\" from $otype to $type\n" red
	    continue
	}
			    
	set shtypes ""
	foreach n [$obj getval section_list] {
	    set sh [$obj getval ${n}_shape]
	    lappend shtypes [list $n [$sh get -shtype]]
	}
	
	set ogroups [$obj getval groups]
	set nparams [list creation_order [$obj getval creation_order] \
			 groups ""]
	
#	update_mtype $type
	set model_container [$obj get -model_container]
#	puts "edit_new $type \"\" 1 $shtypes $nparams \"\" $obj"
	set nobj [edit_new $type "" 1 $shtypes $nparams "" $obj]
	model_set_current $nobj 1
	set obname [$obj getval name]
	
	edit_modify_params
	
	set func [info command app_change_type_${otype}_$type]
	if {$func != ""} {
	    $func $obj $nobj
	    edit_reset_params
	}
	edit_delete 1 $obj
	
	set model_data(name) $obname
	set model_data(groups) $ogroups
	edit_modify_params
	set sh [db_shapes $nobj 0]
	if {$sh != ""} {
	    set cmd [info commands app_make_object_fit_shape_$otype]
	    if {$cmd != ""} {
		if [$cmd $nobj $sh] {
		    edit_reset_params
		}
	    }
	}
    }
}

proc change_object_priority {this before} {
    global current_object model_data model_container_root
    
    set par [$this get -model_container]
    set sibs [$par list_contents]
    set npri [$before getval creation_order]
    $this setval creation_order $npri
    if {$current_object == $this} { set model_data(creation_order) $npri }
    #puts "$this setval creation_order $npri"
    foreach s $sibs {
	set opri [$s getval creation_order]
	if {($s != $this) && ($opri >= $npri)} {
	    set spri [expr $opri + 1]
	    $s setval creation_order $spri
	    #puts "$s setval creation_order $spri"
	    if {$current_object == $s} { set model_data(creation_order) $spri }
	}
    }
    # this is a bit sluggish but it will work  ....
    # tree_reposition_one_object $this
    if {$par == $model_container_root} { set par model }
    tree_sort_children $par
    db_dirty mesh
}

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

proc make_object_type_params_ignore {} {
    global object_type_params_ignore object_type_params_only object_subtypes
    global object_type_params_only_no_others object_params
    global object_type_params_ignore_this
    
    catch {unset object_type_params_ignore}
    catch {unset object_type_params_ignore_this}
    
    foreach type [array names object_subtypes] {
	# First figure out what the options are.
	## *** NOTE This only works for the first subtype **** must fix ****
	
	foreach p $object_params($type) {
	    if [string match \#* $p] continue
	    if {[lindex $p 1] == [lindex [lindex $object_subtypes($type) 0] 0]} {
		set options [lindex $p 5]
		break
	    }
	}
	
	foreach opt $options {
	    catch {unset ok}
	    if ![info exists object_type_params_only($type,$opt)] continue
	    
	    foreach p $object_type_params_only($type,$opt) { set ok($p) 1 }
	    
	    set maybe ""
	    if [info exists object_type_params_only_no_others($type,$opt)] {
		foreach p $object_params($type) {
		    if [string match \#* $p] continue
		    lappend maybe [lindex $p 1]
		}
	    } else {
		foreach o $options {
		    set maybe [concat $maybe \
			    $object_type_params_only($type,$o)]
		}
	    }
	    foreach m $maybe {
		if ![info exists ok($m)] { 
		    lappend object_type_params_ignore($type,$opt) $m
		    set object_type_params_ignore_this($type,$opt,$m) 1
		}
	    }
	}
    }
}

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

# These are convenience functions.

proc db_list_objects {{type ""} {container ""} {sortmode alpha}} {
    global model_container
    
    switch $type {
	group {
	    global ${type}_container
	    set ret ""
	    foreach n [lsort [array names ${type}_container]] {
		lappend ret [set ${type}_container($n)]
	    }
	    return $ret
	}
    }
    
    if {$container == ""} {
	if {$type == "material" || $type == "profile" } {
	    set container [part_get_root]
	} else {
	    set container $model_container
	}
    }
    
    if {$sortmode == "alpha"} {
	set sortname name
    } else {
	set sortname $sortmode
	set sortmode int
    }
    if {$type == ""} {
	set all [$container list_contents $sortname $sortmode]
    } else {
	set all [$container list_type $type $sortname $sortmode]
    }
    set objs ""
    set dom ""
    foreach obj $all {
	if {[$obj si_value active] != ""} {
	    if {[$obj getval obtype] == "domain"} {
		# Let's make the domain always come first
		set dom $obj
	    } else {
		lappend objs $obj
	    }
	}
    }
    return [concat $dom $objs]
}

proc db_list_for_selection {{type ""} {container ""}} {
    global job_listsort object_list_format
    
    set objs [db_list_objects $type $container $job_listsort]
    set ret ""
    if [info exists object_list_format($type)] {
	foreach form $object_list_format($type) {
	    foreach i {0 1 2 3} {
		set [lindex {title field val subt} $i] [lindex $form $i]
	    }
	    lappend ret [list title $title]
	    catch {unset subtypes}
	    foreach o $objs {
		set this_subt [$o si_value $subt ""]
		
		if {($field == "") && ![info exists used($o)]} {
		    lappend subtypes($this_subt) [$o getval name]
		} else {
		    if {[$o si_value $field ""] == $val} {
			lappend subtypes($this_subt) [$o getval name]
			set used($o) 1
		    }
		}
	    }
	    foreach st [lsort [array names subtypes]] {
		if {$st == ""} {
		    set spc "    " 
		} else {
		    set spc "        "
		    lappend ret [list title "    $st"]
		}
		foreach obn [lsort $subtypes($st)] {
		    lappend ret [list obj $spc$obn]
		}
	    }
	}
    } else {
	foreach o $objs {
	    lappend ret [list obj [$o getval name]]
	}
    }
    return $ret
}

proc db_list_objects_recursive {{type ""} {container ""} {sortmode alpha} {also_inactive 0} {stop_when_mesh_sep 0}} {
    if {[llength $type] > 1} {
	set ret ""
	foreach t $type {
	    set ret [concat $ret [db_list_objects_recursive $t $container $sortmode $also_inactive]]
	}
	return $ret
    }
    
    if {$container == ""} { set container [part_get_root] }
    
    if {[$container getval obtype part] != "part"} {
	if {($type == "") || ([$container getval obtype] == $type)} {
	    return $container
	} else {
	    return ""
	}
    }
    
    set objects ""
    foreach obj [db_list_objects $type $container $sortmode] {
	if {[$obj si_value active] || $also_inactive} { lappend objects $obj }
    }
    
    foreach obj [db_list_objects part $container] {
	if [$obj si_value active] {
	    if {$stop_when_mesh_sep && [$obj getval mesh_separate]} continue
	    foreach sub [db_list_objects_recursive $type $obj $sortmode $also_inactive] {
		if {[$sub si_value active] || $also_inactive} { lappend objects $sub }
	    }
	}
    }
    
    return $objects
}

proc db_list_predicate {predicate} {
    global model_container
    
    set all [db_list_objects_recursive]
    set objs ""
    foreach obj $all {
	if {([$obj si_value active] != "") && [eval $predicate $obj]} {
	    lappend objs $obj
	}
    }
    return $objs
}

# This one skips over materials
# If the stop_at_mesh_separate argument is non-"" then it's a list of parts
# whose contents we will return.  If a part isn't in this list (when it's
# given) and the part is mesh-separate, then we stop

proc db_list_all {{type ""} {container ""} {stop_at_mesh_separate ""}} {
    global type_name
    
    if {$container == ""} { set container [part_get_root] }
    
    if {$type == $type_name(domain)} { set type domain }
    
    set objects ""
    foreach obj [db_list_objects $type $container] {
	if ![$obj si_value active] continue
	switch [$obj getval obtype] {
	    part {
		if {$type == "part"} {
		    lappend objects $obj
		    foreach sub [db_list_all part $obj $stop_at_mesh_separate] {
			lappend objects $sub
		    }
		} elseif {($stop_at_mesh_separate != "") && \
			      ![lmember $stop_at_mesh_separate $obj] && \
			      [$obj getval mesh_separate 0]} {
		    lappend objects $obj
		} else {
		    foreach sub [db_list_all "" $obj $stop_at_mesh_separate] {
			lappend objects $sub
		    }
		}
	    }
	    material - profile {
	    }
	    default {
		lappend objects $obj
	    }
	}
    }
    return $objects
}

proc db_foreach_shape {cmd {cont ""}} {
    global model_container
    if {$cont == ""} { set cont [$model_container getval body_shape] }
    eval $cont $cmd
    foreach sub [$cont list] {
	if {[$sub get -shtype] == "container"} {
	    db_foreach_shape $cmd $sub
	} else {
	    eval $sub $cmd
	}
    }
}

proc db_new_name {type} {
    global model_container
    
    return [$model_container new_name $type]
}

proc db_ensure_new_name {name} {
    global model_container
    
    if {[$model_container get_name $name] == ""} { return $name }
    return [db_new_name $name]
}

proc db_get_name {name {container ""}} {
    global model_container_root type_name trash_container
    
    if {$name == $type_name(domain)} {
	return [db_list_objects domain]
    }
    if {$container == ""} {
	set obj [$model_container_root get_name_all $name]
	if {$obj == ""} {
	    set obj [$trash_container get_name $name]
	}
	return $obj
    }
    set obj [$container get_name $name]
    if {$obj != ""} { return $obj }
    foreach con [db_list_objects part $container] {
	set obj [db_get_name $name $con]
	if {$obj != ""} { return $obj }
    }
    
    # It doesn't exist now - maybe it's in the trash
    set obj [$trash_container get_name $name]
    
    return $obj
}

proc db_shapes {obj {which ""} {shname ""}} {
    if {$obj == ""} { return "" }
    set snames [lsort [$obj getval section_list]]
    set shapes ""
    foreach sn $snames {
	set sh [$obj getval ${sn}_shape]
	if {$sh != ""} {
	    set this_shname [$sh get -name]
	    if {($shname != "") && ($this_shname==$shname)} {
		return $sh
	    }
	    lappend shapes $sh
	}
    }
    
    if {$which == ""} {
	return $shapes
    } else {
	return [lindex $shapes $which]
    }
}

proc db_sidenames {obj {also_all 1}} {
    if $also_all { set sides all } else { set sides "" }
    foreach ss [db_shapes $obj 0] {
	foreach sn [$ss list_sides 2] {
	    lappend sides [lindex $sn 1]
	}
    }
    return $sides
}

proc db_shape_sidenames {sh} {
    set sides ""
    foreach sn [$sh list_sides 2] {
	lappend sides [lindex $sn 1]
    }
    return $sides
}

proc db_shape_sidenums {sh} {
    set sides ""
    foreach sn [$sh list_sides 0] {
	lappend sides [lindex $sn 0]
    }
    return $sides
}

proc db_get_sideinfo {sh name {out 1}} {
    # This is a big hack having to do with the fact that we don't do split
    # nodes any more.  It should go away soon.  Add an extra flag like
    # should_split or something like that.
    set obj [$sh get -object]
    set t [$obj getval obtype]
    set side 1
    if {([info command app_should_split_nodes_$t] != "") && \
	    [app_should_split_nodes_$t $obj $sh $side]} {
	set ospl [$sh getval split_flag]
	$sh setval split_flag 1
    }
    set ret ""
    
    # name is the name of the side we have - simply checking 
    # if it is one of the available side of this shape
    foreach side [$sh list_sides $out] {
	set snn [lindex $side 1]
	set snn2 [lindex $side 2]
	if {($name == "all") || ($snn == $name) || ($snn2 == $name) || \
		((($name == "sides") || ($name == "Sides")) \
		     && [string match side* $snn])} {
	    lappend ret $side
	}
    }
    if [info exists ospl] { $sh setval split_flag $ospl }
    
    return $ret
}

# Return a quad shape that represents a side of a hexa, and similar
# operations for other types (eventually).

proc db_shape_from_side {src num} {
    switch [$src get -shtype] {
	hexa {
	    foreach ss [$src list_sides 0] {
		if {[lindex $ss 0] == $num} {
		    set pts [lindex $ss 3]
		    foreach i {0 1 2} v [lindex $pts 0] {
			set min($i) $v
			set max($i) $v
		    }
		    foreach pt [lrange $pts 1 end] {
			foreach i {0 1 2} v $pt {
			    if {$v < $min($i)} { set min($i) $v }
			    if {$v > $max($i)} { set max($i) $v }
			}
		    }
		    set plane ""
		    foreach i {0 1 2} {
			if {$min($i) == $max($i)} {
			    set plane $i
			}
		    }
		    if {$plane == ""} { error "non-planar plane" }
		    set qq [shape_quad -plane $plane \
				-point1 [list $min(0) $min(1) $min(2)] \
				-point2 [list $max(0) $max(1) $max(2)]]
		    return $qq
		}
	    }
	}
    }
    return ""
}

proc db_side_name_from_number {sh num} {
    global domain

    set obj [$sh get -object]
    if {[$sh get_volume] > 0} {
	set cent [$sh get_centroid]
	set out 1
	if {($obj != "") && ([$obj getval obtype] == "domain")} {
	    set out 0
	}
    } else {
	set cent [[$domain getval body_shape] get_centroid]
	set out 2 ;# Kind of a wierd hack.
    }
    
    # For certain objects (fluid blocks, etc) this should not be 1 ...
    foreach side [$sh list_sides $out] {
	if {[lindex $side 0] == $num} {
	    return [lindex $side 1]
	}
    }
}

proc db_side_number_from_name {sh name} {
    array set sss {
	"Min X" 0 minx 0 "Min Y" 2 miny 2 "Min Z" 4 minz 4
	"Max X" 1 maxx 1 "Max Y" 3 maxy 3 "Max Z" 5 maxz 5
    }
    switch [$sh get -shtype] {
	hexa - container { return $sss($name) }
	default { error "not implemented" }
    }
}

proc db_direction_from_side_number {sh snum} {
    array set sss {
	0 "-1 0 0" 1 "1 0 0"
	2 "0 -1 0" 3 "0 1 0"
	4 "0 0 -1" 5 "0 0 1"
    }
    switch [$sh get -shtype] {
	hexa - container { return $sss($snum) }
	default { error "not implemented" }
    }
}

proc db_side_number_from_direction {sh dir} {
    switch [$sh get -shtype] {
	hexa - container {
	    set maxd 0
	    set maxv -1
	    foreach i {0 1 2} {
		set ad [expr {abs([lindex $dir $i])}]
		if {$ad > $maxv} {
		    set maxd $i
		    set maxv $ad
		}
	    }
	    if {[lindex $dir $maxd] > 0} {
		return [expr 1 + 2 * $maxd + 1]
	    } else {
		return [expr 1 + 2 * $maxd]
	    }
	}
	default { error "not implemented" }
    }
}

proc db_get_shape {obj} {
    set snames [$obj getval section_list]
    set shapes ""
    foreach sn $snames {
	set sh [$obj getval ${sn}_shape]
	if {$sh != ""} { lappend shapes $sh }
    }
    return $shapes
}

proc db_shape_type {obj} {
    set sh [db_get_shape $obj]
    if {$sh == ""} {
	return ""
    } else {
	return [$sh get -shtype]
    }
}

proc db_side_area {sh sidename} {
    foreach side [$sh list_sides 0] {
	if {[lindex $side 1] == $sidename} {
	    return [$sh get_area [lindex $side 0]]
	}
    }
    return [$sh get_area] ;# as a fallback
}

proc db_copy {old {newname ""} {container ""} {tree_sort_children 0}} {
    global model_container creation_count current_mtype
    global type_visible type_name model_container_root
    
    set type [$old getval obtype]
    set typen $type
    if [info exists type_name($typen)] { set typen $type_name($typen) }
    
    
    if {$type == "material"} {
	set container $model_container_root 
    } else {
	if {$container == ""} { set container [$old get -model_container] }
	if {$container == ""} { set container $model_container }
    }
    
    if {$newname == ""} {
	#set newname [$model_container new_name $typen]
	set oldname [$old getval name]
	set newname [[part_get_root] new_name $oldname 1]
    }
    set obj [model_object -model_container $container]
    
    $obj copy $old
    $obj unset no_geometry_modify
    $obj setval obtype $type name $newname groups ""
    $container add $newname $obj
    
    if {$type == "material"} {
	$obj setval creation_order -1 mat_lib_path "" mat_lib_name ""
    } elseif {$type != "profile" } {
	$obj setval creation_order [incr creation_count]
#	$obj setval active 1
    }
    
    if {$type != "material" && $type != "profile" } {
	clear_shapes $obj 0
	create_shapes $obj $old
	
	make_visible $obj $type_visible($type)
    }
    
    if {$type == $current_mtype} {
	if {$type == "material"} {
	    #edit_selection_put_type material
	    edit_selection_set $obj
	} else {
	    edit_selection_add $obj ""
	}
    }
    
    tree_add_object $obj $tree_sort_children
    
#    model_set_current $obj
    
    if {$type != "material" && $type != "profile" } {
	db_dirty mesh
    }
    
    return $obj
}

# This has to leave the properties from libraries in place.

proc db_reinit_model {} {
    global model_container_root domain current_object current_shape
    global coll_current group_container materials_loaded model_container
    global selected_shape
    
    trash_empty
    
    foreach obj [$model_container_root list_contents name alpha] {
	# Delete all objects here but not materials from the library.
	if {[$obj getval mat_lib_path ""] == ""} {
	    db_delete_object $model_container_root $obj
	}
    }
    foreach gn [array names group_container] {
	$group_container($gn) delete
    }
    catch {unset group_container}
    set coll_current ""
    
    set domain ""
    set current_object ""
    set current_shape ""
    catch {unset selected_shape}
    set model_container $model_container_root
    # this is not needed because we don't unload the libraries
    # catch {unset materials_loaded}
}

proc db_delete_object {container obj} {
    if ![$container member $obj] {
	set mess "container $container doesn't contain $obj (name [$obj getval name]).  Contents:"
	foreach sub [$container list_contents] {
	    append mess " $sub (name [$sub getval name])"
	}
	error $mess
    }
    if {[$obj getval obtype] == "part"} {
	foreach sub [$obj list_contents] {
	    db_delete_object $obj $sub
	}
    }
    tree_remove_object $obj
    $container remove [$obj getval name]
    clear_shapes $obj 1
    $obj delete
}

proc db_list_active_types {{for_objface 0}} {
    global model_container group_container type_name
    
    foreach obj [$model_container list_contents name alpha] {
	if ![$obj si_value active] continue
	set type [$obj getval obtype]
	if [info exists type_name($type)] { set type $type_name($type) }
	set found($type) 1
    }
    
    if $for_objface {
	catch {unset found(material)}
	
	if {[array names group_container] != ""} {
	    set found(group) 1
	}
	set found($type_name(domain)) 1
    }
    return [lsort [array names found]]
}

proc db_canon_typename {typename} {
    global type_name
    
    foreach tn [array names type_name] {
	if {$typename == $type_name($tn)} { return $tn }
    }
    return $typename
}

# Which can be either off, model, or mesh

proc db_dirty {which} {
    global model_dirty mesh_dirty error_if_dirty job_version
    global disable_db_dirty editing_material_definition

    set now [abs_time_string]
    switch $which {
	disable  { set disable_db_dirty 1 }
	enable   { catch {unset disable_db_dirty} }
	off      {
	    catch {unset disable_db_dirty}
	    catch {unset model_dirty}
	    catch {unset mesh_dirty}
	}
	off_mesh {
	    catch {unset disable_db_dirty}
	    catch {unset mesh_dirty}
	}
	model {
	    if [info exists disable_db_dirty] return
	    
	    if [info exists error_if_dirty] { error dirty }
	    if {![db_check_dirty model] &&
		([info commands post_invalidate] != "")} {
		if ![post_invalidate model] return
	    }
	    set model_dirty $now
	    if [info exists editing_material_definition] {
		set editing_material_definition 1
	    }
	}
	model_no_invalidate {
	    if [info exists disable_db_dirty] return
	    set model_dirty $now
	    if [info exists editing_material_definition] {
		set editing_material_definition 1
	    }
	}
	mesh {
	    if [info exists disable_db_dirty] return
	    
	    if {![db_check_dirty mesh] &&
		([info commands post_invalidate] != "")} {
		if ![post_invalidate mesh] return
	    }
	    if [info exists error_if_dirty] { error dirty }
	    set mesh_dirty $now
	    set model_dirty $now
	    if {[info commands ff_invalidate] != ""} {
		ff_invalidate
	    }
	    grid_clear full
	    if [info exists editing_material_definition] {
		set editing_material_definition 1
	    }
	}
    }
}

proc db_check_dirty {which} {
    global ${which}_dirty
    if [info exists ${which}_dirty] {
	return [set ${which}_dirty]
    } else {
	return 0
    }
}

proc db_bbox_of_object {obj} {
    set shapes [db_shapes $obj]
    if {$shapes == ""} { return "" }
    return [eval bbox_of_images $shapes]
}

proc db_size_of_object {obj} {
    foreach n {min max} v [db_bbox_of_object $obj] { set $n $v }
    set ret ""
    foreach minv $min maxv $max {
	lappend ret [expr $maxv - $minv]
    }
    return $ret
}

proc db_subtypes {obj name} {
    global object_subtypes
    set type [$obj getval obtype]
    if [info exists object_subtypes($type)] {
	set ret ""
	foreach subt $object_subtypes($type) {
	    set st [$obj si_value [lindex $subt 0]]
	    switch $name {
		0 {
		    lappend ret $st
		}
		1 {
		    foreach {v n} [lrange $subt 1 end] {
			if {$v == $st} { set st $n; break }
			if {($v == "capitalize") && ($n == "")} {
			    set st [string totitle $st]
			    break
			}
		    }
		    lappend ret $st
		}
		2 {
		    lappend ret [lindex $subt 0] $st
		}
	    }
	}
	return $ret
    } else {
	return ""
    }
}

proc get_object_mass {obj} {
    set cmd app_[$obj getval obtype]_mass
    if {[info command $cmd] != ""} {
	return [$cmd $obj]
    }
    
    set vol [get_object_volume_from_mesh $obj]
    set density [[get_material default solid] si_value solid_density]
    foreach p [$obj list] {
	if [string match $p *_material] {
	    set mat [get_material $p]
	    if {($mat != "") && ([$mat getval mat_type] == "solid")} {
		set density [$mat si_value solid_density]
		break
	    }
	}
    }
    return [expr $vol * $density]
}

proc simplify_shape_type {obj volc} {
    global tdv_default
    
    foreach osh [db_shapes $obj] {
	if {[$osh get -shtype] == "polygon"} {
	    set nsh [shape_hexa -object $obj -name [$osh get -name] \
			  -container [$osh cget -container]]
	    $nsh initialize_shape $osh NULL 0 0
	    $nsh setval coord_system [$osh getval coord_system]
	    eval $nsh setunits [$osh get_all_units 1]
	    foreach {n e} [$osh get_all_exprs] {
		$nsh setexpr $n $e
	    }
	    if {abs([$nsh get_volume] - [$osh get_volume]) < $volc * [$osh get_volume]} {
		$osh delete
		$obj setval [$nsh get -name]_shape $nsh
		$tdv_default add_image $nsh
		shape_configure $nsh
		db_dirty mesh
		mess "Changed shape type of [$obj getval name] from polygon to hexa\n"
	    } else {
		$nsh delete
	    }
	}
    }
}

proc shape_currently_uses_param {sh p} {
    switch [$sh get -shtype] {
	hexa - quad {
	    if [$sh si_value diff_flag] {
		return [expr ![lmember {xe ye ze} $p]]
	    } else {
		return [expr ![lmember {xd yd zd} $p]]
	    }
	}
	incline {
	    switch [$sh si_value diff_flag] {
		1 { return [expr ![lmember {xe ye ze xd2 yd2 zd2 rotate_angle} $p]] }
		0 { return [expr ![lmember {xd yd zd xd2 yd2 zd2 rotate_angle} $p]] }
		2 { return [expr ![lmember {xe ye ze xd yd zd} $p]] }
	    }
	}
	cyl {
	    switch [$sh si_value changes] {
		0 { return [expr ![lmember {xc2 yc2 zc2} $p]] }
	    }
	}
    }
    return 1
}

proc object_currently_uses_param {obj p} {
    global object_param_active_data object_params
    
    if ![$obj checkval $p] { return 0 }
    set obtype [$obj getval obtype]
    if ![info exists object_param_active_data($obtype,$p)] {
	foreach param $object_params($obtype) {
	    if {[string index $param 0] == "\#"} continue
	    set object_param_active_data($obtype,[lindex $param 1]) \
		[lindex $param 8]
	}
    }
    if ![info exists object_param_active_data($obtype,$p)] {
	return 1 ;# just in case
    }
    set act $object_param_active_data($obtype,$p)
    if {($act == "always") || ![llength $act]} { return 1 }
    foreach act1 $act {
	set val [$obj si_value [lindex $act1 0]]
	if {([llength $act1] > 1) && ![lmember [lrange $act1 1 end] $val]} { return 0 }
    }
    return 1
}

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

proc check_advanced_mesher {obj} {
    global advanced_mesher_ok advanced_mesher_ok_warned_once
    global shape_only_advanced
    
    if {$advanced_mesher_ok || [info exists advanced_mesher_ok_warned_once]} {
	return
    }
    if [has_non_standard_shapes 0 $obj] {
	set mess "Objects were found with shapes that can only be meshed using the Tetra mesher, but either you do not have a license for these meshers, or the executables were not found.  You will not be able to create a mesh unless you delete, deactivate, or change the types of these objects.  To use the Tetra mesher, please contact technical support."
	tk_dialog .warning_type Warning $mess "" 0 Ok
	set advanced_mesher_ok_warned_once 1
	return
    }
}

proc has_non_standard_shapes {count_wires objs} {
    if {$objs == ""} { set objs [db_list_objects] }

    foreach obj $objs {
	if ![$obj si_value active] continue
	foreach sh [db_shapes $obj] {
            switch [$sh get -shtype] {
                sphere - cad {return 1}
                polygon {if {[$sh getval plane] == -1} {return 1}}
                wire { if $count_wires { return 1 } }
            }
	}
    }
    return 0
}

proc select_shapes_by_screen_region {p1 p2 want_objects} {
    global tdv_default
    set w $tdv_default
    set xx [$w screen2world [lindex $p1 0] [lindex $p1 1]]
    set vec [lindex $xx 1]
    set pt1 [lindex $xx 0]
    set pt2 [lindex [$w screen2world [lindex $p1 0] [lindex $p2 1]] 0]
    set pt3 [lindex [$w screen2world [lindex $p2 0] [lindex $p2 1]] 0]
    set pt4 [lindex [$w screen2world [lindex $p2 0] [lindex $p1 1]] 0]

    # The order here is important.
    set items [$w pick_region "" $vec $pt1 $pt2 $pt3 $pt4 ""]
    foreach it $items {
	if ![catch {$it get -object} obj] {
	    if $want_objects {
		set found($obj) 1
	    } else {
		set found($it) 1
	    }
	}
    }
    return [array names found]
}

proc object_serial_type_number {obj} {
    set all [db_list_objects [$obj getval obtype]]
    return [expr [lsearch $all $obj] + 1]
}

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

proc check_name_conflicts {} {
    global env
    if [info exists env(ICEPAK_DEBUG_COPY)] {
	foreach obj [db_list_objects_recursive] {
	    set name [$obj getval name]
	    if [info exists has_name($name)] {
		error "Two objects have name \"$name\" - $obj and $has_name($name)\n"
	    }
	    set has_name($name) $obj
	}
    }
}

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

proc profile_copymove_object {obj cmds} {
    global current_object model_data
    
    foreach p [$obj list] {
	if [string match *_profile $p] {
	    # the profile data is stored in SI units
	    set pdata [$obj getval $p]
	    
	    set ndata ""
	    foreach {x y z v} $pdata {
		set pt [list $x $y $z]
		foreach cmd $cmds {
		    set pt [eval transform_coords [list $pt] $cmd]
		}
		eval lappend ndata $pt $v
	    }
	    $obj setval $p $ndata
	    if {$obj == $current_object} {
		set model_data($p) $ndata
	    }
	}
    }
    if {$obj == $current_object} {
	edit_reset_params
    }
}

proc profile_changepos_object {obj oldpos newpos} {
    if {($oldpos == "") || ($newpos == "") || ($oldpos == $newpos)} return
    set off ""
    foreach o $oldpos n $newpos {
	lappend off [expr $n - $o]
    }
    profile_copymove_object $obj [list [list translate $off]]
}

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

proc write_object_documentation {file} {
    global object_params object_type_title object_edit_info
    global unit_names unit_choices object_extra_units object_description
    
    set fp [open $file w]
    puts $fp "<h2>Object parameters</h2>"
    foreach obtype [lsort [array names object_params]] {
	puts $fp "<a href=\#obj_$obtype>$object_type_title($obtype)</a><br>"
    }
    foreach obtype [lsort [array names object_params]] {
	puts $fp "<hr>"
	puts $fp "<a name=obj_$obtype>"
	puts $fp "<h3>$object_type_title($obtype)</h3>"
	puts $fp "<p>Name in model file: <b>$obtype</b>"
	if [info exists object_description($obtype)] {
	    puts $fp "<p>$object_description($obtype)"
	}
	puts $fp "<p>Object parameters:"
	puts $fp "<table border>"
	puts $fp "<tr><td><b>Name</b><td><b>Title</b><td><b>Type</b><td><b>Default</b><td><b>Unit type</b><td><b>Options</b></tr>"
	foreach par $object_params($obtype) {
	    set par [string trim $par]
	    if [string match \#* $par] {
		puts $fp "<tr><td colspan=6><b><i>[string range $par 1 end]</i></b></tr>"
	    } else {
		set units [string trim [lindex $par 4]]
		if {$units != ""} {
		    set units "<a href=\#units_$units>$units</a>"
		    if {[lindex $par 5] != ""} {
			append units " ([lindex $par 5])"
		    }
		    set choices ""
		} else {
		    set choices [join [lindex $par 5] ", "]
		}
		puts $fp "<tr><td><tt>[lindex $par 1]<br></tt><td>[lindex $par 0]<br><td>[lindex $par 2]<br><td>[lindex $par 3]<br><td>$units<br><td>$choices<br></tr>"
	    }
	}
	if [info exists object_extra_units($obtype)] {
	    foreach un $object_extra_units($obtype) {
		puts $fp "<tr><td><tt>[lindex $un 0]<br></tt><td>(param_units only)<br><td><br><td><br><td>[lindex $un 1]<br><td><br></tr>"
	    }
	}
	puts $fp "</table>"
	
	if {[info exists object_edit_info($obtype)] && [llength $object_edit_info($obtype)]} {
	    puts $fp "<p>Shape information:"
	    puts $fp "<ul>"
	    foreach genus $object_edit_info($obtype) {
		puts $fp "<li>[lindex $genus 1]: genus <tt>[lindex $genus 0]</tt>"
		puts $fp "<ul>"
		foreach section [lrange $genus 2 end] {
		    puts $fp "<li>[lindex $section 1]: section <tt>[lindex $section 0]</tt>"
		    puts $fp "<ul>"
		    foreach shape [lrange $section 2 end] {
			puts $fp "<li>[lindex $shape 1]: shape <tt>[lindex $shape 0]</tt>"
		    }
		    puts $fp "</ul>"
		}
		puts $fp "</ul>"
	    }
	    puts $fp "</ul>"
	} else {
	     puts $fp "<p>No shape information can be given."
	}
    }
    
    puts $fp "<h2>Unit options</h2>"
    puts $fp "<table border>"
    puts $fp "<tr><td><b>Name</b></td><td><b>Title</b></td><td><b>Choices</b></td>"
    foreach units [array names unit_names] {
	if {$unit_names($units) == ""} continue
	puts $fp "<tr><td><a name=units_$units>$units</td><td>$unit_names($units)</td><td>[join $unit_choices($units) ", "]</td>"
    }
    puts $fp "</table>"
    close $fp
}
