
#
# Copyright (c) 2001 Pacific Marketing and Consulting
# Author:  Wayne A. Christopher, wayne@pmac.com
#          Pacific Marketing and Consulting, Berkeley, California
#
# Tree viewing stuff.

proc tree_standalone_model_selection {frame double_cmd sel_cmd {width 16} {height 8} {onelevel 0} {object_class_func ""} {single_is_ctrl 0}} {
    global nonboldfont tree
    
    set sw [ScrolledWindow $frame.tree]
    set tr $sw.t
    Tree $tr -relief flat -borderwidth 0 -width $width -height $height -background white \
	-linesfill gray50 -deltay 18 -deltax 7 -padx 22
    $sw setwidget $tr
    
    foreach tt {Text Image} {
	if $single_is_ctrl {
	    $tr bind$tt <ButtonRelease-1> [list tree_standalone_control_click $frame $sel_cmd $object_class_func]
	} else {
	    $tr bind$tt <ButtonRelease-1> [list tree_standalone_single_click $frame $sel_cmd]
	}
	$tr bind$tt <Double-1> [list tree_standalone_double_click $frame $sel_cmd $double_cmd]
	$tr bind$tt <Shift-ButtonRelease-1> [list tree_standalone_shift_click $frame $sel_cmd $object_class_func]
	$tr bind$tt <Control-ButtonRelease-1> [list tree_standalone_control_click $frame $sel_cmd $object_class_func]
	$tr bind$tt <Button-1> ""
    }
    
    if {!$onelevel} {
	$tr insert end root model -text Model -open 1 -font $nonboldfont \
	    -image [tree_get_image model]
	$tr insert end root groups -text Groups -open 0 -font $nonboldfont \
	    -image [tree_get_image group]
    }
    set tree(standalone-win,$frame) $tr
    return $sw
}

proc tree_standalone_single_click {frame sel_cmd node} {
    global tree
    set tr $tree(standalone-win,$frame)
    if {[$tr itemcget $node -data] == ""} return
    if {$sel_cmd != ""} {
	foreach onode [$tr selection get] {
	    eval $sel_cmd [$tr itemcget $onode -data] 0
	}
    }
    $tr selection set $node
    if {$sel_cmd != ""} {
	eval $sel_cmd [$tr itemcget $node -data] 1
    }
}

proc tree_standalone_double_click {frame sel_cmd double_cmd node} {
    global tree
    set tr $tree(standalone-win,$frame)
    if {[$tr itemcget $node -data] == ""} return
    if {$sel_cmd != ""} {
	foreach onode [$tr selection get] {
	    eval $sel_cmd [$tr itemcget $onode -data] 0
	}
    }
    $tr selection set $node
    if {$sel_cmd != ""} {
	eval $sel_cmd [$tr itemcget $node -data] 1
    }
    if {$double_cmd != ""} {
	eval $double_cmd
    }
}

proc tree_standalone_shift_click {frame sel_cmd class_func node} {
    global tree
    set tr $tree(standalone-win,$frame)
    if {[$tr itemcget $node -data] == ""} return
    set sel [$tr selection get]
    if {$sel != ""} {
	set obj1 [lindex [$tr itemcget [lindex $sel 0] -data] 1]
    } else {
	set obj1 [lindex [$tr itemcget $node -data] 1]
    }
    if {$class_func != ""} {
	set class1 [eval $class_func $obj1]
    } else {
	set class1 ""
    }
    set objn [lindex [$tr itemcget $node -data] 1]
    if {$class_func != ""} {
	set classn [eval $class_func $objn]
    } else {
	set classn ""
    }
    set sel [$tr selection get]
    if {$sel != ""} {
	set last [lindex $sel end]
    } else {
	set last ""
    }
    if {$class1 == $classn} {
	$tr selection add $node
	if {$sel_cmd != ""} {
	    eval $sel_cmd [$tr itemcget $node -data] 1
	}
    }
    if {$last != ""} {
	set p1 [$tr parent $last]
	set p2 [$tr parent $node]
	if {$p1 == $p2} {
	    set i1 [$tr index $last]
	    set i2 [$tr index $node]
	    if {$i2 < $i1} { set i3 $i1; set i1 $i2; set i2 $i3 }
	    set nodes [$tr nodes $p1 $i1 $i2]
	    foreach node $nodes {
		set objn [lindex [$tr itemcget $node -data] 1]
		if {$class_func != ""} {
		    set classn [eval $class_func $objn]
		} else {
		    set classn ""
		}
		if {$class1 == $classn} {
		    $tr selection add $node
		    if {$sel_cmd != ""} {
			eval $sel_cmd [$tr itemcget $node -data] 1
		    }
		}
	    }
	}
    }
}

