
# Stuff for dealing with collections.
#
# Copyright (c) 1993, 1994 Pacific Marketing and Consulting
# Author:  Wayne A. Christopher, wayne@pmac.com
#          Pacific Marketing and Consulting, Berkeley, California
#

# Note: only groups at used at this point.

# The edit group and edit entity forms are similar.  They both allow
# the user to pick collections and highlight them on the screen,
# and to add and remove things  from the group or entity.  They
# also allow the user to export the set of objects as a part,
# which writes it out to a model file.

proc coll_edit {which} {
    global ${which}_container coll_current coll_current_size coll_current_name
    global coll_listbox coll_nameent coll_sizeent coll_objlist form_done_flag
    global icepak_root groups_can_provide_default_families
    
    switch $which {
	group {set title "Group control"; set name groups}
	entity {set title "Entity control"; set name entities}
    }
    
    set existing {}
    if [info exists ${which}_container] {
	set existing [lsort [array names ${which}_container]]
    }
    set coll_current ""
    set coll_current_name ""
    set coll_current_size ""
    
    # Otherwise the colors will get screwed up.
    #set_current_object {}  gotta fix this I think
    
    set d [form_init .${which}_form $title coll \
	    [list "Done \"coll_done $which\""]]
    if {$d == ""} {
	set d .${which}_form.main.fr
	# here we are cheating
	form_listbox_set $d.existing $existing
	set coll_listbox $d.existing
	set coll_objlist $d.elements
	set coll_nameent $d.fr.name
	set coll_sizeent $d.fr.size	
    } else {    
	form_frame $d.fr sunken 3 {0 0}; set d $d.fr
	
	form_listbox $d.existing "Existing $name" $existing \
		"coll_put $which" "" "" {1 1 -sticky news}
	form_listbox $d.elements "Objects in $which" {} \
		"coll_list_click $which" "" "" {2 1 -sticky news}
	
	form_frame $d.fr ridge 2 {0 0 -cols 2}
	form_label $d.fr.namel "Name" {0 0}
	form_label $d.fr.sizel "Size" {1 0}
	form_label $d.fr.coll "Color" {0 3}
	form_label $d.fr.linl "Linewidth" {1 3}
	form_label $d.fr.shll "Shading" {2 3}
	
	form_entry $d.fr.name coll_current_name string {0 1}
	form_entry $d.fr.size coll_current_size string {1 1}
	
	futil_colorentry $d.fr.col coll_current_color {0 4} "" "" "" \
		    {coll_putname group __current__}
	futil_menuentry $d.fr.lin coll_current_linewidth \
		    {list 1 2 3 4 5} {1 4} "" \
		    {coll_putname group __current__}
	futil_menuentry $d.fr.shl coll_current_shading \
	    {list View Wire Solid Solid/wire {Hidden line} Invisible} {2 4} \
		    "" {coll_putname group __current__}
		
	form_frame $d.buts flat 0 {1 0 -rows 2}
	
	form_button $d.buts.new Create "coll_create $which" \
	    {1 0 -sticky ew}
	form_button $d.buts.delete Delete "coll_delete_action $which" \
	    {2 0 -sticky ew}
	form_button $d.buts.merge Merge "coll_merge_action $which" \
	    {3 0 -sticky ew}
	
	set m $d.buts.add.m
	form_menubutton_regular $d.buts.add "Add" $m \
	    {10 0 -sticky ew}
	menu $m
	$m add command -label "Screen select" -command "coll_op $which add"
	$m add command -label "Pattern" -command "coll_pattern $which add"
	$m add command -label "Screen region" -command "coll_region $which add"
	
	set m $d.buts.rem.m
	form_menubutton_regular $d.buts.rem "Remove" $m \
	    {11 0 -sticky ew}
	menu $m
	$m add command -label "Screen select" -command "coll_op $which remove"
	$m add command -label "Pattern" -command "coll_pattern $which remove"
	$m add command -label "Screen region" -command "coll_region $which remove"
	
	form_button $d.buts.copy Copy "coll_copy $which" \
	    {20 0 -sticky ew}
	form_button $d.buts.move Move "coll_move $which" \
	    {21 0 -sticky ew}
	form_button $d.buts.edit Edit "coll_properties $which" \
	    {22 0 -sticky ew}
	form_button $d.buts.actall "Activate all" "coll_act_all $which 1" \
	    {25 0 -sticky ew}
	form_button $d.buts.deactall "Deactivate all" "coll_act_all $which 0" \
	    {26 0 -sticky ew}
	form_button $d.buts.deleteall "Delete all" "coll_del_all $which" \
	    {27 0 -sticky ew}
	
	if [info exists icepak_root] {
	    form_button $d.buts.wpart "Create assembly" \
		"coll_create_part $which" {30 0 -sticky ew}
	    form_button $d.buts.cprop "Copy params" \
		"coll_copy_props $which 0" {31 0 -sticky ew}
	}
	form_button $d.buts.wjob "Save as project" \
	    coll_save_as_job {32 0 -sticky ew}
	
	if [info exists groups_can_provide_default_families] {
	    form_checkbutton $d.buts.famn "Use as family" \
		coll_current_use_as_family {33 0 -sticky ew}
	}
	
	bind $d.fr.name <Return> "coll_setname $which \[%W get\]"
	set coll_listbox $d.existing
	set coll_objlist $d.elements
	set coll_nameent $d.fr.name
	set coll_sizeent $d.fr.size
	
	foreach r {0 9 19 24 29} {
	    form_rowheight $d.buts $r 4
	}
	
	form_finish
    }
    form_listbox_clear $coll_objlist
}