proc tree_standalone_control_click {frame sel_cmd class_func node} {
    global tree
    set tr $tree(standalone-win,$frame)
    if {[$tr itemcget $node -data] == ""} return
    set sel [$tr selection get]
    
    if {$sel == ""} {
	$tr selection add $node
	if {$sel_cmd != ""} {
	    eval $sel_cmd [$tr itemcget $node -data] 1
	}
    } elseif {[lsearch $sel $node] < 0} {
	# First see if we can add this guy.
	if {$class_func != ""} {
	    set obj1 [lindex [$tr itemcget [lindex $sel 0] -data] 1]
	    set objn [lindex [$tr itemcget $node -data] 1]
	    if {($obj1 == "") || ($objn == "")} return
	    set class1 [eval $class_func $obj1]
	    set classn [eval $class_func $objn]
	    if {$class1 != $classn} return
	}
	$tr selection add $node
	if {$sel_cmd != ""} {
	    eval $sel_cmd [$tr itemcget $node -data] 1
	}
    } else {
	$tr selection remove $node
	if {$sel_cmd != ""} {
	    eval $sel_cmd [$tr itemcget $node -data] 0
	}
    }
}

# If only_type is 0 that means all types.  If it's 1 it means meshable types.
# If it's "volume" that means volume objects with a mesh already
# Otherwise it's a list of types that can be given.  Alternately if the first
# word is __func__ then it's a callback function.
# If only_type is also_intnodes that means all types and networks get branches for
# their internal nodes.

proc tree_standalone_model_populate {frame only_type also_groups 
				     also_fix_shapes
				     {textcolor_func ""}} {
    global nonboldfont tree grid_mapping reduced_group
    global model_container_root object_type_title
    global app_has_special_perobject_params
    
    set tr $tree(standalone-win,$frame)
    set onel [$tr exists model]
    if $onel {
	$tr delete [$tr nodes model]
	$tr delete [$tr nodes groups]
	set rnode model
    } else {
	$tr delete [$tr nodes root]
	set rnode root
    }
    set objects ""
    foreach obj [db_list_objects_recursive] {
	set obtype [$obj getval obtype]
	if {$obtype == "material"} continue
	set also_intnodes 0
	#puts "$obtype $obj"
	if [string match __func__* $only_type] {
	    if {($obtype != "part") && ![[lindex $only_type 1] object $obj]} continue
	    set noshapes 1
	    
	} elseif {($only_type == "1") && ![info exists grid_mapping($obj)] && \
		($obtype != "part")} {
	    continue
	    
	} elseif {$only_type == "2"} {
	    # This is just for use with the FF active objects button
	    # Only geometric objects and no subtree for shapes
	    if ![llength [db_shapes $obj]] continue
	    set noshapes 1
	
	} elseif {$only_type == "volume"} {
	    if {($obtype != "part") && (![info exists grid_mapping($obj)] ||
					![info exists "reduced_group($grid_mapping($obj) 0)"])} continue
	    set noshapes 1
	
	} elseif {$only_type == "also_intnodes"} {
	    set also_intnodes 1
	    set noshapes 0
	    if {!$also_fix_shapes && [$obj getval fix_shapes 0]} {
		if {![info exists app_has_special_perobject_params($obtype)] ||
		    ([app_special_perobject_params_$obtype list $obj] == "")} {
		    continue
		} else {
		    set noshapes 1
		}
	    }
	    
	} elseif {[string length $only_type] > 1} {
	    # Big hack
	    if ![lmember $only_type $obtype] continue
	    set noshapes 1
	    
	} else {
	    set noshapes 0
	    if {!$also_fix_shapes && [$obj getval fix_shapes 0]} {
		if {![info exists app_has_special_perobject_params($obtype)] ||
		    ([app_special_perobject_params_$obtype list $obj] == "")} {
		    continue
		} else {
		    set noshapes 1
		}
	    }
	}
	if {$obtype == "domain"} {
	    set name $object_type_title(domain)
	} else {
	    set name [$obj getval name]
	}
	
	set par [$obj get -model_container]
	if {$par == $model_container_root} { set par $rnode }
	
	if {$textcolor_func != ""} {
	    set color [eval $textcolor_func $obj]
	} else {
	    set color black
	}
	$tr insert end $par $obj -text $name -open 0 \
	    -data [list object $obj] -fill $color -font $nonboldfont \
	    -image [tree_get_image [$obj getval obtype]]
	lappend objects object $obj
	
	set shapes [db_shapes $obj]
	if {!$noshapes && ([llength $shapes] > 1)} {
	    foreach sh $shapes {
		if {$textcolor_func != ""} {
		    set color [eval $textcolor_func $sh]
		} else {
		    set color black
		}
		$tr insert end $obj $sh -text [$sh get -name] -open 0 \
		    -data [list shape $sh] -fill $color -font $nonboldfont \
		    -image [tree_get_image [$sh get -shtype]_shape]
		lappend objects shape $sh
	    }
	}
	if {$also_intnodes && ($obtype == "network")} {
	    for {set i 0} {$i < [$obj getval num_int]} {incr i} {
		set name [$obj getval int${i}_name]
		set color black
		$tr insert end $obj ${obj}_int$i -text $name -open 0 \
		    -data [list intnode "$obj $i"] -fill $color -font $nonboldfont \
		    -image [tree_get_image intnode]
		lappend objects intnode "$obj $i"
	    }
	}
    }
    if {$also_groups && [$tr exists groups]} {
	foreach group [coll_list group] {
	    $tr insert end groups group-$group -text $group -open 0 \
		-data [list group $group] -fill black -font $nonboldfont \
		-image [tree_get_image group]
	    lappend objects group $group
	}
    }
    return $objects
}

proc tree_standalone_text_color {frame node color} {
    global tree
    set tr $tree(standalone-win,$frame)
    if [$tr exists $node] {
	$tr itemconfigure $node -fill $color
    } else {
	set node [$node get -object]
	$tr itemconfigure $node -fill $color
    }
}

proc tree_standalone_model_clear_selection {frame} {
    global tree
    $tree(standalone-win,$frame) selection clear
}

proc tree_standalone_model_get_selection {frame just_name} {
    global tree
    set tr $tree(standalone-win,$frame)
    set ret ""
    foreach node [$tr selection get] {
	set data [$tr itemcget $node -data]
	switch [lindex $data 0] {
	    object {
		set name [[lindex $data 1] getval name]
	    }
	    shape {
		set sh [lindex $data 1]
		set obj [$sh get -object]
		set name [list [$obj getval name] [$sh get -name]]
	    }
	    group {
		set name [lindex $data 1]
	    }
	    intnode {
		set nn [lindex $data 1]
		set name [list [[lindex $nn 0] getval name] [lindex $nn 1]]
	    }
	}
	if $just_name {
	    lappend ret $name
	} else {
	    lappend ret [lindex $data 0] $name
	}
    }
    return $ret
}

proc tree_standalone_model_set_selection {frame vals} {
    global tree
    set tr $tree(standalone-win,$frame)
    set nodes ""
    foreach {v1 v2} $vals {
	switch $v1 {
	    object {
		lappend nodes [db_get_name $v2]
	    }
	    shape {
		set obj [db_get_name [lindex $v2 0]]
		if {$obj != ""} {
		    lappend nodes [$obj getval [lindex $v2 1]_shape]
		}
	    }
	    group {
		lappend nodes group-$v2
	    }
	}
    }
    eval $tr selection set $nodes
}

proc tree_standalone_model_pick {frombut var only_type setcmd just_name} {
    global tree
    set w .standalone_tree
    
    catch {destroy $w}
    
    set width [winfo width $frombut]
    top_transient $w "" 0 1
    $w configure -width $width
    set fr [tree_standalone_model_selection $w \
		"set tree(standalone-done) 1" \
		tree_standalone_model_pick_single]
    grid $fr -row 0 -column 0 -sticky news
    frame $w.buts
    grid $w.buts -row 1 -column 0 -sticky news
    button $w.buts.acc -text Accept -command "set tree(standalone-done) 1"
    button $w.buts.cle -text Clear -command "tree_standalone_model_clear_selection $w"
    button $w.buts.can -text Cancel -command "set tree(standalone-done) 0"
    grid $w.buts.acc -row 1 -column 0 -padx 2 -pady 2
    grid $w.buts.cle -row 1 -column 1 -padx 2 -pady 2
    grid $w.buts.can -row 1 -column 2 -padx 2 -pady 2
    
    grid columnconfigure $w 0 -minsize $width
    
    tree_standalone_model_populate .standalone_tree $only_type 1 1
    top_geometry $w +5000+5000
    top_deiconify $w
    update
    
    tree_standalone_position $frombut
    
    bind $w <Visibility> "top_raise $w"
    
    upvar \#0 $var lvar
    
    if [info exists lvar] {
	tree_standalone_model_set_selection $w $lvar
    }
    
    vwait tree(standalone-done)
    top_withdraw $w
    tree_standalone_model_clear_highlights
    if $tree(standalone-done) {
	set lvar [tree_standalone_model_get_selection $w $just_name]
	if {$setcmd != ""} { eval $setcmd }
    }
}