proc coll_edit_parameters {con} {
    global group_container group_edit
    
    set ccc [$con getval obj_color]
    set group_edit(shading) [$con getval obj_shading]
    set group_edit(linewidth) [$con getval obj_linewidth]
    set group_edit(texture) [$con getval obj_texture]
    set group_edit(texture_scale) [$con getval obj_texture_scale 1.0]
    set group_edit(transparency) [$con getval obj_transparency 0.5]
    set group_edit(transparency_on) [$con getval obj_transparency_on 0]
    
    if {$group_edit(linewidth) == ""} {
	set group_edit(linewidth_on) 0
	set group_edit(linewidth) 1
    } else {
	set group_edit(linewidth_on) 1
    }
    if {$group_edit(shading) == ""} {
	set group_edit(shading_on) 0
	set group_edit(shading) Wire
    } else {
	set group_edit(shading_on) 1
    }
    if {$group_edit(texture) == ""} {
	set group_edit(texture_on) 0
	set group_edit(texture) ""
    } else {
	set group_edit(texture_on) 1
    }
    if {$ccc == ""} {
	set group_edit(color_on) 0
	set group_edit(color) white
    } else {
	set group_edit(color_on) 1
	set group_edit(color) $ccc
    }
    
    set d [form_init .group_params "Group parameters"]
    if {$d != ""} {
	form_checkbutton $d.coll "Color" group_edit(color_on) {0 0}
	form_checkbutton $d.linl "Linewidth" group_edit(linewidth_on) {1 0}
	form_checkbutton $d.shll "Shading" group_edit(shading_on) {2 0}
	form_checkbutton $d.texl "Texture" group_edit(texture_on) {3 0}
	form_label $d.texsl "    Texture scale" {4 0} group_edit(texture_on)
	form_checkbutton $d.transl "Transparency\n(0 = opaque)" group_edit(transparency_on) {5 0}
	
	futil_colorentry $d.col group_edit(color) {0 1} group_edit(color_on)
	futil_menuentry $d.lin group_edit(linewidth) \
	    {list 1 2 3 4 5} {1 1} group_edit(linewidth_on)
	futil_menuentry $d.shl group_edit(shading) \
	    {list View Wire Solid Solid/wire {Hidden line} Invisible} {2 1} \
	    group_edit(shading_on)
	futil_listentry $d.tex group_edit(texture) "texture_list" {3 1} group_edit(texture_on) "texture_select group_edit(texture)" 1
	form_entry $d.texs group_edit(texture_scale) float {4 1} group_edit(texture_on)
	form_scale $d.trans group_edit(transparency) "" h 0.0 1.0 0.01 {5 1} group_edit(transparency_on) "" 100
		    
	form_finish +300+300
    }
    if ![form_wait .group_params] return
    
    set upd 0
    foreach i {color shading linewidth texture transparency} {
	set p [$con getval obj_$i ""]
	if $group_edit(${i}_on) {
	    $con setval obj_$i $group_edit($i)
	} else {
	    $con unset obj_$i
	}
	if {$p != [$con getval obj_$i ""]} { incr upd }
    }
    foreach i {transparency_on texture_scale} {
	if {[$con getval obj_$i] != $group_edit($i)} {
	    $con setval obj_$i $group_edit($i)
	    incr upd
	}
    }
    if $upd {
	foreach obj [$con list_contents] {
	    if [$obj si_value active] {
		reconfigure_object $obj
	    }
	}
    }
    db_dirty model
}