proc tree_standalone_position {frombut {want_w ""} {have_w ""}} {
    if {$want_w != $have_w} return
    
    set w .standalone_tree
    if {![winfo exists $frombut] || ![winfo exists $w] ||
	![winfo ismapped $w]} return
    
    set x [expr [winfo rootx $frombut] - [winfo rootx .]]
    set y [expr [winfo rooty $frombut] - [winfo rooty .] + [winfo height $frombut]]
    set rh [winfo reqheight $w]
    if {$y + $rh > [winfo height .]} { incr y [expr {[winfo height .] - ($y + $rh)}] }
    set geo +$x+$y
    top_geometry $w $geo
    top_raise $w
}

proc tree_standalone_model_pick_entry {w var only_type tabgeo {act ""} {setcmd ""} {just_name 0}} {
    form_frame $w sunken 2 "$tabgeo"
    form_entry $w.e $var "" {0 0 -padx 0 -pady 0 -sticky news} $act 24
    $w.e configure -relief flat -borderwidth 0
    set form_entry_datatype($w.e) nocheck
    
    form_menubutton $w.m "" "" {0 1 -padx 0 -pady 0 -sticky ns} $act
    futil_drop_down_button $w.m #c0c0ff #a0a0ff
    
    set cmd [list tree_standalone_model_pick $w.e $var $only_type $setcmd $just_name]
    bind $w.e <ButtonPress-1> $cmd
    bind $w.m <ButtonPress-1> $cmd
    bind $w.m <ButtonRelease-1> break
    
    set top .[lindex [split $w .] 0]
    bind $top <Configure> "+; tree_standalone_position $w.e $top %W"
}

proc tree_standalone_model_pick_single {type name on} {
    #puts "highlight $type $name $on"
}

proc tree_standalone_model_clear_highlights {} {
}

proc tree_standalone_model_form {w getfunc setfunc only_type title {label ""}} {
    global tree
    
    set d [form_init $w $title "" [list accept cancel \
				       [list Clear "tree_standalone_model_clear_selection $w.main"]]]
    if {$d != ""} {
	if {$label != ""} {
	    label $d.lab -text $label
	    grid $d.lab -row 0 -column 0 -sticky news
	}
	tree_standalone_model_selection $d \
	    "form_done $w 1" "" 20 8 1 "" 1
	grid $d.tree -row 1 -column 0 -sticky news
	form_finish +300+300
    } else {
	set d $w.main
    }
    set stuff [tree_standalone_model_populate $d $only_type 1 1]
    puts "stuff is $stuff"
    if {$getfunc != ""} {
	set sel ""
	foreach {type obj} $stuff {
	    if [$getfunc $type $obj] {
		lappend sel $type [$obj getval name]
	    }
	}
	tree_standalone_model_set_selection $d $sel
    }
    
    if ![form_wait $w] { return "" }
    
    set sel ""
    foreach {type name} [tree_standalone_model_get_selection $d 0] {
	set obj [db_get_name $name]
	set ok($type,$obj) 1
	lappend sel $obj
    }
    if {$setfunc != ""} {
	foreach {type obj} $stuff {
	    $setfunc $type $obj [info exists ok($type,$obj)]
	}
    }
    return $sel
}

proc tree_standalone_model_setall {d setfunc on} {
    global tree
    set tr $tree(standalone-win,$d)
    foreach n [$tr nodes root] {
	tree_standalone_model_setall_nodes $tr $n $setfunc $on
    }
}

proc tree_standalone_model_setall_nodes {tr node sel_cmd on} {
    set children [$tr nodes $node]
    if {$children == ""} {
	if $on {
	    $tr selection add $node
	} else {
	    $tr selection remove $node
	}
	if {$sel_cmd != ""} {
	    eval $sel_cmd [$tr itemcget $node -data] $on
	}
    } else {
	foreach ch $children {
	    tree_standalone_model_setall_nodes $tr $ch $sel_cmd $on
	}
    }
}

proc tree_standalone_model_subform {d getfunc setfunc only_type width height single_is_ctrl} {
    if ![winfo exists $d.tree] {
	tree_standalone_model_selection $d \
	    "" [list tree_standalone_model_subform_toggle $setfunc] \
	    $width $height 1 "" $single_is_ctrl
	grid $d.tree -row 0 -column 0 -sticky news -columnspan 2
	button $d.all -text All -command [list tree_standalone_model_setall $d $setfunc 1]
	button $d.none -text None -command [list tree_standalone_model_setall $d $setfunc 0]
	grid $d.all -row 1 -column 0 -sticky news
	grid $d.none -row 1 -column 1 -sticky news
    }
    
    set stuff [tree_standalone_model_populate $d $only_type 1 1]
    
    set sel ""
    foreach {type obj} $stuff {
	if [$getfunc $type $obj] {
	    lappend sel $type [$obj getval name]
	}
    }
    tree_standalone_model_set_selection $d $sel
}

proc tree_standalone_model_subform_toggle {setfunc type object on} {
    eval $setfunc $type $object $on
}