proc coll_reconfigure_visible {} {
    global coll_current coll_current_shading
    
    $coll_current setval obj_shading $coll_current_shading
    foreach obj [$coll_current list_contents] {
	if [$obj si_value active] {
	    reconfigure_object $obj
	}
    }
}

proc coll_create {which {name ""}} {
    global coll_nameent coll_current ${which}_container

    if {$name == ""} {
	set name [$coll_nameent get]
    } elseif {$name == "__ask__"} {
	set name [question "Name for new group?" [coll_new_name group]]
	if {$name == ""} { return "" }
    }
    set name [join $name _]
    
    if {[info exists ${which}_container($name)] || ($name == "")} {
	set name [coll_new_name $which]
	if {[info exists coll_nameent] && [winfo exists $coll_nameent]} {
	    $coll_nameent delete 0 end
	    $coll_nameent insert end $name
	}
    }
    
    coll_putname $which $name
    db_dirty model
    return [set ${which}_container($name)]
}

proc coll_put {which name} {
    global coll_nameent coll_waiting_for_select
    
    if [info exists coll_waiting_for_select] {
	set coll_waiting_for_select $name
	return
    }
    
    form_entry_set $coll_nameent $name
    coll_putname $which $name
}

proc coll_list_click {which {name ""}} {
    global coll_doing_remove coll_current
    
    if {($name == "") || ![info exists coll_doing_remove]} {
	mess "Not in $which remove mode.\n" red
	return
    }
    
    set nn [$coll_current get_name $name 1]
    if ![llength $nn] {
	user_error "Bad object name \"$nn\" in list!\n"
	return
    } elseif {[llength $nn] > 1} {
	mess "Warning: two objects with the same name -- please use the\
              screen to indicate which one you want to remove.\n" red
	return
    }
    coll_remove_action $which $coll_current $nn
}

proc coll_putname {which name} {
    global coll_current ${which}_container
    
    if {$name == "__current__"} {
	set con $coll_current
    } elseif {$name == ""} {
	set con ""
    } elseif [info exists ${which}_container($name)] {
	set con [set ${which}_container($name)]
    } else {
	set con [coll_makenew $which $name ""]

	set undo "coll_delete $which \[set \{${which}_container($name)\}\]"
	set redo "coll_makenew $which \{$name\}; coll_putname $which \{$name\}"
	undo_record $undo $redo
    }
    coll_set_current $which $con
}

proc coll_set_current {which con} {
    global coll_current ${which}_container coll_listbox
    global coll_sizeent coll_objlist
    global coll_current_color coll_current_shading coll_current_linewidth
    global coll_current_use_as_family
    
    if {$coll_current != ""} {
	foreach obj [$coll_current list_contents] {
	    if [$obj si_value active] {
		graph_highlight $obj 0
	    }
	}
    }
    set coll_current $con
    if {$coll_current != ""} {
	foreach obj [$coll_current list_contents name alpha] {
	    if [$obj si_value active] {
		graph_highlight $obj 1
	    }
	}
	set coll_current_shading [$coll_current getval obj_shading]
    }
    coll_done_action
}

proc coll_makenew {which name {objs ""}} {
    global ${which}_container coll_listbox
    
    set con [model_container]
    $con setval name $name obtype $which obj_use_as_family 0
    set ${which}_container($name) $con
    if [info exists coll_listbox] {
	form_listbox_add $coll_listbox $name
    }
    foreach obj $objs {
	coll_add_action $which $con $obj
    }
    tree_create_group $con $objs
    return $con
}

proc coll_setname {which name} {
    global coll_current ${which}_container coll_listbox
    global coll_sizeent coll_objlist
    
    if {$name == ""} return
    
    if [regsub -all " " $name _ nname] {
	mess "Changed name \"$name\" to \"$nname\"\n"
	set name $nname
    }
    if {$coll_current == ""} {
	coll_putname $which $name
    } else {
	set oname [$coll_current getval name]
	$coll_current setval name $name
	if {[info exists coll_sizeent] && [winfo exists $coll_sizeent]} {
	    form_listbox_change $coll_listbox $oname $name
	}
	unset ${which}_container($oname)
	set ${which}_container($name) $coll_current
	
	foreach obj [coll_contents $which $name] {
	    set grs ""
	    foreach g [$obj getval groups] {
		if {$g == $oname} {
		    lappend grs $name
		} else {
		    lappend grs $g
		}
	    }
	    $obj setval groups $grs
	}
	tree_rename_group $coll_current $name
    }
}

proc coll_rename {} {
    global coll_current
    set name [question "Rename group to?" [$coll_current getval name]]
    if {$name != ""} { coll_setname group $name }
}

proc coll_done {which} {
    coll_putname $which ""
    form_done .${which}_form
    coll_done_action
}

proc coll_pattern {which op} {
    global coll_current coll_pattern form_done_flag current_object
    global coll_objlist coll_sizeent
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    
    if ![info exists coll_pattern] { set coll_pattern "" }
    set pat [question "Pattern for objects to $op" $coll_pattern]
    if {$pat == ""} return
    set coll_pattern $pat
    
    switch $op {
	add {
	    foreach obj [db_list_objects_recursive] {
		switch [$obj getval obtype] {
		    domain - material continue
		}
		set key [$obj getval name]
		if [string match $coll_pattern $key] {
		    if [$coll_current member $obj] continue
		    
		    coll_in $coll_current $obj
		    
		    graph_highlight $obj 1
		}
	    }
	}
	remove {
	    foreach obj [$coll_current list_contents] {
		set key [$obj getval name]
		if [string match $coll_pattern $key] {
		    coll_out $coll_current $obj
		    
		    graph_highlight $obj 0
		}
	    }
	}
    }
    
    set all {}
    foreach obj [$coll_current list_contents name alpha] {
	lappend all [$obj getval name]
    }
#    form_listbox_set $coll_objlist $all
#    form_entry_set $coll_sizeent [llength $all]
    db_dirty model
}

proc coll_region {which op} {
    global tdv_default
    global coll_current coll_pattern form_done_flag current_object
    global coll_objlist coll_sizeent
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    
    while 1 {
	banner "Drag open the region with the left button.  Middle, right buttons = cancel."
	set w $tdv_default
	set stuff [tdv_get_rubbox $w]
	banner ""
	
	if {$stuff == ""} return
	set p1 [lindex $stuff 0]
	set p2 [lindex $stuff 1]
	set objects [select_shapes_by_screen_region $p1 $p2 1]
	if {$objects == ""} {
	    mess "No objects matched\n" red
	    return
	}
	
	switch $op {
	    add {
		foreach obj $objects {
		    switch [$obj getval obtype] {
			domain continue
		    }
		    if [$coll_current member $obj] continue
		    
		    coll_in $coll_current $obj
		    
		    graph_highlight $obj 1
		}
	    }
	    remove {
		foreach obj $objects {
		    coll_out $coll_current $obj
		    graph_highlight $obj 0
		}
	    }
	}
	
	set all {}
	foreach obj [$coll_current list_contents name alpha] {
	    lappend all [$obj getval name]
	}
	db_dirty model
    }
}

proc coll_delete_action {which} {
    global coll_current
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    
    set name [$coll_current getval name]

    set objs [$coll_current list_contents]
    
    set undo "coll_makenew $which [$coll_current getval name] \{$objs\}"
    set redo "coll_delete $which \[set \{${which}_container($name)\}\]"
    undo_record $undo $redo
    
    coll_delete $which $coll_current    
}

proc coll_delete {which coll} {
    global coll_current coll_nameent coll_sizeent coll_listbox
    global coll_objlist ${which}_container

    foreach obj [$coll list_contents] {
	coll_out $coll $obj
	graph_highlight $obj 0
    }
    if {$coll == $coll_current} {
	if {[info exists coll_sizeent] && [winfo exists $coll_sizeent]} {
	    $coll_nameent delete 0 end
	    $coll_sizeent delete 0 end
	    form_listbox_clear $coll_objlist
	}
	set coll_current ""
    }
    set name [$coll getval name]
    unset ${which}_container($name)
    $coll delete
    if {[info exists coll_sizeent] && [winfo exists $coll_sizeent]} {
	form_listbox_delete $coll_listbox $name
    }
    tree_delete_group $coll
    db_dirty model
}

proc coll_merge_action {which} {
    global coll_current coll_nameent coll_listbox ${which}_container
    global coll_waiting_for_select
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    mess "Select the second $which from the list.\n"
    set coll_waiting_for_select 1
    tkwait variable coll_waiting_for_select
    set other [set ${which}_container($coll_waiting_for_select)]
    unset coll_waiting_for_select

    if ![confirm "Merge $which \"[$coll_current getval name]\" and\
	    $which \"[$other getval name]\"?  (Second $which will be\
	    deleted.)"] return
    
    coll_merge $coll_current $other
    
    form_listbox_delete $coll_listbox $name
    db_dirty model
}

proc coll_merge {to from} {
    global group_container coll_current
    
    foreach ob [$from list_contents] {
	set sh [db_shapes $ob 0]
	coll_remove_action group $from $sh
	coll_add_action group $to $sh
    }
    set name [$from getval name]
    tree_delete_group $group_container($name)
    unset group_container($name)
    $from delete
    if {$coll_current == $from} { set coll_current "" }
}

proc coll_move {which} {
    global coll_current
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    edit_move 0 $coll_current $which
}

proc coll_copy {which} {
    global coll_current
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    edit_move 1 $coll_current $which
}

proc coll_op {which op} {
    global tdv_default
    global object_select_command coll_current coll_prevcur
    global tdv_pickable_tags coll_prev_pickable_tags coll_doing_remove
    global tdv_mouse_bindings
    
    coll_done_action
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    set name [$coll_current getval name]
    
    set left [lindex {x left middle right} $tdv_mouse_bindings(select)]
    set middle [lindex {x left middle right} $tdv_mouse_bindings(done)]
    set right [lindex {x left middle right} $tdv_mouse_bindings(cancel)]
    
    banner "Select objects with the shifted $left button. \
	Use shift-$middle and shift-$right to end selection mode."
    
    if {$op == "remove"} {
	mess "You can also remove objects by clicking on their names in\
              the lower object list.\n"
    }
    
    set object_select_command(1) "coll_${op}_action $which $coll_current"
    set object_select_command(2) "coll_done_action"
    set object_select_command(3) "coll_done_action"
    set coll_prev_pickable_tags $tdv_pickable_tags($tdv_default)
    set tdv_pickable_tags($tdv_default) obtype_all
    if {$op == "remove"} { set coll_doing_remove 1 }
    
    #set coll_prevcur [$tdv_default getval cursor]
    #$tdv_default configure -cursor "@tcl/add_group.cur orange"
}

proc coll_add_action {which coll {sh ""} {recundo 1}} {
    global coll_sizeent coll_objlist
    
    if [string match model_object__* $sh] {
	set obj $sh
    } else {
	if {($sh == "") || [catch {$sh get -object} obj]} return
    }
    
    if {($obj != "") && ![$coll member $obj]} {
	coll_add_object $coll $obj
	if {[info exists coll_sizeent] && [winfo exists $coll_sizeent]} {
	    form_entry_set $coll_sizeent [llength [$coll list_contents]]
	    form_listbox_add $coll_objlist [$obj getval name]
	}
    }
}

proc coll_add_object {coll objects {recundo 1}} {
    set dirty 0
    foreach obj $objects {
	if {![$coll member $obj]} {
	    coll_in $coll $obj
	    
	    if $recundo {
		set cname "\[set \{group_container([$coll getval name])\}\]"
		set oname "\[db_get_name \"[$obj getval name]\"\]"
		set undo "coll_remove_action group $cname $oname 0"
		set redo "coll_add_action group $cname $oname 0"
		undo_record $undo $redo
	    }
	    graph_highlight $obj 1
	    set dirty 1
	}
    }
    if $dirty { db_dirty model }
}

proc coll_remove_action {which coll {sh ""} {recundo 1}} {
    global coll_sizeent coll_objlist
    
    if {$sh == ""} return
    if [catch {$sh get -object} obj] {
	set obj $sh
    }
    
    if {($obj != "") && [$coll member $obj]} {
	coll_remove_object $coll $obj $recundo
	if {[info exists coll_sizeent] && [winfo exists $coll_sizeent]} {
	    form_entry_set $coll_sizeent [llength [$coll list_contents]]
	    form_listbox_delete $coll_objlist [$obj getval name]
	}
    }
}

proc coll_remove_object {coll obj {recundo 1}} {
    coll_out $coll $obj
    
    if $recundo {
	set cname "\[set \{group_container([$coll getval name])\}\]"
	set oname "\[db_get_name \"[$obj getval name]\"\]"
	set undo "coll_add_action group $cname $oname 0"
	set redo "coll_remove_action group $cname $oname 0"
	undo_record $undo $redo
    }
    
    graph_highlight $obj 0
    db_dirty model
}

proc coll_in {coll obj} {
    global model_data current_object
    
    $coll add [$obj getval name] $obj
    set grs [$obj getval groups]
    lappend grs [$coll getval name]
    $obj setval groups $grs
    if {$obj == $current_object} {
	set model_data(groups) $grs
    }
    tree_add_object_to_group $coll $obj 1
}


proc coll_out_without_selection {coll obj} {
    global model_data current_object group_container
    
    if {$coll == "all"} {
	foreach g [$obj getval groups] {
	    if [info exists group_container($g)] {
		coll_out_without_selection $group_container($g) $obj
	    }
	}
	return
    }
    
    catch {  ;# might not be in the container
	$coll remove [$obj getval name]
    }
    set grs [$obj getval groups]
    set n [lsearch $grs [$coll getval name]]
    if {$n >= 0} {
	set grs [lreplace $grs $n $n]
	$obj setval groups $grs
	if {$obj == $current_object} {
	    set model_data(groups) $grs
	}
    }
    tree_remove_object_from_group_without_selection $coll $obj
    reconfigure_object $obj
}

proc coll_out {coll obj} {
    global model_data current_object group_container
    
    if {$coll == "all"} {
	foreach g [$obj getval groups] {
	    if [info exists group_container($g)] {
		coll_out $group_container($g) $obj
	    }
	}
	return
    }
    
    catch {  ;# might not be in the container
	$coll remove [$obj getval name]
    }
    set grs [$obj getval groups]
    set n [lsearch $grs [$coll getval name]]
    if {$n >= 0} {
	set grs [lreplace $grs $n $n]
	$obj setval groups $grs
	if {$obj == $current_object} {
	    set model_data(groups) $grs
	}
    }
    tree_remove_object_from_group $coll $obj
    reconfigure_object $obj
}

proc coll_done_action {args} {
    global tdv_default
    global object_select_command coll_prevcur view_pickable_tags
    global coll_doing_remove coll_prev_pickable_tags
    
    if [info exists object_select_command(1)] {
	foreach i {1 2 3} {unset object_select_command($i)}
	#$tdv_default configure -cursor $coll_prevcur
	mess "Finished with operation.\n"
	
	set tdv_pickable_tags($tdv_default) $coll_prev_pickable_tags
	catch {unset coll_doing_remove}
	banner ""
    }
}

proc coll_act_all {which on} {
    global coll_current
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    foreach obj [$coll_current list_contents] {
	if {[$obj si_value active] != $on} {
	    edit_modify_object $obj "active $on"
	    graph_highlight $obj $on
	    tree_changeactive_object $obj
	}
    }
}

proc coll_del_all {which} {
    global coll_current coll_sizeent
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    set objects [$coll_current list_contents]
    foreach obj $objects {
	trash_add $obj 0
    }
    undo_record_trash $objects 1
}

proc coll_create_part {which} {
    global coll_current model_container
    
    if {$coll_current == ""} {
	mess "Warning: no $which currently selected\n"
	return
    }
    set name [$coll_current getval name]
    set cur [db_get_name $name]
    if {($cur != "") && ([$cur getval obtype] != "part")} {
	set nn2 [$model_container new_name $name]
	mess "Name \"$name\" is already used - renaming to \"$nn2\"\n" red
	set name $nn2
    }
    set obj [edit_new part $name]
    $obj setval part_type internal
    group_to_part $coll_current $obj
    coll_delete group $coll_current
}

proc coll_save_as_job {} {
    global coll_current
    
    if {$coll_current == ""} {
	mess "Warning: no group currently selected\n"
	return
    }
    file_save 1 "" $coll_current 0 [$coll_current getval name]
}

proc coll_write {fp obj} {
    puts $fp [list [$obj getval obtype] [$obj getval name]]
    foreach sub [$obj list_contents] {
	if {$sub != ""} {
	    puts $fp "    [list [$sub getval obtype] [$sub getval name]]"
	}
    }
    foreach i {color shading linewidth use_as_family} {
	set v [$obj getval obj_$i ""]
	if {$v != ""} {
	    puts $fp "    [list obj_$i $v]"
	}
    }
    puts $fp "end [$obj getval obtype]"
}

proc coll_copy_props {which cur_obj_sel} {
    global current_object coll_current params_not_copied
    global object_params_are_shape current_object_sel app_has_clean_up
    
    if $cur_obj_sel {
	set from [lindex $current_object_sel 0]
    } else {
	set from $current_object
    }
    
    if {$from == ""} {
	mess "Can't copy parameters: no object is selected in the edit form.\n" red
	return
    }
    
    if {$coll_current == ""} {
	mess "Can't copy parameters: no group is selected.\n" red
	return
    }
    
    set ignore_params {
 	section_list groups active *_shape name obtype
 	current_section current_shape creation_order
    }
    
    set fromt [$from getval obtype]
    mess "Copying parameters from [$from getval name] to ${fromt}s ...\n"
    
    if [info exists object_params_are_shape($fromt)] {
 	set ignore_params [concat $ignore_params \
 			       $object_params_are_shape($fromt)]
    }
    
    foreach to [$coll_current list_contents] {
	if {([$to getval obtype] != $fromt) || ($from == $to)} continue
	mess "\t-> [$to getval name]\n"
	
	set undos ""
	foreach t [$from list_values] {
	    set n [lindex $t 0]
	    
	    if {([lsearch -glob $ignore_params $n] >= 0) ||
		[string match *_shape $n]} continue
	    if [$to checkval $n] {
		lappend undos [list $n [$to si_value $n] [lindex $t 1]]
	    } else {
		lappend undos [list $n "" [lindex $t 1]]
	    }
	    $to setval $n [lindex $t 1]
	    set un [$from getunits $n]
	    if {$un != ""} { $to setunits $n $un }
	}
	undo_record_change_object $to $undos
	
	set t [$to getval obtype]
	if [info exists app_has_clean_up($t)] {
	    app_clean_up_$t $to
	}
	reconfigure_object $to
    }
    
    mess "Done.\n"
}

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

proc coll_add {which name obj {sort_tree 0}} {
    global ${which}_container
    if {$name == ""} return
    
    if ![info exists ${which}_container($name)] {
	set ${which}_container($name) [model_container]
	[set ${which}_container($name)] setval name $name obtype $which
    }
    set grp [set ${which}_container($name)]
    $grp add [$obj getval name] $obj
    tree_add_object_to_group $grp $obj $sort_tree
}

proc coll_setparam {which name param val} {
    global ${which}_container
    if {$name == ""} return
    
    if ![info exists ${which}_container($name)] return
    
    [set ${which}_container($name)] setval $param $val
}

proc coll_remove {which name obj} {
    global ${which}_container
    if {$name == ""} return
    
    if ![info exists ${which}_container($name)] return
    set grp [set ${which}_container($name)]
    catch {$grp remove [$obj getval name]}
    tree_remove_object_from_group $grp $obj
}

proc coll_remove_from_all {obj} {
    global group_container
    
    foreach gg [$obj getval groups] {
	set grp [set group_container($gg)]
	catch {$grp remove [$obj getval name]}
	tree_remove_object_from_group $grp $obj
    }
}

proc coll_of_object {which obj} {
    global ${which}_container
    set res {}
    foreach gc [$obj list_containers] {
	if {[$gc getval obtype] == $which} {
	    lappend res [$gc getval name]
	}
    }
    return $res
}

proc coll_contents {which name {recursive 0}} {
    global ${which}_container
    if ![info exists ${which}_container($name)] { return "" }
    set objs [[set ${which}_container($name)] list_contents name alpha]
    if $recursive {
	set objs2 ""
	foreach obj $objs {
	    if {[$obj getval obtype] == "part"} {
		set objs2 [concat $objs2 [part_list_all $obj 0]]
	    } else {
		lappend objs2 $obj
	    }
	}
	return $objs2
    } else {
	return $objs
    }
}

proc coll_contents_object {which obj} {
    if {$which != "entity"} error
    global entity_container
    set ename [$obj getval entity]
    if {$ename == ""} {return $obj}
    return [$entity_container($ename) list_contents name alpha]
}

proc coll_other_contents_object {which obj} {
    if {$which != "entity"} error
    global entity_container
    set ename [$obj getval entity]
    if {$ename == ""} {return ""}
    set items {}
    foreach item [$entity_container($ename) list_contents name alpha] {
	if {$item != $obj} { lappend items $item }
    }
    return $items
}

proc coll_list {which} {
    global ${which}_container
    
    return [lsort [array names ${which}_container]]
}

proc coll_new_name {which {pref ""}} {
    global ${which}_container
    if {$pref == ""} { set pref $which }
    for {set n 1} 1 {incr n} {
	if ![info exists ${which}_container($pref.$n)] {
	    return $pref.$n
	}
    }
}

proc coll_properties {which} {
    global coll_current
    
    if {$coll_current == ""} return
    set objects [$coll_current list_contents]
    if {$objects == ""} return
    
    set obtype ""
    foreach ob $objects {
	if {$obtype == ""} { set obtype [$ob getval obtype] }
	if {$obtype != [$ob getval obtype]} {
	    user_error "Can't edit properties for this group if more than one\
		object type present (this group has both $obtype\
		and [$ob getval obtype]"
	    return
	}
    }
    
    edit_multiple_objects $obtype $objects
}

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

proc db_objects_in_group_of_object {obj} {
    global group_container
    
    set found($obj) 1
    foreach gname [$obj getval groups] {
	foreach oth [$group_container($gname) list_contents] {
	    set found($oth) 1
	}
    }
    return [array names found]
}

proc db_put_in_groups {obj oldgroups newgroups} {
    global group_container
    
    foreach g $oldgroups {
	if [info exists group_container($g)] {
	    set old($group_container($g)) 1
	}
    }
    foreach g $newgroups {
	if ![info exists group_container($g)] {
	    coll_makenew group $g
	}
	set coll $group_container($g)
	catch {unset old($coll)}
	$coll add [$obj getval name] $obj
	tree_add_object_to_group $coll $obj 1
    }
    foreach coll [array names old] {
	$coll remove [$obj getval name]
	tree_remove_object_from_group $coll $obj
    }
    $obj setval groups $newgroups
}

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

proc centroid_of_objects {objects} {
    set bb [bbox_of_objects $objects]
    if {$bb != ""} {
	set cent ""
	set min [lindex $bb 0]; set max [lindex $bb 1]
	foreach c {0 1 2} {
	    lappend cent [expr {([lindex $min $c] + [lindex $max $c]) / 2}]
	}
	return $cent
    }
    return ""
}

# From_sh is used only when moving a recirc opening...

proc bbox_of_objects {objects {from_sh ""}} {
    if {$objects == ""} { return "" }
    
    foreach obj $objects {
	foreach sh [db_shapes $obj] {
	    if {($from_sh != "") && ([$from_sh get -object] == $obj) && \
		    ($sh != $from_sh)} continue
	    set is_wall [expr {([$obj getval obtype] == "wall") && \
				   ([$sh get -shtype] == "quad")}]
	    set bb [$sh get_bbox]
	    if {$bb == ""} continue
	    foreach c {0 1 2} {
		set v1 [lindex [lindex $bb 0] $c]
		set v2 [lindex [lindex $bb 1] $c]
		if {$is_wall && ([$sh get -plane] == $c)} {
		    set v1 [lindex [$sh getval point1] $c]
		    set v2 $v1
		}
		if {![info exists minv($c)] || ($minv($c) > $v1)} {
		    set minv($c) $v1
		}
		if {![info exists maxv($c)] || ($maxv($c) < $v2)} {
		    set maxv($c) $v2
		}
	    }
	}
    }
    if [info exists minv] {
	return [list "$minv(0) $minv(1) $minv(2)" "$maxv(0) $maxv(1) $maxv(2)"]
    } else {
	return ""
    }
}

proc put_in_entity {obj old new} {
    coll_remove entity $old $obj
    coll_add entity $new $obj
}

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

proc app_summary_group_brief {obj} {
    return [coll_summary_brief group $obj]
}

proc app_summary_entity_brief {obj} {
    return [coll_summary_brief entity $obj]
}

proc app_summary_group_detailed {obj} {
    return [coll_summary_detailed group $obj]
}

proc app_summary_entity_detailed {obj} {
    return [coll_summary_detailed entity $obj]
}

proc coll_summary_brief {what obj} {
    set n [llength [$obj list_contents]]
    if {$n == 1} { return "1 object" } else { return "$n objects" }
}

proc coll_summary_detailed {what obj} {
    set lines ""
    foreach sub [$obj list_contents name alpha] {
	lappend lines [list "[$sub getval obtype] [$sub getval name]"]
    }
    return $lines
}
